Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MSDOS.ZIP/MSDOS.PAS

Pascal/Delphi Source File | 1987-08-08 | 14.5 KB | 487 lines

{***********************************************************************

         MS-DOS COMMANDS NOT SUPPORTED DIRECTLY BY TURBO PASCAL
                         Version 1.00, 10/11/85

  Procedure
     or        Subroutine
  Function        Name                       Description
  --------- ---------------- -------------------------------------------

  Function  GetAttribute     Return the value of a specified file's
                             attribute byte.

  Procedure SetAttribute     Set a specified file's attribute byte.

  Function  GetBreak         Return a boolean value reporting the
                             current state of the DOS break switch:
                             on=true, off=false.

  Procedure SetBreak         Turn DOS break switch on/off based on a
                             boolean parameter: on=true, off=false.

  Function  GetDTA           Return a pointer to current disk transfer
                             area.

  Procedure SetDTA           Set the current disk transfer area to the
                             address specified in a pointer variable.

  Function  GetEnvironment   Return the value associated with a
                             specified keyword in the DOS environment
                             string.  A zero-length returned value means
                             the keyword was not found.

  Function  GetVector        Return a pointer to an interrupt routine.

  Procedure SetVector        Set an interrupt vector to the address
                             specified in a pointer variable.

  Function  GetVerify        Return a boolean value reporting the
                             current state of the disk-verify switch:
                             on=true, off=false.

  Procedure SetVerify        Turn the disk-verify switch on/off based
                             on a boolean parameter: on=true, off=false.

  Function  FreeDiskSpace    Return a real number containing the number
                             of bytes available on a specified disk
                             drive letter.

  Function  AvailableMemory  Return a real number containing the size of
                             the largest memory block available OUTSIDE
                             of the Turbo Pascal program's space.

  Function  LoadAndExecute   Load and executes a program, passing a
                             command-line parameter, and returning the
                             program's DOS termination error-level code
                             as an integer.  WARNING: Adjust the maximum
                             stack size at compile-time to allow enough
                             memory for the loaded program!

  Procedure ExecuteCommand   Execute a specified DOS command or, if a
                             zero-length command is entered, exit to a
                             secondary copy of COMMAND.COM (Enter an
                             EXIT command to return to the Turbo Pascal
                             program.)  WARNING: Adjust the maximum
                             stack size at compile-time allow enough
                             memory for COMMAND.COM!

  Function  FindFirstFile    Return a 12-byte string (filename.ext) that
                             contains the name of the first file
                             matching a specified file-search pattern
                             ([d:][\dir\]name.ext) and attribute byte
                             qualification.  File-search patterns may
                             contain wildcards.  Zero-length return
                             values indicate no match on the pattern.

  Function  FindNextFile     Return a 12-byte string (filename.ext) that
                             contains the name of the NEXT matching file
                             after the one found by FindFirstFile or a
                             previous FindNextFile call.  There are no
                             input parameters.

  Function  GetFileTime      Returns an 8-byte string (hh:mm:ss) that
                             contains the create/update time of the file
                             last found by FindFirstFile/FindNextFile.

  Function  GetFileDate      Returns a 10-byte string (mm/dd/yyyy) that
                             contains the create/update date of the file
                             last found by FindFirstFile/FindNextFile.

  Function  GetFileTime      Returns a real number that contains the
                             number of bytes in the file last found by
                             FindFirstFile/FindNextFile.

------------------------------------------------------------------------

  Written and placed in the public domain by:

                           Glen F. Marshall
                           1006 Gwilym Circle
                           Berwyn, PA 19312

***********************************************************************}

type { commonly used definitions for MsDos procedures and functions }

  AsciizInput      = string[255];
  AsciizOutput     = array[1..256] of char;
  MemoryAddress    = ^byte;
  CommandLine      = string[127];

var  { commonly used MsDos interface parameter }

  MsDosRegs: record case integer of
               1: (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: integer);
               2: (AL, AH, BL, BH, CL, CH, DL, DH: byte);
             end;

procedure Asciiz(S: AsciizInput; var R: AsciizOutput);
{ Common internal procedure: Convert a string to "ASCIIZ" format. }
  begin
    inline($1E/$16/$1F/$8D/$76/$08/$30/$ED/$8A/$0C/$46/$C4/$7E/$04/$F3/
           $A4/$26/$88/$0D/$1F);
  end {Asciiz};

procedure MsDosError;
{ Common internal procedure: Report a DOS error and abort the program. }
  begin
    with MsDosRegs do
    begin
      writeln('Abort - DOS Error #',AX);
      halt;
    end;
  end {MsDosError};

const { file attribute bit values }

  FileReadOnly     = 1;
  FileHidden       = 2;
  FileSystem       = 4;
  FileVolumeLabel  = 8;
  FileSubdirectory = 16;
  FileArchive      = 20;

function GetAttribute(FileName: AsciizInput): byte;
  var
    FileNameAsciiz: AsciizOutput;
  begin
    Asciiz(FileName, FileNameAsciiz);
    with MsDosRegs do
    begin
      AX := $4300;
      DS := seg(FileNameAsciiz);
      DX := ofs(FileNameAsciiz);
      MsDos(MsDosRegs);
      if (Flags and 1) <> 0 then MsDosError;
      GetAttribute := CX;
    end;
  end {GetAttribute};

procedure SetAttribute(FileName: AsciizInput; Attribute: byte);
  var
    FileNameAsciiz: AsciizOutput;
  begin
    Asciiz(FileName, FileNameAsciiz);
    with MsDosRegs do
    begin
      AX := $4301;
      DS := seg(FileNameAsciiz);
      DX := ofs(FileNameAsciiz);
      CX := Attribute;
      MsDos(MsDosRegs);
      if (Flags and 1) <> 0 then MsDosError;
    end;
  end {SetAttribute};

function GetBreak: boolean;
  begin
    with MsDosRegs do
    begin
      AX := $3300;
      MsDos(MsDosRegs);
      GetBreak := (DL = 1);
    end;
  end {GetBreak};

procedure SetBreak(Sw: boolean);
  begin
    with MsDosRegs do
    begin
      AX := $3301;
      if sw then DL := 1
            else DL := 0;
    end;
    MsDos(MsDosRegs);
  end {SetBreak};

function GetDTA: MemoryAddress;
  begin
    with MsDosRegs do
    begin
      AH := $2F;
      MsDos(MsDosRegs);
      GetDTA := ptr(ES,BX);
    end;
  end {GetDTA};

procedure SetDTA(DTA: MemoryAddress);
  begin
    with MsDosRegs do
    begin
      AH := $1A;
      DS := seg(DTA^);
      DX := ofs(DTA^);
    end;
    MsDos(MsDosRegs);
  end {SetDTA};

function GetEnvironment(Keyword: CommandLine): CommandLine;
  var
    EnvSeg, i, j: integer;
    s: CommandLine;
  begin
    EnvSeg := memw[Cseg:$2C];
    i := 0;
    s[0] := #0;
    while (mem[EnvSeg:i] <> 0) and (s[0] = #0) do
    begin
      j := 0;
      while mem[EnvSeg:i+j] <> 0 do
      begin
        s[j+1] := chr(mem[EnvSeg:i+j]);
        j := succ(j);
      end;
      s[0] := chr(j);
      i := succ(i + j);
      if pos(Keyword+'=',s) = 1 then
        delete(s,1,length(keyword)+1)
      else
        s[0] := #0;
    end;
    GetEnvironment := s;
  end {GetEnvironment};

function GetVector(Interrupt: byte): MemoryAddress;
  begin
    with MsDosRegs do
    begin
      AH := $35;
      AL := Interrupt;
      MsDos(MsDosRegs);
      GetVector := ptr(ES,BX);
    end;
  end {GetVector};

procedure SetVector(Interrupt: byte; Vector: MemoryAddress);
  begin
    with MsDosRegs do
    begin
      AH := $25;
      AL := Interrupt;
      DS := seg(Vector^);
      DX := ofs(Vector^);
    end;
    MsDos(MsDosRegs);
  end {SetVector};

function GetVerify: boolean;
  begin
    with MsDosRegs do
    begin
      AH := $54;
      MsDos(MsDosRegs);
      GetVerify := (AL = 1);
    end;
  end {GetVerify};

procedure SetVerify(Sw: boolean);
  begin
    with MsDosRegs do
      if Sw then AX := $2E01
            else AX := $2E00;
    MsDos(MsDosRegs);
  end {SetVerify};

function FreeDiskSpace(Drive: char): real;
  begin
    with MsDosRegs do
    begin
      AH := $36;
      DL := ord(upcase(Drive))-64;
      MsDos(MsDosRegs);
      if AX = $FFFF then
        FreeDiskSpace := -1
      else
        FreeDiskSpace := int(AX) * int(BX) * int(CX);
    end;
  end {FreeDiskSpace};

function AvailableMemory: real;
  begin
    with MsDosRegs do
    begin
      AH := $48;
      BX := $A000;
      MsDos(MsDosRegs);
      if (Flags and 1) = 0 then
      begin
        AH := $49;
        BX := $A000;
        MsDos(MsDosRegs);
        BX := $A000;
      end
      else
        if AX <> 8 then MsDosError;
      AvailableMemory := (int(BX and $7FFF)+32768.0*int(BX shr 15))*16;
    end;
  end {AvailableMemory};

function LoadAndExecute(ProgName, Parameter: CommandLine): integer;
  const
    SavedSS: integer = 0;
    SavedSP: integer = 0;
  var
    ProgNameAsciiz : AsciizOutput;
    ExecBlock      : record
                       EnvSeg      : integer;
                       CommandAddr : MemoryAddress;
                       FcbAddr1    : MemoryAddress;
                       FcbAddr2    : MemoryAddress;
                     end;
    MsDosReturn    : integer;

  begin
    Asciiz(ProgName, ProgNameAsciiz);
    with ExecBlock do
    begin
      EnvSeg      := memw[Cseg:$2C];
      CommandAddr := addr(Parameter);
      FcbAddr1    := ptr(Cseg,$5C);
      FcbAddr2    := ptr(Cseg,$6C);
    end;
    with MsDosRegs do
    begin
      AX := 0;
      inline($1E/$55/$8C/$D0/$2E/$A3/SavedSS/$2E/$89/$26/SavedSP/$8E/
             $D8/$8E/$C0/$8D/$96/ProgNameAsciiz/$8D/$9E/ExecBlock/$B8/
             $00/$4B/$CD/$21/$FA/$2E/$8E/$16/SavedSS/$2E/$8B/$26/
             SavedSP/$FB/$5D/$1F/$73/03/$A3/MsDosRegs);
      if AX <> 0 then MsDosError;
      AH := $4D;
      MsDos(MsDosRegs);
      LoadAndExecute := AX;
    end;
  end {LoadAndExecute};

procedure ExecuteCommand(Command: CommandLine);
  var
    Comspec: CommandLine;
    i: integer;
  begin
    Comspec := GetEnvironment('COMSPEC');
    if length(Command) > 0 then
      i := LoadAndExecute(Comspec,'/C '+Command+#13)
    else
      i := LoadAndExecute(Comspec,'');
  end {ExecuteCommand};

type { common definition used by file functions below }

  FileSpec         = string[12];

  FileTimeDate     = record
                       FileTime      : integer;
                       FileDate      : integer;
                     end;

  DisplayFileTime  = string[8];

  DisplayFileDate  = string[10];

  FileSizeLoHi     = record
                       FileSizeLo    : integer;
                       FileSizeHi    : integer;
                     end;

  DisplayFileSize  = string[8];

  FindFileWorkArea = record
                       reserved      : array[0..20] of byte;
                       FileAttribute : byte;
                       FileTimeStamp : FileTimeDate;
                       FileSize      : FileSizeLoHi;
                       FileName      : array[1..13] of char;
                     end;

var  { common storage structure used by file-find function below }

  FindFileDTA      : FindFileWorkArea;

function FindFirstFile(FileParam: AsciizInput;
                       AttributeParam: byte): FileSpec;
  var
    SavedDTA: MemoryAddress;
    FileParamAsciiz: AsciizOutput;
  begin
    SavedDTA := GetDTA;
    SetDTA(addr(FindFileDTA));
    Asciiz(FileParam,FileParamAsciiz);
    with MsDosRegs do
    begin
      AH := $4E;
      DS := seg(FileParamAsciiz);
      DX := ofs(FileParamAsciiz);
      CX := AttributeParam;
      MsDos(MsDosRegs);
      if AX = 0 then
        with FindFileDTA do
          FindFirstFile := copy(FileName,1,Pos(#0,FileName)-1)
      else
        FindFirstFile := '';
    end;
    SetDTA(SavedDTA);
  end {FindFirstFile};

function FindNextFile: FileSpec;
  var
    SavedDTA: MemoryAddress;
  begin
    SavedDTA := GetDTA;
    SetDTA(addr(FindFileDTA));
    with MsDosRegs do
    begin
      AH := $4F;
      MsDos(MsDosRegs);
      if AX = 0 then
        with FindFileDTA do
          FindNextFile := copy(FileName,1,pos(#0,FileName)-1)
      else
        FindNextFile := '';
    end;
    SetDTA(SavedDTA);
  end {FindFirstFile};

function GetFileTime: DisplayFileTime;
  var
    hs,ms,ss: string[2];
  begin
    with FindFileDTA do
      with FileTimeStamp do
      begin
        str((FileTime shr 11):2,hs);
        if hs[1] = ' ' then hs[1] := '0';
        str(((FileTime shr 5) and 63):2,ms);
        if ms[1] = ' ' then ms[1] := '0';
        str(((FileTime shl 1) and 63):2,ss);
        if ss[1] = ' ' then ss[1] := '0';
      end;
    GetFileTime := hs+':'+ms+':'+ss;
  end {GetFileTime};

function GetFileDate: DisplayFileDate;
  var
    ys: string[4];
    ms,ds: string[2];
  begin
    with FindFileDTA do
      with FileTimeStamp do
      begin
        str(((FileDate shr 9)+1980):4,ys);
        str(((FileDate shr 5) and 15):2,ms);
        if ms[1] = ' ' then ms[1] := '0';
        str((FileDate and 31):2,ds);
        if ds[1] = ' ' then ds[1] := '0';
      end;
    GetFileDate := ms+'/'+ds+'/'+ys;
  end {GetFileDate};

function GetFileSize: real;
  begin
    with FindFileDTA do
      with FileSize do
        GetFileSize := int(FileSizeLo and $7FFF) +
                       32768.0 * int(FileSizeLo shr 15) +
                       65536.0 * int(FileSizeHi);
  end {GetFileSize};