home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software of the Month Club 1995 December
/
SOFM_Dec1995.bin
/
pc
/
os2
/
vpascal
/
source
/
rtl
/
dos.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-10-31
|
15KB
|
462 lines
{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█ █}
{█ Virtual Pascal Runtime Library. Version 1.0. █}
{█ DOS interface unit for OS/2 █}
{█ ─────────────────────────────────────────────────█}
{█ Copyright (C) 1995 B&M&T Corporation █}
{█ ─────────────────────────────────────────────────█}
{█ Written by Vitaly Miryanov █}
{█ █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
{$S-,R-,Q-,I-,Cdecl-,OrgName-,AlignRec-}
unit Dos;
interface
uses Os2Def, Os2Base, Use32;
const
{ Flags bit masks }
fCarry = $0001;
fParity = $0004;
fAuxiliary = $0010;
fZero = $0040;
fSign = $0080;
fOverflow = $0800;
{ File mode magic numbers }
fmClosed = $A55AD7B0;
fmInput = $A55AD7B1;
fmOutput = $A55AD7B2;
fmInOut = $A55AD7B3;
{ File attribute constants }
ReadOnly = $01;
Hidden = $02;
SysFile = $04;
VolumeID = $08; { For compatibility only, OS/2 doesn't use this attribute }
Directory = $10;
Archive = $20;
AnyFile = $37;
type
{ String types }
ComStr = String; { Command line string }
PathStr = String; { File pathname string }
DirStr = String; { Drive and directory string }
NameStr = String; { File name string }
ExtStr = String; { File extension string }
{ Typed-file and untyped-file record }
FileRec = record
Handle: Longint; { File Handle }
Mode: Longint; { Current file mode }
RecSize: Longint; { I/O operation record size }
Private: array [1..28] of Byte; { Reserved }
UserData: array [1..8] of Byte; { User data area }
Name: array [0..259] of Char; { File name (ASCIIZ) }
end;
{ Textfile record }
TextBuf = array [0..127] of Char;
TextRec = record
Handle: Longint; { File Handle }
Mode: Longint; { Current file mode }
BufSize: Longint; { Text File buffer size }
BufPos: Longint; { Buffer current position }
BufEnd: Longint; { Buffer ending position }
BufPtr: ^TextBuf; { Pointer to the buffer }
OpenFunc: Pointer; { Open Text File function @ }
InOutFunc: Pointer; { In/Out ... }
FlushFunc: Pointer; { Flush ... }
CloseFunc: Pointer; { Close ... }
UserData: array [1..8] of Byte; { User data area }
Name: array [0..259] of Char; { File name (ASCIIZ) }
Buffer: array [0..127] of Char; { Default I/O buffer }
end;
{ Search record used by FindFirst and FindNext }
SearchRec = record
HDir: ULong;
Attr: Byte;
Time: Longint;
Size: Longint;
Name: NameStr;
end;
{ Date and time record used by PackTime and UnpackTime }
DateTime = record
Year,Month,Day,Hour,Min,Sec: Word;
end;
{ Error status variable }
const
DosError: Integer = 0;
{ Exec flags }
const
efSync = exec_Sync;
efAsync = exec_AsyncResult;
const
ExecFlags: ULong = exec_Sync;
function DosVersion: Word;
procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
procedure SetDate(Year,Month,Day: Word);
procedure GetTime(var Hour,Minute,Second,Sec100: Word);
procedure SetTime(Hour,Minute,Second,Sec100: Word);
procedure GetVerify(var Verify: Boolean);
procedure SetVerify(Verify: Boolean);
function DiskFree(Drive: Byte): Longint;
function DiskSize(Drive: Byte): Longint;
procedure GetFAttr(var F; var Attr: Word);
procedure SetFAttr(var F; Attr: Word);
procedure GetFTime(var F; var Time: Longint);
procedure SetFTime(var F; Time: Longint);
procedure FindFirst(const Path: PathStr; Attr: Word; var F: SearchRec);
procedure FindNext(var F: SearchRec);
procedure UnpackTime(P: Longint; var T: DateTime);
procedure PackTime(var T: DateTime; var P: Longint);
function FSearch(const Path: PathStr; const DirList: String): PathStr;
function FExpand(const Path: PathStr): PathStr;
function EnvCount: Integer;
function EnvStr(Index: Integer): String;
function GetEnv(const EnvVar: String): String;
procedure FSplit(const Path: PathStr; var Dir: DirStr; var Name: NameStr;
var Ext: ExtStr);
procedure Exec(const Path: PathStr; const ComLine: ComStr);
function DosExitCode: Word;
{ The following procedures are not implemented
procedure Intr(IntNo: Byte; var Regs: Registers);
procedure MsDos(var Regs: Registers);
procedure GetCBreak(var Break: Boolean);
procedure SetCBreak(Break: Boolean);
procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
procedure SetIntVec(IntNo: Byte; Vector: Pointer);
procedure Keep(ExitCode: Word);
}
{ SwapVectors remains for compatibility but do nothing }
procedure SwapVectors;
{ The following procedure is added }
procedure FindClose(var F: SearchRec);
implementation
uses Strings;
{ Synchronous Exec result is placed here }
var
ExecResult: ResultCodes;
{$I DOS.INC} { Common Dos and WinDos procedures and functions }
{ Searches the specified (or current) directory for the first entry }
{ that matches the specified filename and attributes. The result is }
{ returned in the specified search record. Errors (and no files found) }
{ are reported in DosError. }
procedure FindFirst(const Path: PathStr; Attr: Word; var F: SearchRec);
var
Count: ULong;
SR: FileFindBuf3;
PathZ: array [0..SizeOf(PathStr)-1] of Char;
begin
StrPCopy(PathZ, Path);
Count := 1;
F.HDir := hdir_Create;
DosError := DosFindFirst(PathZ,F.HDir,Attr,SR,SizeOf(SR),Count,fil_Standard);
if DosError = 0 then
with F,SR do
begin
Attr := attrFile;
DateTimeRec(Time).FTime := ftimeLastWrite;
DateTimeRec(Time).FDate := fdateLastWrite;
Size := cbFile;
Name := achName;
end;
end;
{ Returs the next entry that matches the name and attributes specified }
{ in a previous call to FindFirst. The search record must be one passed }
{ to FindFirst. Errors (and no more files) are reported in DosError. }
procedure FindNext(var F: SearchRec);
var
Count: ULong;
SR: FileFindBuf3;
begin
Count := 1;
DosError := DosFindNext(F.HDir,SR,SizeOf(SR),Count);
if DosError = 0 then
with F,SR do
begin
Attr := attrFile;
DateTimeRec(Time).FTime := ftimeLastWrite;
DateTimeRec(Time).FDate := fdateLastWrite;
Size := cbFile;
Name := achName;
end;
end;
{ Ends the search, closes the search record. FindClose should be issued }
{ whenever search record is no longer needed. Unlike DOS, OS/2 does not }
{ keep search information in the user program space (in the SearchRec). }
{ OS/2 returns only handle that identifies this information, so it }
{ should be freed, otherwise OS/2 runs out of search handles and all }
{ calls to FindFirst later on will fail. If search record is invalid }
{ then error is reported in DosError. }
procedure FindClose(var F: SearchRec);
begin
DosError := DosFindClose(F.HDir);
end;
{ Searches for the file given by Path in the list of directories given }
{ by DirList. The directory paths in DirList must be separated by }
{ semicolons. The search always starts with the current directory of }
{ the current drive. The returned value is a fully qualified file name }
{ or an empty string if the file could not be located. }
function FSearch(const Path: PathStr; const DirList: String): PathStr;
var
Info: FileStatus3;
PathZ: array [0..SizeOf(PathStr)-1] of Char;
DirListZ: array [0..SizeOf(String) -1] of Char;
Result: array [0..SizeOf(PathStr)-1] of Char;
begin
StrPCopy(PathZ, Path);
StrPCopy(DirListZ, DirList);
if DosQueryPathInfo(PathZ,fil_Standard,Info,SizeOf(Info)) = 0 then
if (Info.attrFile and Directory) = 0 then
begin
FSearch := FExpand(Path);
Exit;
end;
if DosSearchPath(dsp_ImpliedCur+dsp_IgnoreNetErr,DirListZ,PathZ,Result,SizeOf(Result)) = 0
then FSearch := StrPas(Result)
else FSearch := '';
end;
{ FExpand expands the file name in Path into a fully qualified file }
{ name. The resulting name consists of a drive letter, a colon, a root }
{ relative directory path, and a file name. Embedded '.' and '..' }
{ directory references are removed. }
function FExpand(const Path: PathStr): PathStr;
var
I,J: Integer;
C: Char;
S,CurDir: String;
procedure AdjustPath;
begin
{ Check for '\.\' }
if (S[J-2] = '\') and (S[J-1] = '.') then Dec(J,2)
else
{ Check for '\..\' }
if (S[J-3] = '\') and (S[J-2] = '.') and (S[J-1] = '.') then
begin
Dec(J,3);
if S[J-1] <> ':' then
repeat
Dec(J);
until S[J] = '\';
end;
end;
begin
if (Length(Path) >= 2) and (Path[2] = ':') then
begin { Path is already in form 'X:\Path }
if (Length(Path) >= 3) and (Path[3] = '\') then S := Path
else
begin { Path is in form 'X:Path' }
GetDir(Ord(UpCase(Path[1])) - Ord('A') + 1, CurDir);
if Length(CurDir) > 3 then CurDir := CurDir + '\';
S := CurDir + Copy(Path, 3, Length(Path));
end;
end
else
begin { Path is without drive letter }
GetDir(0,CurDir); { Get default drive & directory }
if Length(CurDir) > 3 then CurDir := CurDir + '\';
if Path[1] = '\' then S := Copy(CurDir, 1, 2) { only 'X:' }
else S := CurDir;
S := S + Path;
end;
I := 1; J := 1;
for I := 1 to Length(S) do
begin
C := UpCase(S[I]);
if C = '\' then AdjustPath;
S[J] := C;
Inc(J);
end;
AdjustPath;
if S[J-1] = ':' then
begin
S[J] := '\';
Inc(J);
end;
FExpand := Copy(S, 1, J-1);
end;
{ EnvCount returns the number of strings contained in the OS/2 }
{ environment. }
function EnvCount: Integer;
var
P: PChar;
Count: Integer;
begin
P := Environment;
Count := 0;
while P^ <> #0 do
begin
repeat Inc(P) until (P-1)^ = #0;
Inc(Count);
end;
EnvCount := Count;
end;
{ Splits the file name specified by Path into its three components. Dir }
{ is set to the drive and directory path with any leading and trailing }
{ backslashes, Name is set to the file name, and Ext is set to the }
{ extension with a preceding dot. Each of the component strings may }
{ possibly be empty, if Path contains no such component. }
procedure FSplit(const Path: PathStr; var Dir: DirStr; var Name: NameStr;
var Ext: ExtStr);
var
I,NamePos,ExtPos: Integer;
begin
NamePos := 0;
ExtPos := 256;
for I := 1 to Length(Path) do
case Path[I] of
':','\':
begin
NamePos := I;
ExtPos := 256;
end;
'.': ExtPos := I;
end;
Dir := Copy(Path, 1, NamePos);
Name := Copy(Path, NamePos+1, ExtPos-NamePos-1);
Ext := Copy(Path, ExtPos, 255);
end;
{ Returns a specified environment string. The returned string is of the }
{ form "VAR=VALUE". The index of the first string is one. If Index is }
{ less than one or greater than EnvCount,EnvStr returns an empty string.}
function EnvStr(Index: Integer): String;
var
P: PChar;
Count: Integer;
begin
EnvStr := '';
if Index > 0 then
begin
P := Environment;
Count := 1;
while (Count < Index) and (P^ <> #0) do
begin
repeat Inc(P) until (P-1)^ = #0;
Inc(Count);
end;
EnvStr := StrPas(P);
end;
end;
{ Returns the value of a specified environment variable. The variable }
{ name can be in upper or lower case, but it must not include the '=' }
{ character. If the specified environment variable does not exist, }
{ GetEnv returns an empty string. }
function GetEnv(const EnvVar: String): String;
var
P: PChar;
L: Word;
EnvVarZ: array [0..SizeOf(String)-1] of Char;
begin
StrPCopy(EnvVarZ, EnvVar);
L := Length(EnvVar);
P := Environment;
while P^ <> #0 do
begin
if (StrLIComp(P, EnvVarZ, L) = 0) and (P[L] = '=') then
begin
GetEnv := StrPas(P + L + 1);
Exit;
end;
Inc(P, StrLen(P) + 1);
end;
GetEnv := '';
end;
{ Executes another program. The program is specified by the Path }
{ parameter, and the command line is specified by the CmdLine parameter.}
{ ExecFlags specifies Exec type (synchronous or asynchronous). To }
{ execute an OS/2 internal command, run CMD.EXE, e.g. }
{ "Exec(GetEnv('COMSPEC'),'/C DIR *.PAS');". Note the /C in front of }
{ the command. Errors are reported in DosError. }
procedure Exec(const Path: PathStr; const ComLine: ComStr);
var
Times: ULong;
P: PChar;
FailedObj: array [0..255] of Char;
PathZ: array [0..SizeOf(PathStr)-1] of Char;
ComLineZ: array [0..SizeOf(PathStr) + SizeOf(ComStr)] of Char;
begin
StrPCopy(PathZ, Path);
P := StrECopy(ComLineZ, PathZ); { 'Path'#0 }
StrPCopy(P+1, ComLine); { 'Path'#0'CommandLine'#0 }
P[Length(ComLine)+2] := #0; { 'Path'#0'CommandLine'#0#0 }
DosError := DosExecPgm(FailedObj, SizeOf(FailedObj), ExecFlags, ComLineZ,
Environment, ExecResult, PathZ);
end;
{ DosExitCode returns the exit code of a sub-process. To obtain the }
{ correct exit code make sure that ExecFlags variable has not been }
{ changed between calls to Exec and DosExitCode. }
function DosExitCode: Word;
var
RetPid: Pid;
begin
if ExecFlags = efAsync then
DosWaitChild(dcwa_Process,dcww_Wait,ExecResult,RetPid,ExecResult.codeTerminate);
DosExitCode := ExecResult.codeResult;
end;
{ Remains for compatibility only }
procedure SwapVectors;
begin
end;
end.