OS/2 Shareware BBS: 10 Tools/10-Tools.zip/vp21beta.zip/ARTLSRC.RAR/WINDOS.PAS

Pascal/Delphi Source File | 2000-08-15 | 17KB | 537 lines

//█▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀█
//█                                                       █
//█      Virtual Pascal Runtime Library.  Version 2.1.    █
//█      WINDOS 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 WinDos;

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 }

  faReadOnly  = $01;
  faHidden    = $02;
  faSysFile   = $04;
  faVolumeID  = $08;    // N/A under OS/2
  faDirectory = $10;
  faArchive   = $20;
{$IFDEF OS2}
  faAnyFile   = $37;
{$ELSE}
  faAnyFile   = $3F;
{$ENDIF}

{ 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..32] 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:    PTextBuf;                // 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:    TTextBuf;                // Default I/O buffer
  end;

{ Search record used by FindFirst and FindNext }

type
  TSearchRec = record
    Handle: Longint;
    Filler1: Longint;
    Attr: Byte;
    Time: Longint;
    Size: Longint;
    Name: array[0..259] 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}
    Private_data: array[1..sizeof(TOSSearchRec)-4-4-1-4-4-256-4] of Byte;
{$ENDIF}
  end;

{ Date and time record used by PackTime and UnpackTime }

type
  TDateTime = record
    Year, Month, Day, Hour, Min, Sec: Word;
  end;

{ Error status variable }

threadvar
  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 has been added }

procedure FindClose(var F: TSearchRec);

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;

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(TFileRec(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(TFileRec(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(TFileRec(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(TFileRec(F).Handle, Time));
end;

// Converts a 4-byte packed date/time returned by FindFirst, FindNext or
// GetFTime into a TDateTime record.

procedure UnpackTime(P: Longint; var T: TDateTime);
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 TDateTime record into a 4-byte packed date/time used by
// SetFTime.

procedure PackTime(var T: TDateTime; 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
// 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);
begin
  SetDosError(SysFindFirst(Path, Attr, TOSSearchRec(F), True));
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: TSearchRec);
begin
  SetDosError(SysFindNext(TOSSearchRec(F), True));
end;

// Ends the search, closes the search record. FindClose should be issued
// whenever search record is no longer needed.

procedure FindClose(var F: TSearchRec);
begin
  SetDosError(SysFindClose(TOSSearchRec(F)));
end;

// FileSearch searches for the file given by Name in the list of
// directories given by List. The directory paths in List must be
// eparated 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;
begin
  Result := SysFileSearch(Dest, Name, List);
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;
begin
  Result := SysFileExpand(Dest, Name);
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
    begin
      Dir^:=#0;
      StrLCopy(Dir, Path, DirLen);
    end;
  if Name <> nil then
    begin
      Name^:=#0;
      StrLCopy(Name, NamePtr, NameLen);
    end;
  if Ext <> nil then
    begin
      Ext^:=#0;
      StrLCopy(Ext, ExtPtr, fsExtension);
    end;
  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
// ength 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;
begin
  SetDosError(SysDirGetCurrent(Drive, Dir));
  Result := Dir;
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
  SetDosError(SysDirSetCurrent(Dir));
end;

// CreateDir creates a new subdirectory with the path specified by Dir.
// Errors are reported in DosError.

procedure CreateDir(Dir: PChar);
begin
  SetDosError(SysDirCreate(Dir));
end;

// RemoveDir removes the subdirectory with the path specified by Dir.
// Errors are reported in DosError.

procedure RemoveDir(Dir: PChar);
begin
  SetDosError(SysDirDelete(Dir));
end;

// GetArgCount returns the number of parameters passed to the program on
// the command line.

function GetArgCount: Integer;
begin
  GetArgCount := SysCmdlnCount;
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: ShortString;
begin
  if MaxLen > 255 then
    MaxLen := 255;
  SysCmdlnParam(Index, S);
  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 := SysGetEnvironment;
  if P <> nil then
    while P^ <> #0 do
    begin
      if (StrLIComp(P, VarName, L) = 0) and (P[L] = '=') then
      begin
        Result := P + L + 1;
        Exit;
      end;
      Inc(P, StrLen(P) + 1);
    end;
  Result := nil;
end;

end.