ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/CL89APR1.ZIP/ENV.ARC/ENVTEST.PAS

Pascal/Delphi Source File | 1988-09-26 | 12.1 KB | 480 lines

(* Turbo Pascal version 4 *)
{$B-,D-,F-,I-,L+,N-,R-,S-,T-,V-}
{$M 4096,0,0}

PROGRAM Evntest;

  { UNIT Env test }

USES Dos, Crt;

TYPE
  Str4 = string[4];

VAR
  UseCurrentEnv : boolean;  { true if current environment is accessed }
  SecondCommand : boolean;  { true if secondary COMMAND.COM is loaded }
  EnvAddr       : word;     { environment address }
  EnvSize       : integer;  { environment size }
  EnvTyp        : byte;     { environment type }
  RootEnvAddr   : word;     { root environment address }
  RootEnvSize   : integer;  { root environment size }
  Regs          : Registers;
  EnvStr        : string;
  EnvParam      : string;
  EnvVar        : string;

FUNCTION Hex(i : integer): Str4;

      { convert an integer to hex string }
CONST
  HexCh : array[0..15] of char = '0123456789ABCDEF';

VAR
  Temp   : byte;
  TempSt : string[2];

begin
  Temp := hi(i);
  TempSt := HexCh[Temp shr 4] + HexCh[Temp and $0F];
  Temp := lo(i);
  Hex := TempSt + HexCh[Temp shr 4] + HexCh[Temp and $0F];
end;  { Hex }

PROCEDURE GetEnvTyp(VAR EnvTyp : byte);

VAR
  Major : byte;  { major DOS version number }
  Minor : byte;  { minor DOS version number }

begin

      { get DOS version }
  with Regs do
    begin
      AX := $3000;
      MSDos(Regs);
      Major := Lo(AX);
      Minor := Hi(AX);
    end;

      { assign environment type according to DOS version }
  case Major of
    2 : EnvTyp := 1;
    3 : case Minor of
          0, 10 : EnvTyp := 1;
          20    : EnvTyp := 2;
          30    : EnvTyp := 3;
        end;
    4 : EnvTyp := 3;
    else
      begin
        Writeln('Unknown DOS version');
        Halt;
      end;
  end;  { case }
  Writeln('DOS version              : ',Major,'.',Minor);
  Writeln('Environment type         : ',EnvTyp);
end;  { GetEnvTyp }

PROCEDURE SearchMemory(VAR RootEnvaddr : word; VAR RootEnvSize : integer);

      { search memory for root environment }
VAR
  ComMCB  : word;     { COMMAND.COM MCB }
  EnvMCB  : word;     { environment MCB }
  MCBsize : word;     { memory block size in paragraphs }
  Found   : boolean;  { root COMMAND.COM found }

PROCEDURE CheckMCBchain(ComMCB : word; VAR EnvMCB : word;
                        VAR Found : boolean);

      { check for Memory Control Block chain }

begin
  Found := false;
  MCBsize := MemW[ComMCB : 3];
  EnvMCB := Succ(ComMCB + MCBsize);
  if (Mem[EnvMCB : 0] = $4D) then
    Found := true;
end;  { CheckMCBchain }

begin  { SearchMemory }

      { begin search for COMMAND.COM in low memory }
  ComMCB := $500;
  Found := false;
  while not Found do
    begin

      { MCB begins with $4D }
      if Mem[ComMCB:0] = $4D then
        begin

      { check for matching PSP address }
          if MemW[ComMCB : 1] = Succ(ComMCB) then
            CheckMCBchain(ComMCB,EnvMCB,Found);
        end;

      { if not Found then continue search at next paragraph boundary }
      Inc(ComMCB);
    end;  { while }
  Writeln('Root PSP address         : ',Hex(ComMCB));

      { check for environment type }
  if MemW[ComMCB : $2C] = 0 then

      { root environment of DOS 2.0 - 3.2 }
    begin
      RootEnvAddr := Succ(EnvMCB);
      MCBsize := MemW[EnvMCB : 3];
      RootEnvSize := MCBsize * $10;
    end
  else

      { root environment of DOS 3.3 - 4.0 }
    begin
      RootEnvAddr := MemW[ComMCB : $2C];
      EnvMCB := Pred(RootEnvaddr);
      MCBsize := MemW[EnvMCB : 3];
      RootEnvSize := MCBsize * $10;
    end;  { if }
end;  { SearchMemory }

PROCEDURE GetEnv(VAR EnvAddr : word; VAR EnvSize : integer;
                 VAR RootEnvAddr : word; VAR RootEnvSize : integer;
                 EnvTyp : byte);
VAR
  PSPaddr : word;  { COMMAND.COM PSP address }
  ComMCB  : word;  { COMMAND.COM MCB }
  EnvMCB  : word;  { environment MCB }
  MCBsize : word;  { memory block size in paragraphs }

begin
  RootEnvAddr := 0;

      { COMMAND.COM PSP address at offset $16 in program PSP }
  PSPaddr := MemW[PrefixSeg : $16];

      { check for child process }
  while (PSPaddr <> MemW[PSPaddr : $16]) do
    PSPaddr := MemW[PSPaddr : $16];

      { COMMAND.COM MCB address }
  ComMCB := Pred(PSPaddr);

      { size of COMMAND.COM }
  MCBsize := MemW[ComMCB : 3];

      { environment MCB address }
  EnvMCB := PSPaddr + MCBsize;

      { assign environment address }
  EnvAddr := Succ(EnvMCB);

      { size of environment }
  MCBsize := MemW[EnvMCB : 3];
  EnvSize := MCBsize * $10;

      { check for secondary COMMAND.COM }
  case EnvTyp of

      { $2C points to DOS environment in DOS 2.0 - 3.1 }
    1 : if (MemW[PSPaddr : $2C] <> 0) then
          begin
            SearchMemory(RootEnvAddr,RootEnvSize);

      { re-assign environment address }
            EnvAddr := MemW[PSPaddr : $2C];
            EnvMCB := Pred(Envaddr);
            MCBsize := MemW[EnvMCB : 3];
            EnvSize := MCBsize * $10;
          end;

      { $2C points to program environment in DOS 3.2 }
    2 : if (MemW[PSPaddr : $2C] <> 0) then
          SearchMemory(RootEnvAddr,RootEnvSize);

      { $2C points to DOS environment in DOS 3.3 - 4.0 }
    3 : if (MemW[PSPaddr : $2C] = EnvAddr) then
          SearchMemory(RootEnvAddr,RootEnvSize)
        else

      { re-assign environment address }
          begin
            EnvAddr := MemW[PSPaddr : $2C];
            EnvMCB := Pred(Envaddr);
            MCBsize := MemW[EnvMCB : 3];
            EnvSize := MCBsize * $10;
          end;
  end;  { case }
  Writeln('Current PSP address      : ',Hex(PSPaddr));
end;  { GetEnv }

FUNCTION UpStr(St : string) : string;

      { convert a string to upper case }
VAR
  i : byte;

begin
  for i := 1 to Length(St) do
    St[i] := UpCase(St[i]);
  UpStr := St;
end;  { UpStr }

FUNCTION Position(St : string; EnvAddr : word; ArrayLen : integer) : integer;

      { find the position of a string in the environment array }
VAR
  Found : boolean;
  Match : boolean;
  StLen : integer;
  i     : integer;
  p     : integer;

begin
  Found := false;
  StLen := Length(St);
  p := 0;
  while (not Found) and ((ArrayLen - p+1) >= StLen) do

      { find first match }
    begin
      if St[1] = Chr(Mem[EnvAddr : p]) then

      { find next match }
      begin
        Match := true;
        i := 1;
        while Match and (i < StLen) do
          if St[1+i] = Chr(Mem[EnvAddr : p+i]) then
            Inc(i)
          else
            Match := false;
        Found := Match;
        end;
      if not Found then
        Inc(p);
    end;
  if found then
    Position := p
  else
    Position := -1;
end;  {  Position  }

PROCEDURE ReadEnvVar(EnvParam : string; VAR EnvVar : string);

VAR
  ArrayLen : integer;  { environment array length }
  ParamPos : integer;  { parameter position }
  VarPos   : integer;  { variable position }
  i        : integer;

begin
  if EnvParam = '' then
    Exit;
  if not UseCurrentEnv then
    begin
      EnvAddr := RootEnvAddr;
      EnvSize := RootEnvSize;
    end;

      { check if environment is empty }
  if Mem[EnvAddr : 0] = 0 then
    Exit
   else
     begin

      { get the length of the environment string }
        ArrayLen := Position(#0#0,EnvAddr,EnvSize);
        if ArrayLen = -1 then
          begin
            Writeln('End of environment not found');
            Halt;
          end;
     end;  { else }

      { initialize variables }
  EnvParam := UpStr(EnvParam) + '=';
  EnvVar := '';

      { search for variable in environment }
  ParamPos := Position(EnvParam,EnvAddr,ArrayLen);
  if ParamPos = -1 then
    Exit

      { environment parameter found }
      { get length of variable string }
   else
     begin
       ParamPos := ParamPos + Length(EnvParam);
       VarPos := ParamPos;
       while Mem[EnvAddr : VarPos] <> 0 do
         Inc(VarPos);

      { assign environment variable }
       Move(Mem[EnvAddr:ParamPos], EnvVar[1], VarPos-ParamPos);
       EnvVar[0] := Chr(VarPos-ParamPos);
     end;  { else }
end;  { ReadEnvVar }

PROCEDURE WriteEnvVar(EnvParam, EnvVar : string);

VAR
  ArrayLen : integer;  { environment array length }
  EnvStr   : string;   { environment string }
  StLen    : integer;  { environment string length }
  ParamPos : integer;  { parameter position }
  i        : integer;

begin
  if EnvParam = '' then
    Exit;
  if not UseCurrentEnv then
    begin
      EnvAddr := RootEnvAddr;
      EnvSize := RootEnvSize;
    end;

      { check if environment is empty }
  if Mem[EnvAddr : 0] = 0 then
    ArrayLen := 0
   else
     begin

      { get the length of the environment string }
        ArrayLen := Position(#0#0,EnvAddr,EnvSize);

        if ArrayLen = -1 then
          begin
            Writeln('End of environment not found');
            Halt;
          end;
     end;  { else }

      { initialize variables }
  EnvParam := UpStr(EnvParam) + '=';
  EnvStr := EnvParam + EnvVar + #0#0;
  StLen := Length(EnvStr);

      { search for variable in environment }
  ParamPos := Position(EnvParam,EnvAddr,ArrayLen);

  if ParamPos = -1 then
    begin

      { check for empty variable }
        if EnvVar = '' then
          Exit;

      { environment parameter not found }
      { compare environment with string }
        if (ArrayLen + StLen + 1) > EnvSize then
          Writeln('Environment full')
        else

      { add new variable string to end of array }
          begin
            if ArrayLen = 0 then
              Move(EnvStr[1], Mem[EnvAddr : 0], StLen)
            else
              Move(EnvStr[1], Mem[EnvAddr : ArrayLen+1], StLen);
          end;
    end  { if }

      { environment parameter found }
      { get length of variable string }
  else
    begin

      { skip three characters in array }
      i := ParamPos + 3;
      while Mem[EnvAddr : i] <> 0 do
        Inc(i);

      { get beginning of next variable string }
        Inc(i);

      { delete variable from current position in array }
        Move(Mem[EnvAddr: i], Mem[EnvAddr: ParamPos], (ArrayLen+2)-i);
        ArrayLen := ArrayLen - (i-ParamPos);

      { check for empty variable }
       if EnvVar = '' then
         Exit;

      { compare environment array length with environment size }
       if (ArrayLen + StLen + 1) > EnvSize then
         Writeln('Environment full')
       else

      { add variable to end of array }
         Move(EnvStr[1], Mem[EnvAddr : ArrayLen+1], StLen);
     end;  { else }
end;  { WriteEnvVar }

procedure GetParams(EnvStr : string; var EnvParam, EnvVar : string);

var
  p     : integer;

begin
  p := Pos('=',EnvStr);
  if p <= 1 then
    begin
      Writeln('Invalid parameter');
      EnvParam := '';
      EnvVar := '';
      Exit;
    end;
  EnvParam := UpStr(Copy(EnvStr,1,p-1));
  EnvVar := Copy(EnvStr,p+1,Length(EnvStr));
end;  { GetParams }


begin  { Env }

      { initialize environment address }
  UseCurrentEnv := true;
  SecondCommand := true;
  GetEnvTyp(EnvTyp);
  GetEnv(EnvAddr,EnvSize,RootEnvAddr,RootEnvSize,EnvTyp);
  if RootEnvAddr = 0 then
    begin
      RootEnvAddr := EnvAddr;
      RootEnvSize := EnvSize;
      SecondCommand := false;
    end;

      { print environment address }
  if SecondCommand then
    begin
      Writeln('Root environment address : ',Hex(RootEnvAddr));
      Writeln('Root environment size    : ',RootEnvSize);
    end;
  Writeln('Environment address      : ',Hex(EnvAddr));
  Writeln('Environment size         : ',EnvSize);
  Writeln;

      { test reading and writing}
  Write('Add environment variable    :');
  Readln(EnvStr);
  GetParams(EnvStr,EnvParam,EnvVar);
  WriteEnvVar(EnvParam,EnvVar);
  Write('Change environment variable :');
  Readln(EnvStr);
  GetParams(EnvStr,EnvParam,EnvVar);
  WriteEnvVar(EnvParam,EnvVar);
  Write('Show environment variable   :');
  Readln(EnvParam);
  EnvParam := UpStr(EnvParam);
  ReadEnvVar(EnvParam,EnvVar);
  Writeln('   ',EnvParam,'=',EnvVar);
  Write('Delete environment variable :');
  Readln(EnvParam);
  EnvParam := UpStr(EnvParam);
  EnvVar := '';
  WriteEnvVar(EnvParam,EnvVar);
end.  { Env }