unit JRS_EnvU ;

{ ENVIRON by JRS, >=2002-11-23
  Used by NOWMINUS, ENVICALC.  Tested for DOS mode.
  Set or clear an ancestral environment variable.
  Name part of input is made UPPER CASE.
  Status values:
  0 = OK
  1 = No environment found
  2 = Empty environment found
  3 = No environment terminator found
  4 = Insufficient space for change (also: WinNT)
  5 = DEBUG problem
  Note that this affects only one specified environment, Gen deep.
  Ref: MSDOS Bible

  DOS mode (not DPMI/Windows; gave GPF there; JRS_EnvD might be worked on
  Fails harmlessly in Windows NT)
  Limited environment handling, /in lieu/ of TSUntEnv.
  The unit does NOT expand any environment.
  Written with assistance from TS and others in news:c.l.p.b.
  This seems OK for DOS, Win3, Win98;
  but direct environment access may not be allowed in Windows NT. }


interface

type TGetPut = (Get, Put) ;

const EnvironNameWillBeMadeUpperCase : boolean = true ;

procedure Environ(const Ndeep : word ; const RW : TGetPut ;
  EnvNam : string ; var EnvVal : string ; var Status : byte) ;

function GetPSPseg_Ndeep(const Ndeep : word) : word ;

procedure GetEnvDescNdeep(const Ndeep : integer ; var Segt, Size : word) ;

{$IFDEF JRS}
procedure ResizeEnvtNdeep(const Ndeep : integer ; const NewSize : word ;
  var Status : byte) (* DO NOT USE *) ;

procedure ValidateEnvtNdeep ;
{$ENDIF}


implementation

uses Dos ;

type Pword = ^word ;

function GetChar(const Seg, Off : word) : char ;
begin GetChar := Pchar(Ptr(Seg, Off))^ end {GetChar} ;

function GetWord(const Seg, Off : word) : word ;
begin GetWord := Pword(Ptr(Seg, Off))^ end {GetWord} ;

function GetEnvSeg(const PSPsg : word) : word
  { PSP word 2Ch is Seg of Env } ;
begin GetEnvSeg := GetWord(PSPsg, $2C) end {GetEnvSeg} ;

function GetParentSeg(const PSPsg : word) : word
  { PSP word 16h is Seg of Parent } ;
begin GetParentSeg := GetWord(PSPsg, $16) end {GetParentSeg} ;

function GetPSPseg_Ndeep(const Ndeep : word) : word { consider Ndeep=0 } ;
var PSPseg : word ; J : word ;
begin
  PSPseg := PrefixSeg ;
  for J := 1 to Ndeep do PSPseg := GetParentSeg(PSPseg) ;
  GetPSPseg_Ndeep := PSPseg end {GetPSPseg_Ndeep} ;


{ It appears that Ndeep=8 is considered sufficient to reach the deepest.
  With a depth of 0, it sets the program's own environment, given room. }


{ MCB : type-char, owner-word, paragraphs-word, other-11-bytes }

procedure GetEnvDescNdeep(const Ndeep : integer ; var Segt, Size : word) ;
var DosVer, PSPseg : word ;
begin Size := 0;

  PSPseg := GetPSPseg_Ndeep(Ndeep) ;

  if PSPseg=0 then EXIT ;

  Segt := GetEnvSeg(PSPseg) ;

  DosVer := Swap(DosVersion) ;
  if (Segt = 0) or ((DosVer >= $0320) and (DosVer < $0330)) then
    Segt := Succ(PSPseg + GetWord(Pred(PSPseg), $3)) ;

  if GetWord(Pred(Segt), $1) <> PSPseg then EXIT ;
  Size := $10 * GetWord(Pred(Segt), $3) ;
  end {GetEnvDescNdeep} ;


procedure ResizeEnvtNdeep(const Ndeep : integer ; const NewSize : word ;
  var Status : byte) (* DO NOT USE *) ;
var EnvSeg, EnvSize, NewSeg, Paras : word ; Stts : byte ;
begin Stts := 0 ;
  GetEnvDescNdeep(Ndeep, EnvSeg, EnvSize) ;

  { Get new block }
  Paras := Succ(Pred(NewSize) div $10) ;
  asm  mov BX,[Paras] ; mov AH,$48 ; int $21 ; jb @1 {jump if bad }
      mov [NewSeg],AX ; jmp @2 ;
    @1: mov [Stts],AL ;
    @2:
      end ;
  Status := Stts ; if Status>0 then EXIT ;
  Writeln('NewSeg=', NewSeg) ;

  { Move data }
  Move(Ptr(EnvSeg, 0)^, Ptr(NewSeg, 0)^, NewSize) ;

  { Change official pointer }
  PWord(Ptr(GetPSPseg_Ndeep(Ndeep), $2C))^ := NewSeg ;

  { Return old block int 21/49 }
  asm  mov ES,[EnvSeg] ; mov AH,$49 ; int $21 ; jb @1 {jump if bad }
      jmp @2 ;
    @1: mov [Stts],AL ;
    @2:
      end ;
  Status := Stts ;
  end { ResizeEnvtNDeep} ;


procedure ValidateEnvtNdeep ; begin end ;

{ Use RW=Put with an empty EnvVal to delete EnvNam from Environment }

procedure Environ(const Ndeep : word ; const RW : TGetPut ;
  EnvNam : string ; var EnvVal : string ; var Status : byte) ;
var EnvSeg, EnvOff, EnvSize, EnvUsed,
  FoundBeg, { will be offset of first char of entry }
  FoundEnd, { will be offset of terminator of entry }
  FoundLen, { will be length of the completed entry }
  OldBeg, ValBeg : word ;
Found, Maybe, AddNew : boolean ;
Ch, xCh : char ; J : byte ;
{} {$IFDEF DEBUG}
{} W : word ;
{} Dummy : Pchar ;
{} const SDum : word = 0 ;
{} {$ENDIF}
begin
  Status := 0 ;
  GetEnvDescNdeep(Ndeep, EnvSeg, EnvSize) ;
  if EnvSeg = 0 then begin Status := 1 ; EXIT end ;
  if EnvSize = 0 then begin
    if RW=Get then EnvVal := '$0' ;
    Status := 2 ; EXIT end ;

  {} {$IFDEF DEBUG Use dummy environment for test ; assume real one < 24K }
  {} if SDum = 0 then begin
    {} GetMem(Dummy, 32768) { Offset expected small but not 0 } ;
    {} SDum := Seg(Dummy) ; EnvOff := Ofs(Dummy) ;
    {} if EnvOff+EnvSize>32750 then begin Status := 5 ; EXIT end ;
    {} Dec(SDum, (EnvOff div 16)+1) { minor bodge } ;
    {} Move(Ptr(EnvSeg, 0)^, Ptr(SDum, 0)^, EnvSize) ;
    {} end ;
  {} EnvSeg := SDum ;
  {} {$ENDIF}

  if EnvironNameWillBeMadeUpperCase then
    for J := 1 to Length(EnvNam) do EnvNam[J] := UpCase(EnvNam[J]) ;

  EnvNam := EnvNam + '=' ;

  EnvOff := 0 ;
  Maybe := true ;
  Found := false ;
  FoundBeg := 0 ;
  FoundEnd := 0 ;
  ValBeg := 0 ;
  Ch := #255 ;
  J := 0 ;
  OldBeg := 0 ;
  repeat { Scan Environment for EnvVar entry location }
    if EnvOff = EnvSize then begin Status := 3 ; EXIT end ;
    xCh := Ch ; Ch := GetChar(EnvSeg, EnvOff) ; Inc(J) ;
    {} {$IFDEF DEBUG Show } if Ch=#0 then Writeln else Write(Ch) ; {$ENDIF}
    if Ch<>EnvNam[J] then Maybe := false ;
    if Maybe and (Ch='=') then begin ValBeg := EnvOff+1 ; Found := true end ;
    if Ch=#0 then begin
      if Found then begin FoundBeg := OldBeg ; FoundEnd := EnvOff end ;
      Found := false ; Maybe := true ; J := 0 ; OldBeg := Succ(EnvOff) end ;
    Inc(EnvOff) until (Ch=#0) and (xCh=#0) ;

  EnvUsed := EnvOff ;

  (*
    Writeln('@@@') ;
    for W := 0 to 60 do Write(GetChar(EnvSeg, EnvOff+W)) ;
    Writeln(' @@@') ;
    *)

  {} {$IFDEF DEBUG Report }
  {} Writeln('*** EnvUsed = ', EnvUsed,
    {} '  FoundBeg = ', FoundBeg, '  FoundEnd = ', FoundEnd ) ;
  {} if FoundEnd > 0 then begin
    {} Write('*** Located "') ;
    {} for J := FoundBeg to FoundEnd-1 do Write(GetChar(EnvSeg, J)) ;
    {} Writeln('"') end ;
  {} {$ENDIF}

  if RW=Get then begin
    if FoundEnd=0 then EnvVal := '' else begin
      EnvVal[0] := char(FoundEnd-ValBeg) ;
      Move(Ptr(EnvSeg, ValBeg)^, EnvVal[1], byte(EnvVal[0])) ;
      end ;
    {} {$IFDEF DEBUG}
    {} Writeln('*** Get: Returning "', EnvVal, '" for "', EnvNam, '"') ;
    {} {$ENDIF}
    EXIT end {Get} ;


  AddNew := EnvVal>'' ;

  if FoundEnd = 0 then FoundLen := 0 else FoundLen := FoundEnd+1 - FoundBeg ;

  if AddNew then { ADD : check for fit }
    if EnvUsed - FoundLen + Length(EnvNam) + Length(EnvVal) + 2 > EnvSize then
    begin Status := 4 ; EXIT end ;

  if FoundEnd > 0 then { Slide entries down over one to be removed/replaced }
    Move(Ptr(EnvSeg, FoundEnd+1)^, Ptr(EnvSeg, FoundEnd+1-FoundLen)^,
    EnvUsed-FoundEnd) ;

  if AddNew then begin { Add new entry }
    Move(EnvNam[1],
      Ptr(EnvSeg, EnvUsed-FoundLen-1)^, Length(EnvNam)) ;
    Move(EnvVal[1],
      Ptr(EnvSeg, Length(EnvNam)+EnvUsed-FoundLen-1)^, Length(EnvVal)) ;
    Pword(Ptr(EnvSeg,
      Length(EnvNam)+Length(EnvVal)+EnvUsed-FoundLen-1))^ := 00 ;
    end ;

  {} {$IFDEF DEBUG Show Environment }
  {} EnvOff := 0 ;
  {} Ch := #255 ;
  {} repeat
    {} xCh := Ch ; Ch := GetChar(EnvSeg, EnvOff) ;
    {} if Ch=#0 then Writeln('#0') else Write(Ch) ;
    {} Inc(EnvOff) until (Ch=#0) and (xCh=#0) ;
  {} {$ENDIF}

  end {Environ} ;



BEGIN ;
END.