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

    unit setenv;
    interface
    type  s24 = string;
    Function SetTheEnv (symbol, val : s24) : boolean;

    implementation
    {uses asciiz;}
    const
       arena_size = 16;
       NORMAL_ATYPE = #$4D;
       LAST_ATYPE   = #$5A;
       COMSPEC : string[8] = 'COMSPEC=';

    type
        PSP = record
    	fill1              : array [1..10] of char;
            PrevTermHandlerPtr : ^integer;
    	PrevCtrlCptr       : ^integer;
    	PrevCritErrPtr     : ^integer;
    	fill2              : array [1..22] of char;
    	EnvirSeg           : word;
            end;

        Arena = record
    	ArenaType     : char;
    	PspSegment    : word;
    	NumOfSegments : word;
            fill3         : array [1..11] of char;
            ArenaData     : string;{ca}
            end;

         str4 = string[4];

    var
        ap    : ^arena;

    {$ifdef Debug}
    Function HexStr (n:word):str4;
       const ha:array[0..15] of char=('0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f');
       var str : str4;
       begin
       str[0]:=chr(4);
       str[1]:=ha[hi(n) shr 4];
       str[2]:=ha[hi(n) and $F];
       str[3]:=ha[(n shr 4) and $F];
       str[4]:=ha[n and $F];
       HexStr := str;
       end;
    {$endif}

    Function GetNextArena (var ap:arena) : pointer;
       var tp : pointer;
       begin
       tp := Ptr( Seg(ap)+1+ap.NumOfSegments, 0);
       GetNextArena := tp;
       end {GetNextArena};

    Function IsValidArena (var ar:arena) : boolean;
    var ap1 : ^arena;
       begin
       IsValidArena := false;
       if ar.ArenaType <> NORMAL_ATYPE   then  Exit;
       ap1 := GetNextArena (ar);
       if ap1^.ArenaType <> NORMAL_ATYPE then  Exit;

       ap1 := GetNextArena (ap1^);
       if (ap1^.ArenaType <> NORMAL_ATYPE) and
          (ap1^.ArenaType <> LAST_ATYPE)        then  Exit;
       IsValidArena:=true;
       end {IsValidArena};

    Function GetFirstArena : pointer;
    { return pointer to the first arena.
      scan memory for a 0x4D on a segment start,
      see if this points to another two levels of arena. }
    var
       ap, ap1  : ^arena;
       segment  : word;

       begin
            for segment:=60 to Cseg do
                begin
                ap := ptr(segment, 0);
                if IsValidArena (ap^)  then
                   begin  GetFirstArena := ap;  Exit;  end;
                end;
    	GetFirstArena := nil;
    end {GetFirstArena};

    Function IsValidEnv (var ad:ca; NumSegs:integer):boolean;
    var
       COMSPECa : ca;
       adp      : cap;
       BaseAD   : word;

       begin
       BaseAD := ofs (ad);
       adp    := @ad;
       PtoA (COMSPEC, COMSPECa);
       while ( adp^[0] <> #0 ) and
             ( (ofs(adp^)-BaseAD) shr 4 < NumSegs ) do
            begin
            if (strnicmp(adp^, COMSPECa, 8) = 0) then
                begin  IsValidEnv:=true;  Exit;  end;
            adp := @adp^[strlen(adp^) + 1];
            end {while};
       IsValidEnv := false;
    end {IsValidEnv};

    Function GetArenaOfEnvironment : pointer;
    {  First get segment of COMMAND.COM from segment of previous critical err code.
       then go to this COMMAND.COM, and go get its ENV block,
       check that it is an ENV block }

    Label L1, L2;
    var
       ap       : ^arena;
       Mypsp    : ^psp;
       CCpsp    : ^psp;
       CCseg, i : word;
       EnvSeg   : word;
       ad       : cap;

       begin
       GetArenaOfEnvironment := NIL;

       { set Mypspp to psp of this program }
       Mypsp := Ptr (PrefixSeg, 0);

       { set CCpsp to psp of COMMAND.COM }
       CCseg := Seg (Mypsp^.PrevCritErrPtr^);
       i := CCseg - 32;   if i<60 then i:=60;

       while CCseg > i do
             begin
             ap := Ptr (CCseg, 0);
             if IsValidArena (ap^) then  goto L1;
             dec (CCseg);
             end;
        exit;   {error}

    L1: inc (CCseg);
        CCpsp := Ptr (CCseg, 0);

       {$ifdef Debug}
          writeln ('prog psp=', HexStr(seg(Mypsp^)),
                   ' prog crit_err_seg=', HexStr(CCseg) );
       {$endif}

       {first see if the env seg in command.com points at a good env block?}
       EnvSeg := CCpsp^.EnvirSeg;
       ap := Ptr (EnvSeg-1, 0);

       {$ifdef Debug}
          writeln ('Env ', HexStr(seg(ap^)),
                        ',  psp in env=', HexStr(ap^.PspSegment));
       {$endif}

       { if a valid arena, then search the entire arena for validity,
         if not a valid arena, then maybe it is one of these fabricated
         guys that shells like "4DOS" set up, search the first 128 bytes
         only }

       i := ap^.NumOfSegments-1;

       if not IsValidArena(ap^) then
          i := 9
       else
          if  ap^.PspSegment <> CCseg  then  goto L2;

       if IsValidEnv(ap^.ArenaData, i) then
          begin
          GetArenaOfEnvironment := ap;
          {$ifdef Debug} writeln('env found');  {$endif}
          Exit;
          end;

       {command.com did not have a good env segment, lets search all MCB's }
    L2:
       ap := GetFirstArena;
       if ap=NIL then Exit;
       while (ap^.ArenaType <> LAST_ATYPE) do
            begin
            {$ifdef Debug} Writeln ('arena ', HexStr(seg(ap^)));  {$endif}
            if (ap^.PspSegment=CCseg) and
                IsValidEnv(ap^.ArenaData, ap^.NumOfSegments-1) then
               begin
               GetArenaOfEnvironment := ap;
               {$ifdef Debug} writeln('env found'); {$endif}
               Exit;
               end;
            ap := GetNextArena (ap^);
            end;

       end {GetArenaOfEnvironment};

    {*****************************************************************************}

    Function SetTheEnv (symbol, val : s24) : boolean;
    var
        TotalEnvSize,
        NeededSize,
        strlength     : integer;
        sp, op, envir : cap;
        SymbolLen     : integer;
        SymbolA, ValA : ca;
        Found         : boolean;
        ap            : ^arena;

        begin
        NeededSize := 0;
        Found      := false;
        SetTheEnv  := false;

        PtoA  (Symbol, SymbolA);
        PtoA  (Val, ValA);
        strupr(symbolA);
        SymbolLen := strlen (symbolA);
        SymbolA [SymbolLen]   := '=';
        SymbolA [SymbolLen+1] := #0;

        { first, can the COMMAND.COM envir block be found ? }
        ap := GetArenaOfEnvironment;
        if ( ap = NIL) then  exit;

        { search to end of the envir block, get sizes }
        TotalEnvSize := 16 * ap^.NumOfSegments;
        envir := @ap^.ArenaData;
        op    := envir;
        sp    := envir;

        while sp^[0] <> #0 do
            begin
    	strlength := strlen(sp^)+1;
    	if ( strnicmp(sp^, symbolA, SymbolLen+1) = 0 )  then
    	     found := true
    	else
                 begin
                 NeededSize := NeededSize + strlength;
                 if found then  strcpy(op^  , sp^);
                 op := @op^[strlength];
    	     end;
    	sp := @sp^[strlength];
            end;
        op^[0] := #0;

        if (strlen(valA) > 0) then
            begin
    	NeededSize := NeededSize + 3 + SymbolLen + strlen(valA);

    	if (NeededSize > TotalEnvSize) then
    		Exit;    {could mess with environment expansion here}

    	strcpy(op^, symbolA);  strcat(op^, valA);
    	op := @op^[strlen(op^)+1];
            end;
        op^[0] := #0;
        SetTheEnv := true;
      end {SetTheEnv};

    end.

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