dos.pp 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942
  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) : longint;
  109. Function DiskSize(drive: byte) : longint;
  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. {Environment}
  120. Function EnvCount: longint;
  121. Function EnvStr(index: integer): string;
  122. Function GetEnv(envvar: string): string;
  123. {Misc}
  124. Procedure SetFAttr(var f; attr: word);
  125. Procedure SetFTime(var f; time: longint);
  126. Procedure GetCBreak(var breakvalue: boolean);
  127. Procedure SetCBreak(breakvalue: boolean);
  128. Procedure GetVerify(var verify: boolean);
  129. Procedure SetVerify(verify: boolean);
  130. {Do Nothing Functions}
  131. Procedure SwapVectors;
  132. Procedure GetIntVec(intno: byte; var vector: pointer);
  133. Procedure SetIntVec(intno: byte; vector: pointer);
  134. Procedure Keep(exitcode: word);
  135. Const
  136. { allow EXEC to inherited handles from calling process,
  137. needed for FPREDIR in ide/text
  138. now set to true by default because
  139. other OS also pass open handles to childs
  140. finally reset to false after Florian's response PM }
  141. ExecInheritsHandles : BOOL = false;
  142. implementation
  143. uses strings;
  144. {******************************************************************************
  145. --- Conversion ---
  146. ******************************************************************************}
  147. function GetLastError : DWORD;
  148. external 'kernel32' name 'GetLastError';
  149. function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : longbool;
  150. external 'kernel32' name 'FileTimeToDosDateTime';
  151. function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : longbool;
  152. external 'kernel32' name 'DosDateTimeToFileTime';
  153. function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : longbool;
  154. external 'kernel32' name 'FileTimeToLocalFileTime';
  155. function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : longbool;
  156. external 'kernel32' name 'LocalFileTimeToFileTime';
  157. type
  158. Longrec=packed record
  159. lo,hi : word;
  160. end;
  161. function Last2DosError(d:dword):integer;
  162. begin
  163. Last2DosError:=d;
  164. end;
  165. Function DosToWinAttr (Const Attr : Longint) : longint;
  166. begin
  167. DosToWinAttr:=Attr;
  168. end;
  169. Function WinToDosAttr (Const Attr : Longint) : longint;
  170. begin
  171. WinToDosAttr:=Attr;
  172. end;
  173. Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
  174. var
  175. lft : TFileTime;
  176. begin
  177. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
  178. LocalFileTimeToFileTime(lft,Wtime);
  179. end;
  180. Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):longbool;
  181. var
  182. lft : TFileTime;
  183. begin
  184. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  185. FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
  186. end;
  187. {******************************************************************************
  188. --- Dos Interrupt ---
  189. ******************************************************************************}
  190. procedure intr(intno : byte;var regs : registers);
  191. begin
  192. { !!!!!!!! }
  193. end;
  194. procedure msdos(var regs : registers);
  195. begin
  196. { !!!!!!!! }
  197. end;
  198. {******************************************************************************
  199. --- Info / Date / Time ---
  200. ******************************************************************************}
  201. function GetVersion : longint;
  202. external 'kernel32' name 'GetVersion';
  203. procedure GetLocalTime(var t : TSystemTime);
  204. external 'kernel32' name 'GetLocalTime';
  205. function SetLocalTime(const t : TSystemTime) : longbool;
  206. external 'kernel32' name 'SetLocalTime';
  207. function dosversion : word;
  208. begin
  209. dosversion:=GetVersion;
  210. end;
  211. procedure getdate(var year,month,mday,wday : word);
  212. var
  213. t : TSystemTime;
  214. begin
  215. GetLocalTime(t);
  216. year:=t.wYear;
  217. month:=t.wMonth;
  218. mday:=t.wDay;
  219. wday:=t.wDayOfWeek;
  220. end;
  221. procedure setdate(year,month,day : word);
  222. var
  223. t : TSystemTime;
  224. begin
  225. { we need the time set privilege }
  226. { so this function crash currently }
  227. {!!!!!}
  228. GetLocalTime(t);
  229. t.wYear:=year;
  230. t.wMonth:=month;
  231. t.wDay:=day;
  232. { only a quite good solution, we can loose some ms }
  233. SetLocalTime(t);
  234. end;
  235. procedure gettime(var hour,minute,second,sec100 : word);
  236. var
  237. t : TSystemTime;
  238. begin
  239. GetLocalTime(t);
  240. hour:=t.wHour;
  241. minute:=t.wMinute;
  242. second:=t.wSecond;
  243. sec100:=t.wMilliSeconds div 10;
  244. end;
  245. procedure settime(hour,minute,second,sec100 : word);
  246. var
  247. t : TSystemTime;
  248. begin
  249. { we need the time set privilege }
  250. { so this function crash currently }
  251. {!!!!!}
  252. GetLocalTime(t);
  253. t.wHour:=hour;
  254. t.wMinute:=minute;
  255. t.wSecond:=second;
  256. t.wMilliSeconds:=sec100*10;
  257. SetLocalTime(t);
  258. end;
  259. Procedure packtime(var t : datetime;var p : longint);
  260. Begin
  261. 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);
  262. End;
  263. Procedure unpacktime(p : longint;var t : datetime);
  264. Begin
  265. with t do
  266. begin
  267. sec:=(p and 31) shl 1;
  268. min:=(p shr 5) and 63;
  269. hour:=(p shr 11) and 31;
  270. day:=(p shr 16) and 31;
  271. month:=(p shr 21) and 15;
  272. year:=(p shr 25)+1980;
  273. end;
  274. End;
  275. {******************************************************************************
  276. --- Exec ---
  277. ******************************************************************************}
  278. function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
  279. lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
  280. bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
  281. lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
  282. var lpProcessInformation: TProcessInformation): longbool;
  283. external 'kernel32' name 'CreateProcessA';
  284. function getExitCodeProcess(h:THandle;var code:longint):longbool;
  285. external 'kernel32' name 'GetExitCodeProcess';
  286. function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
  287. external 'kernel32' name 'WaitForSingleObject';
  288. function CloseHandle(h : THandle) : longint;
  289. external 'kernel32' name 'CloseHandle';
  290. var
  291. lastdosexitcode : word;
  292. procedure exec(const path : pathstr;const comline : comstr);
  293. var
  294. SI: TStartupInfo;
  295. PI: TProcessInformation;
  296. Proc : THandle;
  297. l : Longint;
  298. AppPath,
  299. AppParam : array[0..255] of char;
  300. begin
  301. FillChar(SI, SizeOf(SI), 0);
  302. SI.cb:=SizeOf(SI);
  303. SI.wShowWindow:=1;
  304. Move(Path[1],AppPath,length(Path));
  305. AppPath[Length(Path)]:=#0;
  306. AppParam[0]:='-';
  307. AppParam[1]:=' ';
  308. Move(ComLine[1],AppParam[2],length(Comline));
  309. AppParam[Length(ComLine)+2]:=#0;
  310. if not CreateProcess(PChar(@AppPath), PChar(@AppParam),
  311. Nil, Nil, ExecInheritsHandles,$20, Nil, Nil, SI, PI) then
  312. begin
  313. DosError:=Last2DosError(GetLastError);
  314. exit;
  315. end;
  316. Proc:=PI.hProcess;
  317. CloseHandle(PI.hThread);
  318. if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
  319. GetExitCodeProcess(Proc,l)
  320. else
  321. l:=-1;
  322. CloseHandle(Proc);
  323. LastDosExitCode:=l;
  324. end;
  325. function dosexitcode : word;
  326. begin
  327. dosexitcode:=lastdosexitcode;
  328. end;
  329. procedure getcbreak(var breakvalue : boolean);
  330. begin
  331. { !! No Win32 Function !! }
  332. end;
  333. procedure setcbreak(breakvalue : boolean);
  334. begin
  335. { !! No Win32 Function !! }
  336. end;
  337. procedure getverify(var verify : boolean);
  338. begin
  339. { !! No Win32 Function !! }
  340. end;
  341. procedure setverify(verify : boolean);
  342. begin
  343. { !! No Win32 Function !! }
  344. end;
  345. {******************************************************************************
  346. --- Disk ---
  347. ******************************************************************************}
  348. function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
  349. freeclusters,totalclusters:longint):longbool;
  350. external 'kernel32' name 'GetDiskFreeSpaceA';
  351. function diskfree(drive : byte) : longint;
  352. var
  353. disk : array[1..4] of char;
  354. secs,bytes,
  355. free,total : longint;
  356. begin
  357. if drive=0 then
  358. begin
  359. disk[1]:='\';
  360. disk[2]:=#0;
  361. end
  362. else
  363. begin
  364. disk[1]:=chr(drive+64);
  365. disk[2]:=':';
  366. disk[3]:='\';
  367. disk[4]:=#0;
  368. end;
  369. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  370. diskfree:=free*secs*bytes
  371. else
  372. diskfree:=-1;
  373. end;
  374. function disksize(drive : byte) : longint;
  375. var
  376. disk : array[1..4] of char;
  377. secs,bytes,
  378. free,total : longint;
  379. begin
  380. if drive=0 then
  381. begin
  382. disk[1]:='\';
  383. disk[2]:=#0;
  384. end
  385. else
  386. begin
  387. disk[1]:=chr(drive+64);
  388. disk[2]:=':';
  389. disk[3]:='\';
  390. disk[4]:=#0;
  391. end;
  392. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  393. disksize:=total*secs*bytes
  394. else
  395. disksize:=-1;
  396. end;
  397. {******************************************************************************
  398. --- Findfirst FindNext ---
  399. ******************************************************************************}
  400. { Needed kernel calls }
  401. function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;
  402. external 'kernel32' name 'FindFirstFileA';
  403. function FindNextFile (hFindFile: THandle; var lpFindFileData: TWIN32FindData): LongBool;
  404. external 'kernel32' name 'FindNextFileA';
  405. function FindCloseFile (hFindFile: THandle): LongBool;
  406. external 'kernel32' name 'FindClose';
  407. Procedure StringToPchar (Var S : String);
  408. Var L : Longint;
  409. begin
  410. L:=ord(S[0]);
  411. Move (S[1],S[0],L);
  412. S[L]:=#0;
  413. end;
  414. procedure FindMatch(var f:searchrec);
  415. begin
  416. { Find file with correct attribute }
  417. While (F.W32FindData.dwFileAttributes and F.ExcludeAttr)<>0 do
  418. begin
  419. if not FindNextFile (F.FindHandle,F.W32FindData) then
  420. begin
  421. DosError:=Last2DosError(GetLastError);
  422. exit;
  423. end;
  424. end;
  425. { Convert some attributes back }
  426. f.size:=F.W32FindData.NFileSizeLow;
  427. f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
  428. WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
  429. f.Name:=StrPas(@F.W32FindData.cFileName);
  430. end;
  431. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  432. begin
  433. { no error }
  434. doserror:=0;
  435. F.Name:=Path;
  436. F.Attr:=attr;
  437. F.ExcludeAttr:=(not Attr) and ($1e); {hidden,sys,dir,volume}
  438. StringToPchar(f.name);
  439. { FindFirstFile is a Win32 Call }
  440. F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
  441. If longint(F.FindHandle)=Invalid_Handle_value then
  442. begin
  443. DosError:=Last2DosError(GetLastError);
  444. exit;
  445. end;
  446. { Find file with correct attribute }
  447. FindMatch(f);
  448. end;
  449. procedure findnext(var f : searchRec);
  450. begin
  451. { no error }
  452. doserror:=0;
  453. if not FindNextFile (F.FindHandle,F.W32FindData) then
  454. begin
  455. DosError:=Last2DosError(GetLastError);
  456. exit;
  457. end;
  458. { Find file with correct attribute }
  459. FindMatch(f);
  460. end;
  461. procedure swapvectors;
  462. begin
  463. end;
  464. Procedure FindClose(Var f: SearchRec);
  465. begin
  466. If longint(F.FindHandle)<>Invalid_Handle_value then
  467. FindCloseFile(F.FindHandle);
  468. end;
  469. {******************************************************************************
  470. --- File ---
  471. ******************************************************************************}
  472. function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
  473. external 'kernel32' name 'GetFileTime';
  474. function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : longbool;
  475. external 'kernel32' name 'SetFileTime';
  476. function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : longbool;
  477. external 'kernel32' name 'SetFileAttributesA';
  478. function GetFileAttributes(lpFileName : pchar) : longint;
  479. external 'kernel32' name 'GetFileAttributesA';
  480. procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
  481. var
  482. dotpos,p1,i : longint;
  483. begin
  484. { allow slash as backslash }
  485. for i:=1 to length(path) do
  486. if path[i]='/' then path[i]:='\';
  487. { get drive name }
  488. p1:=pos(':',path);
  489. if p1>0 then
  490. begin
  491. dir:=path[1]+':';
  492. delete(path,1,p1);
  493. end
  494. else
  495. dir:='';
  496. { split the path and the name, there are no more path informtions }
  497. { if path contains no backslashes }
  498. while true do
  499. begin
  500. p1:=pos('\',path);
  501. if p1=0 then
  502. break;
  503. dir:=dir+copy(path,1,p1);
  504. delete(path,1,p1);
  505. end;
  506. { try to find out a extension }
  507. Ext:='';
  508. i:=Length(Path);
  509. DotPos:=256;
  510. While (i>0) Do
  511. Begin
  512. If (Path[i]='.') Then
  513. begin
  514. DotPos:=i;
  515. break;
  516. end;
  517. Dec(i);
  518. end;
  519. Ext:=Copy(Path,DotPos,255);
  520. Name:=Copy(Path,1,DotPos - 1);
  521. end;
  522. { <immobilizer> }
  523. function GetFullPathName(lpFileName: PChar; nBufferLength: Longint; lpBuffer: PChar; var lpFilePart : PChar):DWORD;
  524. external 'kernel32' name 'GetFullPathNameA';
  525. function FExpand(const path : pathstr) : pathstr;
  526. var value : Array[0..255] of char;
  527. tmp : PChar;
  528. p : string;
  529. i : Longint;
  530. begin
  531. { allow slash as backslash }
  532. p := path;
  533. for i:=1 to length(p) do
  534. if p[i]='/' then
  535. p[i]:='\';
  536. StringToPchar(p);
  537. {getmem(value, 255); lets avoid slow getmem PM
  538. getmem(tmp, 255); not necessary
  539. tmp only points to the filename part at function exit }
  540. GetFullPathName(@p, 255, value, tmp);
  541. FExpand := strpas(value);
  542. { freemem(value,255) this would be nice at least if we use getmem !! PM }
  543. end;
  544. function SearchPath(lpPath : PChar; lpFileName : PChar; lpExtension : PChar; nBufferLength : Longint; lpBuffer : PChar;
  545. var lpFilePart : PChar) : Longint; external 'kernel32' name 'SearchPathA';
  546. Function FSearch(path: pathstr; dirlist: string): pathstr;
  547. var temp : PChar;
  548. value : Array [0..255] of char;
  549. i : Longint;
  550. dir,dir2 : dirstr;
  551. lastchar : char;
  552. name : namestr;
  553. ext : extstr;
  554. begin
  555. fsearch:='';
  556. for i:=1 to length(path) do
  557. if path[i]='/' then
  558. path[i]:='\';
  559. fsplit(path,dir,name,ext);
  560. for i:=1 to length(dirlist) do
  561. if dirlist[i]='/' then
  562. dirlist[i]:='\';
  563. { allow slash as backslash }
  564. StringToPchar(name);
  565. StringToPchar(ext);
  566. repeat
  567. i:=pos(';',dirlist);
  568. while i=1 do
  569. begin
  570. delete(dirlist,1,1);
  571. i:=pos(';',dirlist);
  572. end;
  573. if i=0 then
  574. begin
  575. dir2:=dirlist;
  576. dirlist:='';
  577. end
  578. else
  579. begin
  580. dir2:=Copy(dirlist,1,i-1);
  581. dirlist:=Copy(dirlist,i+1,255);
  582. end;
  583. { don't add anything if dir2 is empty string }
  584. if dir2<>'' then
  585. lastchar:=dir2[length(dir2)]
  586. else
  587. lastchar:='\';
  588. if (lastchar<>'\') and (lastchar<>':') then
  589. dir2:=dir2+'\'+dir
  590. else
  591. dir2:=dir2+dir;
  592. StringToPchar(dir2);
  593. if SearchPath(@dir2, @name, @ext, 255, @value, temp)>0 then
  594. begin
  595. fsearch := strpas(value);
  596. exit;
  597. end;
  598. until dirlist='';
  599. end;
  600. { </immobilizer> }
  601. procedure getftime(var f;var time : longint);
  602. var
  603. ft : TFileTime;
  604. begin
  605. if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
  606. WinToDosTime(ft,time) then
  607. exit
  608. else
  609. time:=0;
  610. end;
  611. procedure setftime(var f;time : longint);
  612. var
  613. ft : TFileTime;
  614. begin
  615. if DosToWinTime(time,ft) then
  616. SetFileTime(filerec(f).Handle,nil,nil,@ft);
  617. end;
  618. procedure getfattr(var f;var attr : word);
  619. var
  620. l : longint;
  621. begin
  622. doserror:=0;
  623. l:=GetFileAttributes(filerec(f).name);
  624. if l=$ffffffff then
  625. doserror:=getlasterror;
  626. attr:=l;
  627. end;
  628. procedure setfattr(var f;attr : word);
  629. begin
  630. doserror:=0;
  631. if not(SetFileAttributes(filerec(f).name,attr)) then
  632. doserror:=getlasterror;
  633. end;
  634. {******************************************************************************
  635. --- Environment ---
  636. ******************************************************************************}
  637. {
  638. The environment is a block of zero terminated strings
  639. terminated by a #0
  640. }
  641. function GetEnvironmentStrings : pchar;
  642. external 'kernel32' name 'GetEnvironmentStringsA';
  643. function FreeEnvironmentStrings(p : pchar) : longbool;
  644. external 'kernel32' name 'FreeEnvironmentStringsA';
  645. function envcount : longint;
  646. var
  647. hp,p : pchar;
  648. count : longint;
  649. begin
  650. p:=GetEnvironmentStrings;
  651. hp:=p;
  652. count:=0;
  653. while hp^<>#0 do
  654. begin
  655. { next string entry}
  656. hp:=hp+strlen(hp)+1;
  657. inc(count);
  658. end;
  659. FreeEnvironmentStrings(p);
  660. envcount:=count;
  661. end;
  662. Function EnvStr(index: integer): string;
  663. var
  664. hp,p : pchar;
  665. count,i : longint;
  666. begin
  667. { envcount takes some time in win32 }
  668. count:=envcount;
  669. { range checking }
  670. if (index<=0) or (index>count) then
  671. begin
  672. envstr:='';
  673. exit;
  674. end;
  675. p:=GetEnvironmentStrings;
  676. hp:=p;
  677. { retrive the string with the given index }
  678. for i:=2 to index do
  679. hp:=hp+strlen(hp)+1;
  680. envstr:=strpas(hp);
  681. FreeEnvironmentStrings(p);
  682. end;
  683. Function GetEnv(envvar: string): string;
  684. var
  685. s : string;
  686. i : longint;
  687. hp,p : pchar;
  688. begin
  689. getenv:='';
  690. p:=GetEnvironmentStrings;
  691. hp:=p;
  692. while hp^<>#0 do
  693. begin
  694. s:=strpas(hp);
  695. i:=pos('=',s);
  696. if upcase(copy(s,1,i-1))=upcase(envvar) then
  697. begin
  698. getenv:=copy(s,i+1,length(s)-i);
  699. break;
  700. end;
  701. { next string entry}
  702. hp:=hp+strlen(hp)+1;
  703. end;
  704. FreeEnvironmentStrings(p);
  705. end;
  706. {******************************************************************************
  707. --- Not Supported ---
  708. ******************************************************************************}
  709. Procedure keep(exitcode : word);
  710. Begin
  711. End;
  712. Procedure getintvec(intno : byte;var vector : pointer);
  713. Begin
  714. End;
  715. Procedure setintvec(intno : byte;vector : pointer);
  716. Begin
  717. End;
  718. end.
  719. {
  720. $Log$
  721. Revision 1.30 2000-01-11 13:45:19 pierre
  722. * fsearch was still worng for multiple pathes
  723. Revision 1.29 2000/01/11 12:49:26 pierre
  724. * fsearch bugs and fexpand memory leak fixed
  725. Revision 1.28 2000/01/07 16:41:52 daniel
  726. * copyright 2000
  727. Revision 1.27 2000/01/07 16:32:34 daniel
  728. * copyright 2000 added
  729. Revision 1.26 1999/11/18 15:28:47 michael
  730. * Better and faster Fexpand, SearchPath fromPiotr Sawicki
  731. Revision 1.25 1999/10/14 08:57:51 peter
  732. * getfattr resets doserror
  733. Revision 1.24 1999/10/12 08:56:48 pierre
  734. * fix form bug660
  735. Revision 1.23 1999/09/22 12:34:05 pierre
  736. ExecInheritsHandles reset to false by default
  737. Revision 1.22 1999/09/21 13:24:32 pierre
  738. * typo error
  739. Revision 1.21 1999/09/21 12:37:09 pierre
  740. * Child inherits now file handles from parent in Exec by default
  741. Revision 1.20 1999/09/21 11:34:40 pierre
  742. + ExecInheritedHandles boolean
  743. Revision 1.19 1999/08/25 13:57:55 michael
  744. + Patched FSearch from Frank McCormick
  745. Revision 1.18 1999/08/12 09:24:14 michael
  746. Fixed win32finddata size; searchrec.excludeattr was overwritten.
  747. Revision 1.17 1999/05/16 17:08:59 peter
  748. * fixed driveletter checking
  749. Revision 1.16 1999/05/08 19:47:27 peter
  750. * check ioresult after getdir calls
  751. Revision 1.15 1999/04/28 11:42:52 peter
  752. + FileNameCaseSensetive boolean
  753. Revision 1.14 1999/04/08 12:23:07 peter
  754. * removed os.inc
  755. Revision 1.13 1998/11/16 15:48:53 peter
  756. * fixed longbool returns for api calls
  757. Revision 1.12 1998/10/27 10:55:55 michael
  758. * environment vars are case insensitive under WinNT/DOS
  759. Revision 1.11 1998/10/22 15:32:38 pierre
  760. * fsplit adapted to long filenames
  761. Revision 1.10 1998/10/16 14:20:06 peter
  762. * removed writelns
  763. Revision 1.9 1998/10/16 08:55:26 peter
  764. * findfirst is now more delphi alike
  765. Revision 1.8 1998/08/16 09:12:11 michael
  766. Corrected fexpand behaviour.
  767. Revision 1.7 1998/06/10 10:39:13 peter
  768. * working w32 rtl
  769. Revision 1.6 1998/06/08 23:07:45 peter
  770. * dos interface is now 100% compatible
  771. * fixed call PASCALMAIN which must be direct asm
  772. Revision 1.5 1998/05/06 12:36:50 michael
  773. + Removed log from before restored version.
  774. Revision 1.4 1998/04/27 14:01:38 florian
  775. * was uncompilable
  776. Revision 1.3 1998/04/26 22:37:02 florian
  777. + getftime, unpacktime, packtime
  778. Revision 1.2 1998/04/26 21:49:09 florian
  779. + first compiling and working version
  780. }