freepascal.compiler/rtl/win32/dos.pp

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team.

    Dos unit for BP7 compatible RTL

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
unit dos;
interface

{ Include Win32 Consts,Types }
{$I win32.inc}

Const
  Max_Path = 260;

  {Bitmasks for CPU Flags}
  fcarry     = $0001;
  fparity    = $0004;
  fauxiliary = $0010;
  fzero      = $0040;
  fsign      = $0080;
  foverflow  = $0800;

  {Bitmasks for file attribute}
  readonly  = $01;
  hidden    = $02;
  sysfile   = $04;
  volumeid  = $08;
  directory = $10;
  archive   = $20;
  anyfile   = $3F;

  {File Status}
  fmclosed = $D7B0;
  fminput  = $D7B1;
  fmoutput = $D7B2;
  fminout  = $D7B3;


Type
{ Needed for Win95 LFN Support }
  ComStr  = String[255];
  PathStr = String[255];
  DirStr  = String[255];
  NameStr = String[255];
  ExtStr  = String[255];

{
  filerec.inc contains the definition of the filerec.
  textrec.inc contains the definition of the textrec.
  It is in a separate file to make it available in other units without
  having to use the DOS unit for it.
}
{$i filerec.inc}
{$i textrec.inc}

  DateTime = packed record
    Year,
    Month,
    Day,
    Hour,
    Min,
    Sec   : word;
  End;

  PWin32FindData = ^TWin32FindData;
  TWin32FindData = record
    dwFileAttributes: Cardinal;
    ftCreationTime: TFileTime;
    ftLastAccessTime: TFileTime;
    ftLastWriteTime: TFileTime;
    nFileSizeHigh: Cardinal;
    nFileSizeLow: Cardinal;
    dwReserved0: Cardinal;
    dwReserved1: Cardinal;
    cFileName: array[0..MAX_PATH - 1] of Char;
    cAlternateFileName: array[0..13] of Char;
    // The structure should be 320 bytes long...
    pad : system.integer;
  end;

  Searchrec = Packed Record
    FindHandle  : THandle;
    W32FindData : TWin32FindData;
    ExcludeAttr : longint;
    time : longint;
    size : longint;
    attr : longint;
    name : string;
  end;


  registers = packed record
    case i : integer of
     0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
     1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
     2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
    end;

Var
  DosError : integer;

{Interrupt}
Procedure Intr(intno: byte; var regs: registers);
Procedure MSDos(var regs: registers);

{Info/Date/Time}
Function  DosVersion: Word;
Procedure GetDate(var year, month, mday, wday: word);
Procedure GetTime(var hour, minute, second, sec100: word);
procedure SetDate(year,month,day: word);
Procedure SetTime(hour,minute,second,sec100: word);
Procedure UnpackTime(p: longint; var t: datetime);
Procedure PackTime(var t: datetime; var p: longint);

{Exec}
Procedure Exec(const path: pathstr; const comline: comstr);
Function  DosExitCode: word;

{Disk}
Function  DiskFree(drive: byte) : longint;
Function  DiskSize(drive: byte) : longint;
Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
Procedure FindNext(var f: searchRec);
Procedure FindClose(Var f: SearchRec);

{File}
Procedure GetFAttr(var f; var attr: word);
Procedure GetFTime(var f; var time: longint);
Function  FSearch(path: pathstr; dirlist: string): pathstr;
Function  FExpand(const path: pathstr): pathstr;
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);

{Environment}
Function  EnvCount: longint;
Function  EnvStr(index: integer): string;
Function  GetEnv(envvar: string): string;

{Misc}
Procedure SetFAttr(var f; attr: word);
Procedure SetFTime(var f; time: longint);
Procedure GetCBreak(var breakvalue: boolean);
Procedure SetCBreak(breakvalue: boolean);
Procedure GetVerify(var verify: boolean);
Procedure SetVerify(verify: boolean);

{Do Nothing Functions}
Procedure SwapVectors;
Procedure GetIntVec(intno: byte; var vector: pointer);
Procedure SetIntVec(intno: byte; vector: pointer);
Procedure Keep(exitcode: word);

Const
  { allow EXEC to inherited handles from calling process,
    needed for FPREDIR in ide/text
    now set to true by default because
    other OS also pass open handles to childs
    finally reset to false after Florian's response PM }
  ExecInheritsHandles : BOOL = false;

implementation
uses strings;

{******************************************************************************
                           --- Conversion ---
******************************************************************************}

   function GetLastError : DWORD;
     external 'kernel32' name 'GetLastError';
   function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : longbool;
     external 'kernel32' name 'FileTimeToDosDateTime';
   function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : longbool;
     external 'kernel32' name 'DosDateTimeToFileTime';
   function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : longbool;
     external 'kernel32' name 'FileTimeToLocalFileTime';
   function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : longbool;
     external 'kernel32' name 'LocalFileTimeToFileTime';

type
  Longrec=packed record
    lo,hi : word;
  end;

function Last2DosError(d:dword):integer;
begin
  Last2DosError:=d;
end;


Function DosToWinAttr (Const Attr : Longint) : longint;
begin
  DosToWinAttr:=Attr;
end;


Function WinToDosAttr (Const Attr : Longint) : longint;
begin
  WinToDosAttr:=Attr;
end;


Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
var
  lft : TFileTime;
begin
  DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
                LocalFileTimeToFileTime(lft,Wtime);
end;


Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):longbool;
var
  lft : TFileTime;
begin
  WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
                FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
end;


{******************************************************************************
                           --- Dos Interrupt ---
******************************************************************************}

procedure intr(intno : byte;var regs : registers);
begin
  { !!!!!!!! }
end;

procedure msdos(var regs : registers);
begin
  { !!!!!!!! }
end;


{******************************************************************************
                        --- Info / Date / Time ---
******************************************************************************}

   function GetVersion : longint;
     external 'kernel32' name 'GetVersion';
   procedure GetLocalTime(var t : TSystemTime);
     external 'kernel32' name 'GetLocalTime';
   function SetLocalTime(const t : TSystemTime) : longbool;
     external 'kernel32' name 'SetLocalTime';

function dosversion : word;
begin
  dosversion:=GetVersion;
end;


procedure getdate(var year,month,mday,wday : word);
var
  t : TSystemTime;
begin
  GetLocalTime(t);
  year:=t.wYear;
  month:=t.wMonth;
  mday:=t.wDay;
  wday:=t.wDayOfWeek;
end;


procedure setdate(year,month,day : word);
var
  t : TSystemTime;
begin
  { we need the time set privilege   }
  { so this function crash currently }
  {!!!!!}
  GetLocalTime(t);
  t.wYear:=year;
  t.wMonth:=month;
  t.wDay:=day;
  { only a quite good solution, we can loose some ms }
  SetLocalTime(t);
end;


procedure gettime(var hour,minute,second,sec100 : word);
var
  t : TSystemTime;
begin
   GetLocalTime(t);
   hour:=t.wHour;
   minute:=t.wMinute;
   second:=t.wSecond;
   sec100:=t.wMilliSeconds div 10;
end;


procedure settime(hour,minute,second,sec100 : word);
var
   t : TSystemTime;
begin
   { we need the time set privilege   }
   { so this function crash currently }
   {!!!!!}
   GetLocalTime(t);
   t.wHour:=hour;
   t.wMinute:=minute;
   t.wSecond:=second;
   t.wMilliSeconds:=sec100*10;
   SetLocalTime(t);
end;


Procedure packtime(var t : datetime;var p : longint);
Begin
  p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;


Procedure unpacktime(p : longint;var t : datetime);
Begin
  with t do
   begin
     sec:=(p and 31) shl 1;
     min:=(p shr 5) and 63;
     hour:=(p shr 11) and 31;
     day:=(p shr 16) and 31;
     month:=(p shr 21) and 15;
     year:=(p shr 25)+1980;
   end;
End;


{******************************************************************************
                               --- Exec ---
******************************************************************************}

   function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
               lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
               bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
               lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
               var lpProcessInformation: TProcessInformation): longbool;
     external 'kernel32' name 'CreateProcessA';
   function getExitCodeProcess(h:THandle;var code:longint):longbool;
     external 'kernel32' name 'GetExitCodeProcess';
   function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
     external 'kernel32' name 'WaitForSingleObject';
   function CloseHandle(h : THandle) : longint;
     external 'kernel32' name 'CloseHandle';

var
  lastdosexitcode : word;

procedure exec(const path : pathstr;const comline : comstr);
var
  SI: TStartupInfo;
  PI: TProcessInformation;
  Proc : THandle;
  l    : Longint;
  AppPath,
  AppParam : array[0..255] of char;
begin
  FillChar(SI, SizeOf(SI), 0);
  SI.cb:=SizeOf(SI);
  SI.wShowWindow:=1;
  Move(Path[1],AppPath,length(Path));
  AppPath[Length(Path)]:=#0;
  AppParam[0]:='-';
  AppParam[1]:=' ';
  Move(ComLine[1],AppParam[2],length(Comline));
  AppParam[Length(ComLine)+2]:=#0;
  if not CreateProcess(PChar(@AppPath), PChar(@AppParam),
           Nil, Nil, ExecInheritsHandles,$20, Nil, Nil, SI, PI) then
   begin
     DosError:=Last2DosError(GetLastError);
     exit;
   end;
  Proc:=PI.hProcess;
  CloseHandle(PI.hThread);
  if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
    GetExitCodeProcess(Proc,l)
  else
    l:=-1;
  CloseHandle(Proc);
  LastDosExitCode:=l;
end;


function dosexitcode : word;
begin
  dosexitcode:=lastdosexitcode;
end;


procedure getcbreak(var breakvalue : boolean);
begin
{ !! No Win32 Function !! }
end;


procedure setcbreak(breakvalue : boolean);
begin
{ !! No Win32 Function !! }
end;


procedure getverify(var verify : boolean);
begin
{ !! No Win32 Function !! }
end;


procedure setverify(verify : boolean);
begin
{ !! No Win32 Function !! }
end;


{******************************************************************************
                               --- Disk ---
******************************************************************************}

   function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
                             freeclusters,totalclusters:longint):longbool;
     external 'kernel32' name 'GetDiskFreeSpaceA';

function diskfree(drive : byte) : longint;
var
  disk : array[1..4] of char;
  secs,bytes,
  free,total : longint;
begin
  if drive=0 then
   begin
     disk[1]:='\';
     disk[2]:=#0;
   end
  else
   begin
     disk[1]:=chr(drive+64);
     disk[2]:=':';
     disk[3]:='\';
     disk[4]:=#0;
   end;
  if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
   diskfree:=free*secs*bytes
  else
   diskfree:=-1;
end;


function disksize(drive : byte) : longint;
var
  disk : array[1..4] of char;
  secs,bytes,
  free,total : longint;
begin
  if drive=0 then
   begin
     disk[1]:='\';
     disk[2]:=#0;
   end
  else
   begin
     disk[1]:=chr(drive+64);
     disk[2]:=':';
     disk[3]:='\';
     disk[4]:=#0;
   end;
  if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
   disksize:=total*secs*bytes
  else
   disksize:=-1;
end;


{******************************************************************************
                         --- Findfirst FindNext ---
******************************************************************************}

{ Needed kernel calls }

   function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;
     external 'kernel32' name 'FindFirstFileA';
   function FindNextFile  (hFindFile: THandle; var lpFindFileData: TWIN32FindData): LongBool;
     external 'kernel32' name 'FindNextFileA';
   function FindCloseFile (hFindFile: THandle): LongBool;
     external 'kernel32' name 'FindClose';

Procedure StringToPchar (Var S : String);
Var L : Longint;
begin
  L:=ord(S[0]);
  Move (S[1],S[0],L);
  S[L]:=#0;
end;


procedure FindMatch(var f:searchrec);
begin
{ Find file with correct attribute }
  While (F.W32FindData.dwFileAttributes and F.ExcludeAttr)<>0 do
   begin
     if not FindNextFile (F.FindHandle,F.W32FindData) then
      begin
        DosError:=Last2DosError(GetLastError);
        exit;
      end;
   end;
{ Convert some attributes back }
  f.size:=F.W32FindData.NFileSizeLow;
  f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
  WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
  f.Name:=StrPas(@F.W32FindData.cFileName);
end;


procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
begin
{ no error }
  doserror:=0;
  F.Name:=Path;
  F.Attr:=attr;
  F.ExcludeAttr:=(not Attr) and ($1e); {hidden,sys,dir,volume}
  StringToPchar(f.name);
{ FindFirstFile is a Win32 Call }
  F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
  If longint(F.FindHandle)=Invalid_Handle_value then
   begin
     DosError:=Last2DosError(GetLastError);
     exit;
   end;
{ Find file with correct attribute }
  FindMatch(f);
end;


procedure findnext(var f : searchRec);
begin
{ no error }
  doserror:=0;
  if not FindNextFile (F.FindHandle,F.W32FindData) then
   begin
     DosError:=Last2DosError(GetLastError);
     exit;
   end;
{ Find file with correct attribute }
  FindMatch(f);
end;


procedure swapvectors;
begin
end;


Procedure FindClose(Var f: SearchRec);
begin
  If longint(F.FindHandle)<>Invalid_Handle_value then
   FindCloseFile(F.FindHandle);
end;


{******************************************************************************
                               --- File ---
******************************************************************************}

   function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
     external 'kernel32' name 'GetFileTime';
   function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
     external 'kernel32' name 'SetFileTime';
   function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : longbool;
     external 'kernel32' name 'SetFileAttributesA';
   function GetFileAttributes(lpFileName : pchar) : longint;
     external 'kernel32' name 'GetFileAttributesA';

procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
   dotpos,p1,i : longint;
begin
   { allow slash as backslash }
   for i:=1 to length(path) do
    if path[i]='/' then path[i]:='\';
   { get drive name }
   p1:=pos(':',path);
   if p1>0 then
     begin
        dir:=path[1]+':';
        delete(path,1,p1);
     end
   else
     dir:='';
   { split the path and the name, there are no more path informtions }
   { if path contains no backslashes                                 }
   while true do
     begin
        p1:=pos('\',path);
        if p1=0 then
          break;
        dir:=dir+copy(path,1,p1);
        delete(path,1,p1);
     end;
   { try to find out a extension }
   Ext:='';
   i:=Length(Path);
   DotPos:=256;
   While (i>0) Do
     Begin
        If (Path[i]='.') Then
          begin
             DotPos:=i;
             break;
          end;
        Dec(i);
     end;
   Ext:=Copy(Path,DotPos,255);
   Name:=Copy(Path,1,DotPos - 1);
end;

{ <immobilizer> }

  function GetFullPathName(lpFileName: PChar; nBufferLength: Longint; lpBuffer: PChar; var lpFilePart : PChar):DWORD;
    external 'kernel32' name 'GetFullPathNameA';

function FExpand(const path : pathstr) : pathstr;
var value, tmp : PChar;
    p          : string;
    i          : Longint;
begin
  { allow slash as backslash }
  p := path;
  for i:=1 to length(p) do 
   if p[i]='/' then
    p[i]:='\';
  StringToPchar(p);
  getmem(value, 255);
  getmem(tmp, 255);
  GetFullPathName(@p, 255, value, tmp);
  FExpand := strpas(value);
end;

  function SearchPath(lpPath : PChar; lpFileName : PChar; lpExtension : PChar; nBufferLength : Longint; lpBuffer : PChar;
    var lpFilePart : PChar) : Longint; external 'kernel32' name 'SearchPathA';

Function FSearch(path: pathstr; dirlist: string): pathstr;
var temp, value : PChar;
    i           : Longint;
begin
  { allow slash as backslash }
  for i:=1 to length(path) do
   if path[i]='/' then
    path[i]:='\';
  StringToPchar(path); 
  StringToPchar(dirlist);
  SearchPath(@dirlist, @path, nil, 255, value, temp);
  fsearch := strpas(value);
end;

{ </immobilizer> }

procedure getftime(var f;var time : longint);
var
   ft : TFileTime;
begin
  if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
     WinToDosTime(ft,time) then
    exit
  else
    time:=0;
end;


procedure setftime(var f;time : longint);
var
  ft : TFileTime;
begin
  if DosToWinTime(time,ft) then
   SetFileTime(filerec(f).Handle,nil,nil,@ft);
end;


procedure getfattr(var f;var attr : word);
var
   l : longint;
begin
  doserror:=0;
  l:=GetFileAttributes(filerec(f).name);
  if l=$ffffffff then
   doserror:=getlasterror;
  attr:=l;
end;


procedure setfattr(var f;attr : word);
begin
  doserror:=0;
  if not(SetFileAttributes(filerec(f).name,attr)) then
    doserror:=getlasterror;
end;


{******************************************************************************
                             --- Environment ---
******************************************************************************}

{
  The environment is a block of zero terminated strings
  terminated by a #0
}

   function GetEnvironmentStrings : pchar;
     external 'kernel32' name 'GetEnvironmentStringsA';
   function FreeEnvironmentStrings(p : pchar) : longbool;
     external 'kernel32' name 'FreeEnvironmentStringsA';

function envcount : longint;
var
   hp,p : pchar;
   count : longint;
begin
   p:=GetEnvironmentStrings;
   hp:=p;
   count:=0;
   while  hp^<>#0 do
     begin
        { next string entry}
        hp:=hp+strlen(hp)+1;
        inc(count);
     end;
   FreeEnvironmentStrings(p);
   envcount:=count;
end;


Function  EnvStr(index: integer): string;
var
   hp,p : pchar;
   count,i : longint;
begin
   { envcount takes some time in win32 }
   count:=envcount;

   { range checking }
   if (index<=0) or (index>count) then
     begin
        envstr:='';
        exit;
     end;
   p:=GetEnvironmentStrings;
   hp:=p;

   { retrive the string with the given index }
   for i:=2 to index do
     hp:=hp+strlen(hp)+1;

   envstr:=strpas(hp);
   FreeEnvironmentStrings(p);
end;


Function  GetEnv(envvar: string): string;
var
   s : string;
   i : longint;
   hp,p : pchar;
begin
   getenv:='';
   p:=GetEnvironmentStrings;
   hp:=p;
   while hp^<>#0 do
     begin
        s:=strpas(hp);
        i:=pos('=',s);
        if upcase(copy(s,1,i-1))=upcase(envvar) then
          begin
             getenv:=copy(s,i+1,length(s)-i);
             break;
          end;
        { next string entry}
        hp:=hp+strlen(hp)+1;
     end;
   FreeEnvironmentStrings(p);
end;


{******************************************************************************
                             --- Not Supported ---
******************************************************************************}

Procedure keep(exitcode : word);
Begin
End;

Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;

Procedure setintvec(intno : byte;vector : pointer);
Begin
End;


end.
{
  $Log$
  Revision 1.28  2000-01-07 16:41:52  daniel
    * copyright 2000

  Revision 1.27  2000/01/07 16:32:34  daniel
    * copyright 2000 added

  Revision 1.26  1999/11/18 15:28:47  michael
  * Better and faster Fexpand, SearchPath fromPiotr Sawicki

  Revision 1.25  1999/10/14 08:57:51  peter
    * getfattr resets doserror

  Revision 1.24  1999/10/12 08:56:48  pierre
   * fix form bug660

  Revision 1.23  1999/09/22 12:34:05  pierre
   ExecInheritsHandles  reset to false by default

  Revision 1.22  1999/09/21 13:24:32  pierre
   * typo error

  Revision 1.21  1999/09/21 12:37:09  pierre
   * Child inherits now file handles from parent in Exec by default

  Revision 1.20  1999/09/21 11:34:40  pierre
   + ExecInheritedHandles boolean

  Revision 1.19  1999/08/25 13:57:55  michael
  + Patched FSearch from Frank McCormick

  Revision 1.18  1999/08/12 09:24:14  michael
  Fixed win32finddata size; searchrec.excludeattr was overwritten.

  Revision 1.17  1999/05/16 17:08:59  peter
    * fixed driveletter checking

  Revision 1.16  1999/05/08 19:47:27  peter
    * check ioresult after getdir calls

  Revision 1.15  1999/04/28 11:42:52  peter
    + FileNameCaseSensetive boolean

  Revision 1.14  1999/04/08 12:23:07  peter
    * removed os.inc

  Revision 1.13  1998/11/16 15:48:53  peter
    * fixed longbool returns for api calls

  Revision 1.12  1998/10/27 10:55:55  michael
  * environment vars are case insensitive under WinNT/DOS

  Revision 1.11  1998/10/22 15:32:38  pierre
   * fsplit adapted to long filenames

  Revision 1.10  1998/10/16 14:20:06  peter
    * removed writelns

  Revision 1.9  1998/10/16 08:55:26  peter
    * findfirst is now more delphi alike

  Revision 1.8  1998/08/16 09:12:11  michael
  Corrected fexpand behaviour.

  Revision 1.7  1998/06/10 10:39:13  peter
    * working w32 rtl

  Revision 1.6  1998/06/08 23:07:45  peter
    * dos interface is now 100% compatible
    * fixed call PASCALMAIN which must be direct asm

  Revision 1.5  1998/05/06 12:36:50  michael
  + Removed log from before restored version.

  Revision 1.4  1998/04/27 14:01:38  florian
    * was uncompilable

  Revision 1.3  1998/04/26 22:37:02  florian
    + getftime, unpacktime, packtime

  Revision 1.2  1998/04/26 21:49:09  florian
    + first compiling and working version
}