[Back to DOS SWAG index] [Back to Main SWAG index] [Original]

    {$R-,S-,V-,I-,B-,F-}

    {Disable the following define if you don't have Turbo Professional}
    {$DEFINE UseTpro}

    {*********************************************************}
    {*                    TPENV.PAS 1.02                     *}
    {*                by TurboPower Software                 *}
    {*********************************************************}

    {
      Version 1.01 11/7/88
        Find master environment in Dos 3.3 and 4.0
      Version 1.02 11/14/88
        Correctly find master environment when run
          Within AUTOEXEC.BAT
    }

    Unit TpEnv;
      {-Manipulate the environment}

    Interface

    Uses Opus;

    Type
      EnvArray = Array[0..32767] of Char;
      EnvArrayPtr = ^EnvArray;
      EnvRec =
        Record
          EnvSeg : Word;              {Segment of the environment}
          EnvLen : Word;              {Usable length of the environment}
          EnvPtr : Pointer;           {Nil except when allocated on heap}
        end;

    Const
      ShellUserProc : Pointer = nil;  {Put address of ExecDos user proc here if desi

    Procedure MasterEnv(Var Env : EnvRec);
      {-Return master environment Record}

    Procedure CurrentEnv(Var Env : EnvRec);
      {-Return current environment Record}

    Procedure NewEnv(Var Env : EnvRec; Size : Word);
      {-Allocate a new environment on the heap}

    Procedure DisposeEnv(Var Env : EnvRec);
      {-Deallocate an environment previously allocated on heap}

    Procedure SetCurrentEnv(Env : EnvRec);
      {-Specify a different environment For the current Program}

    Procedure CopyEnv(Src, Dest : EnvRec);
      {-Copy contents of Src environment to Dest environment}

    Function EnvFree(Env : EnvRec) : Word;
      {-Return Bytes free in environment}

    Function GetEnvStr(Env : EnvRec; Search : String) : String;
      {-Return a String from the environment}

    Function SetEnvStr(Env : EnvRec; Search, Value : String) : Boolean;
      {-Set environment String, returning True if successful}

    Procedure DumpEnv(Env : EnvRec);
      {-Dump the environment to StdOut}

    Function ProgramStr : String;
      {-Return the complete path to the current Program, '' if Dos < 3.0}

    Function SetProgramStr(Env : EnvRec; Path : String) : Boolean;
      {-Add a Program name to the end of an environment if sufficient space}

      {$IFDEF UseTpro}
    Function ShellWithPrompt(Prompt : String) : Integer;
      {-Shell to Dos With a new prompt}
      {$endIF}

    Procedure DisposeEnv(Var Env : EnvRec);
      {-Deallocate an environment previously allocated on heap}
    begin
      With Env do
        if EnvPtr <> nil then begin
          FreeMem(EnvPtr, EnvLen+31);
          ClearEnvRec(Env);
        end;
    end;

    Procedure SetCurrentEnv(Env : EnvRec);
      {-Specify a different environment For the current Program}
    begin
      With Env do
        if EnvSeg <> 0 then
          MemW[PrefixSeg:$2C] := EnvSeg;
    end;

    Procedure CopyEnv(Src, Dest : EnvRec);
      {-Copy contents of Src environment to Dest environment}
    Var
      Size : Word;
      SPtr : EnvArrayPtr;
      DPtr : EnvArrayPtr;
    begin
      if (Src.EnvSeg = 0) or (Dest.EnvSeg = 0) then
        Exit;

      if Src.EnvLen <= Dest.EnvLen then
        {Space For the whole thing}
        Size := Src.EnvLen
      else
        {Take what fits}
        Size := Dest.EnvLen-1;

      SPtr := Ptr(Src.EnvSeg, 0);
      DPtr := Ptr(Dest.EnvSeg, 0);
      Move(SPtr^, DPtr^, Size);
      FillChar(DPtr^[Size], Dest.EnvLen-Size, 0);
    end;

    Procedure SkipAsciiZ(EPtr : EnvArrayPtr; Var EOfs : Word);
      {-Skip to end of current AsciiZ String}
    begin
      While EPtr^[EOfs] <> #0 do
        Inc(EOfs);
    end;

    Function EnvNext(EPtr : EnvArrayPtr) : Word;
      {-Return the next available location in environment at EPtr^}
    Var
      EOfs : Word;
    begin
      EOfs := 0;
      if EPtr <> nil then begin
        While EPtr^[EOfs] <> #0 do begin
          SkipAsciiZ(EPtr, EOfs);
          Inc(EOfs);
        end;
      end;
      EnvNext := EOfs;
    end;

    Function EnvFree(Env : EnvRec) : Word;
      {-Return Bytes free in environment}
    begin
      With Env do
        if EnvSeg <> 0 then
          EnvFree := EnvLen-EnvNext(Ptr(EnvSeg, 0))-1
        else
          EnvFree := 0;
    end;

    {$IFNDEF UseTpro}
    Function StUpcase(S : String) : String;
      {-Uppercase a String}
    Var
      SLen : Byte Absolute S;
      I : Integer;
    begin
      For I := 1 to SLen do
        S[I] := UpCase(S[I]);
      StUpcase := S;
    end;
    Function SearchEnv(EPtr : EnvArrayPtr;
                       Var Search : String) : Word;
      {-Return the position of Search in environment, or $FFFF if not found.
        Prior to calling SearchEnv, assure that
          EPtr is not nil,
          Search is not empty
      }
    Var
      SLen : Byte Absolute Search;
      EOfs : Word;
      MOfs : Word;
      SOfs : Word;
      Match : Boolean;
    begin
      {Force upper Case search}
      Search := Upper(Search);

      {Assure search String ends in =}
      if Search[SLen] <> '=' then begin
        Inc(SLen);
        Search[SLen] := '=';
      end;

      EOfs := 0;
      While EPtr^[EOfs] <> #0 do begin
        {At the start of a new environment element}
        SOfs := 1;
        MOfs := EOfs;
        Repeat
          Match := (EPtr^[EOfs] = Search[SOfs]);
          if Match then begin
            Inc(EOfs);
            Inc(SOfs);
          end;
        Until not Match or (SOfs > SLen);

        if Match then begin
          {Found a match, return index of start of match}
          SearchEnv := MOfs;
          Exit;
        end;

        {Skip to end of this environment String}
        SkipAsciiZ(EPtr, EOfs);

        {Skip to start of next environment String}
        Inc(EOfs);
      end;

      {No match}
      SearchEnv := $FFFF;
    end;

    Procedure GetAsciiZ(EPtr : EnvArrayPtr; Var EOfs : Word; Var EStr : String);
      {-Collect AsciiZ String starting at EPtr^[EOfs]}
    Var
      ELen : Byte Absolute EStr;
    begin
      ELen := 0;
      While (EPtr^[EOfs] <> #0) and (ELen < 255) do begin
        Inc(ELen);
        EStr[ELen] := EPtr^[EOfs];
        Inc(EOfs);
      end;
    end;

    Function GetEnvStr(Env : EnvRec; Search : String) : String;
      {-Return a String from the environment}
    Var
      SLen : Byte Absolute Search;
      EPtr : EnvArrayPtr;
      EOfs : Word;
      EStr : String;
      ELen : Byte Absolute EStr;
    begin
      With Env do begin
        ELen := 0;
        if (EnvSeg <> 0) and (SLen <> 0) then begin
          {Find the search String}
          EPtr := Ptr(EnvSeg, 0);
          EOfs := SearchEnv(EPtr, Search);
          if EOfs <> $FFFF then begin
            {Skip over the search String}
            Inc(EOfs, SLen);
            {Build the result String}
            GetAsciiZ(EPtr, EOfs, EStr);
          end;
        end;
        GetEnvStr := EStr;
      end;
    end;

    Implementation

    Type
    SO =
      Record
        O : Word;
        S : Word;
      end;

    Procedure ClearEnvRec(Var Env : EnvRec);
      {-Initialize an environment Record}
    begin
      FillChar(Env, SizeOf(Env), 0);
    end;

    Procedure MasterEnv(Var Env : EnvRec);
      {-Return master environment Record}
    Var
      Owner : Word;
      Mcb : Word;
      Eseg : Word;
      Done : Boolean;
    begin
      With Env do begin
        ClearEnvRec(Env);

        {Interrupt $2E points into COMMAND.COM}
        Owner := MemW[0:(2+4*$2E)];

        {Mcb points to memory control block For COMMAND}
        Mcb := Owner-1;
        if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
          Exit;

        {Read segment of environment from PSP of COMMAND}
        Eseg := MemW[Owner:$2C];

        {Earlier versions of Dos don't store environment segment there}
        if Eseg = 0 then begin
          {Master environment is next block past COMMAND}
          Mcb := Owner+MemW[Mcb:3];
          if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
            {Not the right memory control block}
            Exit;
          Eseg := Mcb+1;
        end else
          Mcb := Eseg-1;

        {Return segment and length of environment}
        EnvSeg := Eseg;
        EnvLen := MemW[Mcb:3] shl 4;
      end;
    end;

    Procedure CurrentEnv(Var Env : EnvRec);
      {-Return current environment Record}
    Var
      ESeg : Word;
      Mcb : Word;
    begin
      With Env do begin
        ClearEnvRec(Env);
        ESeg := MemW[PrefixSeg:$2C];
        Mcb := ESeg-1;
        if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> PrefixSeg) then
          Exit;
        EnvSeg := ESeg;
        EnvLen := MemW[Mcb:3] shl 4;
      end;
    end;

    Procedure NewEnv(Var Env : EnvRec; Size : Word);
      {-Allocate a new environment (on the heap)}
    Var
      Mcb : Word;
    begin
      With Env do
        if MaxAvail < Size+31 then
          {Insufficient space}
          ClearEnvRec(Env)
        else begin
          {31 extra Bytes For paraGraph alignment, fake MCB}
          GetMem(EnvPtr, Size+31);
          EnvSeg := SO(EnvPtr).S+1;
          if SO(EnvPtr).O <> 0 then
            Inc(EnvSeg);
          EnvLen := Size;
          {Fill it With nulls}
          FillChar(EnvPtr^, Size+31, 0);
          {Make a fake MCB below it}
          Mcb := EnvSeg-1;
          Mem[Mcb:0] := Byte('M');
          MemW[Mcb:1] := PrefixSeg;
          MemW[Mcb:3] := (Size+15) shr 4;
        end;
    end;

    Function SetEnvStr(Env : EnvRec; Search, Value : String) : Boolean;
      {-Set environment String, returning True if successful}
    Var
      SLen : Byte Absolute Search;
      VLen : Byte Absolute Value;
      EPtr : EnvArrayPtr;
      ENext : Word;
      EOfs : Word;
      MOfs : Word;
      OldLen : Word;
      NewLen : Word;
      NulLen : Word;
    begin
      With Env do begin
        SetEnvStr := False;
        if (EnvSeg = 0) or (SLen = 0) then
          Exit;
        EPtr := Ptr(EnvSeg, 0);

        {Find the search String}
        EOfs := SearchEnv(EPtr, Search);

        {Get the index of the next available environment location}
        ENext := EnvNext(EPtr);

        {Get total length of new environment String}
        NewLen := SLen+VLen;

        if EOfs <> $FFFF then begin
          {Search String exists}
          MOfs := EOfs+SLen;
          {Scan to end of String}
          SkipAsciiZ(EPtr, MOfs);
          OldLen := MOfs-EOfs;
          {No extra nulls to add}
          NulLen := 0;
        end else begin
          OldLen := 0;
          {One extra null to add}
          NulLen := 1;
        end;

        if VLen <> 0 then
          {Not a pure deletion}
          if ENext+NewLen+NulLen >= EnvLen+OldLen then
            {New String won't fit}
            Exit;

        if OldLen <> 0 then begin
          {OverWrite previous environment String}
          Move(EPtr^[MOfs+1], EPtr^[EOfs], ENext-MOfs-1);
          {More space free now}
          Dec(ENext, OldLen+1);
        end;

        {Append new String}
        if VLen <> 0 then begin
          Move(Search[1], EPtr^[ENext], SLen);
          Inc(ENext, SLen);
          Move(Value[1], EPtr^[ENext], VLen);
          Inc(ENext, VLen);
        end;

        {Clear out the rest of the environment}
        FillChar(EPtr^[ENext], EnvLen-ENext, 0);

        SetEnvStr := True;
      end;
    end;

    Procedure DumpEnv(Env : EnvRec);
      {-Dump the environment to StdOut}
    Var
      EOfs : Word;
      EPtr : EnvArrayPtr;
    begin
      With Env do begin
        if EnvSeg = 0 then
          Exit;
        EPtr := Ptr(EnvSeg, 0);
        EOfs := 0;
        WriteLn;
        While EPtr^[EOfs] <> #0 do begin
          While EPtr^[EOfs] <> #0 do begin
            Write(EPtr^[EOfs]);
            Inc(EOfs);
          end;
          WriteLn;
          Inc(EOfs);
        end;
        WriteLn('Bytes free: ', EnvFree(Env));
      end;
    end;
    {$IFDEF UseTpro}
    Function ShellWithPrompt(Prompt : String) : Integer;
      {-Shell to Dos With a new prompt}
    Const
      PromptStr : String[7] = 'PROMPT=';
    Var
      PLen : Byte Absolute Prompt;
      NSize : Word;
      Status : Integer;
      CE : EnvRec;
      NE : EnvRec;
      OldP : String;
      OldPLen : Byte Absolute OldP;
    begin
      {Point to current environment}
      CurrentEnv(CE);
      if CE.EnvSeg = 0 then begin
        {Error getting environment}
        ShellWithPrompt := -5;
        Exit;
      end;

      {Compute size of new environment}
      OldP := GetEnvStr(CE, PromptStr);
      NSize := CE.EnvLen;
      if OldPLen < PLen then
        Inc(NSize, PLen-OldPLen);

      {Allocate and initialize a new environment}
      NewEnv(NE, NSize);
      if NE.EnvSeg = 0 then begin
        {Insufficient memory For new environment}
        ShellWithPrompt := -6;
        Exit;
      end;
      CopyEnv(CE, NE);

      {Get the Program name from the current environment}
      OldP := ProgramStr;

      {Set the new prompt String}
      if not SetEnvStr(NE, PromptStr, Prompt) then begin
        {Program error, should have enough space}
        ShellWithPrompt := -7;
        Exit;
      end;

      {Transfer Program name to new environment if possible}
      if not SetProgramStr(NE, OldP) then
        ;

      {Point to new environment}
      SetCurrentEnv(NE);

      {Shell to Dos With new prompt in place}
      {Status := Exec('', True, ShellUserProc);}

      {Restore previous environment}
      SetCurrentEnv(CE);

      {Release the heap space}
      if Status >= 0 then
        DisposeEnv(NE);

      {Return exec status}
      ShellWithPrompt := Status;
    end;
    {$endIF}

    end.

    { EXAMPLE PROGRAM }

    Function DosVersion : Word;
      {-Return the Dos version, major part in AX}
    Inline(
      $B4/$30/                 {mov ah,$30}
      $CD/$21/                 {int $21}
      $86/$C4);                {xchg ah,al}

    Function ProgramStr : String;
      {-Return the name of the current Program, '' if Dos < 3.0}
    Var
      EOfs : Word;
      Env : EnvRec;
      EPtr : EnvArrayPtr;
      PStr : String;
    begin
      ProgramStr := '';
      if DosVersion < $0300 then
        Exit;
      CurrentEnv(Env);
      if Env.EnvSeg = 0 then
        Exit;
      {Find the end of the current environment}
      EPtr := Ptr(Env.EnvSeg, 0);
      EOfs := EnvNext(EPtr);
      {Skip to start of path name}
      Inc(EOfs, 3);
      {Collect the path name}
      GetAsciiZ(EPtr, EOfs, PStr);
      ProgramStr := PStr;
    end;

    Function SetProgramStr(Env : EnvRec; Path : String) : Boolean;
      {-Add a Program name to the end of an environment if sufficient space}
    Var
      PLen : Byte Absolute Path;
      EOfs : Word;
      Numb : Word;
      EPtr : EnvArrayPtr;
    begin
      SetProgramStr := False;
      With Env do begin
        if EnvSeg = 0 then
          Exit;
        {Find the end of the current environment}
        EPtr := Ptr(EnvSeg, 0);
        EOfs := EnvNext(EPtr);
        {Assure space For path}
        if EnvLen < PLen+EOfs+4 then
          Exit;
        {Put in the count field}
        Inc(EOfs);
        Numb := 1;
        Move(Numb, EPtr^[EOfs], 2);
        {Skip to start of path name}
        Inc(EOfs, 2);
        {Move the path into place}
        Path := Upper(Path);
        Move(Path[1], EPtr^[EOfs], PLen);
        {Null terminate}
        Inc(EOfs, PLen);
        EPtr^[EOfs] := #0;
        SetProgramStr := True;
      end;
    end;

[Back to DOS SWAG index] [Back to Main SWAG index] [Original]