home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
vp21beta.zip
/
ARTLSRC.RAR
/
DOS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
2000-08-15
|
16KB
|
533 lines
//█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█
//█ █
//█ Virtual Pascal Runtime Library. Version 2.1. █
//█ DOS interface unit for OS/2 & Win32 █
//█ ─────────────────────────────────────────────────█
//█ Copyright (C) 1995-2000 vpascal.com █
//█ █
//▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀
{$S-,R-,Q-,I-,H-,T-,X+} // Common compiler directive
{&Cdecl-,OrgName-,AlignRec-,Delphi+,Use32+} // VP specific compiler directives
unit Dos;
interface
uses VpSysLow;
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; // N/A under OS/2
Directory = $10;
Archive = $20;
{$IFDEF OS2}
AnyFile = $37;
{$ELSE}
AnyFile = $3F;
{$ENDIF}
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..32] 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..32] of Byte; // User data area
Name: array [0..259] of Char; // File name (ASCIIZ)
Buffer: TextBuf; // Default I/O buffer
end;
{ Search record used by FindFirst and FindNext }
SearchRec = record
Handle: Longint;
Filler1: Longint;
Attr: Byte;
Time: Longint;
Size: Longint;
Name: ShortString;
Filler2: array[0..3] of Char;
{$IFDEF WIN32}
Filler3: array[0..321] of Char;
{$ENDIF}
{$IFDEF DPMI32}
Private_data: array[1..sizeof(TOSSearchRec)-4-4-1-4-4-256-4] of Byte;
{$ENDIF}
{$IFDEF LINUX}
Pattern: ShortString;
FileMode: LongInt;
Directory: ShortString;
{$ENDIF}
end;
{ Date and time record used by PackTime and UnpackTime }
DateTime = record
Year,Month,Day,Hour,Min,Sec: Word;
end;
{ Error status variable }
threadvar
DosError: Integer;
ExecFlags: Longint;
{ Exec flags }
const
efSync = 0; // exec_Sync
efAsync = 1; // exec_AsyncResult
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 support have been added }
procedure FindClose(var F: SearchRec);
implementation
uses Strings;
type
TDateTimeRec = record
FTime,FDate: SmallWord;
end;
// Assigns the value of the last error code to DosError and returns it.
function SetDosError(ErrCode: Integer): Integer;
begin
DosError := ErrCode;
Result := ErrCode;
end;
// Returns the version number of the operating system. The low byte of the
// result is the major version number, and the high byte is the minor version
// number. For example, OS/2 2.10 returns $0A14, i.e. 20 in the low byte, and
// 10 in the high byte.
function DosVersion: Word;
begin
Result := SysOsVersion;
end;
// Returns the current date set in the operating system. Ranges of the
// values returned are: Year 1980-2099, Month 1-12, Day 1-31 and
// DayOfWeek 0-6 (0 corresponds to Sunday).
procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
begin
SysGetDateTime(@Year, @Month, @Day, @DayOfWeek, nil, nil, nil, nil);
end;
// Sets the current date set in the operating system. Valid parameter
// ranges are: Year 1980-2099, Month 1-12 and Day 1-31. If the date is
// not valid, the function call is ignored.
procedure SetDate(Year,Month,Day: Word);
begin
SysSetDateTime(@Year, @Month, @Day, nil, nil, nil, nil);
end;
// Returns the current time set in the operating system. Ranges of the
// values returned are: Hour 0-23, Minute 0-59, Second 0-59 and Sec100
// (hundredths of seconds) 0-99.
procedure GetTime(var Hour,Minute,Second,Sec100: Word);
begin
SysGetDateTime(nil, nil, nil, nil, @Hour, @Minute, @Second, @Sec100);
Sec100 := Sec100 div 10;
end;
// Sets the time in the operating system. Valid parameter ranges are:
// Hour 0-23, Minute 0-59, Second 0-59 and Sec100 (hundredths of seconds
// 0-99. If the time is not valid, the function call is ignored.
procedure SetTime(Hour,Minute,Second,Sec100: Word);
begin
Sec100 := Sec100 * 10;
SysSetDateTime(nil, nil, nil, @Hour, @Minute, @Second, @Sec100);
end;
// GetVerify returns the state of the verify flag in OS/2. When off
// (False), disk writes are not verified. When on (True), all disk
// writes are verified to insure proper writing.
procedure GetVerify(var Verify: Boolean);
begin
Verify := SysVerify(False, False);
end;
// SetVerify sets the state of the verify flag in OS/2.
procedure SetVerify(Verify: Boolean);
begin
SysVerify(True, Verify);
end;
// Returns the number of free bytes on the specified drive number
// (0=Default,1=A,2=B,..). Returns -1 if the drive number is invalid.
function DiskFree(Drive: Byte): Longint;
begin
Result := SysDiskFree(Drive);
end;
// Returns the size in bytes of the specified drive number (0=Default,
// 1=A,2=B,..). Returns -1 if the drive number is invalid.
function DiskSize(Drive: Byte): Longint;
begin
Result := SysDiskSize(Drive);
end;
// Returns the attributes of a file. F must be a file variable (typed,
// untyped or textfile) which has been assigned a name. The attributes
// are examined by ANDing with the attribute masks defined as constants
// above. Errors are reported in DosError.
procedure GetFAttr(var F; var Attr: Word);
begin
SetDosError(SysGetFileAttr(FileRec(F).Name, Attr));
end;
// Sets the attributes of a file. F must be a file variable (typed,
// untyped or textfile) which has been assigned a name. The attribute
// alue is formed by adding (or ORing) the appropriate attribute masks
// efined as constants above. Errors are reported in DosError.
procedure SetFAttr(var F; Attr: Word);
begin
SetDosError(SysSetFileAttr(FileRec(F).Name, Attr));
end;
// Returns the date and time a file was last written. F must be a file
// variable (typed, untyped or textfile) which has been assigned and
// opened. The Time parameter may be unpacked throgh a call to
// UnpackTime. Errors are reported in DosError.
procedure GetFTime(var F; var Time: Longint);
begin
SetDosError(SysGetFileTime(FileRec(F).Handle, Time));
end;
// Sets the date and time a file was last written. F must be a file
// variable (typed, untyped or textfile) which has been assigned and
// opened. The Time parameter may be created through a call to PackTime.
// Errors are reported in DosError.
procedure SetFTime(var F; Time: Longint);
begin
SetDosError(SysSetFileTime(FileRec(F).Handle, Time));
end;
// Converts a 4-byte packed date/time returned by FindFirst, FindNext or
// GetFTime into a DateTime record.
procedure UnpackTime(P: Longint; var T: DateTime);
var
FDateTime: TDateTimeRec absolute P;
begin
with T,FDateTime do
begin
Year := (FDate and $FE00) shr 9 + 1980;
Month := (FDate and $01E0) shr 5;
Day := (FDate and $001F);
Hour := (FTime and $F800) shr 11;
Min := (FTime and $07E0) shr 5;
Sec := (FTime and $001F) * 2;
end;
end;
// Converts a DateTime record into a 4-byte packed date/time used by
// SetFTime.
procedure PackTime(var T: DateTime; var P: Longint);
var
FDateTime: TDateTimeRec absolute P;
begin
with T,FDateTime do
begin
FDate := (Year - 1980) shl 9 + Month shl 5 + Day;
FTime := Hour shl 11 + Min shl 5 + (Sec div 2);
end;
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
':', {$IFDEF LINUX} '/' {$ELSE} '\' {$ENDIF} :
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;
// EnvCount returns the number of strings contained in the OS environment.
function EnvCount: Integer;
var
P: PChar;
Count: Integer;
begin
P := SysGetEnvironment;
Count := 0;
while P^ <> #0 do
begin
repeat Inc(P) until (P-1)^ = #0;
Inc(Count);
end;
Result := Count;
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
Result := '';
if Index > 0 then
begin
P := SysGetEnvironment;
Count := 1;
while (Count < Index) and (P^ <> #0) do
begin
repeat Inc(P) until (P-1)^ = #0;
Inc(Count);
end;
Result := 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;
EnvVarBuf: array [0..255] of Char;
begin
StrPCopy(EnvVarBuf, EnvVar);
L := Length(EnvVar);
P := SysGetEnvironment;
while P^ <> #0 do
begin
if (StrLIComp(P, EnvVarBuf, L) = 0) and (P[L] = '=') then
begin
Result := StrPas(P + L + 1);
Exit;
end;
Inc(P, StrLen(P) + 1);
end;
Result := '';
end;
// Remains for backward compatibility with TP & BP only
procedure SwapVectors;
begin
end;
// 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
PathBuf: array [0..SizeOf(PathStr)-1] of Char;
begin
SetDosError(SysFindFirst(StrPCopy(PathBuf, Path), Attr, TOSSearchRec(F), False));
end;
// Returns 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);
begin
SetDosError(SysFindNext(TOSSearchRec(F), False));
end;
// Ends the search, closes the search record. FindClose should be issued
// whenever search record is no longer needed. Errors are reported in DosError.
procedure FindClose(var F: SearchRec);
begin
SetDosError(SysFindClose(TOSSearchRec(F)));
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
PathBuf: array[0..259] of Char;
DirListBuf: array[0..259] of Char;
ResBuf: array[0..259] of Char;
begin
Result := StrPas(SysFileSearch(ResBuf, StrPCopy(PathBuf, Path), StrPCopy(DirListBuf, DirList)));
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: Integer;
PathBuf: array[0..259] of Char;
ResBuf: array[0..259] of Char;
begin
Result := StrPas(SysFileExpand(ResBuf, StrPCopy(PathBuf, Path)));
{$IFDEF UpperCase}
for I := 1 to Length(Result) do
Result[I] := UpCase(Result[I]);
{$ENDIF}
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
PathBuf: array [0..255] of Char;
CmdLineBuf: array [0..255] of Char;
begin
SetDosError(SysExecute(StrPCopy(PathBuf, Path), StrPCopy(CmdLineBuf, ComLine), nil, ExecFlags = efAsync, nil, -1, -1, -1));
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;
begin
Result := SysExitCode;
end;
end.