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

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.