Power-Programmierung/CD1.mdf/pascal/library/dos/bix/checkenv.pas

Pascal/Delphi Source File | 1986-11-01 | 6KB | 194 lines

{TITLE: MODIFICATION OF THE ORIGINAL DOS ENVIRONMENT:}
program checkenv;
(*********************************************************************)
{  Include module ENVIRON.INC ---  Modification of the Original DOS
   Environment with Error Trapping (same as DOS SET command).

   Return Codes for Function AddToOrig:
      0 : Normal Completion; String Was Added, Replaced or Deleted.
      1 : Invalid Environment String.  Follows same rules as DOS SET Command.
      2 : Insufficent Space in Environment.
      3 : String Not Found in Environment.

   This code assumes that the DOS Critical Error Handler has not been
   reset; in most cases, this is true.  If it has been modified, the
   Environment used will be that of the Critical Error Handler.

   John Leonard  9/11/1986
}

Type
   EnvironmentType=Array [0..32767] Of Char;
   EnvironPtr = ^EnvironmentType;
   EnvironStr = String[255];

const
   envseg : integer = 0;
   envoff : integer = 0;
   envsiz : integer = 0;

{$V-}

function EnvUpcaseStr(S : EnvironStr) : EnvironStr;
   var P : Integer;
   begin
      for P := 1 to Length(S) do S[P] := UpCase(S[P]);
      EnvUpcaseStr := S;
   end;

procedure GetOrigEnvInfo;
   begin
      {The Segment of the Original Environment is the same
       Segment as the critical error handler.  The critical error
       handler vector is stored at offset of the program PSP.}

      EnvSeg := memw[cseg:$14];

      {The Offset of the Original Environment is stored at offset
       $2C of the PSP of the critical error handler.}

      EnvOff := memw[EnvSeg:$2C];
      if EnvOff = 0 then
         EnvSeg  := pred(EnvSeg) + memw[pred(EnvSeg):$3] + 2;

      { The Size of the Environment is computed here. }

      EnvSiz :=  memw[pred(EnvSeg):$3] shl 4;
   end;


Function GetOldStr(SearchString: EnvironStr): EnvironStr;
   Type
      Env=EnvironmentType;
   Var
      EPtr: ^EnvironmentType;
      EStr:  EnvironStr;
      Done: Boolean;
      I: Integer;
   Begin
      getorigenvinfo;
      GetOldStr:='';
      If SearchString<>'' Then Begin
         EPtr:=Ptr(EnvSeg,0);
         I:=0;
         SearchString:=SearchString+'=';
         Done:=False;
         EStr:='';
         Repeat
            If EPtr^[I]=#0 Then Begin
               If EPtr^[Succ(I)]=#0 Then Begin
                  Done:=True;
                  If SearchString='==' Then Begin
                     EStr:='';
                     I:=I+4;
                     While EPtr^[I]<>#0 Do Begin
                        EStr:=EStr+EPtr^[I];
                        I:=Succ(I);
                     End;
                     GetOldStr:=EStr;
                  End;
               End;
               If Copy(EStr,1,Length(SearchString))=SearchString Then Begin
                  GetOldStr:=Copy(EStr,Succ(Length(SearchString)),255);
                  Done:=True;
               End;
               EStr:='';
            End
            Else EStr:=EStr+EPtr^[I];
            I:=Succ(I);
         Until Done;
      End;
   End;


Function AddToOrig(AddString: EnvironStr): integer;
   Type
      Env=EnvironmentType;
   Var
      EPtr: ^EnvironmentType;
      EStr,name : EnvironStr;
      kill,Done: Boolean;
      I,istart,j: Integer;
   Begin
      getorigenvinfo;
      if AddString = '' then begin
         AddToOrig := 1;            { Return 1: Invalid String }
         exit;
      end;
      i := pos('=',AddString);
      if i = 0 then begin
         AddToOrig := 1;
         exit;
      end;
      name := EnvUpCaseStr( copy(AddString,1,pred(i)) );
      delete(AddString,1,pred(i));
      writeln;
      if addstring = '=' then kill := true else kill := false;
      AddString := name + addstring + #0;
      If name<>'' Then Begin
         EPtr:=Ptr(EnvSeg,0);
         I:=0;
         Done:=False;
         EStr:='';
         IStart := 0;
         Repeat
            If EPtr^[I]=#0 Then Begin
               If Copy(EStr,1,ord(name[0]))=name Then begin
                  move(EPtr^[succ(i)],EPtr^[succ(istart)],EnvSiz-i);
                  if kill then begin
                     AddtoOrig := 0;
                     exit;
                  end;
               end;
               If EPtr^[Succ(I)]=#0 Then Begin
                  Done:=True;
                  if kill then begin
                     AddToOrig := 3;
                     exit;
                  end;
                  if (ord(addstring[0])) > (EnvSiz-i+2) then begin
                     AddtoOrig := 2;
                     exit;
                  end;
                  addstring := addstring + #0;
                  move(addstring[1],EPtr^[succ(i)],ord(addstring[0]));
                  AddtoOrig := 0;
               end;
               EStr:='';
               Istart := I;
            end
            Else EStr:=EStr+EPtr^[I];
            I:=Succ(I);
         Until Done;
      End;
   End;
{$V+}
(*********************************************************************)
(*****               End of Include Module ENVIRON.INC           *****)


(*** Example Program ***)

var i:integer;
    Seg,Off,Size:integer;
    ErrorMsg,SetString : string[100];
begin
   lowvideo;clrscr;
   getorigenvinfo;
   writeln('Size of Original DOS Environment: ',EnvSiz,' Bytes.');
   writeln;
   writeln('Enter Set String (Follow same rules as DOS SET. Leave off SET):');
   write('---> ');normvideo;
   readln(SetString);
   writeln;lowvideo;
   i := AddToOrig(SetString);
   case i of
      0 : errormsg := 'Environment Modified.  Use SET to examine.';
      1 : errormsg := 'Invalid SET String.  Refer to DOS manual.';
      2 : ErrorMsg := 'Not Enough Room in Environment.  Sorry.';
      3 : ErrorMsg := 'String Not Found in Environment.';
   end;
   writeln(errormsg);
   writeln;
end.