dos.pp 26 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075
  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. 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. { Include Win32 Consts,Types }
  15. {$I win32.inc}
  16. Const
  17. Max_Path = 260;
  18. {Bitmasks for CPU Flags}
  19. fcarry = $0001;
  20. fparity = $0004;
  21. fauxiliary = $0010;
  22. fzero = $0040;
  23. fsign = $0080;
  24. foverflow = $0800;
  25. {Bitmasks for file attribute}
  26. readonly = $01;
  27. hidden = $02;
  28. sysfile = $04;
  29. volumeid = $08;
  30. directory = $10;
  31. archive = $20;
  32. anyfile = $3F;
  33. {File Status}
  34. fmclosed = $D7B0;
  35. fminput = $D7B1;
  36. fmoutput = $D7B2;
  37. fminout = $D7B3;
  38. Type
  39. { Needed for Win95 LFN Support }
  40. ComStr = String[255];
  41. PathStr = String[255];
  42. DirStr = String[255];
  43. NameStr = String[255];
  44. ExtStr = String[255];
  45. {
  46. filerec.inc contains the definition of the filerec.
  47. textrec.inc contains the definition of the textrec.
  48. It is in a separate file to make it available in other units without
  49. having to use the DOS unit for it.
  50. }
  51. {$i filerec.inc}
  52. {$i textrec.inc}
  53. DateTime = packed record
  54. Year,
  55. Month,
  56. Day,
  57. Hour,
  58. Min,
  59. Sec : word;
  60. End;
  61. PWin32FindData = ^TWin32FindData;
  62. TWin32FindData = record
  63. dwFileAttributes: Cardinal;
  64. ftCreationTime: TFileTime;
  65. ftLastAccessTime: TFileTime;
  66. ftLastWriteTime: TFileTime;
  67. nFileSizeHigh: Cardinal;
  68. nFileSizeLow: Cardinal;
  69. dwReserved0: Cardinal;
  70. dwReserved1: Cardinal;
  71. cFileName: array[0..MAX_PATH - 1] of Char;
  72. cAlternateFileName: array[0..13] of Char;
  73. // The structure should be 320 bytes long...
  74. pad : system.integer;
  75. end;
  76. Searchrec = Packed Record
  77. FindHandle : THandle;
  78. W32FindData : TWin32FindData;
  79. ExcludeAttr : longint;
  80. time : longint;
  81. size : longint;
  82. attr : longint;
  83. name : string;
  84. end;
  85. registers = packed record
  86. case i : integer of
  87. 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
  88. 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
  89. 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
  90. end;
  91. Var
  92. DosError : integer;
  93. {Interrupt}
  94. Procedure Intr(intno: byte; var regs: registers);
  95. Procedure MSDos(var regs: registers);
  96. {Info/Date/Time}
  97. Function DosVersion: Word;
  98. Procedure GetDate(var year, month, mday, wday: word);
  99. Procedure GetTime(var hour, minute, second, sec100: word);
  100. procedure SetDate(year,month,day: word);
  101. Procedure SetTime(hour,minute,second,sec100: word);
  102. Procedure UnpackTime(p: longint; var t: datetime);
  103. Procedure PackTime(var t: datetime; var p: longint);
  104. {Exec}
  105. Procedure Exec(const path: pathstr; const comline: comstr);
  106. Function DosExitCode: word;
  107. {Disk}
  108. Function DiskFree(drive: byte) : int64;
  109. Function DiskSize(drive: byte) : int64;
  110. Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
  111. Procedure FindNext(var f: searchRec);
  112. Procedure FindClose(Var f: SearchRec);
  113. {File}
  114. Procedure GetFAttr(var f; var attr: word);
  115. Procedure GetFTime(var f; var time: longint);
  116. Function FSearch(path: pathstr; dirlist: string): pathstr;
  117. Function FExpand(const path: pathstr): pathstr;
  118. Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
  119. function GetShortName(var p : String) : boolean;
  120. function GetLongName(var p : String) : boolean;
  121. {Environment}
  122. Function EnvCount: longint;
  123. Function EnvStr(index: integer): string;
  124. Function GetEnv(envvar: string): string;
  125. {Misc}
  126. Procedure SetFAttr(var f; attr: word);
  127. Procedure SetFTime(var f; time: longint);
  128. Procedure GetCBreak(var breakvalue: boolean);
  129. Procedure SetCBreak(breakvalue: boolean);
  130. Procedure GetVerify(var verify: boolean);
  131. Procedure SetVerify(verify: boolean);
  132. {Do Nothing Functions}
  133. Procedure SwapVectors;
  134. Procedure GetIntVec(intno: byte; var vector: pointer);
  135. Procedure SetIntVec(intno: byte; vector: pointer);
  136. Procedure Keep(exitcode: word);
  137. Const
  138. { allow EXEC to inherited handles from calling process,
  139. needed for FPREDIR in ide/text
  140. now set to true by default because
  141. other OS also pass open handles to childs
  142. finally reset to false after Florian's response PM }
  143. ExecInheritsHandles : BOOL = false;
  144. implementation
  145. uses strings;
  146. type
  147. OSVERSIONINFO = record
  148. dwOSVersionInfoSize : DWORD;
  149. dwMajorVersion : DWORD;
  150. dwMinorVersion : DWORD;
  151. dwBuildNumber : DWORD;
  152. dwPlatformId : DWORD;
  153. szCSDVersion : array[0..127] of char;
  154. end;
  155. LPOSVERSIONINFO = ^OSVERSIONINFO;
  156. var
  157. versioninfo : OSVERSIONINFO;
  158. kernel32dll : THandle;
  159. {******************************************************************************
  160. --- Conversion ---
  161. ******************************************************************************}
  162. function GetLastError : DWORD;
  163. external 'kernel32' name 'GetLastError';
  164. function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : longbool;
  165. external 'kernel32' name 'FileTimeToDosDateTime';
  166. function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : longbool;
  167. external 'kernel32' name 'DosDateTimeToFileTime';
  168. function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : longbool;
  169. external 'kernel32' name 'FileTimeToLocalFileTime';
  170. function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : longbool;
  171. external 'kernel32' name 'LocalFileTimeToFileTime';
  172. type
  173. Longrec=packed record
  174. lo,hi : word;
  175. end;
  176. function Last2DosError(d:dword):integer;
  177. begin
  178. case d of
  179. 87 : { Parameter invalid -> Data invalid }
  180. Last2DosError:=13;
  181. else
  182. Last2DosError:=d;
  183. end;
  184. end;
  185. Function DosToWinAttr (Const Attr : Longint) : longint;
  186. begin
  187. DosToWinAttr:=Attr;
  188. end;
  189. Function WinToDosAttr (Const Attr : Longint) : longint;
  190. begin
  191. WinToDosAttr:=Attr;
  192. end;
  193. Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
  194. var
  195. lft : TFileTime;
  196. begin
  197. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
  198. LocalFileTimeToFileTime(lft,Wtime);
  199. end;
  200. Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):longbool;
  201. var
  202. lft : TFileTime;
  203. begin
  204. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  205. FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
  206. end;
  207. {******************************************************************************
  208. --- Dos Interrupt ---
  209. ******************************************************************************}
  210. procedure intr(intno : byte;var regs : registers);
  211. begin
  212. { !!!!!!!! }
  213. end;
  214. procedure msdos(var regs : registers);
  215. begin
  216. { !!!!!!!! }
  217. end;
  218. {******************************************************************************
  219. --- Info / Date / Time ---
  220. ******************************************************************************}
  221. function GetVersion : longint;
  222. external 'kernel32' name 'GetVersion';
  223. procedure GetLocalTime(var t : TSystemTime);
  224. external 'kernel32' name 'GetLocalTime';
  225. function SetLocalTime(const t : TSystemTime) : longbool;
  226. external 'kernel32' name 'SetLocalTime';
  227. function dosversion : word;
  228. begin
  229. dosversion:=GetVersion and $ffff;
  230. end;
  231. procedure getdate(var year,month,mday,wday : word);
  232. var
  233. t : TSystemTime;
  234. begin
  235. GetLocalTime(t);
  236. year:=t.wYear;
  237. month:=t.wMonth;
  238. mday:=t.wDay;
  239. wday:=t.wDayOfWeek;
  240. end;
  241. procedure setdate(year,month,day : word);
  242. var
  243. t : TSystemTime;
  244. begin
  245. { we need the time set privilege }
  246. { so this function crash currently }
  247. {!!!!!}
  248. GetLocalTime(t);
  249. t.wYear:=year;
  250. t.wMonth:=month;
  251. t.wDay:=day;
  252. { only a quite good solution, we can loose some ms }
  253. SetLocalTime(t);
  254. end;
  255. procedure gettime(var hour,minute,second,sec100 : word);
  256. var
  257. t : TSystemTime;
  258. begin
  259. GetLocalTime(t);
  260. hour:=t.wHour;
  261. minute:=t.wMinute;
  262. second:=t.wSecond;
  263. sec100:=t.wMilliSeconds div 10;
  264. end;
  265. procedure settime(hour,minute,second,sec100 : word);
  266. var
  267. t : TSystemTime;
  268. begin
  269. { we need the time set privilege }
  270. { so this function crash currently }
  271. {!!!!!}
  272. GetLocalTime(t);
  273. t.wHour:=hour;
  274. t.wMinute:=minute;
  275. t.wSecond:=second;
  276. t.wMilliSeconds:=sec100*10;
  277. SetLocalTime(t);
  278. end;
  279. Procedure packtime(var t : datetime;var p : longint);
  280. Begin
  281. 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);
  282. End;
  283. Procedure unpacktime(p : longint;var t : datetime);
  284. Begin
  285. with t do
  286. begin
  287. sec:=(p and 31) shl 1;
  288. min:=(p shr 5) and 63;
  289. hour:=(p shr 11) and 31;
  290. day:=(p shr 16) and 31;
  291. month:=(p shr 21) and 15;
  292. year:=(p shr 25)+1980;
  293. end;
  294. End;
  295. {******************************************************************************
  296. --- Exec ---
  297. ******************************************************************************}
  298. function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
  299. lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
  300. bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
  301. lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
  302. var lpProcessInformation: TProcessInformation): longbool;
  303. external 'kernel32' name 'CreateProcessA';
  304. function getExitCodeProcess(h:THandle;var code:longint):longbool;
  305. external 'kernel32' name 'GetExitCodeProcess';
  306. function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
  307. external 'kernel32' name 'WaitForSingleObject';
  308. function CloseHandle(h : THandle) : longint;
  309. external 'kernel32' name 'CloseHandle';
  310. var
  311. lastdosexitcode : longint;
  312. procedure exec(const path : pathstr;const comline : comstr);
  313. var
  314. SI: TStartupInfo;
  315. PI: TProcessInformation;
  316. Proc : THandle;
  317. l : Longint;
  318. CommandLine : array[0..511] of char;
  319. AppParam : array[0..255] of char;
  320. pathlocal : string;
  321. begin
  322. DosError := 0;
  323. FillChar(SI, SizeOf(SI), 0);
  324. SI.cb:=SizeOf(SI);
  325. SI.wShowWindow:=1;
  326. { always surroound the name of the application by quotes
  327. so that long filenames will always be accepted. But don't
  328. do it if there are already double quotes, since Win32 does not
  329. like double quotes which are duplicated!
  330. }
  331. if pos('"',path) = 0 then
  332. pathlocal:='"'+path+'"'
  333. else
  334. pathlocal := path;
  335. Move(Pathlocal[1],CommandLine,length(Pathlocal));
  336. AppParam[0]:=' ';
  337. AppParam[1]:=' ';
  338. Move(ComLine[1],AppParam[2],length(Comline));
  339. AppParam[Length(ComLine)+2]:=#0;
  340. { concatenate both pathnames }
  341. Move(Appparam[0],CommandLine[length(Pathlocal)],strlen(Appparam)+1);
  342. if not CreateProcess(nil, PChar(@CommandLine),
  343. Nil, Nil, ExecInheritsHandles,$20, Nil, Nil, SI, PI) then
  344. begin
  345. DosError:=Last2DosError(GetLastError);
  346. exit;
  347. end;
  348. Proc:=PI.hProcess;
  349. CloseHandle(PI.hThread);
  350. if WaitForSingleObject(Proc, dword(Infinite)) <> $ffffffff then
  351. GetExitCodeProcess(Proc,l)
  352. else
  353. l:=-1;
  354. CloseHandle(Proc);
  355. LastDosExitCode:=l;
  356. end;
  357. function dosexitcode : word;
  358. begin
  359. dosexitcode:=lastdosexitcode and $ffff;
  360. end;
  361. procedure getcbreak(var breakvalue : boolean);
  362. begin
  363. { !! No Win32 Function !! }
  364. breakvalue := true;
  365. end;
  366. procedure setcbreak(breakvalue : boolean);
  367. begin
  368. { !! No Win32 Function !! }
  369. end;
  370. procedure getverify(var verify : boolean);
  371. begin
  372. { !! No Win32 Function !! }
  373. verify := true;
  374. end;
  375. procedure setverify(verify : boolean);
  376. begin
  377. { !! No Win32 Function !! }
  378. end;
  379. {******************************************************************************
  380. --- Disk ---
  381. ******************************************************************************}
  382. function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
  383. freeclusters,totalclusters:longint):longbool;
  384. external 'kernel32' name 'GetDiskFreeSpaceA';
  385. type
  386. TGetDiskFreeSpaceEx = function(drive:pchar;var availableforcaller,
  387. total,free):longbool;stdcall;
  388. var
  389. GetDiskFreeSpaceEx : TGetDiskFreeSpaceEx;
  390. function diskfree(drive : byte) : int64;
  391. var
  392. disk : array[1..4] of char;
  393. secs,bytes,
  394. free,total : longint;
  395. qwtotal,qwfree,qwcaller : int64;
  396. begin
  397. if drive=0 then
  398. begin
  399. disk[1]:='\';
  400. disk[2]:=#0;
  401. end
  402. else
  403. begin
  404. disk[1]:=chr(drive+64);
  405. disk[2]:=':';
  406. disk[3]:='\';
  407. disk[4]:=#0;
  408. end;
  409. if assigned(GetDiskFreeSpaceEx) then
  410. begin
  411. if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
  412. diskfree:=qwfree
  413. else
  414. diskfree:=-1;
  415. end
  416. else
  417. begin
  418. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  419. diskfree:=int64(free)*secs*bytes
  420. else
  421. diskfree:=-1;
  422. end;
  423. end;
  424. function disksize(drive : byte) : int64;
  425. var
  426. disk : array[1..4] of char;
  427. secs,bytes,
  428. free,total : longint;
  429. qwtotal,qwfree,qwcaller : int64;
  430. begin
  431. if drive=0 then
  432. begin
  433. disk[1]:='\';
  434. disk[2]:=#0;
  435. end
  436. else
  437. begin
  438. disk[1]:=chr(drive+64);
  439. disk[2]:=':';
  440. disk[3]:='\';
  441. disk[4]:=#0;
  442. end;
  443. if assigned(GetDiskFreeSpaceEx) then
  444. begin
  445. if GetDiskFreeSpaceEx(@disk,qwcaller,qwtotal,qwfree) then
  446. disksize:=qwtotal
  447. else
  448. disksize:=-1;
  449. end
  450. else
  451. begin
  452. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  453. disksize:=int64(total)*secs*bytes
  454. else
  455. disksize:=-1;
  456. end;
  457. end;
  458. {******************************************************************************
  459. --- Findfirst FindNext ---
  460. ******************************************************************************}
  461. { Needed kernel calls }
  462. function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;
  463. external 'kernel32' name 'FindFirstFileA';
  464. function FindNextFile (hFindFile: THandle; var lpFindFileData: TWIN32FindData): LongBool;
  465. external 'kernel32' name 'FindNextFileA';
  466. function FindCloseFile (hFindFile: THandle): LongBool;
  467. external 'kernel32' name 'FindClose';
  468. Procedure StringToPchar (Var S : String);
  469. Var L : Longint;
  470. begin
  471. L:=ord(S[0]);
  472. Move (S[1],S[0],L);
  473. S[L]:=#0;
  474. end;
  475. Procedure PCharToString (Var S : String);
  476. Var L : Longint;
  477. begin
  478. L:=strlen(pchar(@S[0]));
  479. Move (S[0],S[1],L);
  480. S[0]:=char(l);
  481. end;
  482. procedure FindMatch(var f:searchrec);
  483. begin
  484. { Find file with correct attribute }
  485. While (F.W32FindData.dwFileAttributes and cardinal(F.ExcludeAttr))<>0 do
  486. begin
  487. if not FindNextFile (F.FindHandle,F.W32FindData) then
  488. begin
  489. DosError:=Last2DosError(GetLastError);
  490. if DosError=2 then
  491. DosError:=18;
  492. exit;
  493. end;
  494. end;
  495. { Convert some attributes back }
  496. f.size:=F.W32FindData.NFileSizeLow;
  497. f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
  498. WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
  499. f.Name:=StrPas(@F.W32FindData.cFileName);
  500. end;
  501. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  502. begin
  503. { no error }
  504. doserror:=0;
  505. F.Name:=Path;
  506. F.Attr:=attr;
  507. F.ExcludeAttr:=(not Attr) and ($1e); {hidden,sys,dir,volume}
  508. StringToPchar(f.name);
  509. { FindFirstFile is a Win32 Call }
  510. F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
  511. If longint(F.FindHandle)=Invalid_Handle_value then
  512. begin
  513. DosError:=Last2DosError(GetLastError);
  514. if DosError=2 then
  515. DosError:=18;
  516. exit;
  517. end;
  518. { Find file with correct attribute }
  519. FindMatch(f);
  520. end;
  521. procedure findnext(var f : searchRec);
  522. begin
  523. { no error }
  524. doserror:=0;
  525. if not FindNextFile (F.FindHandle,F.W32FindData) then
  526. begin
  527. DosError:=Last2DosError(GetLastError);
  528. if DosError=2 then
  529. DosError:=18;
  530. exit;
  531. end;
  532. { Find file with correct attribute }
  533. FindMatch(f);
  534. end;
  535. procedure swapvectors;
  536. begin
  537. end;
  538. Procedure FindClose(Var f: SearchRec);
  539. begin
  540. If longint(F.FindHandle)<>Invalid_Handle_value then
  541. FindCloseFile(F.FindHandle);
  542. end;
  543. {******************************************************************************
  544. --- File ---
  545. ******************************************************************************}
  546. function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
  547. external 'kernel32' name 'GetFileTime';
  548. function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
  549. external 'kernel32' name 'SetFileTime';
  550. function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : longbool;
  551. external 'kernel32' name 'SetFileAttributesA';
  552. function GetFileAttributes(lpFileName : pchar) : longint;
  553. external 'kernel32' name 'GetFileAttributesA';
  554. procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
  555. var
  556. dotpos,p1,i : longint;
  557. begin
  558. { allow slash as backslash }
  559. for i:=1 to length(path) do
  560. if path[i]='/' then path[i]:='\';
  561. { get drive name }
  562. p1:=pos(':',path);
  563. if p1>0 then
  564. begin
  565. dir:=path[1]+':';
  566. delete(path,1,p1);
  567. end
  568. else
  569. dir:='';
  570. { split the path and the name, there are no more path informtions }
  571. { if path contains no backslashes }
  572. while true do
  573. begin
  574. p1:=pos('\',path);
  575. if p1=0 then
  576. break;
  577. dir:=dir+copy(path,1,p1);
  578. delete(path,1,p1);
  579. end;
  580. { try to find out a extension }
  581. Ext:='';
  582. i:=Length(Path);
  583. DotPos:=256;
  584. While (i>0) Do
  585. Begin
  586. If (Path[i]='.') Then
  587. begin
  588. DotPos:=i;
  589. break;
  590. end;
  591. Dec(i);
  592. end;
  593. Ext:=Copy(Path,DotPos,255);
  594. Name:=Copy(Path,1,DotPos - 1);
  595. end;
  596. { <immobilizer> }
  597. function GetFullPathName(lpFileName: PChar; nBufferLength: Longint; lpBuffer: PChar; var lpFilePart : PChar):DWORD;
  598. external 'kernel32' name 'GetFullPathNameA';
  599. function GetShortPathName(lpszLongPath:pchar; lpszShortPath:pchar; cchBuffer:DWORD):DWORD;
  600. external 'kernel32' name 'GetShortPathNameA';
  601. (*
  602. function FExpand (const Path: PathStr): PathStr;
  603. - declared in fexpand.inc
  604. *)
  605. {$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
  606. {$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
  607. {$I fexpand.inc}
  608. {$UNDEF FPC_FEXPAND_DRIVES}
  609. {$UNDEF FPC_FEXPAND_UNC}
  610. function SearchPath(lpPath : PChar; lpFileName : PChar; lpExtension : PChar; nBufferLength : Longint; lpBuffer : PChar;
  611. var lpFilePart : PChar) : Longint; external 'kernel32' name 'SearchPathA';
  612. Function FSearch(path: pathstr; dirlist: string): pathstr;
  613. var temp : PChar;
  614. value : Array [0..255] of char;
  615. i : Longint;
  616. dir,dir2 : dirstr;
  617. lastchar : char;
  618. name : namestr;
  619. ext : extstr;
  620. s : SearchRec;
  621. found : boolean;
  622. begin
  623. { check if the file specified exists }
  624. findfirst(path,anyfile,s);
  625. found:=(doserror=0);
  626. findclose(s);
  627. if found then
  628. begin
  629. fsearch:=path;
  630. exit;
  631. end;
  632. { search the path }
  633. fsearch:='';
  634. for i:=1 to length(path) do
  635. if path[i]='/' then
  636. path[i]:='\';
  637. fsplit(path,dir,name,ext);
  638. for i:=1 to length(dirlist) do
  639. if dirlist[i]='/' then
  640. dirlist[i]:='\';
  641. { bugfix here : Win98SE returns a path, when the name is NULL! }
  642. { so if the name of the file to search is '' then simply exit }
  643. { immediately (WinNT behavior is correct). }
  644. if name='' then
  645. exit;
  646. { allow slash as backslash }
  647. StringToPchar(name);
  648. StringToPchar(ext);
  649. StringToPchar(dir);
  650. if SearchPath(@dir, @name, @ext, 255, @value, temp)>0 then
  651. begin
  652. fsearch := strpas(value);
  653. exit;
  654. end;
  655. PCharToString(dir);
  656. repeat
  657. i:=pos(';',dirlist);
  658. while i=1 do
  659. begin
  660. delete(dirlist,1,1);
  661. i:=pos(';',dirlist);
  662. end;
  663. if i=0 then
  664. begin
  665. dir2:=dirlist;
  666. dirlist:='';
  667. end
  668. else
  669. begin
  670. dir2:=Copy(dirlist,1,i-1);
  671. dirlist:=Copy(dirlist,i+1,255);
  672. end;
  673. { don't add anything if dir2 is empty string }
  674. if dir2<>'' then
  675. lastchar:=dir2[length(dir2)]
  676. else
  677. lastchar:='\';
  678. if (lastchar<>'\') and (lastchar<>':') then
  679. dir2:=dir2+'\'+dir
  680. else
  681. dir2:=dir2+dir;
  682. StringToPchar(dir2);
  683. if SearchPath(@dir2, @name, @ext, 255, @value, temp)>0 then
  684. begin
  685. fsearch := strpas(value);
  686. exit;
  687. end;
  688. until dirlist='';
  689. end;
  690. { </immobilizer> }
  691. procedure getftime(var f;var time : longint);
  692. var
  693. ft : TFileTime;
  694. begin
  695. doserror:=0;
  696. if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
  697. WinToDosTime(ft,time) then
  698. exit
  699. else
  700. begin
  701. DosError:=Last2DosError(GetLastError);
  702. time:=0;
  703. end;
  704. end;
  705. procedure setftime(var f;time : longint);
  706. var
  707. ft : TFileTime;
  708. begin
  709. doserror:=0;
  710. if DosToWinTime(time,ft) and
  711. SetFileTime(filerec(f).Handle,nil,nil,@ft) then
  712. exit
  713. else
  714. DosError:=Last2DosError(GetLastError);
  715. end;
  716. procedure getfattr(var f;var attr : word);
  717. var
  718. l : longint;
  719. begin
  720. doserror:=0;
  721. l:=GetFileAttributes(filerec(f).name);
  722. if l=longint($ffffffff) then
  723. begin
  724. doserror:=getlasterror;
  725. attr:=0;
  726. end
  727. else
  728. attr:=l and $ffff;
  729. end;
  730. procedure setfattr(var f;attr : word);
  731. begin
  732. doserror:=0;
  733. if not(SetFileAttributes(filerec(f).name,attr)) then
  734. doserror:=getlasterror;
  735. end;
  736. { change to short filename if successful win32 call PM }
  737. function GetShortName(var p : String) : boolean;
  738. var
  739. buffer : array[0..255] of char;
  740. ret : longint;
  741. begin
  742. {we can't mess with p, because we have to return it if call is
  743. unsuccesfully.}
  744. if Length(p)>0 then {copy p to array of char}
  745. move(p[1],buffer[0],length(p));
  746. buffer[length(p)]:=chr(0);
  747. {Should return value load loaddoserror?}
  748. ret:=GetShortPathName(@buffer,@buffer,255);
  749. if ret=0 then
  750. p:=strpas(buffer);
  751. GetShortName:=ret<>0;
  752. end;
  753. { change to long filename if successful DOS call PM }
  754. function GetLongName(var p : String) : boolean;
  755. var
  756. lfn,sfn : array[0..255] of char;
  757. filename : pchar;
  758. ret : longint;
  759. begin
  760. {contrary to shortname, SDK does not mention input buffer can be equal
  761. to output.}
  762. if Length(p)>0 then {copy p to array of char}
  763. move(p[1],sfn[0],length(p));
  764. sfn[length(p)]:=chr(0);
  765. fillchar(lfn,sizeof(lfn),#0);
  766. filename:=nil;
  767. {Should return value load loaddoserror?}
  768. ret:=GetFullPathName(@sfn,255,@lfn,filename);
  769. if ret=0 then
  770. p:=strpas(lfn); {lfn here returns full path, filename only fn}
  771. GetLongName:=ret<>0;
  772. end;
  773. {******************************************************************************
  774. --- Environment ---
  775. ******************************************************************************}
  776. {
  777. The environment is a block of zero terminated strings
  778. terminated by a #0
  779. }
  780. function GetEnvironmentStrings : pchar;
  781. external 'kernel32' name 'GetEnvironmentStringsA';
  782. function FreeEnvironmentStrings(p : pchar) : longbool;
  783. external 'kernel32' name 'FreeEnvironmentStringsA';
  784. function envcount : longint;
  785. var
  786. hp,p : pchar;
  787. count : longint;
  788. begin
  789. p:=GetEnvironmentStrings;
  790. hp:=p;
  791. count:=0;
  792. while hp^<>#0 do
  793. begin
  794. { next string entry}
  795. hp:=hp+strlen(hp)+1;
  796. inc(count);
  797. end;
  798. FreeEnvironmentStrings(p);
  799. envcount:=count;
  800. end;
  801. Function EnvStr(index: integer): string;
  802. var
  803. hp,p : pchar;
  804. count,i : longint;
  805. begin
  806. { envcount takes some time in win32 }
  807. count:=envcount;
  808. { range checking }
  809. if (index<=0) or (index>count) then
  810. begin
  811. envstr:='';
  812. exit;
  813. end;
  814. p:=GetEnvironmentStrings;
  815. hp:=p;
  816. { retrive the string with the given index }
  817. for i:=2 to index do
  818. hp:=hp+strlen(hp)+1;
  819. envstr:=strpas(hp);
  820. FreeEnvironmentStrings(p);
  821. end;
  822. Function GetEnv(envvar: string): string;
  823. var
  824. s : string;
  825. i : longint;
  826. hp,p : pchar;
  827. begin
  828. getenv:='';
  829. p:=GetEnvironmentStrings;
  830. hp:=p;
  831. while hp^<>#0 do
  832. begin
  833. s:=strpas(hp);
  834. i:=pos('=',s);
  835. if upcase(copy(s,1,i-1))=upcase(envvar) then
  836. begin
  837. getenv:=copy(s,i+1,length(s)-i);
  838. break;
  839. end;
  840. { next string entry}
  841. hp:=hp+strlen(hp)+1;
  842. end;
  843. FreeEnvironmentStrings(p);
  844. end;
  845. {******************************************************************************
  846. --- Not Supported ---
  847. ******************************************************************************}
  848. Procedure keep(exitcode : word);
  849. Begin
  850. End;
  851. Procedure getintvec(intno : byte;var vector : pointer);
  852. Begin
  853. End;
  854. Procedure setintvec(intno : byte;vector : pointer);
  855. Begin
  856. End;
  857. function FreeLibrary(hLibModule : THANDLE) : longbool;
  858. external 'kernel32' name 'FreeLibrary';
  859. function GetVersionEx(var VersionInformation:OSVERSIONINFO) : longbool;
  860. external 'kernel32' name 'GetVersionExA';
  861. function LoadLibrary(lpLibFileName : pchar):THandle;
  862. external 'kernel32' name 'LoadLibraryA';
  863. function GetProcAddress(hModule : THandle;lpProcName : pchar) : pointer;
  864. external 'kernel32' name 'GetProcAddress';
  865. var
  866. oldexitproc : pointer;
  867. procedure dosexitproc;
  868. begin
  869. exitproc:=oldexitproc;
  870. if kernel32dll<>0 then
  871. FreeLibrary(kernel32dll);
  872. end;
  873. begin
  874. oldexitproc:=exitproc;
  875. exitproc:=@dosexitproc;
  876. versioninfo.dwOSVersionInfoSize:=sizeof(versioninfo);
  877. GetVersionEx(versioninfo);
  878. kernel32dll:=0;
  879. GetDiskFreeSpaceEx:=nil;
  880. if ((versioninfo.dwPlatformId=VER_PLATFORM_WIN32_WINDOWS) and
  881. (versioninfo.dwBuildNUmber>=1000)) or
  882. (versioninfo.dwPlatformId=VER_PLATFORM_WIN32_NT) then
  883. begin
  884. kernel32dll:=LoadLibrary('kernel32');
  885. if kernel32dll<>0 then
  886. GetDiskFreeSpaceEx:=TGetDiskFreeSpaceEx(GetProcAddress(kernel32dll,'GetDiskFreeSpaceExA'));
  887. end;
  888. end.
  889. {
  890. $Log$
  891. Revision 1.18 2002-12-24 15:35:15 peter
  892. * error code fixes
  893. Revision 1.17 2002/12/15 20:23:53 peter
  894. * map error 87 to 13 to be compatible with dos
  895. Revision 1.16 2002/12/04 21:35:50 carl
  896. * bugfixes for dos.exec() : it would not be able to execute 16-bit apps
  897. * doserror was not reset to zero in dos.exec
  898. Revision 1.15 2002/12/03 20:39:14 carl
  899. * fix for dos.exec with non-microsoft shells
  900. Revision 1.14 2002/09/07 16:01:28 peter
  901. * old logs removed and tabs fixed
  902. Revision 1.13 2002/07/06 11:48:09 carl
  903. + fsearch bugfix for Win9X systems
  904. Revision 1.12 2002/05/16 19:32:57 carl
  905. * fix range check error
  906. }