Turbo Pascal Compatibility: DOS

unit dos;
  { unit for DOS functions in Delphi - coded by Glenn9999 under Delphi 3.  Used helps from
    the Internet for Turbo Pascal references and the Free Pascal sources. }
  interface
    uses sysutils, windows;
    const
      { file attribute constants }
      ReadOnly = faReadOnly;
      Hidden = faHidden;
      SysFile = faSysFile;
      VolumeID =  faVolumeID;
      Directory = faDirectory;
      Archive = faArchive;
      AnyFile = faAnyFile;
    type
      Int64 = Comp;      { comment out if you have Int64 type }

      { data types and records that were defined in the DOS unit }
      PathStr = String[79];
      DirStr = String[67];
      NameStr = String[8];
      ExtStr = String[4];
      ComStr = string[128];

      { used for PackTime and UnPackTime }
      DateTime = record
         Year, Month, Day, Hour, Min, Sec: Word;
      end;

      { searchrec type.  Changed in certain respects to ease functionality
        in Windows, since the exact record format shouldn't matter too much
        as long the record is not accessed directly, as opposed to access by
        the record type definition.  Also, NTFS file systems do not necessarily
        store and return short file names, so you may get LFNs out of FindFirst
        if run against such systems.
         - check your TP program before you try using FindFirst }
      SearchRec = record
         Attr: Byte;                 { attribute of file returned }
         Time: Longint;              { packed timestamp }
         Size: Longint;              { size of file }
         Name: string;               { name of file (short name if available }
         { variables following are necessary for continued functionality
           of findfirst/FindNext }
         FindHandle: THandle;        { saved search handle }
         ExcludeAttr: Integer;       { saved attribute parm }
         Path: PathStr;              { saved path parm }
      end;

      Registers = record { for the do-nothing calls }
        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;

    var
      doserror: integer;
      DosExitCode: DWord;

    { these two functions are not in the DOS unit, but are here if needed,
      otherwise the regular functions as defined in the DOS unit will only
      report a maximum of 2GB. }
    function  DiskSizeEx(Drive: Byte): Int64;  // addl functions added
    function  DiskFreeEx(Drive: Byte): Int64;  // these work for > 2GB

    function  fexpand(filename: string): string;
    procedure GetFAttr(var f; var attr: word);
    procedure SetFAttr(var F; Attr: Word);
    procedure FSplit(Path: PathStr; var Dir: DirStr;
                       var Name: NameStr; var Ext: ExtStr);
    procedure PackTime(var T: DateTime; var P: Longint);
    procedure UnpackTime(P: Longint; var T: DateTime);
    procedure FindFirst(Path: PathStr; Attr: Word; var F: SearchRec);
    procedure FindNext(var F: SearchRec);
    function  DiskFree(Drive: Byte): Longint;
    function  DiskSize(Drive: Byte): Longint;
    function  DosVersion: Word;
    function  FSearch(Path: PathStr; DirList: String): PathStr;
    procedure GetFTime(var F; var Time: Longint);
    procedure SetFTime(var F; Time: Longint);
    procedure GetDate(var Year,Month,Day, DayOfWeek: Word);
    procedure GetTime(var Hour,Minute,Second,Sec100: Word);
    procedure SetDate(Year,Month,Day: Word);
    procedure SetTime(Hour,Minute,Second,Sec100: Word);
    function  EnvCount: Integer;
    function  EnvStr(Index: Integer): String;
    function  GetEnv(EnvVar: String): String;
    procedure Exec(Path: PathStr; ComLine: ComStr);

    { do nothing functions - generally incompatible for Windows, included
      here both for documentation and to not break compilation of programs
      that might not otherwise work. }
    procedure GetVerify(var Verify: Boolean);
    procedure Intr(IntNo: Byte; var Regs: Registers);
    procedure Keep(ExitCode: Word);
    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 SetVerify(Verify: Boolean);
    procedure SwapVectors;

  { crossover DOS unit, allows some functions to go through sysutils unit }

  implementation
    uses messages;

  { ***********************************************************************
    Service functions for the other functions listed in the interface unit
   *********************************************************************** }
     function GetShortName(sLongName: string): string;
       begin
         Result := sLongName;
       end;

     function getvolname(input: string): string;
     { returns Volume Name of the drive that is inputted
       adapted from http://www.delphicorner.f9.co.uk/articles/wapi2.htm
       MAX_PATH is a dword defined to be 260 }
       var
         nVNameSer: PDWORD;
         pVolName: PChar;
         FSSysFlags, maxCmpLen: DWord;
         pFSBuf: PChar;
       begin
         GetMem(pVolName, MAX_PATH);
         GetMem(pFSBuf, MAX_PATH);
         GetMem(nVNameSer, MAX_PATH);
         GetVolumeInformation(PChar(input), pVolName, MAX_PATH,
                         nVNameSer, maxCmpLen, FSSysFlags, pFSBuf,
                         MAX_PATH);
         GetVolName := String(pVolName);
         FreeMem(pVolName, MAX_PATH);
         FreeMem(pFSBuf, MAX_PATH);
         FreeMem(nVNameSer, MAX_PATH);
       end;

     function DiskFreeEx(Drive: Byte): Int64;
       { redone DiskFree function which reports amount free on a disk > 2GB
         - original from Delphi 3 sources, changed to increase size of
         variable returned.  Can be called if real size is necessary. }
       var
         RootPath: array[0..4] of Char;
         RootPtr: PChar;
         SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: Integer;
         OutInt64: Int64;
       begin
         RootPtr := nil;
         if Drive > 0 then
           begin
             StrCopy(RootPath, 'A:\');
             RootPath[0] := Char(Drive + $40);
             RootPtr := RootPath;
           end;
         if GetDiskFreeSpace(RootPtr, SectorsPerCluster, BytesPerSector,
           FreeClusters, TotalClusters) then
           begin
             OutInt64 := SectorsPerCluster;
             Result := OutInt64 * BytesPerSector * FreeClusters;
           end
         else
           Result := -1;
       end;

     function DiskSizeEx(Drive: Byte): Int64;
       { redone DiskSize function which reports size of disk > 2GB
         - original from Delphi 3 sources, changed to increase size of
         variable returned.  Can be called if real size is necessary. }
       var
         RootPath: array[0..4] of Char;
         RootPtr: PChar;
         SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: Integer;
         OutInt64: Int64;
       begin
         RootPtr := nil;
         if Drive > 0 then
           begin
             StrCopy(RootPath, 'A:\');
             RootPath[0] := Char(Drive + $40);
             RootPtr := RootPath;
           end;
         if GetDiskFreeSpace(RootPtr, SectorsPerCluster, BytesPerSector,
           FreeClusters, TotalClusters) then
           begin
             OutInt64 := SectorsPerCluster;
             Result := OutInt64 * BytesPerSector * TotalClusters;
           end
         else
           Result := -1;
       end;

     function ProcessAMsg: Boolean;
       { service function for ProcessMessage }
       var
         Msg: TMsg;
         msg_proc: boolean;
       begin
         msg_proc := False;
         if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
           begin
             msg_proc := True;
             if Msg.Message <> WM_QUIT then
               begin
                 TranslateMessage(Msg);
                 DispatchMessage(Msg);
               end;
           end;
         ProcessAMsg := msg_proc;
       end;

     procedure ProcessMessage;
      { this should be an equivalent to TApplication.ProcessMessages }
       begin
         while ProcessAMsg do;
       end;

     function os_is_nt: Boolean;
       { returns whether the OS is NT based or not }
       var
         osvinfo: TOsVersionInfo;
       begin
        { get windows version }
         osvinfo.dwOSVersionInfoSize := Sizeof(osvinfo);
         GetVersionEx(osvinfo);
         os_is_nt := (osvinfo.dwPlatformId = VER_PLATFORM_WIN32_NT);
       end;

     function NTSetPrivilege(sMachine, sPrivilege: string;
                             bEnabled: Boolean): Boolean;
     { set privilege on remote computer.  Define sMachine to be null if you want
       local machine.   Modified from something on SwissCenter. }
       var
         hToken: THandle;
         TokenPriv: TTokenPrivileges;
         PrevTokenPriv: TTokenPrivileges;
         ReturnLength: DWord;
       begin
      // Only for Windows NT/2000/XP and later.
         if not (os_is_nt) then
           begin
             Result := true;
             Exit;
           end;

      // obtain the processes token
         if OpenProcessToken(GetCurrentProcess(),
            TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
           begin
             try
             // Get the locally unique identifier (LUID) .
              if LookupPrivilegeValue(PChar(sMachine), PChar(sPrivilege),
                 TokenPriv.Privileges[0].Luid) then
                begin
                  TokenPriv.PrivilegeCount := 1; // one privilege to set

                  case bEnabled of
                    True: TokenPriv.Privileges[0].Attributes  := SE_PRIVILEGE_ENABLED;
                    False: TokenPriv.Privileges[0].Attributes := 0;
                  end;

                  ReturnLength := 0; // replaces a var parameter
                  PrevTokenPriv := TokenPriv;

                // enable or disable the privilege

                  AdjustTokenPrivileges(hToken, False, TokenPriv,
                           SizeOf(PrevTokenPriv), PrevTokenPriv, ReturnLength);
                end;
             finally
               CloseHandle(hToken);
             end;
           end;
       // test the return value of AdjustTokenPrivileges.
         Result := GetLastError = ERROR_SUCCESS;
         if not Result then
           raise Exception.Create(SysErrorMessage(GetLastError));
       end;

{ ***********************************************************************
    Dos Compatibility Functions listed after this point
   *********************************************************************** }

     function fexpand(filename: string): string;
       { returns the fully qualified path for a file }
       var
         test: string;
         test_len: integer;
       begin
         // we need a string for ExpandFileName if there is not one
         if filename = '' then filename := '*.*';
         test := GetShortName(ExpandFileName(Filename));
         { check for trailing . - we want the path as TP returns,
           not the base directory identifier as well }
         test_len := length(test);
         if test[test_len] = '.' then
           begin
             test := copy(test, 1, test_len-1);
             dec(test_len, 1);
           end;
         // ExpandFileName returns *.* on the path.  The TP FExpand did not.
         if pos('\*.*', test) > 0 then
           test := copy(test, 1, test_len-4);
    //   if test[test_len] = '\' then
    //      test := test + '*.*';
         fexpand := test;
       end;

     procedure GetFAttr(var f; var attr: word);
       { gets the file attribute for a file variable }
       begin
         doserror := 0;
         attr := FileGetAttr(TFileRec(f).Name);
         if attr = -1 then
           doserror := GetLastError;
       end;

     procedure SetFAttr(var F; Attr: Word);
       { sets the file attribute for a file variable }
       begin
         doserror := 0;
         doserror := FileSetAttr(TFileRec(f).Name, attr);
       end;

     procedure FSplit(Path: PathStr; var Dir: DirStr;
                  var Name: NameStr; var Ext: ExtStr);
       { splits a full file path into the directory, name, and extension }
       var
         filename: string;
       begin
         Path := GetShortName(Path);
         Dir := ExtractFilePath(Path);
         filename := ExtractFileName(Path);
         Name := copy(filename, 1, pos('.', filename)-1);
         Ext := ExtractFileExt(Path);
       end;

     procedure PackTime(var T: DateTime; var P: Longint);
       { datetime type to packed DOS Timestamp }
       var
         MSec: Word;
         DateTime: TDateTime;
       begin
         MSec := 0;
         With T Do
           begin
             DateTime := EncodeDate(Year, Month, Day) +
                         EncodeTime(Hour, Min, Sec, MSec);
           end;
         P := DateTimeToFileDate(DateTime);
       end;

     procedure UnpackTime(P: Longint; var T: DateTime);
       { Packed DOS Timestamp to datetime type }
       var
         MSec: Word;
         MyDateTime: TDateTime;
       begin
         MyDateTime := FileDateToDateTime(p);
         With T Do
           begin
             DecodeDate(MyDateTime, Year, Month, Day);
             DecodeTime(MyDateTime, Hour, Min, Sec, MSec);
           end;
       end;

     procedure move_sr(F: TSearchRec; var O: SearchRec);
       { moves information from TSearchRec to SearchRec }
       begin
         if F.FindData.cAlternateFileName <> '' then
           O.Name := F.FindData.cAlternateFileName
         else
           O.Name := F.Name;
         O.Size := F.Size;
         O.Attr := F.Attr;
         O.Time := F.Time;
         O.FindHandle := F.FindHandle;
         O.excludeattr := F.ExcludeAttr;
       end;

     procedure FindFirst(Path: PathStr; Attr: Word; var F: SearchRec);
       { revised FindFirst.  TP returned volume attribute, so we must
         handle that first, and return it first }
       var
         tempsr: TSearchRec;
         return_volid: boolean;
         expf: string;
       begin
         DosError := 0;
         { determine whether to return VolumeID }
         return_volid := false;
         if (Attr and VolumeID) = VolumeID then
           begin
             expf := ExpandFileName(Path);
             if Copy(expf, 2, 5) = ':\*.*' then
               return_volid := true;
           end;
         { handle volume ID if it is called for }
         if return_volid then
           begin
             F.name := GetVolName(expf[1] + ':\');
             if F.name <> '' then   { if there is a volumeID to return }
               begin
                 if Length(F.Name) > 8 then  // format in the way DOS does
                   F.Name := Copy(F.name, 1, 8) + '.' + Copy(F.Name, 9, 20);
                 F.ExcludeAttr := Attr;                   { save attr }
                 F.Attr := VolumeID;                      { indicate VolumeID attr }
                 F.FindHandle := INVALID_HANDLE_VALUE;    { have not opened FindFirst }
                 F.Path := Path;                          { store path }
               end
             else
               if Attr = VolumeID then  { if we are supposed to only return VolumeID}
                 DosError := 18;
           end
         else
           begin   { not supposed to return VolumeID }
             DosError := SysUtils.FindFirst(Path, Attr, tempsr);
             Move_SR(tempsr, F);
           end;
       end;

     procedure FindNext(var F: SearchRec);
       { revised FindNext }
       var
         tempsr: TSearchRec;
       begin
         { check if FindFirst actually called - i.e. first call was for
           VolumeID }
         if F.FindHandle = INVALID_HANDLE_VALUE then
           begin
             DosError := SysUtils.FindFirst(F.Path, F.ExcludeAttr, tempsr);
             F.Path := '';
             Move_SR(tempsr, F);
           end
         else
           begin
             tempsr.FindHandle := F.FindHandle;
             tempsr.ExcludeAttr := F.ExcludeAttr;
             DosError := SysUtils.FindNext(tempsr);
             Move_SR(tempsr, F);
             if DosError <> 0 then
               SysUtils.FindClose(tempsr);
           end;
       end;

     function DiskFree(Drive: Byte): Longint;
       { TP DOS unit compatible function.  Calls the working Diskfree function
         and then returns a maximum of 2GB. }
       var
         DF: Int64;
       begin
         DF := DiskFreeEx(Drive);
         if DF > MAXLONGINT then
           Result := MAXLONGINT
         else
           Result := Trunc(DF);
       end;

     function DiskSize(Drive: Byte): Longint;
       { TP DOS unit compatible function.  Calls the working DiskSize function
         and then returns a maximum of 2GB. }
       var
         DS: Int64;
       begin
         DS := DiskSizeEx(Drive);
         if DS > MAXLONGINT then
           Result := MAXLONGINT
         else
           Result := Trunc(DS);
       end;

     function DosVersion: Word;
       { uses Win32 version in same format as expected in DOS unit,
         lo byte = major hi byte = minor.  Values come from sysutils unit }
       begin
         DosVersion := (Win32MinorVersion shl 8) + Win32MajorVersion;
       end;

     function  FSearch(Path: PathStr; DirList: String): PathStr;
       { searches for the Path in the Directory List given }
       begin
         FSearch := GetShortName(FileSearch(Path, DirList));
       end;

     procedure GetFTime(var F; var Time: Longint);
       { return file time.  Takes file id and packed time }
       begin
         doserror := 0;
         Time := FileGetDate(TFileRec(F).Handle);
         if Time = -1 then
           doserror := GetLastError;
       end;

     procedure SetFTime(var F; Time: Longint);
       { Set file time.  Takes file id and packed time }
       begin
         doserror := 0;
         FileSetDate(TFileRec(f).Handle, time);
         doserror := GetLastError;
       end;

     function EnvCount: Integer;
       { returns the number of environment strings.  Is resource-intensive,
         be careful in calling this function }
       var
         Env1, Env2: PChar;
         envi_count: integer;
       begin
         envi_count := 0;
         Env1 := GetEnvironmentStrings;
         Env2 := Env1;
         if Env2 <> nil then
           repeat
             inc(Env2, StrLen(Env2) + 1);
             inc(envi_count);
           until Env2^ = #0;
         FreeEnvironmentStrings(Env1);
         EnvCount := envi_count;
       end;

     function EnvStr(Index: Integer): String;
       { returns an environment string with specific index.
         Is resource-intensive, be careful in calling this function }
       var
         Env1, Env2: PChar;
         envi_count: integer;
       begin
         envi_count := 1;
         Env1 := GetEnvironmentStrings;
         Env2 := Env1;
         if Env2 <> nil then
            while (envi_count <> index) and (Env2^ <> #0) do
              begin
                inc(Env2, StrLen(Env2) + 1);
                inc(envi_count);
              end;
         EnvStr := StrPas(Env2);
         FreeEnvironmentStrings(Env1);
       end;

     function GetEnv(EnvVar: String): String;
       { gets an environment string with a specific name }
       var
         PathName: PChar;
         Buffer: array[0..255] of char;
       begin
         PathName := PChar(EnvVar);
         GetEnvironmentVariable(PathName, @Buffer, Sizeof(Buffer));
         GetEnv := String(Buffer);
       end;

     procedure Exec(Path: PathStr; ComLine: ComStr);
       { executes a program, and waits for completion }
       var
         StartInfo  : TStartupInfo;
         ProcInfo   : TProcessInformation;
         CreateOK   : Boolean;
         ErrorCode  : DWord;
         AppDone    : DWord;
       begin
         ErrorCode := 0;
         FillChar(StartInfo,SizeOf(TStartupInfo),#0);
         FillChar(ProcInfo,SizeOf(TProcessInformation),#0);
         StartInfo.cb := SizeOf(TStartupInfo);

         CreateOK := Windows.CreateProcess(nil,
                PChar(String(Path) + ' ' + String(ComLine)),
                nil, nil, False,
                CREATE_NEW_PROCESS_GROUP+IDLE_PRIORITY_CLASS+SYNCHRONIZE,
                nil, nil, StartInfo, ProcInfo);
         WaitForInputIdle(ProcInfo.hProcess, INFINITE);
         if CreateOK then
           repeat
             AppDone := WaitForSingleObject(ProcInfo.hProcess, 10);
             ProcessMessage;
           until AppDone <> WAIT_TIMEOUT;
         CloseHandle(ProcInfo.hProcess);
         CloseHandle(ProcInfo.hThread);
         GetExitCodeProcess(ProcInfo.hProcess, ErrorCode);
         DosExitCode := GetLastError;
       end;

    procedure GetDate(var Year,Month,Day,DayOfWeek: Word);
      { returns the system date }
      var
        MySystemTime: TSystemTime;
      begin
        GetLocalTime(MySystemTime);
        with MySystemTime do
          begin
            Year := wYear;
            Month := wMonth;
            Day := wDay;
            DayOfWeek := wDayOfWeek;
          end;
      end;

    procedure GetTime(var Hour,Minute,Second,Sec100: Word);
      { returns the system time }
      var
        MySystemTime: TSystemTime;
      begin
        GetLocalTime(MySystemTime);
        with MySystemTime do
          begin
            Hour := wHour;
            Minute := wMinute;
            Second := wSecond;
            Sec100 := wMilliseconds;
          end;
      end;

    procedure SetDate(Year,Month,Day: Word);
      { sets the system date }
      const
        SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
      var
        MySystemTime: TSystemTime;
      begin
        GetLocalTime(MySystemTime);
        NTSetPrivilege('',SE_SYSTEMTIME_NAME, true);
        with mysystemtime do
          begin
            wYear := Year;
            wMonth := Month;
            wDay := Day;
          end;
        SetLocalTime(MySystemTime);
        NTSetPrivilege('',SE_SYSTEMTIME_NAME, false);
      end;

    procedure SetTime(Hour,Minute,Second,Sec100: Word);
      { sets the system time }
      const
        SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
      var
        MySystemTime: TSystemTime;
      begin
        GetLocalTime(MySystemTime);
        NTSetPrivilege('',SE_SYSTEMTIME_NAME, true);
        with mysystemtime do
          begin
            wHour := Hour;
            wMinute := Minute;
            wSecond := Second;
            wMilliseconds := Sec100;
          end;
        SetLocalTime(MySystemTime);
        NTSetPrivilege('', SE_SYSTEMTIME_NAME, false);
      end;

{ ***********************************************************************
  do nothing functions follow.  These are things that were in the DOS unit,
  but do not have any applicability to Windows (or were not implemented yet
  in this unit for some reason) -  they are included more for
  compatibility than functionality
  *********************************************************************** }

    procedure GetVerify(var Verify: Boolean);
      { do nothing function}
      begin
      end;

    procedure Intr(IntNo: Byte; var Regs: Registers);
      { do nothing function}
      begin
      end;

    procedure Keep(ExitCode: Word);
      { do nothing function}
      begin
      end;

    procedure MsDos(var Regs: Registers);
      { do nothing function}
      begin
      end;

    procedure GetCBreak(var Break: Boolean);
      { do nothing function}
      begin
      end;

    procedure SetCBreak(Break: Boolean);
      { do nothing function}
      begin
      end;

    procedure GetIntVec(IntNo: Byte; var Vector: Pointer);
      { do nothing function}
      begin
      end;

    procedure SetIntVec(IntNo: Byte; Vector: Pointer);
      { do nothing function}
      begin
      end;

    procedure SetVerify(Verify: Boolean);
      { do nothing function}
      begin
      end;

    procedure SwapVectors;
      { do nothing function}
      begin
      end;

  end.