dos.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2004 by the Free Pascal development team.
  5. Dos unit for BP7 compatible RTL
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. unit dos;
  13. interface
  14. Const
  15. Max_Path = 260;
  16. Type
  17. TWin32Handle = longint;
  18. PWin32FileTime = ^TWin32FileTime;
  19. TWin32FileTime = record
  20. dwLowDateTime,
  21. dwHighDateTime : DWORD;
  22. end;
  23. PWin32FindData = ^TWin32FindData;
  24. TWin32FindData = record
  25. dwFileAttributes: Cardinal;
  26. ftCreationTime: TWin32FileTime;
  27. ftLastAccessTime: TWin32FileTime;
  28. ftLastWriteTime: TWin32FileTime;
  29. nFileSizeHigh: Cardinal;
  30. nFileSizeLow: Cardinal;
  31. dwReserved0: Cardinal;
  32. dwReserved1: Cardinal;
  33. cFileName: array[0..MAX_PATH - 1] of Char;
  34. cAlternateFileName: array[0..13] of Char;
  35. // The structure should be 320 bytes long...
  36. pad : system.integer;
  37. end;
  38. Searchrec = Packed Record
  39. FindHandle : TWin32Handle;
  40. W32FindData : TWin32FindData;
  41. ExcludeAttr : longint;
  42. time : longint;
  43. size : longint;
  44. attr : longint;
  45. name : string;
  46. end;
  47. {$i dosh.inc}
  48. Const
  49. { allow EXEC to inherited handles from calling process,
  50. needed for FPREDIR in ide/text
  51. now set to true by default because
  52. other OS also pass open handles to childs
  53. finally reset to false after Florian's response PM }
  54. ExecInheritsHandles : Longbool = false;
  55. implementation
  56. uses
  57. strings;
  58. {$DEFINE HAS_GETMSCOUNT}
  59. {$DEFINE HAS_GETSHORTNAME}
  60. {$DEFINE HAS_GETLONGNAME}
  61. {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
  62. {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
  63. {$I dos.inc}
  64. const
  65. INVALID_HANDLE_VALUE = longint($ffffffff);
  66. VER_PLATFORM_WIN32s = 0;
  67. VER_PLATFORM_WIN32_WINDOWS = 1;
  68. VER_PLATFORM_WIN32_NT = 2;
  69. type
  70. OSVERSIONINFO = record
  71. dwOSVersionInfoSize : DWORD;
  72. dwMajorVersion : DWORD;
  73. dwMinorVersion : DWORD;
  74. dwBuildNumber : DWORD;
  75. dwPlatformId : DWORD;
  76. szCSDVersion : array[0..127] of char;
  77. end;
  78. var
  79. versioninfo : OSVERSIONINFO;
  80. kernel32dll : TWin32Handle;
  81. {******************************************************************************
  82. --- Conversion ---
  83. ******************************************************************************}
  84. function GetLastError : DWORD;
  85. stdcall; external 'kernel32' name 'GetLastError';
  86. function FileTimeToDosDateTime(const ft :TWin32FileTime;var data,time : word) : longbool;
  87. stdcall; external 'kernel32' name 'FileTimeToDosDateTime';
  88. function DosDateTimeToFileTime(date,time : word;var ft :TWin32FileTime) : longbool;
  89. stdcall; external 'kernel32' name 'DosDateTimeToFileTime';
  90. function FileTimeToLocalFileTime(const ft : TWin32FileTime;var lft : TWin32FileTime) : longbool;
  91. stdcall; external 'kernel32' name 'FileTimeToLocalFileTime';
  92. function LocalFileTimeToFileTime(const lft : TWin32FileTime;var ft : TWin32FileTime) : longbool;
  93. stdcall; external 'kernel32' name 'LocalFileTimeToFileTime';
  94. function GetTickCount : longint;
  95. stdcall;external 'kernel32' name 'GetTickCount';
  96. function GetMsCount: int64;
  97. begin
  98. GetMsCount := cardinal (GetTickCount);
  99. end;
  100. type
  101. Longrec=packed record
  102. lo,hi : word;
  103. end;
  104. function Last2DosError(d:dword):integer;
  105. begin
  106. case d of
  107. 87 : { Parameter invalid -> Data invalid }
  108. Last2DosError:=13;
  109. else
  110. Last2DosError:=d;
  111. end;
  112. end;
  113. Function DosToWinAttr (Const Attr : Longint) : longint;
  114. begin
  115. DosToWinAttr:=Attr;
  116. end;
  117. Function WinToDosAttr (Const Attr : Longint) : longint;
  118. begin
  119. WinToDosAttr:=Attr;
  120. end;
  121. Function DosToWinTime (DTime:longint;Var Wtime : TWin32FileTime):longbool;
  122. var
  123. lft : TWin32FileTime;
  124. begin
  125. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
  126. LocalFileTimeToFileTime(lft,Wtime);
  127. end;
  128. Function WinToDosTime (Const Wtime : TWin32FileTime;var DTime:longint):longbool;
  129. var
  130. lft : TWin32FileTime;
  131. begin
  132. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  133. FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
  134. end;
  135. {******************************************************************************
  136. --- Info / Date / Time ---
  137. ******************************************************************************}
  138. type
  139. TSystemTime = record
  140. wYear,
  141. wMonth,
  142. wDayOfWeek,
  143. wDay,
  144. wHour,
  145. wMinute,
  146. wSecond,
  147. wMilliseconds: Word;
  148. end;
  149. function GetVersion : longint;
  150. stdcall; external 'kernel32' name 'GetVersion';
  151. procedure GetLocalTime(var t : TSystemTime);
  152. stdcall; external 'kernel32' name 'GetLocalTime';
  153. function SetLocalTime(const t : TSystemTime) : longbool;
  154. stdcall; external 'kernel32' name 'SetLocalTime';
  155. function dosversion : word;
  156. begin
  157. dosversion:=GetVersion and $ffff;
  158. end;
  159. procedure getdate(var year,month,mday,wday : word);
  160. var
  161. t : TSystemTime;
  162. begin
  163. GetLocalTime(t);
  164. year:=t.wYear;
  165. month:=t.wMonth;
  166. mday:=t.wDay;
  167. wday:=t.wDayOfWeek;
  168. end;
  169. procedure setdate(year,month,day : word);
  170. var
  171. t : TSystemTime;
  172. begin
  173. { we need the time set privilege }
  174. { so this function crash currently }
  175. {!!!!!}
  176. GetLocalTime(t);
  177. t.wYear:=year;
  178. t.wMonth:=month;
  179. t.wDay:=day;
  180. { only a quite good solution, we can loose some ms }
  181. SetLocalTime(t);
  182. end;
  183. procedure gettime(var hour,minute,second,sec100 : word);
  184. var
  185. t : TSystemTime;
  186. begin
  187. GetLocalTime(t);
  188. hour:=t.wHour;
  189. minute:=t.wMinute;
  190. second:=t.wSecond;
  191. sec100:=t.wMilliSeconds div 10;
  192. end;
  193. procedure settime(hour,minute,second,sec100 : word);
  194. var
  195. t : TSystemTime;
  196. begin
  197. { we need the time set privilege }
  198. { so this function crash currently }
  199. {!!!!!}
  200. GetLocalTime(t);
  201. t.wHour:=hour;
  202. t.wMinute:=minute;
  203. t.wSecond:=second;
  204. t.wMilliSeconds:=sec100*10;
  205. SetLocalTime(t);
  206. end;
  207. {******************************************************************************
  208. --- Exec ---
  209. ******************************************************************************}
  210. type
  211. PProcessInformation = ^TProcessInformation;
  212. TProcessInformation = record
  213. hProcess: TWin32Handle;
  214. hThread: TWin32Handle;
  215. dwProcessId: DWORD;
  216. dwThreadId: DWORD;
  217. end;
  218. function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
  219. lpProcessAttributes, lpThreadAttributes: Pointer;
  220. bInheritHandles: Longbool; dwCreationFlags: DWORD; lpEnvironment: Pointer;
  221. lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
  222. var lpProcessInformation: TProcessInformation): longbool;
  223. stdcall; external 'kernel32' name 'CreateProcessA';
  224. function getExitCodeProcess(h:TWin32Handle;var code:longint):longbool;
  225. stdcall; external 'kernel32' name 'GetExitCodeProcess';
  226. function WaitForSingleObject(hHandle: TWin32Handle; dwMilliseconds: DWORD): DWORD;
  227. stdcall; external 'kernel32' name 'WaitForSingleObject';
  228. function CloseHandle(h : TWin32Handle) : longint;
  229. stdcall; external 'kernel32' name 'CloseHandle';
  230. procedure exec(const path : pathstr;const comline : comstr);
  231. var
  232. SI: TStartupInfo;
  233. PI: TProcessInformation;
  234. Proc : TWin32Handle;
  235. l : Longint;
  236. CommandLine : array[0..511] of char;
  237. AppParam : array[0..255] of char;
  238. pathlocal : string;
  239. begin
  240. DosError := 0;
  241. FillChar(SI, SizeOf(SI), 0);
  242. SI.cb:=SizeOf(SI);
  243. SI.wShowWindow:=1;
  244. { always surroound the name of the application by quotes
  245. so that long filenames will always be accepted. But don't
  246. do it if there are already double quotes, since Win32 does not
  247. like double quotes which are duplicated!
  248. }
  249. if pos('"',path) = 0 then
  250. pathlocal:='"'+path+'"'
  251. else
  252. pathlocal := path;
  253. Move(Pathlocal[1],CommandLine,length(Pathlocal));
  254. AppParam[0]:=' ';
  255. AppParam[1]:=' ';
  256. Move(ComLine[1],AppParam[2],length(Comline));
  257. AppParam[Length(ComLine)+2]:=#0;
  258. { concatenate both pathnames }
  259. Move(Appparam[0],CommandLine[length(Pathlocal)],strlen(Appparam)+1);
  260. if not CreateProcess(nil, PChar(@CommandLine),
  261. Nil, Nil, ExecInheritsHandles,$20, Nil, Nil, SI, PI) then
  262. begin
  263. DosError:=Last2DosError(GetLastError);
  264. exit;
  265. end;
  266. Proc:=PI.hProcess;
  267. CloseHandle(PI.hThread);
  268. if WaitForSingleObject(Proc, dword($ffffffff)) <> $ffffffff then
  269. GetExitCodeProcess(Proc,l)
  270. else
  271. l:=-1;
  272. CloseHandle(Proc);
  273. LastDosExitCode:=l;
  274. end;
  275. {******************************************************************************
  276. --- Disk ---
  277. ******************************************************************************}
  278. function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
  279. freeclusters,totalclusters:longint):longbool;
  280. stdcall; external 'kernel32' name 'GetDiskFreeSpaceA';
  281. type
  282. TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,
  283. total,free):longbool;stdcall;
  284. var
  285. GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
  286. function diskfree(drive : byte) : int64;
  287. var
  288. disk : array[1..4] of char;
  289. secs,bytes,
  290. free,total : longint;
  291. qwtotal,qwfree,qwcaller : int64;
  292. begin
  293. if drive=0 then
  294. begin
  295. disk[1]:='\';
  296. disk[2]:=#0;
  297. end
  298. else
  299. begin
  300. disk[1]:=chr(drive+64);
  301. disk[2]:=':';
  302. disk[3]:='\';
  303. disk[4]:=#0;
  304. end;
  305. if assigned(GetDiskFreeSpaceEx) then
  306. begin
  307. if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
  308. diskfree:=qwfree
  309. else
  310. diskfree:=-1;
  311. end
  312. else
  313. begin
  314. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  315. diskfree:=int64(free)*secs*bytes
  316. else
  317. diskfree:=-1;
  318. end;
  319. end;
  320. function disksize(drive : byte) : int64;
  321. var
  322. disk : array[1..4] of char;
  323. secs,bytes,
  324. free,total : longint;
  325. qwtotal,qwfree,qwcaller : int64;
  326. begin
  327. if drive=0 then
  328. begin
  329. disk[1]:='\';
  330. disk[2]:=#0;
  331. end
  332. else
  333. begin
  334. disk[1]:=chr(drive+64);
  335. disk[2]:=':';
  336. disk[3]:='\';
  337. disk[4]:=#0;
  338. end;
  339. if assigned(GetDiskFreeSpaceEx) then
  340. begin
  341. if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
  342. disksize:=qwtotal
  343. else
  344. disksize:=-1;
  345. end
  346. else
  347. begin
  348. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  349. disksize:=int64(total)*secs*bytes
  350. else
  351. disksize:=-1;
  352. end;
  353. end;
  354. {******************************************************************************
  355. --- Findfirst FindNext ---
  356. ******************************************************************************}
  357. { Needed kernel calls }
  358. function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): TWin32Handle;
  359. stdcall; external 'kernel32' name 'FindFirstFileA';
  360. function FindNextFile (hFindFile: TWin32Handle; var lpFindFileData: TWIN32FindData): LongBool;
  361. stdcall; external 'kernel32' name 'FindNextFileA';
  362. function FindCloseFile (hFindFile: TWin32Handle): LongBool;
  363. stdcall; external 'kernel32' name 'FindClose';
  364. Procedure StringToPchar (Var S : String);
  365. Var L : Longint;
  366. begin
  367. L:=ord(S[0]);
  368. Move (S[1],S[0],L);
  369. S[L]:=#0;
  370. end;
  371. Procedure PCharToString (Var S : String);
  372. Var L : Longint;
  373. begin
  374. L:=strlen(pchar(@S[0]));
  375. Move (S[0],S[1],L);
  376. S[0]:=char(l);
  377. end;
  378. procedure FindMatch(var f:searchrec);
  379. begin
  380. { Find file with correct attribute }
  381. While (F.W32FindData.dwFileAttributes and cardinal(F.ExcludeAttr))<>0 do
  382. begin
  383. if not FindNextFile (F.FindHandle,F.W32FindData) then
  384. begin
  385. DosError:=Last2DosError(GetLastError);
  386. if DosError=2 then
  387. DosError:=18;
  388. exit;
  389. end;
  390. end;
  391. { Convert some attributes back }
  392. f.size:=F.W32FindData.NFileSizeLow;
  393. f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
  394. WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
  395. f.Name:=StrPas(@F.W32FindData.cFileName);
  396. end;
  397. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  398. begin
  399. fillchar(f,sizeof(f),0);
  400. { no error }
  401. doserror:=0;
  402. F.Name:=Path;
  403. F.Attr:=attr;
  404. F.ExcludeAttr:=(not Attr) and ($1e); {hidden,sys,dir,volume}
  405. StringToPchar(f.name);
  406. { FindFirstFile is a Win32 Call }
  407. F.W32FindData.dwFileAttributes:=DosToWinAttr(f.attr);
  408. F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
  409. If longint(F.FindHandle)=Invalid_Handle_value then
  410. begin
  411. DosError:=Last2DosError(GetLastError);
  412. if DosError=2 then
  413. DosError:=18;
  414. exit;
  415. end;
  416. { Find file with correct attribute }
  417. FindMatch(f);
  418. end;
  419. procedure findnext(var f : searchRec);
  420. begin
  421. { no error }
  422. doserror:=0;
  423. if not FindNextFile (F.FindHandle,F.W32FindData) then
  424. begin
  425. DosError:=Last2DosError(GetLastError);
  426. if DosError=2 then
  427. DosError:=18;
  428. exit;
  429. end;
  430. { Find file with correct attribute }
  431. FindMatch(f);
  432. end;
  433. Procedure FindClose(Var f: SearchRec);
  434. begin
  435. If longint(F.FindHandle)<>Invalid_Handle_value then
  436. FindCloseFile(F.FindHandle);
  437. end;
  438. {******************************************************************************
  439. --- File ---
  440. ******************************************************************************}
  441. function GeTWin32FileTime(h : longint;creation,lastaccess,lastwrite : PWin32FileTime) : longbool;
  442. stdcall; external 'kernel32' name 'GetFileTime';
  443. function SeTWin32FileTime(h : longint;creation,lastaccess,lastwrite : PWin32FileTime) : longbool;
  444. stdcall; external 'kernel32' name 'SetFileTime';
  445. function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : longbool;
  446. stdcall; external 'kernel32' name 'SetFileAttributesA';
  447. function GetFileAttributes(lpFileName : pchar) : longint;
  448. stdcall; external 'kernel32' name 'GetFileAttributesA';
  449. { <immobilizer> }
  450. function GetFullPathName(lpFileName: PChar; nBufferLength: Longint; lpBuffer: PChar; var lpFilePart : PChar):DWORD;
  451. stdcall; external 'kernel32' name 'GetFullPathNameA';
  452. function GetShortPathName(lpszLongPath:pchar; lpszShortPath:pchar; cchBuffer:DWORD):DWORD;
  453. stdcall; external 'kernel32' name 'GetShortPathNameA';
  454. Function FSearch(path: pathstr; dirlist: string): pathstr;
  455. var
  456. i,p1 : longint;
  457. s : searchrec;
  458. newdir : pathstr;
  459. begin
  460. { check if the file specified exists }
  461. findfirst(path,anyfile and not(directory),s);
  462. if doserror=0 then
  463. begin
  464. findclose(s);
  465. fsearch:=path;
  466. exit;
  467. end;
  468. { No wildcards allowed in these things }
  469. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  470. fsearch:=''
  471. else
  472. begin
  473. { allow slash as backslash }
  474. for i:=1 to length(dirlist) do
  475. if dirlist[i]='/' then dirlist[i]:='\';
  476. repeat
  477. p1:=pos(';',dirlist);
  478. if p1<>0 then
  479. begin
  480. newdir:=copy(dirlist,1,p1-1);
  481. delete(dirlist,1,p1);
  482. end
  483. else
  484. begin
  485. newdir:=dirlist;
  486. dirlist:='';
  487. end;
  488. if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
  489. newdir:=newdir+'\';
  490. findfirst(newdir+path,anyfile and not(directory),s);
  491. if doserror=0 then
  492. newdir:=newdir+path
  493. else
  494. newdir:='';
  495. until (dirlist='') or (newdir<>'');
  496. fsearch:=newdir;
  497. end;
  498. findclose(s);
  499. end;
  500. { </immobilizer> }
  501. procedure getftime(var f;var time : longint);
  502. var
  503. ft : TWin32FileTime;
  504. begin
  505. doserror:=0;
  506. if GeTWin32FileTime(filerec(f).Handle,nil,nil,@ft) and
  507. WinToDosTime(ft,time) then
  508. exit
  509. else
  510. begin
  511. DosError:=Last2DosError(GetLastError);
  512. time:=0;
  513. end;
  514. end;
  515. procedure setftime(var f;time : longint);
  516. var
  517. ft : TWin32FileTime;
  518. begin
  519. doserror:=0;
  520. if DosToWinTime(time,ft) and
  521. SeTWin32FileTime(filerec(f).Handle,nil,nil,@ft) then
  522. exit
  523. else
  524. DosError:=Last2DosError(GetLastError);
  525. end;
  526. procedure getfattr(var f;var attr : word);
  527. var
  528. l : longint;
  529. begin
  530. doserror:=0;
  531. l:=GetFileAttributes(filerec(f).name);
  532. if l=longint($ffffffff) then
  533. begin
  534. doserror:=getlasterror;
  535. attr:=0;
  536. end
  537. else
  538. attr:=l and $ffff;
  539. end;
  540. procedure setfattr(var f;attr : word);
  541. begin
  542. { Fail for setting VolumeId }
  543. if (attr and VolumeID)<>0 then
  544. doserror:=5
  545. else
  546. if SetFileAttributes(filerec(f).name,attr) then
  547. doserror:=0
  548. else
  549. doserror:=getlasterror;
  550. end;
  551. { change to short filename if successful win32 call PM }
  552. function GetShortName(var p : String) : boolean;
  553. var
  554. buffer : array[0..255] of char;
  555. ret : longint;
  556. begin
  557. {we can't mess with p, because we have to return it if call is
  558. unsuccesfully.}
  559. if Length(p)>0 then {copy p to array of char}
  560. move(p[1],buffer[0],length(p));
  561. buffer[length(p)]:=chr(0);
  562. {Should return value load loaddoserror?}
  563. ret:=GetShortPathName(@buffer,@buffer,255);
  564. if ret=0 then
  565. p:=strpas(buffer);
  566. GetShortName:=ret<>0;
  567. end;
  568. { change to long filename if successful DOS call PM }
  569. function GetLongName(var p : String) : boolean;
  570. var
  571. lfn,sfn : array[0..255] of char;
  572. filename : pchar;
  573. ret : longint;
  574. begin
  575. {contrary to shortname, SDK does not mention input buffer can be equal
  576. to output.}
  577. if Length(p)>0 then {copy p to array of char}
  578. move(p[1],sfn[0],length(p));
  579. sfn[length(p)]:=chr(0);
  580. fillchar(lfn,sizeof(lfn),#0);
  581. filename:=nil;
  582. {Should return value load loaddoserror?}
  583. ret:=GetFullPathName(@sfn,255,@lfn,filename);
  584. if ret=0 then
  585. p:=strpas(lfn); {lfn here returns full path, filename only fn}
  586. GetLongName:=ret<>0;
  587. end;
  588. {******************************************************************************
  589. --- Environment ---
  590. ******************************************************************************}
  591. {
  592. The environment is a block of zero terminated strings
  593. terminated by a #0
  594. }
  595. function GetEnvironmentStrings : pchar;
  596. stdcall; external 'kernel32' name 'GetEnvironmentStringsA';
  597. function FreeEnvironmentStrings(p : pchar) : longbool;
  598. stdcall; external 'kernel32' name 'FreeEnvironmentStringsA';
  599. function envcount : longint;
  600. var
  601. hp,p : pchar;
  602. count : longint;
  603. begin
  604. p:=GetEnvironmentStrings;
  605. hp:=p;
  606. count:=0;
  607. while hp^<>#0 do
  608. begin
  609. { next string entry}
  610. hp:=hp+strlen(hp)+1;
  611. inc(count);
  612. end;
  613. FreeEnvironmentStrings(p);
  614. envcount:=count;
  615. end;
  616. Function EnvStr (Index: longint): string;
  617. var
  618. hp,p : pchar;
  619. count,i : longint;
  620. begin
  621. { envcount takes some time in win32 }
  622. count:=envcount;
  623. { range checking }
  624. if (index<=0) or (index>count) then
  625. begin
  626. envstr:='';
  627. exit;
  628. end;
  629. p:=GetEnvironmentStrings;
  630. hp:=p;
  631. { retrive the string with the given index }
  632. for i:=2 to index do
  633. hp:=hp+strlen(hp)+1;
  634. envstr:=strpas(hp);
  635. FreeEnvironmentStrings(p);
  636. end;
  637. Function GetEnv(envvar: string): string;
  638. var
  639. s : string;
  640. i : longint;
  641. hp,p : pchar;
  642. begin
  643. getenv:='';
  644. p:=GetEnvironmentStrings;
  645. hp:=p;
  646. while hp^<>#0 do
  647. begin
  648. s:=strpas(hp);
  649. i:=pos('=',s);
  650. if upcase(copy(s,1,i-1))=upcase(envvar) then
  651. begin
  652. getenv:=copy(s,i+1,length(s)-i);
  653. break;
  654. end;
  655. { next string entry}
  656. hp:=hp+strlen(hp)+1;
  657. end;
  658. FreeEnvironmentStrings(p);
  659. end;
  660. function FreeLibrary(hLibModule : TWin32Handle) : longbool;
  661. stdcall; external 'kernel32' name 'FreeLibrary';
  662. function GetVersionEx(var VersionInformation:OSVERSIONINFO) : longbool;
  663. stdcall; external 'kernel32' name 'GetVersionExA';
  664. function LoadLibrary(lpLibFileName : pchar):TWin32Handle;
  665. stdcall; external 'kernel32' name 'LoadLibraryA';
  666. function GetProcAddress(hModule : TWin32Handle;lpProcName : pchar) : pointer;
  667. stdcall; external 'kernel32' name 'GetProcAddress';
  668. var
  669. oldexitproc : pointer;
  670. procedure dosexitproc;
  671. begin
  672. exitproc:=oldexitproc;
  673. if kernel32dll<>0 then
  674. FreeLibrary(kernel32dll);
  675. end;
  676. begin
  677. oldexitproc:=exitproc;
  678. exitproc:=@dosexitproc;
  679. versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
  680. GetVersionEx(versioninfo);
  681. kernel32dll:=0;
  682. GetDiskFreeSpaceEx:=nil;
  683. if ((versioninfo.dwPlatformId=VER_PLATFORM_WIN32_WINDOWS) and
  684. (versioninfo.dwBuildNUmber>=1000)) or
  685. (versioninfo.dwPlatformId=VER_PLATFORM_WIN32_NT) then
  686. begin
  687. kernel32dll:=LoadLibrary('kernel32');
  688. if kernel32dll<>0 then
  689. GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
  690. end;
  691. end.
  692. {
  693. $Log$
  694. Revision 1.29 2004-12-05 16:44:43 hajny
  695. * GetMsCount added, platform independent routines moved to single include file
  696. Revision 1.28 2004/04/07 09:26:23 michael
  697. + Patch for findfirst (bug 3042) from Peter Vreman
  698. Revision 1.27 2004/03/14 18:43:21 peter
  699. * reset searchrec info in findfirst
  700. Revision 1.26 2004/02/17 17:37:26 daniel
  701. * Enable threadvars again
  702. Revision 1.25 2004/02/16 22:18:44 hajny
  703. * LastDosExitCode changed back from threadvar temporarily
  704. Revision 1.24 2004/02/15 21:36:10 hajny
  705. * overloaded ExecuteProcess added, EnvStr param changed to longint
  706. Revision 1.23 2004/02/09 12:03:16 michael
  707. + Switched to single interface in dosh.inc
  708. Revision 1.22 2004/01/06 00:58:35 florian
  709. * fixed fsearch
  710. Revision 1.21 2003/10/27 15:27:47 peter
  711. * fixed setfattr with volumeid
  712. Revision 1.20 2003/09/17 15:06:36 peter
  713. * stdcall patch
  714. Revision 1.19 2003/06/10 11:16:15 jonas
  715. * fix from Peter
  716. Revision 1.18 2002/12/24 15:35:15 peter
  717. * error code fixes
  718. Revision 1.17 2002/12/15 20:23:53 peter
  719. * map error 87 to 13 to be compatible with dos
  720. Revision 1.16 2002/12/04 21:35:50 carl
  721. * bugfixes for dos.exec() : it would not be able to execute 16-bit apps
  722. * doserror was not reset to zero in dos.exec
  723. Revision 1.15 2002/12/03 20:39:14 carl
  724. * fix for dos.exec with non-microsoft shells
  725. Revision 1.14 2002/09/07 16:01:28 peter
  726. * old logs removed and tabs fixed
  727. Revision 1.13 2002/07/06 11:48:09 carl
  728. + fsearch bugfix for Win9X systems
  729. Revision 1.12 2002/05/16 19:32:57 carl
  730. * fix range check error
  731. }