Power-Programmierung/CD1.mdf/pascal/library/dos/environ/envunit.pas

Pascal/Delphi Source File | 1988-09-19 | 15.7 KB | 608 lines

unit EnvUnit; {             Version 2.0            88/09/19

Handy little routines to simplify using the environment string.

See the example program ENVTEST.PAS, for hints on how to use this unit.

MOST LIKELY TO BE USED:   1) FFind - search the path for a named file and
                                     return the fully qualified file name
                                     if it is found.

                          2) PathTo - search the path for a named file;
                                      return the path to that file if found

                          3) ParamStr - the complete parameter string


This program is hereby donated to the public domain. It may be freely copied,
used & modified without charge or fee.

Author        :  Mike Babulic
                 3827 Charleswood Dr. N.W.
                 Calgary, Alberta
                 CANADA
                 T2L 2C7
Compuserve ID :  72307,314

}


interface

uses Dos;


{$IFDEF VER40}   {These objects are already in TP Version 5's Dos Unit}
                 {I've included them so you can upgrade gracefully}

type
   PathStr = string[79];
   DirStr  = string[67];
   NameStr = string[8];
   ExtStr  = string[4];

function DosVersion: word;  { lo = version (ex. 3);  hi = fraction (ex. .2) }

function EnvCount: integer;              {number of Environment Strings}
function EnvStr(Index:integer): string;  {get Env. String number index}
function GetEnv(EnvVar:string): string;  {get Env. String named by EnvVar}

function FExpand(Path:PathStr):PathStr;
  {expand the path to a fully qualified file name}
function FSearch(Path:PathStr;DirList:string):PathStr;
   {Search DirList (paths separated by ";") for Path & return full name of
    this file}
procedure FSplit(Path:PathStr; var Dir:DirStr; var Name:NameStr; var Ext:ExtStr);
{$ENDIF}


  var   MyPath : string;        {Path & Name of the running program}
        MyDir  : DirStr;
        MyName : NameStr;
        MyExt  : ExtStr;


  function DOS_Version: integer;
      {Returns the version of DOS being used (ex. 302 is DOS 3.2)}


  function ParamString: String;
      {Returns the complete parameter string}

  function EnvStrPtr:Pointer;
      {Point to environment strings}


  var PSP : word;  {Program Segment Prefix;  initially = PrefixSeg}

  function ProgPath: PathStr;    {Path to program owning current PSP}
  function ProgDir:  DirStr;        {Directory of program owning current PSP}
  function ProgName: NameStr;       {Name of program owning current PSP}
  function ProgExt:  ExtStr;        {Extension of program owning current PSP}

  procedure UseMyPSP;
      {Use the program's PSP to find the environment}
  procedure UseParentPSP;
      {Use the parent of the current PSP to find the environment}
  procedure UseRootPSP;
      {Use the parent of the current PSP to find the environment}


  function FirstEnv:String;
      {Get the First Environment string}
  function NextEnv:String;
      {Get the Next Environment string}
  function EOEnv:Boolean;
     {True if End Of Environment}


  function FirstNamed(name,delim:String):String;
     {Get the first string in an the named environment specification
         eg. If name = 'PATH' and delim = ';' then get the first path string
             "Path" strings are delimited by semicolins: ";" }
  function NextNamed:String;
     {Get the next string in an environment specification}
  function EONamed:Boolean;
     {True if end of environment specification}


  function FirstPath:String;
     {Almost the same as Firstnamed('PATH',';'), but appends a '\' to the
      string if needed}
  function NextPath:String;


  function PathTo(filename:string):string;
     {Searches the environment PATH and returns a path to the named file.
        Check the current directory,
        then search the environment PATH,
        then check the directory containing the calling program (MyDir).
        If the file is still not found, return a null string ('')}

  function FFind(filename:string):string;
     {Find the File called "fileneme".
        Check the current directory,
        then search the environment PATH,
        then check the directory containing the calling program (MyDir).
        - if "filename" is found return the fully qualified file name.
        - if "filename" is NOT found then return a PERIOD (".")
          - a period is returned because if you write something like:
                Assign(aFile,FFind('MISSING.TXT'));
                Reset(aFile);
            and FFind returned '' when it failed then aFile would be assigned
            to the standard INPUT file (usually the keyboard)! }

{misc}
  function FileExists(name:string):Boolean;      {True if named file exists}
  procedure PtrInc(var p:Pointer; n: Longint);   {Increment pointer by n}


{----------------------------------------------------------------------------}

implementation


  procedure PtrInc(var p:Pointer; n: Longint);   {Increment pointer by n}
    type pointr = record  lo,hi: word  end;
    var
       pt : pointr   absolute  p;
       c  : pointr   absolute  n;
    begin
      n := pt.lo + n;
      pt.hi := pt.hi + n shr 4;
      pt.lo := c.lo and $F;
    end;


{-----------------------------------------------------------------------------}



  type WordP = ^word;

  function EnvStrPtr:Pointer;
    begin
      EnvStrPtr := Ptr(WordP(Ptr(PSP,$2C))^,0);
    end;

  procedure UseMyPSP;
    begin
      PSP := PrefixSeg;
    end;

  Procedure UseParentPSP;
    begin
      PSP := WordP(Ptr(PSP,$16))^;
    end;

  Procedure UseRootPSP;
    var oldPSP : word;
    begin
      repeat
        oldPSP := PSP;
        UseParentPSP;
      until PSP=oldPSP;
    end;


{-----------------------------------------------------------------------------}

  Type ASCIIz = array [0..127] of char;
       ASCIIptr = ^ASCIIz;

  function StrZ(var c:ASCIIz):string;
    label done;
    var i: integer;
    begin
      for i := 0 to 127 do begin
       if c[i]=#0 then goto done;
        StrZ[i+1] := c[i];
      end;
      i := 128;
      done: StrZ[0] := chr(i);
    end;

  function ToDelim(d:string; var s:string):integer;
    var i:integer;
    begin
      i := pos(d,s);    {length to first delimiter}
      if i>0 then
        s[0] := chr(i-1)
      else
        i := length(s);
      ToDelim := i;
    end;


{----------------------------------------------------------------------------}


function ParamString: String;
  type StrPtr = ^String;
  begin
    ParamString := StrPtr(Ptr(PrefixSeg,$80))^;
  end;


{----------------------------------------------------------------------------}


  var EnvPtr : ASCIIptr;

  function FirstEnv:String;
    var s: string[255];
        i: integer;
    begin
      EnvPtr := EnvStrPtr;
      FirstEnv := NextEnv;
    end;

  function NextEnv:String;
    var s: string;
        i: integer;
    begin
      if EOEnv then
        NextEnv := ''
      else begin
        s := StrZ(EnvPtr^);
        i := ToDelim(#0,s);
        PtrInc(Pointer(EnvPtr),i+1);
        NextEnv := s;
      end;
    end;

procedure SkipEnv;
  var i : integer;
  begin
    for i := 1 to MaxInt do
      if EnvPtr^[i]=#0 then begin
        PtrInc(Pointer(EnvPtr),i+1);
        exit
      end;
  end;

   function EOEnv:Boolean;
     begin
       EOEnv := (EnvPtr^[0]=#0);
     end;


{----------------------------------------------------------------------------}


  var namePtr : ASCIIptr;
      dummy  : LongInt;
      namedDelim : string;

  function EONamed:Boolean;
    begin
      EONamed := (namePtr^[0]=#0);
    end;

  function FirstNamed(name,delim:String):string;
    var
        s: string;
        i: integer;
    begin
      for i := 1 to length(name) do name[i] := upcase(name[i]);
      name := name+'=';
      FirstNamed := '';
      namePtr := EnvStrPtr;
      namedDelim := delim;
      while namePtr^[0]<>#0 do begin
        s := StrZ(namePtr^);
        if (length(s)>=length(name)) and (name=copy(s,1,length(name))) then begin
          i := Pos('=',s);  {skip past the '='}
          PtrInc(Pointer(namePtr),i);
          s := StrZ(namePtr^);
          i := ToDelim(NamedDelim,s);
          PtrInc(Pointer(namePtr),i);
          FirstNamed := s;
          Exit;
          end
        else
          PtrInc(Pointer(namePtr),length(s)+1);
      end;
    end;

  function NextNamed:string;
    var
        s: string;
        i: integer;
    begin
      if EONamed then begin
        NextNamed := '';
        end
      else begin
        s := StrZ(namePtr^);
        i := ToDelim(NamedDelim,s);
        PtrInc(Pointer(namePtr),i);
        NextNamed := s;
      end;
    end;

{----------------------------------------------------------------------------}

  function DirDelim(s:String):String;
    var i: integer;
    begin
      DirDelim := '';
      i := length(s);
      while (i>0) and (s[i]=' ') do i := pred(i);
      if i<=0 then exit;
      s[0] := chr(i);
      if not (s[i] IN [':','\']) then  s := s + '\';
      DirDelim := s;
    end;

  function FirstPath: String;
    begin
      FirstPath := DirDelim(FirstNamed('PATH',';'));
    end;

  function NextPath: String;
    begin
      NextPath := DirDelim(NextNamed);
    end;


  function PathTo(filename:string):string;
    var path: string;
        found: boolean;
    begin
      PathTo := '';
      if filename<>'' then begin
        found := FALSE;
        if FileExists(filename) then begin   {Check Current Directory}
          GetDir(0,path);
          path := DirDelim(path);
          found := FileExists(path+filename);
        end;
        if not found then begin              {Check the Path}
          path  := FirstPath;
          found := FileExists(path+filename);
          while not (EONamed or found) do begin
            path  := NextPath;
            found := FileExists(path+filename);
          end;
        end;
        if not found then begin               {Check the Program's Directory}
          found := FileExists(MyDir+filename);
          if found then path := MyDir;
        end;
        if found then
          PathTo := path;
      end;
    end;

  function FFind(filename:string):string;
    var p : string;
    begin
      p := PathTo(filename);
      if p<>'' then
        FFind := FExpand(p+filename)
      else
        FFind := '.';
    end;



{-----------------------------------------------------------------------------}

  function FileExists(name:string):Boolean;
    var s : SearchRec;
    begin
      FindFirst(Name,0,s);
      FileExists := (DosError=0);
    end;


{-----------------------------------------------------------------------------}



  function DOS_Version: integer;
      {Returns the version of DOS being used}
    var r : registers;
    begin
      r.ax := $3000;
      MsDos(r);
      with r do
        DOS_Version := al * 100 + ah
    end;


{-----------------------------------------------------------------------------}

  var
      pPath : string;
      pDir  : DirStr;
      pName : NameStr;
      pExt  : ExtStr;

  procedure GetPName;
    var
      c : ^char;
      i : word;
    begin
      if DOS_Version<300 then begin {Only for DOS 3.x and greater}
        pPath := '';
        pName := '';
       end
      else begin
        c := EnvStrPtr;
        {Skip to the end of the Environment}
          repeat
            while c^<>#0 do
              PtrInc(pointer(c),1);
            PtrInc(pointer(c),1);
          until c^=#0;
          PtrInc(Pointer(c),3);
        pPath := FExpand(StrZ(AsciiPtr(c)^));
        FSplit(pPath,pDir,pName,pExt);
      end;
    end;



  function ProgPath: PathStr;    {Path to program owning current PSP}
    begin
      GetPName;  ProgPath := pPath;
    end;

  function ProgDir:  DirStr;        {Directory of program owning current PSP}
    begin
      GetPName;  ProgDir := pDir;
    end;

  function ProgName: NameStr;       {Name of program owning current PSP}
    begin
      GetPName;  ProgName := pName;
    end;

  function ProgExt:  ExtStr;        {Extension of program owning current PSP}
    begin
      GetPName;  ProgExt := pExt;
    end;


{-----------------------------------------------------------------------------}

{$IFDEF VER40}  {These objects are already in TP Version 5's Dos Unit}


function DosVersion: word;  { lo = version (ex. 3);  hi = fraction (ex. .2) }
    var r : registers;
    begin
      r.ax := $3000;
      MsDos(r);
      DOSVersion := r.ax;
    end;


function EnvCount: integer;              {number of Environment Strings}
  var i: integer;
  begin
    UseMyPSP;
    EnvPtr := EnvStrPtr;
    i := 0;
    while not EoEnv do begin
      SkipEnv;
      i := succ(i);
    end;
    EnvCount := i;
  end;


function EnvStr(Index:integer): string;  {get Env. String number index}
  begin
    UseMyPSP;
    EnvPtr := EnvStrPtr;
    while (index>1) and not EoEnv do begin
      SkipEnv;
      index := pred(index);
    end;
    if index = 1 then
      EnvStr := NextEnv
    else
      EnvStr := '';
  end;


function GetEnv(EnvVar:string): string;  {get Env. String named by EnvVar}
  begin
    GetEnv := FirstNamed(EnvVar,#0);
  end;


function FExpand(Path:PathStr):PathStr;
  var
    i : integer;
    old: PathStr;
  begin
    FSplit(path,pDir,pName,pExt);
    if length(pDir)=0 then
      GetDir(0,pDir)
    else begin
      if pDir[length(pDir)]='\' then  pDir[0] := chr(length(pDir)-1);
      GetDir(0,old);
      ChDir(pDir);
      GetDir(0,pDir);
      ChDir(old);
    end;
    path := pName+pExt;
    for i := 1 to length(path) do path[i] := UpCase(path[i]);
    FExpand := pDir+'\'+path;
  end;


  function FSearch(Path:PathStr;DirList:string):PathStr;
    var dir: string;
        i: integer;
        found: boolean;
    procedure NextDir;
      var j : integer;
      begin
        i := succ(i);  j := i;
        while (j<length(DirList)) and (DirList[j]<>';') do j := succ(j);
        Dir := DirDelim(Copy(Dirlist,i,j-i))+Path;
        i := j;
      end;
    begin
      FSearch := '';
      if Path<>'' then begin
        found := FileExists(path);       {Check Current Directory}
        if Found then
          Dir := Path
        else begin                       {Check DirList}
          i := 0;
          repeat
            NextDir;
            found := FileExists(Dir);
          until (i>=length(DirList)) or found;
        end;
        if found then
          FSearch := Dir;
      end;
    end;


procedure FSplit(Path:PathStr; var Dir:DirStr; var Name:NameStr; var Ext:ExtStr);
  var i,j : integer;
      done : boolean;
  begin
    Dir  := '';  Name := '';  Ext := '';
    if Path='' then exit;
    if Path[length(Path)]='.' then begin
      Dir := Path;
      if length(Path)=1 then exit;
      if Path[length(Path)-1] in ['.','\'] then exit;
      Dir := '';
    end;
    i := length(Path);  j := 0;  done := FALSE;
    while (i>0) and (j<sizeof(Ext)) and not done do begin
      done := (Path[i]='.');
      if done then
        Ext := Copy(Path,i,j+1);
      j := succ(j);
      i := pred(i);
    end;
    i := length(Path) - length(Ext);  j := i;
    while (i>0) and not (Path[i] in [':','\']) do  i := pred(i);
    Name := Copy(Path,i+1,j-i);
    Dir := Copy(Path,1,i);
  end;
{$ENDIF}


{-----------------------------------------------------------------------------}

  begin
    UseMyPSP;
    EnvPtr := EnvStrPtr;
    dummy := 0;
    namePtr := @dummy;
    GetPName;
    MyPath := pPath;
    MyDir := pDir;  MyName := pName;  MyExt := pExt;
  end.