Power-Programmierung/CD1.mdf/pascal/bp7os2/oscrt4/dos.pas

Pascal/Delphi Source File | 1994-02-11 | 36.0 KB | 1,334 lines

unit Dos;

{$S-,R-,Q-,I-,B-}

{**********************************************************}
{                                                          }
{ BP4OS2: DOS Interface Unit                               }
{                                                          }
{         Portions of this file                            }
{         Copyright (C) 1988,92 Borland International      }
{         Used with permission                             }
{                                                          }
{----------------------------------------------------------}
{  Borland - Interface                                     }
{  Matthias Withopf / c't - limited Port to OS/2           }
{  Rohit Gupta  -  Completed DOS compatability             }
{  Rick Widmer - Added comments                            }
{**********************************************************}



{****************************************}
{                                        }
{      ***    ****   *****     *         }
{      *  *   *        *      * *        }
{      ***    ***      *      ***        }
{      *  *   *        *     *   *       }
{      ***    ****     *     *   *       }
{                                        }
{ Please report problems (and successes) }
{ on BPASCAL section 17. Prefix all      }
{ messages with BP4OS2.                  }
{                                        }
{ Internet: [e-mail]     }
{                                        }
{ NOTE:  Flags, Registers, MSDOS, INTR   }
{        GetIntVec and SetIntVec are     }
{        in Compatab.Pas                 }
{                                        }
{        The functions of Keep and       }
{        SwapVectors are not needed      }
{        with OS/2, they are not         }
{        supported.                      }
{                                        }
{        GetCBreak and SetCBreak have    }
{        not been needed yet, and are    }
{        not ported.                     }
{                                        }
{****************************************}

interface

uses
  Os2Def, BseDos, BseSub;

const

{ Flags bit masks }

  FCarry     = $0001;
  FParity    = $0004;
  FAuxiliary = $0010;
  FZero      = $0040;
  FSign      = $0080;
  FOverflow  = $0800;

{ File mode magic numbers }

  fmClosed = $D7B0;
  fmInput  = $D7B1;
  fmOutput = $D7B2;
  fmInOut  = $D7B3;

{ File attribute constants }

  ReadOnly  = $01;
  Hidden    = $02;
  SysFile   = $04;
  VolumeId  = $08;
  Directory = $10;
  Archive   = $20;
  AnyFile   = $37;

type

{ String types }

  ComStr  = string[127];        { Command line string }
  PathStr = string[79];         { File pathname string }
  DirStr  = string[67];         { Drive and directory string }
  NameStr = string[8];          { File name string }
  ExtStr  = string[4];          { File extension string }

{ Registers record used by Intr and MsDos }

  Registers = record
                case Integer of
                  0: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Word);
                  1: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
              end;

{ Typed-file and untyped-file record }

  FileRec = record
              Handle  : Word;
              Mode    : Word;
              RecSize : Word;
              Private : array[1..26] of Byte;
              UserData: array[1..16] of Byte;
              Name    : array[0..79] of Char;
            end;

{ Textfile record }

  TextBuf = array[0..127] of Char;
  TextRec = record
              Handle   : Word;
              Mode     : Word;
              BufSize  : Word;
              Private  : Word;
              BufPos   : Word;
              Bufend   : Word;
              BufPtr   : ^TextBuf;
              OpenFunc : Pointer;
              InOutFunc: Pointer;
              FlushFunc: Pointer;
              CloseFunc: Pointer;
              UserData : array[1..16] of Byte;
              Name     : array[0..79] of Char;
              Buffer   : TextBuf;
            end;

{ Search record used by FindFirst and FindNext }

  SearchRec = record
                Fill: array[1..21] of Byte;
                Attr: Byte;
                Time: Longint;
                Size: Longint;
                Name: string[12];
              end;

{ Date and time record used by PackTime and UnpackTime }

  DateTime = record
               Year,Month,Day,Hour,Min,Sec: Word;
             end;
const

  ExecFlags     : Word = 0;   { EXEC_SYNC }

var

{ Error status variable }

  DosError: Integer;

{ OS/2 Global Information Segment pointer }

  GlobalInfoSeg: pGInfoSeg;

{ OS/2 Local Information Segment pointer }

  LocalInfoSeg : pLInfoSeg;


{ DosVersion returns the DOS version number. The low byte of    }
{ the result is the major version number, and the high byte is  }
{ the minor version number. For example, DOS 3.20 returns 3 in  }
{ the low byte, and 20 in the high byte.                        }

function  DosVersion: Word;

{ Intr executes a specified software interrupt with a specified }
{ Registers package.                                            }

procedure Intr(IntNo: Byte; var Regs: Registers);

{ MsDos invokes the DOS function call handler with a specified  }
{ Registers package.                                            }

procedure MsDos(var Regs: Registers);

{ GetDate 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);

{ SetDate sets the current date 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);

{ GetTime 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);

{ SetTime 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);

{ GetCBreak returns the state of Ctrl-Break checking in DOS.    }
{ When off (False), DOS only checks for Ctrl-Break during I/O   }
{ to console, printer, or communication devices. When on        }
{ (True), checks are made at every system call.                 }

procedure GetCBreak(var Break: Boolean);

{ SetCBreak sets the state of Ctrl-Break checking in DOS.       }

procedure SetCBreak(Break: Boolean);

{ GetVerify returns the state of the verify flag in DOS. 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);

{ SetVerify sets the state of the verify flag in DOS.           }

procedure SetVerify(Verify: Boolean);

{ DiskFree returns the number of free bytes on the specified    }
{ drive number (0=Default,1=A,2=B,..). DiskFree returns -1 if   }
{ the drive number is invalid.                                  }

function  DiskFree(Drive: Byte) : Longint;

{ DiskSize returns the size in bytes of the specified drive     }
{ number (0=Default,1=A,2=B,..). DiskSize returns -1 if the     }
{ drive number is invalid.                                      }

function  DiskSize(Drive: Byte) : Longint;

{ GetFAttr 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);

{ SetFAttr sets the attributes of a file. F must be a file      }
{ variable (typed, untyped or textfile) which has been assigned }
{ a name. The attribute value is formed by adding (or ORing)    }
{ the appropriate attribute masks defined as constants above.   }
{ Errors are reported in DosError.                              }

procedure SetFAttr(var F; Attr: Word);

{ GetFTime 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);

{ SetFTime 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);

{ FindFirst 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: PathStr; Attr: Word; var S: SearchRec);

{ FindNext 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 S: SearchRec);

{ UnpackTime converts a 4-byte packed date/time returned by     }
{ FindFirst, FindNext or GetFTime into a DateTime record.       }

procedure UnpackTime(P: Longint; var T: DateTime);

{ PackTime converts a DateTime record into a 4-byte packed      }
{ date/time used by SetFTime.                                   }

procedure PackTime(var T: DateTime; var P: LongInt);

{ GetIntVec returns the address stored in the specified         }
{ interrupt vector.                                             }

procedure GetIntVec(IntNo: Byte; var Vector: Pointer);

{ SetIntVec sets the address in the interrupt vector table for  }
{ the specified interrupt.                                      }

procedure SetIntVec(IntNo: Byte; Vector: Pointer);

{ FSearch 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 concatenation of one of the directory paths and    }
{ the file name, or an empty string if the file could not be    }
{ located.                                                      }

function  FSearch(Path: PathStr; DirList: string): PathStr;

{ 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(Path: PathStr): PathStr;

{ FSplit 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(Path: PathStr; var Dir: DirStr;
              var Name: NameStr; var Ext: ExtStr);

{ EnvCount returns the number of strings contained in the DOS   }
{ environment.                                                  }

function  EnvCount : Integer;

{ EnvStr 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;

{ GetEnv 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(Envvar: string): string;

{ SwapVectors swaps the contents of the SaveIntXX pointers in   }
{ the System unit with the current contents of the interrupt    }
{ vectors. SwapVectors is typically called just before and just }
{ after a call to Exec. This insures that the Exec'd process    }
{ does not use any interrupt handlers installed by the current  }
{ process, and vice versa.                                      }

procedure SwapVectors;

{**                                                           **}
{** SwapVectors is no longer needed.  Exec starts a separate  **}
{** session that does not depend on the machine state, or use **}
{** any memory of this session.                               **}
{**                                                           **}

{ Keep (or Terminate Stay Resident) terminates the program and  }
{ makes it stay in memory. The entire program stays in memory,  }
{ including data segment, stack segment, and heap. The ExitCode }
{ corresponds to the one passed to the Halt standard procedure. }

procedure Keep(ExitCode: Word);

{**                                                           **}
{**    OS/2 makes the whole idea of TSR programs obsolete.    **}
{**  this procedure is no longer supported.                   **}
{**                                                           **}

{ Exec executes another program. The program is specified by    }
{ the Path parameter, and the command line is specified by the  }
{ CmdLine parameter. To execute a DOS internal command, run     }
{ COMMAND.COM, e.g. "Exec('\COMMAND.COM','/C DIR *.PAS');".     }
{ Note the /C in front of the command. Errors are reported in   }
{ DosError. When compiling a program that uses Exec, be sure    }
{ to specify a maximum heap size as there will otherwise not be }
{ enough memory.                                                }

procedure Exec(Path: PathStr; ComLine: ComStr);

{ DosExitCode returns the exit code of a sub-process. The low   }
{ byte is the code sent by the terminating process. The high    }
{ byte is zero for normal termination, 1 if terminated by       }
{ Ctrl-C, 2 if terminated due to a device error, or 3 if        }
{ terminated by the Keep procedure (function call 31 hex).      }

function  DosExitCode: Word;

{ Extra routines for OS/2                                       }

procedure PlaySound(Frequency, Duration: Word);

implementation

const
  Video_IO  = $10;
  Keybd_IO  = $16;
  Dos_Int   = $21;


procedure USI(Msg: String; IntNo: Byte);
  begin
    Writeln(Msg, ': ', IntNo);
    Halt;
  end;


procedure SetMode(Mode: Byte); near;
  var
    CrtVioMode : tVioModeInfo;
  begin
    CrtVioMode.cb := SizeOf(tVioModeInfo);
    VioGetMode(CrtVioMode, 0);
    case Mode of
      $00:
        begin
          CrtVioMode.fbType := 5;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 40;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 360;
          CrtVioMode.vres   := 400;
        end;
      $01:
        begin
          CrtVioMode.fbType := 1;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 40;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 360;
          CrtVioMode.vres   := 400;
        end;
      $02:
        begin
          CrtVioMode.fbType := 5;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 720;
          CrtVioMode.vres   := 400;
        end;
      $03:
        begin
          CrtVioMode.fbType := 1;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 720;
          CrtVioMode.vres   := 400;
        end;
      $04:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 2;
          CrtVioMode.col    := 40;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 320;
          CrtVioMode.vres   := 200;
        end;
      $05:
        begin
          CrtVioMode.fbType := 7;
          CrtVioMode.color  := 2;
          CrtVioMode.col    := 40;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 320;
          CrtVioMode.vres   := 200;
        end;
      $06:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 1;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 640;
          CrtVioMode.vres   := 200;
        end;
      $07:
        begin
          CrtVioMode.fbType := 0;
          CrtVioMode.color  := 0;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 720;
          CrtVioMode.vres   := 400;
        end;
      $0D:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 40;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 320;
          CrtVioMode.vres   := 200;
        end;
      $0E:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 640;
          CrtVioMode.vres   := 200;
        end;
      $0F:
        begin
          CrtVioMode.fbType := 2;
          CrtVioMode.color  := 0;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 640;
          CrtVioMode.vres   := 350;
        end;
      $10:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 640;
          CrtVioMode.vres   := 350;
        end;
      $11:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 1;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 30;
          CrtVioMode.hres   := 640;
          CrtVioMode.vres   := 480;
        end;
      $12:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 4;
          CrtVioMode.col    := 80;
          CrtVioMode.row    := 30;
          CrtVioMode.hres   := 640;
          CrtVioMode.vres   := 480;
        end;
      $13:
        begin
          CrtVioMode.fbType := 3;
          CrtVioMode.color  := 8;
          CrtVioMode.col    := 40;
          CrtVioMode.row    := 25;
          CrtVioMode.hres   := 320;
          CrtVioMode.vres   := 200;
        end;
    end;
    VioSetMode(CrtVioMode, 0)
  end;


function GetMode: Byte; near;
  var
    CrtVioMode : tVioModeInfo;
    Mode: Byte;
  begin
    CrtVioMode.cb := SizeOf(tVioModeInfo);
    VioGetMode(CrtVioMode, 0);
    if (CrtVioMode.fbType and 2) = 0 then  { Text Mode }
      begin
        if CrtVioMode.fbType = 0 then
          Mode := 7
        else
          begin
            if CrtVioMode.col = 40 then
              Mode := 1
            else if CrtVioMode.col = 80 then
              Mode := $3
            else
              Mode := $FF;
            if CrtVioMode.fbType = 5 then
              Dec(Mode);
          end;
      end
    else                                { Graphic mode }
      begin
        case CrtVioMode.color of
          0:
            Mode := $0F;
          1:
            begin
              if CrtVioMode.row = 30 then
                Mode := $11
              else
                Mode := $06;
            end;
          2:
            begin
              if CrtVioMode.fbType = 7 then
                Mode := $05
              else
                Mode := $04;
            end;
          4:
            begin
              if CrtVioMode.col = 40 then
                Mode := $0D
              else
                case CrtVioMode.vres of
                  200:
                    Mode := $0E;
                  350:
                    Mode := $10;
                  480:
                    Mode := $12;
                end;
            end;
          8:
            Mode := $13
        else
          Mode := $FF;
        end;
      end;
    GetMode := Mode;
  end;

procedure Int10(var Regs: Registers);
  type
    tCell = record
      c, a: Byte;
    end;

  var
    Row, Col,
    Len       : Word;
    Cell      : tCell;
    CursorInfo: tVioCursorInfo;

  begin
    case Regs.AH of
      $00 :
        SetMode(Regs.AL);
      $01 :                             { Set cursor type }
        begin
          CursorInfo.yStart := Regs.CH;
          CursorInfo.cend   := Regs.CL;
          CursorInfo.cx     := 0;
          CursorInfo.attr   := 0;
          VioSetCurType(CursorInfo, 0);
        end;
      $02 :                             { Set cursor position }
        VioSetCurPos(Regs.DH, Regs.DL, 0);
      $03 :                             { Read cursor position }
        begin
          VioGetCurType(CursorInfo, 0);
          Regs.CH := CursorInfo.yStart;
          Regs.CL := CursorInfo.cend;
          VioGetCurPos(Row, Col, 0);
          Regs.DH := Lo(Row);
          Regs.DL := Lo(Col);
        end;
      $06 :                             { Scroll window up }
        begin
          Cell.a := Regs.BH;
          Cell.c := $20;
          if Regs.AL = 0 then
            Regs.AX := $FFFF
          else
            Regs.AH := 0;
          VioScrollUp(Regs.CH, Regs.CL, Regs.DH, Regs.DL, Regs.AX, Cell, 0);
        end;
      $07 :                             { Scroll window down }
        begin
          Cell.a := Regs.BH;
          Cell.c := $20;
          if Regs.AL = 0 then
            Regs.AX := $FFFF
          else
            Regs.AH := 0;
          VioScrollDn(Regs.CH, Regs.CL, Regs.DH, Regs.DL, Regs.AX, Cell, 0);
        end;
      $08 :                             { Read character and attrib }
        begin
          VioGetCurPos(Row, Col, 0);
          Len := SizeOf(Cell);
          VioReadCellStr(Cell, Len, Row, Col, 0);
          Regs.AH := Cell.a;
          Regs.AL := Cell.c;
        end;
      $09 :                             { Write character and attrib }
        begin
          VioGetCurPos(Row, Col, 0);
          Cell.c := Regs.AL;
          Cell.a := Regs.BL;
          VioWrtNCell(Cell, Regs.CX, Row, Col, 0);
        end;
      $0A :                             { Write character only }
        begin
          VioGetCurPos(Row, Col, 0);
          VioWrtNChar(Regs.AL, Regs.CX, Row, Col, 0);
        end;
      $0E :
        begin
          Cell.c := Regs.AL;
          Cell.a := $0;
          VioWrtTTY(Cell, 1, 0);
        end;
      $0F :
        begin
          Regs.AL := GetMode;
        end;
    else
      USI('Unsupported Video Function', Regs.AH);
    end;
  end;


procedure Int16(var Regs: Registers);
  var
    KeyInfo: tKbdKeyInfo;
    KbdInfo: tKbdInfo;

  begin
    case Regs.AH of
      $00, $10 :
        begin
          KbdCharIn(KeyInfo, io_Wait, 0);
          Regs.AL := Ord(KeyInfo.chChar);
          Regs.AH := Ord(KeyInfo.chScan);
        end;
      $01, $11 :                      { Check for keystroke. }
        begin
          KbdPeek(KeyInfo, 0);
          if (KeyInfo.fbStatus and $40) <> 0 then
            begin
              Regs.Flags := Regs.Flags and Not(FZero);
              Regs.AL    := Ord(KeyInfo.chChar);
              Regs.AH    := Ord(KeyInfo.chScan);
            end
          else
            Regs.Flags := Regs.Flags or FZero;
        end;
      $02, $12 :                      { Read flags }
        begin
          KbdInfo.cb := 10;
          KbdGetStatus(KbdInfo, 0);
          if Regs.AH = $02 then
            Regs.AH := 0
          else
            Regs.AH := Hi(KbdInfo.fsState);
          Regs.AL := Lo(KbdInfo.fsState);
        end
    else
      USI('Unsupported Keyboard Function', Regs.AH);
    end;
  end;


procedure MsDos(var Regs: Registers);
  var
    Row, Col,
    DrvNum   : Word;
    LogDrvMap: Longint;
    KeyInfo  : tKbdKeyInfo;
    i        : Integer;
  begin
    case Regs.AH of
      $00 :
        DosExit(0, 0);
      $01 :
        begin
          KbdCharIn(KeyInfo, io_Wait, 0);
          Regs.AL := Ord(KeyInfo.chChar);
        end;
      $02 :
        begin
          VioGetCurPos(Row, Col, 0);
          VioWrtNChar(Regs.AL, 1, Row, Col, 0);
        end;

      $0E :
        begin
          DosSelectDisk(Word(Regs.DL + 1));
          DosQCurDisk(DrvNum, LogDrvMap);
          Regs.AL := 0;
          for i := 0 to 25 do
            if (LogDrvMap and 1) = 1 then
              begin
                Inc(Regs.AL);
                LogDrvMap := LogDrvMap shr 1;
              end;
        end;
    end;

  end;


procedure Intr(IntNo: Byte; var Regs: Registers);
  begin
    case IntNo of
      Video_IO :
        Int10(Regs);
      Keybd_IO :
        Int16(Regs);
      Dos_Int :
        MsDos(Regs)
    else
      USI('Unsupported Interrupt', IntNo);
    end;
  end;


function DosVersion: Word;
  begin
    DosVersion := GlobalInfoSeg^.uchMajorVersion
                  + (GlobalInfoSeg^.uchMinorVersion shl 8);
  end;


procedure GetDate(var Year,Month,Day,DayofWeek: Word);
  begin
    Year      := GlobalInfoSeg^.year;
    Month     := GlobalInfoSeg^.month;
    Day       := GlobalInfoSeg^.day;
    DayofWeek := GlobalInfoSeg^.weekday;
  end;


procedure SetDate(Year, Month, Day: Word);
  var
    DT: tDateTime;
  begin
    DosError := DosGetDateTime(DT);
    if DosError = 0 then
      begin
        DT.Year    := Year;
        DT.Month   := Month;
        DT.Day     := Day;
        DosSetDateTime(DT);
      end;
  end;


procedure GetTime(var Hour, Minute, Second, Sec100: Word);
  begin
    Hour   := GlobalInfoSeg^.hour;
    Minute := GlobalInfoSeg^.minutes;
    Second := GlobalInfoSeg^.seconds;
    Sec100 := GlobalInfoSeg^.hundredths;
  end;


procedure SetTime(Hour, Minute, Second, Sec100: Word);
  var
    DT: tDateTime;
  begin
    DosError := DosGetDateTime(DT);
    if DosError = 0 then
      begin
        DT.Hours      := Hour;
        DT.Minutes    := Minute;
        DT.Seconds    := Second;
        DT.Hundredths := Sec100;
        DosSetDateTime(DT);
      end;
  end;


procedure GetCBreak(var Break: Boolean);
  begin
    Break := True;
  end;


procedure SetCBreak(Break: Boolean);
  begin

  end;


procedure GetVerify(var Verify: Boolean);
  var
    V: Word;
  begin
    DosError := DosQVerify(V);
    if DosError = 0 then
      Verify := Boolean(V)
    else
      Verify := False;
  end;


procedure SetVerify(Verify: Boolean);
  begin
    DosError := DosSetVerify(Word(Verify));
  end;


function DiskFree(Drive: Byte): Longint;
  var
    FI: tFSAllocate;
  begin
    DosError := DosQFSInfo(Drive, 1, FI, sizeof(FI));
    if DosError = 0 then
      DiskFree := FI.cUnitAvail * FI.cSectorUnit * FI.cbSector
    else
      DiskFree := -1;
  end;


function DiskSize(Drive: Byte): Longint;
  var
    FI: tFSAllocate;
  begin
    DosError := DosQFSInfo(Drive, 1, FI, sizeof(FI));
    if DosError = 0 then
      DiskSize := FI.cUnit * FI.cSectorUnit * FI.cbSector
    else
      DiskSize := -1;
  end;


procedure GetFAttr(var F; var Attr: Word);
  var
    A: Word;
  begin
    DosError := DosQFileMode(FileRec(F).Name, A, 0);
    if DosError = 0 then
      Attr := A
    else
      Attr := 0;
  end;


procedure SetFAttr(var F; Attr: Word);
  begin
    DosError := DosSetFileMode(FileRec(F).Name, Attr, 0);
  end;


procedure GetFTime(var F; var Time: Longint);
  var
    FI: tFileStatus;
    T1: record
          Time,Date: Word;
        end absolute Time;
  begin
    DosError := DosQFileInfo(FileRec(F).Handle, 1, FI, SizeOf(FI));
    if DosError = 0 then
      begin
        T1.Time := FI.fTimeLastWrite;
        T1.Date := FI.fDateLastWrite;
      end
    else
      begin
        T1.Time := 0;
        T1.Date := 0;
      end;
  end;


procedure SetFTime(var F; Time: Longint);
  var
    FI: tFileStatus;
    T1: record
          Time,Date: Word;
        end absolute Time;
  begin
    DosError := DosQFileInfo(FileRec(f).Handle, 1, FI, SizeOf(FI));
    if DosError = 0 then
      begin
        FI.fTimeLastWrite := T1.Time;
        FI.fDateLastWrite := T1.Date;
        DosError := DosSetFileInfo(FileRec(f).Handle, 1, FI, SizeOf(FI));
      end;
  end;


procedure FindFirst(Path: PathStr; Attr: Word; var S: SearchRec);
  type
    PWord = ^Word;
  var
    FF   : tFileFindBuf;
    N    : string;
    Count: Word;
  begin
    N := Path + #0;
    Count := 1;
    PWord(@S)^ := $FFFF; { HDIR_CREATE }
    DosError := DosFindFirst(@N[1], PWord(@S)^, Attr, FF, SizeOf(FF), Count, 0);
    if DosError = 0 then
      begin
        S.Attr := FF.AttrFile;
        S.Time := (LongInt(FF.fDateLastWrite) shl 16) + FF.fTimeLastWrite;
        S.Size := FF.cbFile;
        Move(FF.cchName, S.Name, SizeOf(S.Name))
      end;
  end;


procedure FindNext(var S: SearchRec);
  type
    PWord = ^Word;
  var
    FF   : tFileFindBuf;
    Count: Word;
  begin
    Count := 1;
    DosError := DosFindNext(PWord(@S)^, FF, SizeOf(FF), Count);
    if DosError = 0 then
      begin
        S.Attr := FF.AttrFile;
        S.Time := (LongInt(FF.fDateLastWrite) shl 16) + FF.fTimeLastWrite;
        S.Size := FF.cbFile;
        Move(FF.cchName, S.Name, SizeOf(S.Name))
      end
    else
      DosFindClose(PWord(@S)^);
  end;


procedure UnpackTime(P: Longint; var T: DateTime);
  var
    P1: record
          Time,Date: Word;
        end absolute P;
  begin
    T.Year  := P1.Date shr 9 + 1980;
    T.Month := (P1.Date shr 5) and 15;
    T.Day   := P1.Date and 31;
    T.Hour  := P1.Time shr 11;
    T.Min   := (P1.Time shr 5) and 63;
    T.Sec   := (P1.Time and 31) shl 1;
  end;


procedure PackTime(var T: DateTime; var P: Longint);
  var
    P1: record
          Time,Date: Word;
        end absolute P;
  begin
    P1.Date := (T.Year - 1980) shl 9 + T.Month shl 5 + T.Day;
    P1.Time := T.Hour shl 11 + T.Min shl 5 + T.Sec shr 1;
  end;


procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
  var
    P: PFn;
  begin
    Vector := nil;
    if DosSetVec(IntNo, nil, P) = 0 then
      begin
        Vector := Pointer(P);
        DosSetVec(IntNo, P, P);
      end;
  end;


procedure SetIntVec(IntNo: Byte; Vector: Pointer);
  var
    P: pFn;
  begin
    DosSetVec(IntNo, pFn(Vector), P);
  end;


function FSearch(Path: PathStr; DirList: string): PathStr;
  var
    Name   : string;
    Attrib : Word;
    p      : Byte;
  begin
    FSearch := '';
    Name := Path;
    repeat
      Name := Name + #0;
      DosError := DosQFileMode(@Name[1], Attrib, 0);
      if (DosError = 0) and ((Attrib and $18) = 0) then
        begin
          FSearch := Copy(Name, 1, Length(Name) - 1);
          Break;
        end
      else
        begin
          if DirList = '' then Break;
          p := Pos(';', DirList);
          if p <> 0 then
            begin
              Name := Copy(DirList, 1, p - 1) + '\' + Path;
              DirList := Copy(DirList, p + 1, 255);
            end
          else
            begin
              Name := DirList + '\' + Path;
              DirList := '';
            end;
        end;
    until False;
  end;


function FExpand(Path: PathStr): PathStr;
  var
    s: string;
  begin
    GetDir(0, s);
    if s <> '' then
      if s[Length(s) - 1] <> '\' then
        s := s + '\';
    FExpand := s + Path;
  end;


procedure FSplit(Path: PathStr; var Dir: DirStr;
                 var Name: NameStr; var Ext: ExtStr);
  var
    l: Integer;
  begin
    l := Length(Path);
    While Not(Path[l] in ['\',':']) and (l > 0) do Dec(l);
    Dir := Copy(Path, 1, l);
    Path := Copy(Path, l + 1, 255);
    l := Pos('.', Path);
    if l <> 0 then
      begin
        Name := Copy(Path, 1, l - 1);
        Ext  := Copy(Path, l, 4);
      end
    else
      begin
        Name := Path;
        Ext  := '';
      end;
  end;


{ Support Routine for EnvCount/EnvStr }
{
procedure EnvStrCnt; near; assembler;
  asm
    MOV   ES,EnvironmentSeg
    XOR   DI,DI
    CLD
@@1:
    XOR   AL,AL
    CMP   AL,ES:[DI]
    JE    @@2
    DEC   DX
    JE    @@2
    MOV   CX,-1
    REPNE SCASB
    JMP   @@1
@@2:
  end;
}

function EnvCount: Integer;
  const
    i: Integer = 0;
  var
    p: pChar;
  begin
    p := Ptr(EnvironmentSeg, 0);
    while p^ <> #0 do
      begin
        while p^ <> #0 do
          Inc(p);
        Inc(p);
        Inc(i);
      end;
    EnvCount := i;
  end;
{
function EnvCount: Integer; assembler;
  asm
    XOR   DX,DX
    CALL  EnvStrCnt
    XCHG  AX,DX
    NEG   AX
  end;
}

function EnvStr(Index: Integer): string;
  var
    p: pChar;
    s: string;
  begin
    p := Ptr(EnvironmentSeg, 0);
    while p^ <> #0 do
      begin
        Dec(Index);
        if Index <= 0 then
          Break;
        while p^ <> #0 do
          Inc(p);
        Inc(p);
      end;
    s := '';
    if Index = 0 then
      while p^ <> #0 do
        begin
          s := s + p^;
          Inc(p);
        end;
    EnvStr := s;
  end;

{
function EnvStr(Index: Integer): string; assembler;
  asm
    PUSH  DS
    MOV   DX,Index
    CALL  EnvStrCnt
    MOV   SI,DI
    PUSH  ES
    POP   DS
    XOR   AL,AL
    MOV   CX,256
    REPNE SCASB
    NOT   CL
    LES   DI,@Result
    MOV   AL,CL
    STOSB
    REP   MOVSB
    POP   DS
  end;
}

function GetEnv(EnvVar: string): string;
  var
    Cnt    : Integer;
    p      : pChar;
    s      : string;
    Srching: Boolean;
  begin
    for Cnt := Length(EnvVar) downto 1 do
      EnvVar[Cnt] := UpCase(EnvVar[Cnt]);
    p := Ptr(EnvironmentSeg, 0);
    while p^ <> #0 do
      begin
        s := '';
        Srching := True;
        while p^ <> #0 do
          begin
            if Srching and (p^ = '=') and (s = EnvVar) then
              begin
                Srching := False;
                s := '';
                Inc(p);
                Continue;
              end;
            s := s + p^;
            Inc(p);
          end;
        if Srching = False then
          begin
            GetEnv := s;
            Exit;
          end;
        Inc(p);
      end;
    GetEnv := '';
  end;


procedure SwapVectors;
  begin

  end;


procedure Keep(ExitCode: Word);
  begin

  end;


var
  ExecResult: tResultCodes;


procedure Exec(Path: PathStr; ComLine: ComStr);
  var
    b: array[0..255] of Char;
    c: string;
  begin
    if (length(comline) > 0) and (comline[1] <> ' ') then
       c := path + #0' ' + comline + #0#0
    else
      c := path + #0 + comline + #0#0;
    DosError := DosExecPgm(b, 256, ExecFlags, @c[1], Ptr(EnvironmentSeg, 0),
                           ExecResult, @c[1]);
  end;


function DosExitCode: Word;
  begin
    DosExitCode := ExecResult.CodeResult;
  end;


procedure PlaySound(Frequency, Duration: Word);
  begin
    DosBeep(Frequency, Duration);
  end;


procedure DosInit;
  var
    GlobalSel, LocalSel: Sel;
  begin
    if DosGetInfoSeg(GlobalSel, LocalSel) = 0 then
      begin
        GlobalInfoSeg := Ptr(GlobalSel, 0);
        LocalInfoSeg  := Ptr(LocalSel, 0);
      end
    else
      begin
        GlobalInfoSeg := nil;
        LocalInfoSeg  := nil;
      end;
  end;


begin
  DosInit;
end.