home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software of the Month Club 1995 December
/
SOFM_Dec1995.bin
/
pc
/
os2
/
vpascal
/
source
/
rtl
/
windos.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-10-31
|
16KB
|
455 lines
{█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█}
{█ █}
{█ Virtual Pascal Runtime Library. Version 1.0. █}
{█ OS/2 Presentation Manager DOS interface unit █}
{█ ─────────────────────────────────────────────────█}
{█ Copyright (C) 1995 B&M&T Corporation █}
{█ ─────────────────────────────────────────────────█}
{█ Written by Vitaly Miryanov █}
{█ █}
{▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀}
{$S-,R-,Q-,I-,Cdecl-,OrgName-,AlignRec-}
unit WinDos;
interface
uses 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 }
faReadOnly = $01;
faHidden = $02;
faSysFile = $04;
faVolumeID = $08; { For compatibility only, OS/2 doesn't use this attribute }
faDirectory = $10;
faArchive = $20;
faAnyFile = $37;
{ Maximum file name component string lengths }
const
fsPathName = 259;
fsDirectory = 255;
fsFileName = 255;
fsExtension = 255;
{ FileSplit return flags }
const
fcExtension = $0001;
fcFileName = $0002;
fcDirectory = $0004;
fcWildcards = $0008;
{ Typed-file and untyped-file record }
type
TFileRec = 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 }
type
PTextBuf = ^TTextBuf;
TTextBuf = array[0..127] of Char;
TTextRec = 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: ^TTextBuf; { 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: TTextBuf; { Default I/O buffer }
end;
{ Search record used by FindFirst and FindNext }
type
TSearchRec = record
HDir: Longint;
Attr: Byte;
Time: Longint;
Size: Longint;
Name: array[0..fsFileName] of Char;
end;
{ Date and time record used by PackTime and UnpackTime }
type
TDateTime = record
Year, Month, Day, Hour, Min, Sec: Word;
end;
{ Error status variable }
var
DosError: Integer;
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(Path: PChar; Attr: Word; var F: TSearchRec);
procedure FindNext(var F: TSearchRec);
procedure UnpackTime(P: Longint; var T: TDateTime);
procedure PackTime(var T: TDateTime; var P: Longint);
function FileSearch(Dest, Name, List: PChar): PChar;
function FileExpand(Dest, Name: PChar): PChar;
function FileSplit(Path, Dir, Name, Ext: PChar): Word;
function GetCurDir(Dir: PChar; Drive: Byte): PChar;
procedure SetCurDir(Dir: PChar);
procedure CreateDir(Dir: PChar);
procedure RemoveDir(Dir: PChar);
function GetArgCount: Integer;
function GetArgStr(Dest: PChar; Index: Integer; MaxLen: Word): PChar;
function GetEnvVar(VarName: PChar): PChar;
{ The following procedures are not implemented
procedure Intr(IntNo: Byte; var Regs: TRegisters);
procedure MsDos(var Regs: TRegisters);
procedure GetCBreak(var Break: Boolean);
procedure SetCBreak(Break: Boolean);
procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
procedure SetIntVec(IntNo: Byte; Vector: Pointer);
}
{ The following procedure is added }
procedure FindClose(var F: TSearchRec);
implementation
uses Os2Def, Os2Base, Strings;
type
DateTime = TDateTime;
FileRec = TFileRec;
{$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(Path: PChar; Attr: Word; var F: TSearchRec);
var
Count: ULong;
SR: FileFindBuf3;
begin
Count := 1;
F.HDir := hdir_Create;
DosError := DosFindFirst(Path,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;
StrPCopy(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: TSearchRec);
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;
StrPCopy(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: TSearchRec);
begin
DosError := DosFindClose(F.HDir);
end;
{ FileSearch searches for the file given by Name in the list of }
{ directories given by List. The directory paths in List must be }
{ separated by semicolons. The search always starts with the current }
{ directory of the current drive. If the file is found, FileSearch }
{ stores a concatenation of the directory path and the file name in }
{ Dest. Otherwise FileSearch stores an empty string in Dest. The }
{ maximum length of the result is defined by the fsPathName constant. }
{ The returned value is Dest. }
function FileSearch(Dest, Name, List: PChar): PChar;
var
Info: FileStatus3;
begin
if (DosQueryPathInfo(Name,fil_Standard,Info,SizeOf(Info)) = 0)
and ((Info.attrFile and faDirectory) = 0) then FileExpand(Dest, Name)
else
if DosSearchPath(dsp_ImpliedCur+dsp_IgnoreNetErr,List,Name,Dest,fsPathName+1) <> 0
then Dest[0] := #0;
FileSearch := Dest;
end;
{ FileExpand fully expands the file name in Name, and stores the result }
{ in Dest. The maximum length of the result is defined by the }
{ fsPathName constant. The result is an all upper case string }
{ consisting of a drive letter, a colon, a root relative directory path,}
{ and a file name. Embedded '.' and '..' directory references are }
{ removed. The returned value is Dest. }
function FileExpand(Dest, Name: PChar): PChar;
var
I,J,L: Integer;
C: Char;
CurDir: String;
procedure AdjustPath;
begin
{ Check for '\.\' }
if (Dest[J-2] = '\') and (Dest[J-1] = '.') then Dec(J,2)
else
{ Check for '\..\' }
if (Dest[J-3] = '\') and (Dest[J-2] = '.') and (Dest[J-1] = '.') then
begin
Dec(J,3);
if Dest[J-1] <> ':' then
repeat
Dec(J);
until Dest[J] = '\';
end;
end;
begin
L := StrLen(Name);
if (L >= 2) and (Name[1] = ':') then
begin { Path is already in form 'X:\Path' }
if (L >= 3) and (Name[2] = '\') then StrCopy(Dest, Name)
else
begin { Path is in form 'X:Path' }
GetDir(Ord(UpCase(Name[0])) - Ord('A') + 1, CurDir);
if Length(CurDir) > 3 then CurDir := CurDir + '\';
StrLCat(StrPCopy(Dest, CurDir), @Name[2], fsPathName);
end;
end
else
begin { Path is without drive letter }
GetDir(0,CurDir); { Get default drive & directory }
if Length(CurDir) > 3 then CurDir := CurDir + '\';
if Name[0] = '\' then StrLCopy(Dest, @CurDir[1], 2) { only 'X:' }
else StrPCopy(Dest, CurDir);
StrLCat(Dest, Name, fsPathName);
end;
I := 0; J := 0;
for I := 0 to StrLen(Dest)-1 do
begin
C := UpCase(Dest[I]);
if C = '\' then AdjustPath;
Dest[J] := C;
Inc(J);
end;
AdjustPath;
if Dest[J-1] = ':' then
begin
Dest[J] := '\';
Inc(J);
end;
Dest[J] := #0;
FileExpand := Dest;
end;
{ FileSplit 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 period. If a component }
{ string parameter is NIL, the corresponding part of the path is not }
{ stored. If the path does not contain a given component, the returned }
{ component string is empty. The maximum lengths of the strings }
{ returned in Dir, Name, and Ext are defined by the fsDirectory, }
{ fsFileName, and fsExtension constants. The returned value is a }
{ combination of the fcDirectory, fcFileName, and fcExtension bit masks,}
{ indicating which components were present in the path. If the name or }
{ extension contains any wildcard characters (* or ?), the fcWildcards }
{ flag is set in the returned value. }
function FileSplit(Path, Dir, Name, Ext: PChar): Word;
var
DirLen, NameLen, Flags: Word;
NamePtr, ExtPtr: PChar;
begin
NamePtr := StrRScan(Path, '\');
if NamePtr = nil then NamePtr := StrRScan(Path, ':');
if NamePtr = nil then NamePtr := Path else Inc(NamePtr);
ExtPtr := StrScan(NamePtr, '.');
if ExtPtr = nil then ExtPtr := StrEnd(NamePtr);
DirLen := NamePtr - Path;
if DirLen > fsDirectory then DirLen := fsDirectory;
NameLen := ExtPtr - NamePtr;
if NameLen > fsFilename then NameLen := fsFilename;
Flags := 0;
if (StrScan(NamePtr, '?') <> nil) or (StrScan(NamePtr, '*') <> nil) then
Flags := fcWildcards;
if DirLen <> 0 then Flags := Flags or fcDirectory;
if NameLen <> 0 then Flags := Flags or fcFilename;
if ExtPtr[0] <> #0 then Flags := Flags or fcExtension;
if Dir <> nil then StrLCopy(Dir, Path, DirLen);
if Name <> nil then StrLCopy(Name, NamePtr, NameLen);
if Ext <> nil then StrLCopy(Ext, ExtPtr, fsExtension);
FileSplit := Flags;
end;
{ GetCurDir returns the current directory of a specified drive. }
{ Drive = 0 indicates the current drive, 1 indicates drive A, 2 }
{ indicates drive B, and so on. The string returned in Dir always }
{ starts with a drive letter, a colon, and a backslash. The maximum }
{ length of the resulting string is defined by the fsDirectory constant.}
{ The returned value is Dir. Errors are reported in DosError. }
function GetCurDir(Dir: PChar; Drive: Byte): PChar;
var
S: String;
begin
GetDir(Drive, S);
ChDir(S);
DosError := IOResult;
GetCurDir := StrPCopy(Dir, S);
end;
{ SetCurDir changes the current directory to the path specified by Dir. }
{ If Dir specifies a drive letter, the current drive is also changed. }
{ Errors are reported in DosError. }
procedure SetCurDir(Dir: PChar);
begin
ChDir(StrPas(Dir));
DosError := IOResult;
end;
{ CreateDir creates a new subdirectory with the path specified by Dir. }
{ Errors are reported in DosError. }
procedure CreateDir(Dir: PChar);
begin
MkDir(StrPas(Dir));
DosError := IOResult;
end;
{ RemoveDir removes the subdirectory with the path specified by Dir. }
{ Errors are reported in DosError. }
procedure RemoveDir(Dir: PChar);
begin
RmDir(StrPas(Dir));
DosError := IOResult;
end;
{ GetArgCount returns the number of parameters passed to the program on }
{ the command line. }
function GetArgCount: Integer;
begin
GetArgCount := ParamCount;
end;
{ GetArgStr returns the Index'th parameter from the command line, or an }
{ empty string if Index is less than zero or greater than GetArgCount. }
{ If Index is zero, GetArgStr returns the filename of the current }
{ module. The maximum length of the string returned in Dest is given by }
{ the MaxLen parameter. The returned value is Dest. }
function GetArgStr(Dest: PChar; Index: Integer; MaxLen: Word): PChar;
var
S: String;
begin
if MaxLen > 255 then MaxLen := 255;
S := ParamStr(Index);
if Length(S) > MaxLen then S[0] := Chr(MaxLen);
GetArgStr := StrPCopy(Dest, S);
end;
{ GetEnvVar returns a pointer to the value of a specified environment }
{ variable, i.e. a pointer to the first character after the equals sign }
{ (=) in the environment entry given by VarName. VarName is case }
{ insensitive. GetEnvVar returns NIL if the specified environment }
{ variable does not exist. }
function GetEnvVar(VarName: PChar): PChar;
var
L: Word;
P: PChar;
begin
L := StrLen(VarName);
P := Environment;
while P^ <> #0 do
begin
if (StrLIComp(P, VarName, L) = 0) and (P[L] = '=') then
begin
GetEnvVar := P + L + 1;
Exit;
end;
Inc(P, StrLen(P) + 1);
end;
GetEnvVar := nil;
end;
end.