home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS - Coast to Coast
/
simteldosarchivecoasttocoast2.iso
/
turbopas
/
env20.zip
/
ENVUNIT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1988-09-19
|
16KB
|
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.