development/compilers/freepascal/rtl/win32/dos.pp

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by the Free Pascal development team.
   5
   6     Dos unit for BP7 compatible RTL
   7
   8     See the file COPYING.FPC, included in this distribution,
   9     for details about the copyright.
  10
  11     This program is distributed in the hope that it will be useful,
  12     but WITHOUT ANY WARRANTY; without even the implied warranty of
  13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  14
  15  **********************************************************************}
  16 unit dos;
  17 interface
  18
  19 { Include Win32 Consts,Types }
  20 {$I win32.inc}
  21
  22 Const
  23   Max_Path = 260;
  24
  25   {Bitmasks for CPU Flags}
  26   fcarry     = $0001;
  27   fparity    = $0004;
  28   fauxiliary = $0010;
  29   fzero      = $0040;
  30   fsign      = $0080;
  31   foverflow  = $0800;
  32
  33   {Bitmasks for file attribute}
  34   readonly  = $01;
  35   hidden    = $02;
  36   sysfile   = $04;
  37   volumeid  = $08;
  38   directory = $10;
  39   archive   = $20;
  40   anyfile   = $3F;
  41
  42   {File Status}
  43   fmclosed = $D7B0;
  44   fminput  = $D7B1;
  45   fmoutput = $D7B2;
  46   fminout  = $D7B3;
  47
  48
  49 Type
  50 { Needed for Win95 LFN Support }
  51   ComStr  = String[255];
  52   PathStr = String[255];
  53   DirStr  = String[255];
  54   NameStr = String[255];
  55   ExtStr  = String[255];
  56
  57 {
  58   filerec.inc contains the definition of the filerec.
  59   textrec.inc contains the definition of the textrec.
  60   It is in a separate file to make it available in other units without
  61   having to use the DOS unit for it.
  62 }
  63 {$i filerec.inc}
  64 {$i textrec.inc}
  65
  66   DateTime = packed record
  67     Year,
  68     Month,
  69     Day,
  70     Hour,
  71     Min,
  72     Sec   : word;
  73   End;
  74
  75   PWin32FindData = ^TWin32FindData;
  76   TWin32FindData = record
  77     dwFileAttributes: Cardinal;
  78     ftCreationTime: TFileTime;
  79     ftLastAccessTime: TFileTime;
  80     ftLastWriteTime: TFileTime;
  81     nFileSizeHigh: Cardinal;
  82     nFileSizeLow: Cardinal;
  83     dwReserved0: Cardinal;
  84     dwReserved1: Cardinal;
  85     cFileName: array[0..MAX_PATH - 1] of Char;
  86     cAlternateFileName: array[0..13] of Char;
  87     // The structure should be 320 bytes long...
  88     pad : system.integer;
  89   end;
  90
  91   Searchrec = Packed Record
  92     FindHandle  : THandle;
  93     W32FindData : TWin32FindData;
  94     ExcludeAttr : longint;
  95     time : longint;
  96     size : longint;
  97     attr : longint;
  98     name : string;
  99   end;
 100
 101
 102   registers = packed record
 103     case i : integer of
 104      0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
 105      1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
 106      2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
 107     end;
 108
 109 Var
 110   DosError : integer;
 111
 112 {Interrupt}
 113 Procedure Intr(intno: byte; var regs: registers);
 114 Procedure MSDos(var regs: registers);
 115
 116 {Info/Date/Time}
 117 Function  DosVersion: Word;
 118 Procedure GetDate(var year, month, mday, wday: word);
 119 Procedure GetTime(var hour, minute, second, sec100: word);
 120 procedure SetDate(year,month,day: word);
 121 Procedure SetTime(hour,minute,second,sec100: word);
 122 Procedure UnpackTime(p: longint; var t: datetime);
 123 Procedure PackTime(var t: datetime; var p: longint);
 124
 125 {Exec}
 126 Procedure Exec(const path: pathstr; const comline: comstr);
 127 Function  DosExitCode: word;
 128
 129 {Disk}
 130 Function  DiskFree(drive: byte) : int64;
 131 Function  DiskSize(drive: byte) : int64;
 132 Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
 133 Procedure FindNext(var f: searchRec);
 134 Procedure FindClose(Var f: SearchRec);
 135
 136 {File}
 137 Procedure GetFAttr(var f; var attr: word);
 138 Procedure GetFTime(var f; var time: longint);
 139 Function  FSearch(path: pathstr; dirlist: string): pathstr;
 140 Function  FExpand(const path: pathstr): pathstr;
 141 Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
 142 function  GetShortName(var p : String) : boolean;
 143 function  GetLongName(var p : String) : boolean;
 144
 145 {Environment}
 146 Function  EnvCount: longint;
 147 Function  EnvStr(index: integer): string;
 148 Function  GetEnv(envvar: string): string;
 149
 150 {Misc}
 151 Procedure SetFAttr(var f; attr: word);
 152 Procedure SetFTime(var f; time: longint);
 153 Procedure GetCBreak(var breakvalue: boolean);
 154 Procedure SetCBreak(breakvalue: boolean);
 155 Procedure GetVerify(var verify: boolean);
 156 Procedure SetVerify(verify: boolean);
 157
 158 {Do Nothing Functions}
 159 Procedure SwapVectors;
 160 Procedure GetIntVec(intno: byte; var vector: pointer);
 161 Procedure SetIntVec(intno: byte; vector: pointer);
 162 Procedure Keep(exitcode: word);
 163
 164 Const
 165   { allow EXEC to inherited handles from calling process,
 166     needed for FPREDIR in ide/text
 167     now set to true by default because
 168     other OS also pass open handles to childs
 169     finally reset to false after Florian's response PM }
 170   ExecInheritsHandles : BOOL = false;
 171
 172 implementation
 173 uses strings;
 174 type
 175    OSVERSIONINFO = record
 176         dwOSVersionInfoSize : DWORD;
 177         dwMajorVersion : DWORD;
 178         dwMinorVersion : DWORD;
 179         dwBuildNumber : DWORD;
 180         dwPlatformId : DWORD;
 181         szCSDVersion : array[0..127] of char;
 182      end;
 183
 184    LPOSVERSIONINFO = ^OSVERSIONINFO;
 185
 186 var
 187    versioninfo : OSVERSIONINFO;
 188    kernel32dll : THandle;
 189
 190 {******************************************************************************
 191                            --- Conversion ---
 192 ******************************************************************************}
 193
 194    function GetLastError : DWORD;
 195      external 'kernel32' name 'GetLastError';
 196    function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : longbool;
 197      external 'kernel32' name 'FileTimeToDosDateTime';
 198    function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : longbool;
 199      external 'kernel32' name 'DosDateTimeToFileTime';
 200    function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : longbool;
 201      external 'kernel32' name 'FileTimeToLocalFileTime';
 202    function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : longbool;
 203      external 'kernel32' name 'LocalFileTimeToFileTime';
 204
 205 type
 206   Longrec=packed record
 207     lo,hi : word;
 208   end;
 209
 210 function Last2DosError(d:dword):integer;
 211 begin
 212   Last2DosError:=d;
 213 end;
 214
 215
 216 Function DosToWinAttr (Const Attr : Longint) : longint;
 217 begin
 218   DosToWinAttr:=Attr;
 219 end;
 220
 221
 222 Function WinToDosAttr (Const Attr : Longint) : longint;
 223 begin
 224   WinToDosAttr:=Attr;
 225 end;
 226
 227
 228 Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
 229 var
 230   lft : TFileTime;
 231 begin
 232   DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
 233                 LocalFileTimeToFileTime(lft,Wtime);
 234 end;
 235
 236
 237 Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):longbool;
 238 var
 239   lft : TFileTime;
 240 begin
 241   WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
 242                 FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
 243 end;
 244
 245
 246 {******************************************************************************
 247                            --- Dos Interrupt ---
 248 ******************************************************************************}
 249
 250 procedure intr(intno : byte;var regs : registers);
 251 begin
 252   { !!!!!!!! }
 253 end;
 254
 255 procedure msdos(var regs : registers);
 256 begin
 257   { !!!!!!!! }
 258 end;
 259
 260
 261 {******************************************************************************
 262                         --- Info / Date / Time ---
 263 ******************************************************************************}
 264
 265    function GetVersion : longint;
 266      external 'kernel32' name 'GetVersion';
 267    procedure GetLocalTime(var t : TSystemTime);
 268      external 'kernel32' name 'GetLocalTime';
 269    function SetLocalTime(const t : TSystemTime) : longbool;
 270      external 'kernel32' name 'SetLocalTime';
 271
 272 function dosversion : word;
 273 begin
 274   dosversion:=GetVersion;
 275 end;
 276
 277
 278 procedure getdate(var year,month,mday,wday : word);
 279 var
 280   t : TSystemTime;
 281 begin
 282   GetLocalTime(t);
 283   year:=t.wYear;
 284   month:=t.wMonth;
 285   mday:=t.wDay;
 286   wday:=t.wDayOfWeek;
 287 end;
 288
 289
 290 procedure setdate(year,month,day : word);
 291 var
 292   t : TSystemTime;
 293 begin
 294   { we need the time set privilege   }
 295   { so this function crash currently }
 296   {!!!!!}
 297   GetLocalTime(t);
 298   t.wYear:=year;
 299   t.wMonth:=month;
 300   t.wDay:=day;
 301   { only a quite good solution, we can loose some ms }
 302   SetLocalTime(t);
 303 end;
 304
 305
 306 procedure gettime(var hour,minute,second,sec100 : word);
 307 var
 308   t : TSystemTime;
 309 begin
 310    GetLocalTime(t);
 311    hour:=t.wHour;
 312    minute:=t.wMinute;
 313    second:=t.wSecond;
 314    sec100:=t.wMilliSeconds div 10;
 315 end;
 316
 317
 318 procedure settime(hour,minute,second,sec100 : word);
 319 var
 320    t : TSystemTime;
 321 begin
 322    { we need the time set privilege   }
 323    { so this function crash currently }
 324    {!!!!!}
 325    GetLocalTime(t);
 326    t.wHour:=hour;
 327    t.wMinute:=minute;
 328    t.wSecond:=second;
 329    t.wMilliSeconds:=sec100*10;
 330    SetLocalTime(t);
 331 end;
 332
 333
 334 Procedure packtime(var t : datetime;var p : longint);
 335 Begin
 336   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);
 337 End;
 338
 339
 340 Procedure unpacktime(p : longint;var t : datetime);
 341 Begin
 342   with t do
 343    begin
 344      sec:=(p and 31) shl 1;
 345      min:=(p shr 5) and 63;
 346      hour:=(p shr 11) and 31;
 347      day:=(p shr 16) and 31;
 348      month:=(p shr 21) and 15;
 349      year:=(p shr 25)+1980;
 350    end;
 351 End;
 352
 353
 354 {******************************************************************************
 355                                --- Exec ---
 356 ******************************************************************************}
 357
 358    function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
 359                lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
 360                bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
 361                lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
 362                var lpProcessInformation: TProcessInformation): longbool;
 363      external 'kernel32' name 'CreateProcessA';
 364    function getExitCodeProcess(h:THandle;var code:longint):longbool;
 365      external 'kernel32' name 'GetExitCodeProcess';
 366    function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
 367      external 'kernel32' name 'WaitForSingleObject';
 368    function CloseHandle(h : THandle) : longint;
 369      external 'kernel32' name 'CloseHandle';
 370
 371 var
 372   lastdosexitcode : longint;
 373
 374 procedure exec(const path : pathstr;const comline : comstr);
 375 var
 376   SI: TStartupInfo;
 377   PI: TProcessInformation;
 378   Proc : THandle;
 379   l    : Longint;
 380   AppPath,
 381   AppParam : array[0..255] of char;
 382 begin
 383   FillChar(SI, SizeOf(SI), 0);
 384   SI.cb:=SizeOf(SI);
 385   SI.wShowWindow:=1;
 386   Move(Path[1],AppPath,length(Path));
 387   AppPath[Length(Path)]:=#0;
 388   AppParam[0]:='-';
 389   AppParam[1]:=' ';
 390   Move(ComLine[1],AppParam[2],length(Comline));
 391   AppParam[Length(ComLine)+2]:=#0;
 392   if not CreateProcess(PChar(@AppPath), PChar(@AppParam),
 393            Nil, Nil, ExecInheritsHandles,$20, Nil, Nil, SI, PI) then
 394    begin
 395      DosError:=Last2DosError(GetLastError);
 396      exit;
 397    end
 398   else
 399    DosError:=0;
 400   Proc:=PI.hProcess;
 401   CloseHandle(PI.hThread);
 402   if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
 403     GetExitCodeProcess(Proc,l)
 404   else
 405     l:=-1;
 406   CloseHandle(Proc);
 407   LastDosExitCode:=l;
 408 end;
 409
 410
 411 function dosexitcode : word;
 412 begin
 413   dosexitcode:=lastdosexitcode and $ffff;
 414 end;
 415
 416
 417 procedure getcbreak(var breakvalue : boolean);
 418 begin
 419 { !! No Win32 Function !! }
 420 end;
 421
 422
 423 procedure setcbreak(breakvalue : boolean);
 424 begin
 425 { !! No Win32 Function !! }
 426 end;
 427
 428
 429 procedure getverify(var verify : boolean);
 430 begin
 431 { !! No Win32 Function !! }
 432 end;
 433
 434
 435 procedure setverify(verify : boolean);
 436 begin
 437 { !! No Win32 Function !! }
 438 end;
 439
 440
 441 {******************************************************************************
 442                                --- Disk ---
 443 ******************************************************************************}
 444
 445    function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
 446                              freeclusters,totalclusters:longint):longbool;
 447      external 'kernel32' name 'GetDiskFreeSpaceA';
 448 type
 449    TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,
 450                              total,free):longbool;stdcall;
 451
 452 var
 453    GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
 454
 455 function diskfree(drive : byte) : int64;
 456 var
 457   disk : array[1..4] of char;
 458   secs,bytes,
 459   free,total : longint;
 460   qwtotal,qwfree,qwcaller : int64;
 461
 462
 463 begin
 464   if drive=0 then
 465    begin
 466      disk[1]:='\';
 467      disk[2]:=#0;
 468    end
 469   else
 470    begin
 471      disk[1]:=chr(drive+64);
 472      disk[2]:=':';
 473      disk[3]:='\';
 474      disk[4]:=#0;
 475    end;
 476   if assigned(GetDiskFreeSpaceEx) then
 477     begin
 478        if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
 479          diskfree:=qwfree
 480        else
 481          diskfree:=-1;
 482     end
 483   else
 484     begin
 485        if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
 486          diskfree:=int64(free)*secs*bytes
 487        else
 488          diskfree:=-1;
 489     end;
 490 end;
 491
 492
 493 function disksize(drive : byte) : int64;
 494 var
 495   disk : array[1..4] of char;
 496   secs,bytes,
 497   free,total : longint;
 498   qwtotal,qwfree,qwcaller : int64;
 499
 500 begin
 501   if drive=0 then
 502    begin
 503      disk[1]:='\';
 504      disk[2]:=#0;
 505    end
 506   else
 507    begin
 508      disk[1]:=chr(drive+64);
 509      disk[2]:=':';
 510      disk[3]:='\';
 511      disk[4]:=#0;
 512    end;
 513   if assigned(GetDiskFreeSpaceEx) then
 514     begin
 515        if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
 516          disksize:=qwtotal
 517        else
 518          disksize:=-1;
 519     end
 520   else
 521     begin
 522        if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
 523          disksize:=int64(total)*secs*bytes
 524        else
 525          disksize:=-1;
 526     end;
 527 end;
 528
 529
 530 {******************************************************************************
 531                          --- Findfirst FindNext ---
 532 ******************************************************************************}
 533
 534 { Needed kernel calls }
 535
 536    function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;
 537      external 'kernel32' name 'FindFirstFileA';
 538    function FindNextFile  (hFindFile: THandle; var lpFindFileData: TWIN32FindData): LongBool;
 539      external 'kernel32' name 'FindNextFileA';
 540    function FindCloseFile (hFindFile: THandle): LongBool;
 541      external 'kernel32' name 'FindClose';
 542
 543 Procedure StringToPchar (Var S : String);
 544 Var L : Longint;
 545 begin
 546   L:=ord(S[0]);
 547   Move (S[1],S[0],L);
 548   S[L]:=#0;
 549 end;
 550
 551 Procedure PCharToString (Var S : String);
 552 Var L : Longint;
 553 begin
 554   L:=strlen(pchar(@S[0]));
 555   Move (S[0],S[1],L);
 556   S[0]:=char(l);
 557 end;
 558
 559
 560 procedure FindMatch(var f:searchrec);
 561 begin
 562 { Find file with correct attribute }
 563   While (F.W32FindData.dwFileAttributes and F.ExcludeAttr)<>0 do
 564    begin
 565      if not FindNextFile (F.FindHandle,F.W32FindData) then
 566       begin
 567         DosError:=Last2DosError(GetLastError);
 568         exit;
 569       end;
 570    end;
 571 { Convert some attributes back }
 572   f.size:=F.W32FindData.NFileSizeLow;
 573   f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
 574   WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
 575   f.Name:=StrPas(@F.W32FindData.cFileName);
 576 end;
 577
 578
 579 procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
 580 begin
 581 { no error }
 582   doserror:=0;
 583   F.Name:=Path;
 584   F.Attr:=attr;
 585   F.ExcludeAttr:=(not Attr) and ($1e); {hidden,sys,dir,volume}
 586   StringToPchar(f.name);
 587 { FindFirstFile is a Win32 Call }
 588   F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
 589   If longint(F.FindHandle)=Invalid_Handle_value then
 590    begin
 591      DosError:=Last2DosError(GetLastError);
 592      exit;
 593    end;
 594 { Find file with correct attribute }
 595   FindMatch(f);
 596 end;
 597
 598
 599 procedure findnext(var f : searchRec);
 600 begin
 601 { no error }
 602   doserror:=0;
 603   if not FindNextFile (F.FindHandle,F.W32FindData) then
 604    begin
 605      DosError:=Last2DosError(GetLastError);
 606      exit;
 607    end;
 608 { Find file with correct attribute }
 609   FindMatch(f);
 610 end;
 611
 612
 613 procedure swapvectors;
 614 begin
 615 end;
 616
 617
 618 Procedure FindClose(Var f: SearchRec);
 619 begin
 620   DosError:=0;
 621   If longint(F.FindHandle)<>Invalid_Handle_value then
 622    begin
 623      if not FindCloseFile(F.FindHandle) then
 624       begin
 625         DosError:=Last2DosError(GetLastError);
 626         exit;
 627       end;
 628    end;
 629 end;
 630
 631
 632 {******************************************************************************
 633                                --- File ---
 634 ******************************************************************************}
 635
 636    function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
 637      external 'kernel32' name 'GetFileTime';
 638    function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
 639      external 'kernel32' name 'SetFileTime';
 640    function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : longbool;
 641      external 'kernel32' name 'SetFileAttributesA';
 642    function GetFileAttributes(lpFileName : pchar) : longint;
 643      external 'kernel32' name 'GetFileAttributesA';
 644
 645 procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
 646 var
 647    dotpos,p1,i : longint;
 648 begin
 649    { allow slash as backslash }
 650    for i:=1 to length(path) do
 651     if path[i]='/' then path[i]:='\';
 652    { get drive name }
 653    p1:=pos(':',path);
 654    if p1>0 then
 655      begin
 656         dir:=path[1]+':';
 657         delete(path,1,p1);
 658      end
 659    else
 660      dir:='';
 661    { split the path and the name, there are no more path informtions }
 662    { if path contains no backslashes                                 }
 663    while true do
 664      begin
 665         p1:=pos('\',path);
 666         if p1=0 then
 667           break;
 668         dir:=dir+copy(path,1,p1);
 669         delete(path,1,p1);
 670      end;
 671    { try to find out a extension }
 672    Ext:='';
 673    i:=Length(Path);
 674    DotPos:=256;
 675    While (i>0) Do
 676      Begin
 677         If (Path[i]='.') Then
 678           begin
 679              DotPos:=i;
 680              break;
 681           end;
 682         Dec(i);
 683      end;
 684    Ext:=Copy(Path,DotPos,255);
 685    Name:=Copy(Path,1,DotPos - 1);
 686 end;
 687
 688 { <immobilizer> }
 689
 690 function GetFullPathName(lpFileName: PChar; nBufferLength: Longint; lpBuffer: PChar; var lpFilePart : PChar):DWORD;
 691     external 'kernel32' name 'GetFullPathNameA';
 692
 693 function GetShortPathName(lpszLongPath:pchar; lpszShortPath:pchar; cchBuffer:DWORD):DWORD;
 694     external 'kernel32' name 'GetShortPathNameA';
 695
 696 function FExpand(const path : pathstr) : pathstr;
 697 var value      : Array[0..255] of char;
 698     tmp        : PChar;
 699     p          : string;
 700     i          : Longint;
 701 begin
 702   { if path is empty then return the current dir }
 703   if path<>'' then
 704    p:=path
 705   else
 706    p:='.';
 707   { allow slash as backslash }
 708   for i:=1 to length(p) do
 709    if p[i]='/' then
 710     p[i]:='\';
 711   StringToPchar(p);
 712   tmp:=nil;
 713   fillchar(value,sizeof(value),0);
 714   GetFullPathName(@p, 255, value, tmp);
 715   FExpand := strpas(value);
 716 end;
 717
 718   function SearchPath(lpPath : PChar; lpFileName : PChar; lpExtension : PChar; nBufferLength : Longint; lpBuffer : PChar;
 719     var lpFilePart : PChar) : Longint; external 'kernel32' name 'SearchPathA';
 720
 721 Function FSearch(path: pathstr; dirlist: string): pathstr;
 722 var temp        : PChar;
 723     value       : Array [0..255] of char;
 724     i           : Longint;
 725     dir,dir2    : dirstr;
 726     lastchar    : char;
 727     name        : namestr;
 728     ext         : extstr;
 729     s           : SearchRec;
 730     found       : boolean;
 731 begin
 732 { check if the file specified exists }
 733   findfirst(path,anyfile,s);
 734   found:=(doserror=0);
 735   findclose(s);
 736   if found then
 737    begin
 738      fsearch:=path;
 739      exit;
 740    end;
 741 { search the path }
 742   fsearch:='';
 743   for i:=1 to length(path) do
 744    if path[i]='/' then
 745     path[i]:='\';
 746   fsplit(path,dir,name,ext);
 747   for i:=1 to length(dirlist) do
 748    if dirlist[i]='/' then
 749     dirlist[i]:='\';
 750   { allow slash as backslash }
 751   StringToPchar(name);
 752   StringToPchar(ext);
 753
 754   StringToPchar(dir);
 755   if SearchPath(@dir, @name, @ext, 255, @value, temp)>0 then
 756     begin
 757       fsearch := strpas(value);
 758       exit;
 759     end;
 760   PCharToString(dir);
 761
 762   repeat
 763     i:=pos(';',dirlist);
 764     while i=1 do
 765       begin
 766         delete(dirlist,1,1);
 767         i:=pos(';',dirlist);
 768       end;
 769     if i=0 then
 770       begin
 771         dir2:=dirlist;
 772         dirlist:='';
 773       end
 774     else
 775       begin
 776         dir2:=Copy(dirlist,1,i-1);
 777         dirlist:=Copy(dirlist,i+1,255);
 778       end;
 779   { don't add anything if dir2 is empty string }
 780   if dir2<>'' then
 781     lastchar:=dir2[length(dir2)]
 782   else
 783     lastchar:='\';
 784   if (lastchar<>'\') and (lastchar<>':') then
 785     dir2:=dir2+'\'+dir
 786   else
 787     dir2:=dir2+dir;
 788   StringToPchar(dir2);
 789   if SearchPath(@dir2, @name, @ext, 255, @value, temp)>0 then
 790     begin
 791       fsearch := strpas(value);
 792       exit;
 793     end;
 794   until dirlist='';
 795
 796 end;
 797
 798 { </immobilizer> }
 799
 800 procedure getftime(var f;var time : longint);
 801 var
 802    ft : TFileTime;
 803 begin
 804   if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
 805      WinToDosTime(ft,time) then
 806    DosError:=0
 807   else
 808    begin
 809      DosError:=Last2DosError(GetLastError);
 810      time:=0;
 811    end;
 812 end;
 813
 814
 815 procedure setftime(var f;time : longint);
 816 var
 817   ft : TFileTime;
 818 begin
 819   if DosToWinTime(time,ft) and
 820      SetFileTime(filerec(f).Handle,nil,nil,@ft) then
 821    DosError:=0
 822   else
 823    DosError:=Last2DosError(GetLastError);
 824 end;
 825
 826
 827 procedure getfattr(var f;var attr : word);
 828 var
 829    l : longint;
 830 begin
 831   doserror:=0;
 832   l:=GetFileAttributes(filerec(f).name);
 833   if l=$ffffffff then
 834    begin
 835      DosError:=Last2DosError(GetLastError);
 836      attr:=0;
 837    end
 838   else
 839    attr:=l and $ffff;
 840 end;
 841
 842
 843 procedure setfattr(var f;attr : word);
 844 begin
 845   doserror:=0;
 846   if not(SetFileAttributes(filerec(f).name,attr)) then
 847    DosError:=Last2DosError(GetLastError);
 848 end;
 849
 850 { change to short filename if successful win32 call PM }
 851 function GetShortName(var p : String) : boolean;
 852 var
 853   buffer   : array[0..255] of char;
 854   ret : longint;
 855 begin
 856   {we can't mess with p, because we have to return it if call is
 857       unsuccesfully.}
 858
 859   if Length(p)>0 then                   {copy p to array of char}
 860    move(p[1],buffer[0],length(p));
 861   buffer[length(p)]:=chr(0);
 862
 863   {Should return value load loaddoserror?}
 864
 865   ret:=GetShortPathName(@buffer,@buffer,255);
 866   if ret=0 then
 867    begin
 868      DosError:=0;
 869      p:=strpas(buffer)
 870    end
 871   else
 872    DosError:=Last2DosError(GetLastError);
 873   GetShortName:=ret<>0;
 874 end;
 875
 876
 877 { change to long filename if successful DOS call PM }
 878 function GetLongName(var p : String) : boolean;
 879 var
 880   lfn,sfn   : array[0..255] of char;
 881   filename  : pchar;
 882   ret       : longint;
 883 begin
 884   {contrary to shortname, SDK does not mention input buffer can be equal
 885    to output.}
 886
 887   if Length(p)>0 then                   {copy p to array of char}
 888    move(p[1],sfn[0],length(p));
 889   sfn[length(p)]:=chr(0);
 890   fillchar(lfn,sizeof(lfn),#0);
 891   filename:=nil;
 892
 893   {Should return value load loaddoserror?}
 894
 895   ret:=GetFullPathName(@sfn,255,@lfn,filename);
 896   if ret=0 then
 897    begin
 898      DosError:=0;
 899      p:=strpas(lfn);              {lfn here returns full path, filename only fn}
 900    end
 901   else
 902    DosError:=Last2DosError(GetLastError);
 903   GetLongName:=ret<>0;
 904 end;
 905
 906 {******************************************************************************
 907                              --- Environment ---
 908 ******************************************************************************}
 909
 910 {
 911   The environment is a block of zero terminated strings
 912   terminated by a #0
 913 }
 914
 915    function GetEnvironmentStrings : pchar;
 916      external 'kernel32' name 'GetEnvironmentStringsA';
 917    function FreeEnvironmentStrings(p : pchar) : longbool;
 918      external 'kernel32' name 'FreeEnvironmentStringsA';
 919
 920 function envcount : longint;
 921 var
 922    hp,p : pchar;
 923    count : longint;
 924 begin
 925    p:=GetEnvironmentStrings;
 926    hp:=p;
 927    count:=0;
 928    while  hp^<>#0 do
 929      begin
 930         { next string entry}
 931         hp:=hp+strlen(hp)+1;
 932         inc(count);
 933      end;
 934    FreeEnvironmentStrings(p);
 935    envcount:=count;
 936 end;
 937
 938
 939 Function  EnvStr(index: integer): string;
 940 var
 941    hp,p : pchar;
 942    count,i : longint;
 943 begin
 944    { envcount takes some time in win32 }
 945    count:=envcount;
 946
 947    { range checking }
 948    if (index<=0) or (index>count) then
 949      begin
 950         envstr:='';
 951         exit;
 952      end;
 953    p:=GetEnvironmentStrings;
 954    hp:=p;
 955
 956    { retrive the string with the given index }
 957    for i:=2 to index do
 958      hp:=hp+strlen(hp)+1;
 959
 960    envstr:=strpas(hp);
 961    FreeEnvironmentStrings(p);
 962 end;
 963
 964
 965 Function  GetEnv(envvar: string): string;
 966 var
 967    s : string;
 968    i : longint;
 969    hp,p : pchar;
 970 begin
 971    getenv:='';
 972    p:=GetEnvironmentStrings;
 973    hp:=p;
 974    while hp^<>#0 do
 975      begin
 976         s:=strpas(hp);
 977         i:=pos('=',s);
 978         if upcase(copy(s,1,i-1))=upcase(envvar) then
 979           begin
 980              getenv:=copy(s,i+1,length(s)-i);
 981              break;
 982           end;
 983         { next string entry}
 984         hp:=hp+strlen(hp)+1;
 985      end;
 986    FreeEnvironmentStrings(p);
 987 end;
 988
 989
 990 {******************************************************************************
 991                              --- Not Supported ---
 992 ******************************************************************************}
 993
 994 Procedure keep(exitcode : word);
 995 Begin
 996 End;
 997
 998 Procedure getintvec(intno : byte;var vector : pointer);
 999 Begin
1000 End;
1001
1002 Procedure setintvec(intno : byte;vector : pointer);
1003 Begin
1004 End;
1005
1006
1007 function FreeLibrary(hLibModule : THANDLE) : longbool;
1008   external 'kernel32' name 'FreeLibrary';
1009 function GetVersionEx(var VersionInformation:OSVERSIONINFO) : longbool;
1010   external 'kernel32' name 'GetVersionExA';
1011 function LoadLibrary(lpLibFileName : pchar):THandle;
1012   external 'kernel32' name 'LoadLibraryA';
1013 function GetProcAddress(hModule : THandle;lpProcName : pchar) : pointer;
1014   external 'kernel32' name 'GetProcAddress';
1015
1016
1017 initialization
1018   versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
1019   GetVersionEx(versioninfo);
1020   kernel32dll:=0;
1021   GetDiskFreeSpaceEx:=nil;
1022   if ((versioninfo.dwPlatformId=VER_PLATFORM_WIN32_WINDOWS) and
1023     (versioninfo.dwBuildNUmber>=1000)) or
1024     (versioninfo.dwPlatformId=VER_PLATFORM_WIN32_NT) then
1025     begin
1026        kernel32dll:=LoadLibrary('kernel32');
1027        if kernel32dll<>0 then
1028          GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
1029     end;
1030
1031 finalization
1032   if kernel32dll<>0 then
1033    FreeLibrary(kernel32dll);
1034
1035 end.
1036 {
1037   $Log$
1038   Revision 1.1  2002/02/19 08:26:23  sasu
1039   Initial revision
1040
1041   Revision 1.1.2.5  2000/09/06 20:46:19  peter
1042     * removed previous fsplit() patch as it's not the correct behaviour for
1043       LFNs. The code showing the bug could easily be adapted
1044
1045   Revision 1.1.2.4  2000/09/04 20:15:22  peter
1046     * fixed previous commit
1047
1048   Revision 1.1.2.3  2000/09/04 19:36:25  peter
1049     * fsplit with .. fix from Thomas
1050
1051   Revision 1.1.2.1  2000/08/02 19:30:07  peter
1052     * doserror setting fixes
1053
1054   Revision 1.1  2000/07/13 06:31:19  michael
1055   + Initial import
1056
1057   Revision 1.37  2000/05/26 12:03:13  marco
1058    * added getlongname and getshortname
1059
1060   Revision 1.36  2000/05/19 13:20:37  pierre
1061    * avoid some Range Check errors
1062
1063   Revision 1.35  2000/04/17 20:43:27  pierre
1064    fix bug 902 for win32 and linux
1065
1066   Revision 1.34  2000/02/26 13:24:26  peter
1067     * fixed fexpand with empty argument to return current dir
1068
1069   Revision 1.33  2000/02/09 16:59:34  peter
1070     * truncated log
1071
1072   Revision 1.32  2000/02/02 17:32:59  pierre
1073    * use int64 typecast in diskfree and disksize
1074
1075   Revision 1.31  2000/01/24 21:57:56  florian
1076     * disksize/diskfree return now a int64
1077
1078   Revision 1.30  2000/01/11 13:45:19  pierre
1079    * fsearch was still worng for multiple pathes
1080
1081   Revision 1.29  2000/01/11 12:49:26  pierre
1082    * fsearch bugs and fexpand memory leak fixed
1083
1084   Revision 1.28  2000/01/07 16:41:52  daniel
1085     * copyright 2000
1086
1087   Revision 1.27  2000/01/07 16:32:34  daniel
1088     * copyright 2000 added
1089
1090   Revision 1.26  1999/11/18 15:28:47  michael
1091   * Better and faster Fexpand, SearchPath fromPiotr Sawicki
1092
1093   Revision 1.25  1999/10/14 08:57:51  peter
1094     * getfattr resets doserror
1095
1096   Revision 1.24  1999/10/12 08:56:48  pierre
1097    * fix form bug660
1098
1099   Revision 1.23  1999/09/22 12:34:05  pierre
1100    ExecInheritsHandles  reset to false by default
1101
1102   Revision 1.22  1999/09/21 13:24:32  pierre
1103    * typo error
1104
1105   Revision 1.21  1999/09/21 12:37:09  pierre
1106    * Child inherits now file handles from parent in Exec by default
1107
1108   Revision 1.20  1999/09/21 11:34:40  pierre
1109    + ExecInheritedHandles boolean
1110
1111   Revision 1.19  1999/08/25 13:57:55  michael
1112   + Patched FSearch from Frank McCormick
1113
1114   Revision 1.18  1999/08/12 09:24:14  michael
1115   Fixed win32finddata size; searchrec.excludeattr was overwritten.
1116
1117 }