[net.micro.pc] Pushd, Popd turbo pascal source

g-tsang@gumby.UUCP (Michael H. Tsang) (02/14/86)

     I have received some requests on posting the source of pushd and popd.
So, here they are!

DOSENV.I------------------------CUT HERE---------------------------------------
{ Please report any bugs or suggestions to the author: g-tsang@gumby.wisc.edu }
{ [DOSEnvLib v1.00 (c) 2.13.86] by Michael H. Tsang }

  function GetDOSEnvSeg: integer;
  var
    SegPtr: integer;
  begin
    SegPtr := MemW[CSeg:$0016];
    while MemW[SegPtr:$0016] <> SegPtr do { Trace back to root process }
      SegPtr := MemW[SegPtr:$0016];
    GetDOSEnvSeg := SegPtr + MemW[SegPtr-1:$0003] + 1 { Skip DOS program seg }
  end; { GetDOSEnvSeg }

  function StrEqual(Key: Str; DOSEnv, MemIndex: integer): boolean;
  var
    StrIndex: integer;
    StillMatch: boolean;
  begin
    StillMatch := true;
    StrIndex := 1;
    while StillMatch and (StrIndex <= Length(Key)) do
      if Mem[DOSEnv:MemIndex] = ord(Key[StrIndex]) then begin
        MemIndex := MemIndex + 1;
        StrIndex := StrIndex + 1
      end else
        StillMatch := false;
    if StillMatch and (Mem[DOSEnv:MemIndex] = ord('=')) then
      StrEqual := true
    else
      StrEqual := false
  end; { StrEqual }

  function GetDOSEnvir(Key: Str; DOSEnv: integer; var MemIndex: integer): Str;

    function GetStr(Index: integer): Str;
    var
      TmpStr: Str;
    begin
      TmpStr := '';
      while Mem[DOSEnv:Index] <> 0 do begin
        TmpStr := TmpStr + chr(Mem[DOSEnv:Index]);
        Index := Index + 1
      end;
      GetStr := TmpStr
    end; { GetStr }

  var
    Found: boolean;
  begin { GetDOSEnvir }
    MemIndex := 0;
    Found := false;
    while (not Found) and (Mem[DOSEnv:MemIndex] <> 0) do
      if StrEqual(Key, DOSEnv, MemIndex) then
        Found := true
      else begin { Skip this variable }
        while Mem[DOSEnv:MemIndex] <> 0 do
          MemIndex := MemIndex + 1;
        MemIndex := MemIndex + 1
      end;
    if Found then
      GetDOSEnvir := GetStr(MemIndex + Length(Key) + 1)
    else
      GetDOSEnvir := ''
  end; { GetDOSEnvir }

  function SetDOSEnvir(EnvVar, EnvStr: Str; DOSEnv: integer): boolean;
  var
    TmpStr: Str;
    Index1, Index2: integer;

    procedure WriteStr(S: Str);
    var
      Index: integer;
    begin
      for Index := 1 to Length(S) do begin
        Mem[DOSEnv:Index1] := ord(S[Index]);
        Index1 := Index1 + 1
      end
    end; { WriteStr }

  begin { SetDOSEnvir }
    TmpStr := GetDOSEnvir(EnvVar, DOSEnv, Index1); { Save the old string }
    if TmpStr <> '' then begin { Variable was defined }
      Index2 := Index1 + Length(EnvVar) + Length(TmpStr) + 2; { Point to next variable }
      while Mem[DOSEnv:Index2] <> 0 do { Move following variables up }
        repeat
          Mem[DOSEnv:Index1] := Mem[DOSEnv:Index2];
          Index1 := Index1 + 1;
          Index2 := Index2 + 1
        until Mem[DOSEnv:Index2-1] = 0
    end;
    if (Index1+Length(EnvVar)+Length(EnvStr)+3) <= (MemW[DOSEnv-1:$0003]*16) then begin
    { There is sufficient environment space }
      if EnvStr <> '' then { Set the variable }
        WriteStr(EnvVar + '=' + EnvStr + chr(0));
      SetDOSEnvir := true
    end else if TmpStr <> '' then begin { Restore old content of variable }
      WriteStr(EnvVar + '=' + TmpStr + chr(0));
      writeln(ProgramName, ': Insufficient environment space');
      SetDOSEnvir := false
    end;
    Mem[DOSEnv:Index1] := 0
  end; { SetDOSEnvir }
PUSHD.PAS---------------------------CUT HERE-----------------------------------
{ Please report any bugs or suggestions to the author: g-tsang@gumby.wisc.edu }

{$G512,P512}
program Pushd(input, output);

const
  ProgramName = 'pushd';
  Version = '[v2.30 (c) 2.13.86] by Michael H. Tsang';
  StrLen = 255;
type
  Str = string[StrLen];
var
  StackStr: Str;
  Depth, DOSEnv: integer;
  Dirty: boolean;

  {$I c:\tools\turbo\lib\dosenv.i}

  function GetStack: boolean;
  var
    Index: integer;
    TmpStr: Str;
  begin
    GetDir(0, StackStr);
    TmpStr := GetDOSEnvir('DIRSTACK', DOSEnv, Index);
    if (Length(StackStr) + Length(TmpStr)) >= StrLen then begin
      writeln(ProgramName, ': Stack too large');
      GetStack := false
    end else begin
      if TmpStr = '' then
        Depth := 0
      else begin
        Depth := 1;
        for Index := 1 to Length(TmpStr) do { Count depth }
          if TmpStr[Index] = ';' then
            Depth := Depth + 1;
        StackStr := StackStr + ';' + TmpStr { Prepend current directory }
      end;
      GetStack := true
    end
  end; { GetStack }

  procedure SwapStackTop;
  var
    TmpStr: Str;
    Where: integer;
  begin
    if Depth = 0 then
      writeln(ProgramName, ': No other directory')
    else begin
      Where := Pos(';', StackStr);
      TmpStr := Copy(StackStr, 1, Where-1);
      Delete(StackStr, 1, Where);
      Where := Pos(';', StackStr);
      if Where = 0 then
        StackStr := StackStr + ';' + TmpStr
      else
        Insert(';'+TmpStr, StackStr, Where);
      Dirty := true
    end
  end; { SwapStackTop }

  procedure RotateStack(NumStr: Str);
  var
    Index, Cnt, Num, Result: integer;
    TmpStr: Str;
  begin
    Val(Copy(NumStr, 2, Length(NumStr)-1), Num, Result);
    if (Result <> 0) or (Num <= 0) then
      writeln(ProgramName, ': ', NumStr, ': No such file or directory')
    else begin
      if Num > Depth then
        writeln(ProgramName, ': Directory stack not that deep')
      else begin
        Index := 1;
        for Cnt := 1 to Num do begin
          while StackStr[Index] <> ';' do
            Index := Index + 1;
          Index := Index + 1
        end;
        TmpStr := Copy(StackStr, 1, Index-2);
        Delete(StackStr, 1, Index-1);
        StackStr := StackStr + ';' + TmpStr;
        Dirty := true
      end
    end
  end; { RotateStack }

  procedure PushStack(ArgStr: Str);
  var
    Home: Str;
    Index: integer;
  begin
    if ArgStr[1] = '~' then begin
      Home := GetDOSEnvir('HOME', DOSEnv, Index);
      if Home <> '' then begin
        Delete(ArgStr, 1, 1);
        Insert(Home, ArgStr, 1)
      end
    end;
    if (Length(StackStr) + Length(ArgStr)) >= StrLen then
      writeln(ProgramName, ': Insufficient stack space')
    else begin
      ArgStr := ArgStr + ';';
      Insert(ArgStr, StackStr, 1);
      Dirty := true
    end
  end; { PushStack }

  procedure SaveStack;
  var
    TopStr, CDStr: Str;
    Where: integer;
  begin
    GetDir(0, CDStr);
    Where := Pos(';', StackStr);
    if Where = 0 then begin { Isolate top of stack }
      TopStr := StackStr;
      StackStr := ''
    end else begin
      TopStr := Copy(StackStr, 1, Where-1);
      Delete(StackStr, 1, Where)
    end;
    {$I-}
    ChDir(TopStr);
    {$I+}
    if IOResult <> 0 then
      writeln(ProgramName, ': ', TopStr, ': No such file or directory')
    else
      if SetDOSEnvir('DIRSTACK', StackStr, DOSEnv) then begin
        GetDir(0, TopStr);
        if StackStr = '' then
          writeln(TopStr)
        else
          writeln(TopStr, ';', StackStr)
      end else { Out of environment space }
        ChDir(CDStr) { Restore previous directory }
  end; { SaveStack }

var
  Argc: integer;
  ArgStr: Str;
begin { Pushd }
  Argc := ParamCount;
  if Argc > 1 then
    writeln('Usage: ', ProgramName, ' [pathname | +n | -v]')
  else begin
    Dirty := false;
    DOSEnv := GetDOSEnvSeg;
    if GetStack then begin
      if Argc = 0 then
        SwapStackTop
      else begin
        ArgStr := ParamStr(1);
        if ArgStr = '-v' then
          writeln(ProgramName, ': ', Version)
        else if ArgStr[1] = '+' then
          RotateStack(ArgStr)
        else
          PushStack(ArgStr)
      end;
      if Dirty then
        SaveStack
    end
  end
end. { Pushd }
POPD.PAS-----------------------------CUT HERE----------------------------------
{ Please report any bugs or suggestions to the author: g-tsang@gumby.wisc.edu }

{$G512,P512}
program Popd(input, output);

const
  ProgramName = 'popd';
  Version = '[v2.30 (c) 2.13.86] by Michael H. Tsang';
  StrLen = 255;
type
  Str = string[StrLen];
var
  StackStr: Str;
  Depth, DOSEnv: integer;
  Dirty: boolean;

  {$I c:\tools\turbo\lib\dosenv.i}

  function GetStack: boolean;
  var
    Index: integer;
    TmpStr: Str;
  begin
    GetDir(0, StackStr);
    TmpStr := GetDOSEnvir('DIRSTACK', DOSEnv, Index);
    if (Length(StackStr) + Length(TmpStr)) >= StrLen then begin
      writeln(ProgramName, ': Stack too large');
      GetStack := false
    end else begin
      if TmpStr = '' then
        Depth := 0
      else begin
        Depth := 1;
        for Index := 1 to Length(TmpStr) do
          if TmpStr[Index] = ';' then
            Depth := Depth + 1;
        StackStr := StackStr + ';' + TmpStr
      end;
      GetStack := true
    end
  end; { GetStack }

  procedure PopStack;
  var
    Where: integer;
  begin
    if Depth = 0 then
      writeln(ProgramName, ': Directory stack empty')
    else begin
      Where := Pos(';', StackStr);
      Delete(StackStr, 1, Where);
      Dirty := true
    end
  end; { PopStack }

  procedure DeleteStack(NumStr: Str);
  var
    Cnt, Num, Result, Index1, Index2: integer;
    Found: boolean;
  begin
    Val(Copy(NumStr, 2, Length(NumStr)-1), Num, Result);
    if (Result <> 0) or (Num <= 0) then
      writeln(ProgramName, ': ', NumStr, ': Bad directory')
    else begin
      if Num > Depth then
        writeln(ProgramName, ': Directory stack not that deep')
      else begin
        Index1 := 1;
        for Cnt := 1 to Num do begin
          while StackStr[Index1] <> ';' do
            Index1 := Index1 + 1;
          Index1 := Index1 + 1
        end;
        Index2 := Index1 - 1;
        Found := false;
        while not Found and (Index1 <= Length(StackStr)) do
          if StackStr[Index1] <> ';' then
            Index1 := Index1 + 1
          else
            Found := true;
        Delete(StackStr, Index2, Index1-Index2);
        Dirty := true
      end
    end
  end; { DeleteStack }

  procedure SaveStack;
  var
    TopStr, CDStr: Str;
    Where: integer;
  begin
    GetDir(0, CDStr);
    Where := Pos(';', StackStr);
    if Where = 0 then begin
      TopStr := StackStr;
      StackStr := ''
    end else begin
      TopStr := Copy(StackStr, 1, Where-1);
      Delete(StackStr, 1, Where)
    end;
    {$I-}
    ChDir(TopStr);
    {$I+}
    if IOResult <> 0 then
      writeln(ProgramName, ': ', TopStr, ': No such file or directory')
    else
      if SetDOSEnvir('DIRSTACK', StackStr, DOSEnv) then begin
        GetDir(0, TopStr);
        if StackStr = '' then
          writeln(TopStr)
        else
          writeln(TopStr, ';', StackStr)
      end else
        ChDir(CDStr)
  end; { SaveStack }

var
  Argc: integer;
  ArgStr: Str;
begin { Popd }
  Argc := ParamCount;
  if Argc > 1 then
    writeln('Usage: ', ProgramName, ' [+n | -v]')
  else begin
    Dirty := false;
    DOSEnv := GetDOSEnvSeg;
    if GetStack then begin
      if Argc = 0 then
        PopStack
      else begin
        ArgStr := ParamStr(1);
        if ArgStr = '-v' then
          writeln(ProgramName, ': ', Version)
        else if ArgStr[1] = '+' then
          DeleteStack(ArgStr)
        else
          writeln(ProgramName, ': ', ArgStr, ': Bad directory')
      end;
      if Dirty then
        SaveStack
    end
  end
end. { Popd }
--------------------------------------CUT HERE---------------------------------

	Mike Tsang (g-tsang@gumby.wisc.edu)