dos.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1993,97 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. {$I os.inc}
  14. interface
  15. { Include Win32 Consts,Types }
  16. {$I win32.inc}
  17. Const
  18. Max_Path = 255;
  19. {Bitmasks for CPU Flags}
  20. fcarry = $0001;
  21. fparity = $0004;
  22. fauxiliary = $0010;
  23. fzero = $0040;
  24. fsign = $0080;
  25. foverflow = $0800;
  26. {Bitmasks for file attribute}
  27. readonly = $01;
  28. hidden = $02;
  29. sysfile = $04;
  30. volumeid = $08;
  31. directory = $10;
  32. archive = $20;
  33. anyfile = $3F;
  34. {File Status}
  35. fmclosed = $D7B0;
  36. fminput = $D7B1;
  37. fmoutput = $D7B2;
  38. fminout = $D7B3;
  39. Type
  40. { Needed for Win95 LFN Support }
  41. ComStr = String[255];
  42. PathStr = String[255];
  43. DirStr = String[255];
  44. NameStr = String[255];
  45. ExtStr = String[255];
  46. {
  47. filerec.inc contains the definition of the filerec.
  48. textrec.inc contains the definition of the textrec.
  49. It is in a separate file to make it available in other units without
  50. having to use the DOS unit for it.
  51. }
  52. {$i filerec.inc}
  53. {$i textrec.inc}
  54. DateTime = packed record
  55. Year,
  56. Month,
  57. Day,
  58. Hour,
  59. Min,
  60. Sec : word;
  61. End;
  62. PWin32FindData = ^TWin32FindData;
  63. TWin32FindData = packed record
  64. dwFileAttributes: Cardinal;
  65. ftCreationTime: TFileTime;
  66. ftLastAccessTime: TFileTime;
  67. ftLastWriteTime: TFileTime;
  68. nFileSizeHigh: Cardinal;
  69. nFileSizeLow: Cardinal;
  70. dwReserved0: Cardinal;
  71. dwReserved1: Cardinal;
  72. cFileName: array[0..MAX_PATH - 1] of Char;
  73. cAlternateFileName: array[0..13] of Char;
  74. end;
  75. Searchrec = Packed Record
  76. FindHandle : THandle;
  77. W32FindData : TWin32FindData;
  78. ExcludeAttr : longint;
  79. time : longint;
  80. size : longint;
  81. attr : longint;
  82. name : string;
  83. end;
  84. registers = packed record
  85. case i : integer of
  86. 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
  87. 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
  88. 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
  89. end;
  90. Var
  91. DosError : integer;
  92. {Interrupt}
  93. Procedure Intr(intno: byte; var regs: registers);
  94. Procedure MSDos(var regs: registers);
  95. {Info/Date/Time}
  96. Function DosVersion: Word;
  97. Procedure GetDate(var year, month, mday, wday: word);
  98. Procedure GetTime(var hour, minute, second, sec100: word);
  99. procedure SetDate(year,month,day: word);
  100. Procedure SetTime(hour,minute,second,sec100: word);
  101. Procedure UnpackTime(p: longint; var t: datetime);
  102. Procedure PackTime(var t: datetime; var p: longint);
  103. {Exec}
  104. Procedure Exec(const path: pathstr; const comline: comstr);
  105. Function DosExitCode: word;
  106. {Disk}
  107. Function DiskFree(drive: byte) : longint;
  108. Function DiskSize(drive: byte) : longint;
  109. Procedure FindFirst(const path: pathstr; attr: word; var f: searchRec);
  110. Procedure FindNext(var f: searchRec);
  111. Procedure FindClose(Var f: SearchRec);
  112. {File}
  113. Procedure GetFAttr(var f; var attr: word);
  114. Procedure GetFTime(var f; var time: longint);
  115. Function FSearch(path: pathstr; dirlist: string): pathstr;
  116. Function FExpand(const path: pathstr): pathstr;
  117. Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
  118. {Environment}
  119. Function EnvCount: longint;
  120. Function EnvStr(index: integer): string;
  121. Function GetEnv(envvar: string): string;
  122. {Misc}
  123. Procedure SetFAttr(var f; attr: word);
  124. Procedure SetFTime(var f; time: longint);
  125. Procedure GetCBreak(var breakvalue: boolean);
  126. Procedure SetCBreak(breakvalue: boolean);
  127. Procedure GetVerify(var verify: boolean);
  128. Procedure SetVerify(verify: boolean);
  129. {Do Nothing Functions}
  130. Procedure SwapVectors;
  131. Procedure GetIntVec(intno: byte; var vector: pointer);
  132. Procedure SetIntVec(intno: byte; vector: pointer);
  133. Procedure Keep(exitcode: word);
  134. implementation
  135. uses strings;
  136. {******************************************************************************
  137. --- Conversion ---
  138. ******************************************************************************}
  139. function GetLastError : DWORD;
  140. external 'kernel32' name 'GetLastError';
  141. function FileTimeToDosDateTime(const ft :TFileTime;var data,time : word) : longbool;
  142. external 'kernel32' name 'FileTimeToDosDateTime';
  143. function DosDateTimeToFileTime(date,time : word;var ft :TFileTime) : longbool;
  144. external 'kernel32' name 'DosDateTimeToFileTime';
  145. function FileTimeToLocalFileTime(const ft : TFileTime;var lft : TFileTime) : longbool;
  146. external 'kernel32' name 'FileTimeToLocalFileTime';
  147. function LocalFileTimeToFileTime(const lft : TFileTime;var ft : TFileTime) : longbool;
  148. external 'kernel32' name 'LocalFileTimeToFileTime';
  149. type
  150. Longrec=packed record
  151. lo,hi : word;
  152. end;
  153. function Last2DosError(d:dword):integer;
  154. begin
  155. Last2DosError:=d;
  156. end;
  157. Function DosToWinAttr (Const Attr : Longint) : longint;
  158. begin
  159. DosToWinAttr:=Attr;
  160. end;
  161. Function WinToDosAttr (Const Attr : Longint) : longint;
  162. begin
  163. WinToDosAttr:=Attr;
  164. end;
  165. Function DosToWinTime (DTime:longint;Var Wtime : TFileTime):longbool;
  166. var
  167. lft : TFileTime;
  168. begin
  169. DosToWinTime:=DosDateTimeToFileTime(longrec(dtime).hi,longrec(dtime).lo,lft) and
  170. LocalFileTimeToFileTime(lft,Wtime);
  171. end;
  172. Function WinToDosTime (Const Wtime : TFileTime;var DTime:longint):longbool;
  173. var
  174. lft : TFileTime;
  175. begin
  176. WinToDosTime:=FileTimeToLocalFileTime(WTime,lft) and
  177. FileTimeToDosDateTime(lft,longrec(dtime).hi,longrec(dtime).lo);
  178. end;
  179. {******************************************************************************
  180. --- Dos Interrupt ---
  181. ******************************************************************************}
  182. procedure intr(intno : byte;var regs : registers);
  183. begin
  184. { !!!!!!!! }
  185. end;
  186. procedure msdos(var regs : registers);
  187. begin
  188. { !!!!!!!! }
  189. end;
  190. {******************************************************************************
  191. --- Info / Date / Time ---
  192. ******************************************************************************}
  193. function GetVersion : longint;
  194. external 'kernel32' name 'GetVersion';
  195. procedure GetLocalTime(var t : TSystemTime);
  196. external 'kernel32' name 'GetLocalTime';
  197. function SetLocalTime(const t : TSystemTime) : boolean;
  198. external 'kernel32' name 'SetLocalTime';
  199. function dosversion : word;
  200. begin
  201. dosversion:=GetVersion;
  202. end;
  203. procedure getdate(var year,month,mday,wday : word);
  204. var
  205. t : TSystemTime;
  206. begin
  207. GetLocalTime(t);
  208. year:=t.wYear;
  209. month:=t.wMonth;
  210. mday:=t.wDay;
  211. wday:=t.wDayOfWeek;
  212. end;
  213. procedure setdate(year,month,day : word);
  214. var
  215. t : TSystemTime;
  216. begin
  217. { we need the time set privilege }
  218. { so this function crash currently }
  219. {!!!!!}
  220. GetLocalTime(t);
  221. t.wYear:=year;
  222. t.wMonth:=month;
  223. t.wDay:=day;
  224. { only a quite good solution, we can loose some ms }
  225. SetLocalTime(t);
  226. end;
  227. procedure gettime(var hour,minute,second,sec100 : word);
  228. var
  229. t : TSystemTime;
  230. begin
  231. GetLocalTime(t);
  232. hour:=t.wHour;
  233. minute:=t.wMinute;
  234. second:=t.wSecond;
  235. sec100:=t.wMilliSeconds div 10;
  236. end;
  237. procedure settime(hour,minute,second,sec100 : word);
  238. var
  239. t : TSystemTime;
  240. begin
  241. { we need the time set privilege }
  242. { so this function crash currently }
  243. {!!!!!}
  244. GetLocalTime(t);
  245. t.wHour:=hour;
  246. t.wMinute:=minute;
  247. t.wSecond:=second;
  248. t.wMilliSeconds:=sec100*10;
  249. SetLocalTime(t);
  250. end;
  251. Procedure packtime(var t : datetime;var p : longint);
  252. Begin
  253. 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);
  254. End;
  255. Procedure unpacktime(p : longint;var t : datetime);
  256. Begin
  257. with t do
  258. begin
  259. sec:=(p and 31) shl 1;
  260. min:=(p shr 5) and 63;
  261. hour:=(p shr 11) and 31;
  262. day:=(p shr 16) and 31;
  263. month:=(p shr 21) and 15;
  264. year:=(p shr 25)+1980;
  265. end;
  266. End;
  267. {******************************************************************************
  268. --- Exec ---
  269. ******************************************************************************}
  270. function CreateProcess(lpApplicationName: PChar; lpCommandLine: PChar;
  271. lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
  272. bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
  273. lpCurrentDirectory: PChar; const lpStartupInfo: TStartupInfo;
  274. var lpProcessInformation: TProcessInformation): boolean;
  275. external 'kernel32' name 'CreateProcessA';
  276. function getExitCodeProcess(h:THandle;var code:longint):boolean;
  277. external 'kernel32' name 'GetExitCodeProcess';
  278. function WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD): DWORD;
  279. external 'kernel32' name 'WaitForSingleObject';
  280. function CloseHandle(h : THandle) : longint;
  281. external 'kernel32' name 'CloseHandle';
  282. var
  283. lastdosexitcode : word;
  284. procedure exec(const path : pathstr;const comline : comstr);
  285. var
  286. SI: TStartupInfo;
  287. PI: TProcessInformation;
  288. Proc : THandle;
  289. l : Longint;
  290. AppPath,
  291. AppParam : array[0..255] of char;
  292. begin
  293. FillChar(SI, SizeOf(SI), 0);
  294. SI.cb:=SizeOf(SI);
  295. SI.wShowWindow:=1;
  296. Move(Path[1],AppPath,length(Path));
  297. AppPath[Length(Path)]:=#0;
  298. AppParam[0]:='-';
  299. AppParam[1]:=' ';
  300. Move(ComLine[1],AppParam[2],length(Comline));
  301. AppParam[Length(ComLine)+2]:=#0;
  302. if not CreateProcess(PChar(@AppPath), PChar(@AppParam), Nil, Nil, False,$20, Nil, Nil, SI, PI) then
  303. begin
  304. DosError:=Last2DosError(GetLastError);
  305. exit;
  306. end;
  307. Proc:=PI.hProcess;
  308. CloseHandle(PI.hThread);
  309. if WaitForSingleObject(Proc, Infinite) <> $ffffffff then
  310. GetExitCodeProcess(Proc,l)
  311. else
  312. l:=-1;
  313. CloseHandle(Proc);
  314. LastDosExitCode:=l;
  315. end;
  316. function dosexitcode : word;
  317. begin
  318. dosexitcode:=lastdosexitcode;
  319. end;
  320. procedure getcbreak(var breakvalue : boolean);
  321. begin
  322. { !! No Win32 Function !! }
  323. end;
  324. procedure setcbreak(breakvalue : boolean);
  325. begin
  326. { !! No Win32 Function !! }
  327. end;
  328. procedure getverify(var verify : boolean);
  329. begin
  330. { !! No Win32 Function !! }
  331. end;
  332. procedure setverify(verify : boolean);
  333. begin
  334. { !! No Win32 Function !! }
  335. end;
  336. {******************************************************************************
  337. --- Disk ---
  338. ******************************************************************************}
  339. function GetDiskFreeSpace(drive:pchar;var sector_cluster,bytes_sector,
  340. freeclusters,totalclusters:longint):boolean;
  341. external 'kernel32' name 'GetDiskFreeSpaceA';
  342. function diskfree(drive : byte) : longint;
  343. var
  344. disk : array[1..4] of char;
  345. secs,bytes,
  346. free,total : longint;
  347. begin
  348. if drive=0 then
  349. begin
  350. disk[1]:='\';
  351. disk[2]:=#0;
  352. end
  353. else
  354. begin
  355. disk[1]:=chr(drive+64);
  356. disk[2]:=':';
  357. disk[3]:='\';
  358. disk[4]:=#0;
  359. end;
  360. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  361. diskfree:=free*secs*bytes
  362. else
  363. diskfree:=-1;
  364. end;
  365. function disksize(drive : byte) : longint;
  366. var
  367. disk : array[1..4] of char;
  368. secs,bytes,
  369. free,total : longint;
  370. begin
  371. if drive=0 then
  372. begin
  373. disk[1]:='\';
  374. disk[2]:=#0;
  375. end
  376. else
  377. begin
  378. disk[1]:=chr(drive+64);
  379. disk[2]:=':';
  380. disk[3]:='\';
  381. disk[4]:=#0;
  382. end;
  383. if GetDiskFreeSpace(@disk,secs,bytes,free,total) then
  384. disksize:=total*secs*bytes
  385. else
  386. disksize:=-1;
  387. end;
  388. {******************************************************************************
  389. --- Findfirst FindNext ---
  390. ******************************************************************************}
  391. { Needed kernel calls }
  392. function FindFirstFile (lpFileName: PChar; var lpFindFileData: TWIN32FindData): THandle;
  393. external 'kernel32' name 'FindFirstFileA';
  394. function FindNextFile (hFindFile: THandle; var lpFindFileData: TWIN32FindData): Boolean;
  395. external 'kernel32' name 'FindNextFileA';
  396. function FindCloseFile (hFindFile: THandle): Boolean;
  397. external 'kernel32' name 'FindClose';
  398. Procedure StringToPchar (Var S : String);
  399. Var L : Longint;
  400. begin
  401. L:=ord(S[0]);
  402. Move (S[1],S[0],L);
  403. S[L]:=#0;
  404. end;
  405. procedure FindMatch(var f:searchrec);
  406. Var
  407. TheAttr : Longint;
  408. begin
  409. { Find file with correct attribute }
  410. While (F.W32FindData.dwFileAttributes and F.ExcludeAttr)<>0 do
  411. begin
  412. if not FindNextFile (F.FindHandle,F.W32FindData) then
  413. begin
  414. DosError:=Last2DosError(GetLastError);
  415. exit;
  416. end;
  417. end;
  418. { Convert some attributes back }
  419. f.size:=F.W32FindData.NFileSizeLow;
  420. f.attr:=WinToDosAttr(F.W32FindData.dwFileAttributes);
  421. WinToDosTime(F.W32FindData.ftLastWriteTime,f.Time);
  422. f.Name:=StrPas(@F.W32FindData.cFileName);
  423. end;
  424. procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
  425. begin
  426. { no error }
  427. doserror:=0;
  428. F.Name:=Path;
  429. F.Attr:=attr;
  430. F.ExcludeAttr:=(not Attr) and ($1e); {hidden,sys,dir,volume}
  431. StringToPchar(f.name);
  432. { FindFirstFile is a Win32 Call }
  433. F.FindHandle:=FindFirstFile (pchar(@f.Name),F.W32FindData);
  434. If longint(F.FindHandle)=Invalid_Handle_value then
  435. begin
  436. DosError:=Last2DosError(GetLastError);
  437. exit;
  438. end;
  439. { Find file with correct attribute }
  440. FindMatch(f);
  441. end;
  442. procedure findnext(var f : searchRec);
  443. begin
  444. { no error }
  445. doserror:=0;
  446. if not FindNextFile (F.FindHandle,F.W32FindData) then
  447. begin
  448. DosError:=Last2DosError(GetLastError);
  449. exit;
  450. end;
  451. { Find file with correct attribute }
  452. FindMatch(f);
  453. end;
  454. procedure swapvectors;
  455. begin
  456. end;
  457. Procedure FindClose(Var f: SearchRec);
  458. begin
  459. If longint(F.FindHandle)<>Invalid_Handle_value then
  460. FindCloseFile(F.FindHandle);
  461. end;
  462. {******************************************************************************
  463. --- File ---
  464. ******************************************************************************}
  465. function GetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;
  466. external 'kernel32' name 'GetFileTime';
  467. function SetFileTime(h : longint;creation,lastaccess,lastwrite : PFileTime) : boolean;
  468. external 'kernel32' name 'SetFileTime';
  469. function SetFileAttributes(lpFileName : pchar;dwFileAttributes : longint) : boolean;
  470. external 'kernel32' name 'SetFileAttributesA';
  471. function GetFileAttributes(lpFileName : pchar) : longint;
  472. external 'kernel32' name 'GetFileAttributesA';
  473. procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
  474. var
  475. dotpos,p1,i : longint;
  476. begin
  477. { allow slash as backslash }
  478. for i:=1 to length(path) do
  479. if path[i]='/' then path[i]:='\';
  480. { get drive name }
  481. p1:=pos(':',path);
  482. if p1>0 then
  483. begin
  484. dir:=path[1]+':';
  485. delete(path,1,p1);
  486. end
  487. else
  488. dir:='';
  489. { split the path and the name, there are no more path informtions }
  490. { if path contains no backslashes }
  491. while true do
  492. begin
  493. p1:=pos('\',path);
  494. if p1=0 then
  495. break;
  496. dir:=dir+copy(path,1,p1);
  497. delete(path,1,p1);
  498. end;
  499. { try to find out a extension }
  500. Ext:='';
  501. i:=Length(Path);
  502. DotPos:=256;
  503. While (i>0) Do
  504. Begin
  505. If (Path[i]='.') Then
  506. begin
  507. DotPos:=i;
  508. break;
  509. end;
  510. Dec(i);
  511. end;
  512. Ext:=Copy(Path,DotPos,255);
  513. Name:=Copy(Path,1,DotPos - 1);
  514. end;
  515. function fexpand(const path : pathstr) : pathstr;
  516. var
  517. s,pa : string[79];
  518. i,j : longint;
  519. begin
  520. getdir(0,s);
  521. pa:=upcase(path);
  522. { allow slash as backslash }
  523. for i:=1 to length(pa) do
  524. if pa[i]='/' then
  525. pa[i]:='\';
  526. if (length(pa)>1) and (pa[1] in ['A'..'Z']) and (pa[2]=':') then
  527. begin
  528. { we must get the right directory }
  529. getdir(ord(pa[1])-ord('A')+1,s);
  530. if (ord(pa[0])>2) and (pa[3]<>'\') then
  531. if pa[1]=s[1] then
  532. pa:=s+'\'+copy (pa,3,length(pa))
  533. else
  534. pa:=pa[1]+':\'+copy (pa,3,length(pa))
  535. end
  536. else
  537. if pa[1]='\' then
  538. pa:=s[1]+':'+pa
  539. else if s[0]=#3 then
  540. pa:=s+pa
  541. else
  542. pa:=s+'\'+pa;
  543. { Turbo Pascal gives current dir on drive if only drive given as parameter! }
  544. if length(pa) = 2 then
  545. begin
  546. getdir(byte(pa[1])-64,s);
  547. pa := s;
  548. end;
  549. {First remove all references to '\.\'}
  550. while pos ('\.\',pa)<>0 do
  551. delete (pa,pos('\.\',pa),2);
  552. {Now remove also all references to '\..\' + of course previous dirs..}
  553. repeat
  554. i:=pos('\..\',pa);
  555. if i<>0 then
  556. begin
  557. j:=i-1;
  558. while (j>1) and (pa[j]<>'\') do
  559. dec (j);
  560. if pa[j+1] = ':' then j := 3;
  561. delete (pa,j,i-j+3);
  562. end;
  563. until i=0;
  564. { Turbo Pascal gets rid of a \.. at the end of the path }
  565. { Now remove also any reference to '\..' at end of line
  566. + of course previous dir.. }
  567. i:=pos('\..',pa);
  568. if i<>0 then
  569. begin
  570. if i = length(pa) - 2 then
  571. begin
  572. j:=i-1;
  573. while (j>1) and (pa[j]<>'\') do
  574. dec (j);
  575. delete (pa,j,i-j+3);
  576. end;
  577. pa := pa + '\';
  578. end;
  579. { Remove End . and \}
  580. if (length(pa)>0) and (pa[length(pa)]='.') then
  581. dec(byte(pa[0]));
  582. { if only the drive + a '\' is left then the '\' should be left to prevtn the program
  583. accessing the current directory on the drive rather than the root!}
  584. { if the last char of path = '\' then leave it in as this is what TP does! }
  585. if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
  586. dec(byte(pa[0]));
  587. { if only a drive is given in path then there should be a '\' at the
  588. end of the string given back }
  589. if length(path) = 2 then pa := pa + '\';
  590. fexpand:=pa;
  591. end;
  592. Function FSearch(path: pathstr; dirlist: string): pathstr;
  593. var
  594. i,p1 : longint;
  595. s : searchrec;
  596. newdir : pathstr;
  597. begin
  598. { No wildcards allowed in these things }
  599. if (pos('?',path)<>0) or (pos('*',path)<>0) then
  600. fsearch:=''
  601. else
  602. begin
  603. { allow slash as backslash }
  604. for i:=1 to length(dirlist) do
  605. if dirlist[i]='/' then dirlist[i]:='\';
  606. repeat
  607. p1:=pos(';',dirlist);
  608. if p1=0 then
  609. begin
  610. newdir:=copy(dirlist,1,p1-1);
  611. delete(dirlist,1,p1);
  612. end
  613. else
  614. begin
  615. newdir:=dirlist;
  616. dirlist:='';
  617. end;
  618. if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
  619. newdir:=newdir+'\';
  620. findfirst(newdir+path,anyfile,s);
  621. if doserror=0 then
  622. newdir:=newdir+path
  623. else
  624. newdir:='';
  625. until (dirlist='') or (newdir<>'');
  626. fsearch:=newdir;
  627. end;
  628. end;
  629. procedure getftime(var f;var time : longint);
  630. var
  631. ft : TFileTime;
  632. begin
  633. if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
  634. WinToDosTime(ft,time) then
  635. exit
  636. else
  637. time:=0;
  638. end;
  639. procedure setftime(var f;time : longint);
  640. var
  641. ft : TFileTime;
  642. begin
  643. if DosToWinTime(time,ft) then
  644. SetFileTime(filerec(f).Handle,nil,nil,@ft);
  645. end;
  646. procedure getfattr(var f;var attr : word);
  647. var
  648. l : longint;
  649. begin
  650. l:=GetFileAttributes(filerec(f).name);
  651. if l=$ffffffff then
  652. doserror:=getlasterror;
  653. attr:=l;
  654. end;
  655. procedure setfattr(var f;attr : word);
  656. begin
  657. doserror:=0;
  658. if not(SetFileAttributes(filerec(f).name,attr)) then
  659. doserror:=getlasterror;
  660. end;
  661. {******************************************************************************
  662. --- Environment ---
  663. ******************************************************************************}
  664. {
  665. The environment is a block of zero terminated strings
  666. terminated by a #0
  667. }
  668. function GetEnvironmentStrings : pchar;
  669. external 'kernel32' name 'GetEnvironmentStringsA';
  670. function FreeEnvironmentStrings(p : pchar) : boolean;
  671. external 'kernel32' name 'FreeEnvironmentStringsA';
  672. function envcount : longint;
  673. var
  674. hp,p : pchar;
  675. count : longint;
  676. begin
  677. p:=GetEnvironmentStrings;
  678. hp:=p;
  679. count:=0;
  680. while hp^<>#0 do
  681. begin
  682. { next string entry}
  683. hp:=hp+strlen(hp)+1;
  684. inc(count);
  685. end;
  686. FreeEnvironmentStrings(p);
  687. envcount:=count;
  688. end;
  689. Function EnvStr(index: integer): string;
  690. var
  691. hp,p : pchar;
  692. count,i : longint;
  693. begin
  694. { envcount takes some time in win32 }
  695. count:=envcount;
  696. { range checking }
  697. if (index<=0) or (index>count) then
  698. begin
  699. envstr:='';
  700. exit;
  701. end;
  702. p:=GetEnvironmentStrings;
  703. hp:=p;
  704. { retrive the string with the given index }
  705. for i:=2 to index do
  706. hp:=hp+strlen(hp)+1;
  707. envstr:=strpas(hp);
  708. FreeEnvironmentStrings(p);
  709. end;
  710. Function GetEnv(envvar: string): string;
  711. var
  712. s : string;
  713. i : longint;
  714. hp,p : pchar;
  715. begin
  716. getenv:='';
  717. p:=GetEnvironmentStrings;
  718. hp:=p;
  719. while hp^<>#0 do
  720. begin
  721. s:=strpas(hp);
  722. i:=pos('=',s);
  723. if upcase(copy(s,1,i-1))=upcase(envvar) then
  724. begin
  725. getenv:=copy(s,i+1,length(s)-i);
  726. break;
  727. end;
  728. { next string entry}
  729. hp:=hp+strlen(hp)+1;
  730. end;
  731. FreeEnvironmentStrings(p);
  732. end;
  733. {******************************************************************************
  734. --- Not Supported ---
  735. ******************************************************************************}
  736. Procedure keep(exitcode : word);
  737. Begin
  738. End;
  739. Procedure getintvec(intno : byte;var vector : pointer);
  740. Begin
  741. End;
  742. Procedure setintvec(intno : byte;vector : pointer);
  743. Begin
  744. End;
  745. end.
  746. {
  747. $Log$
  748. Revision 1.12 1998-10-27 10:55:55 michael
  749. * environment vars are case insensitive under WinNT/DOS
  750. Revision 1.11 1998/10/22 15:32:38 pierre
  751. * fsplit adapted to long filenames
  752. Revision 1.10 1998/10/16 14:20:06 peter
  753. * removed writelns
  754. Revision 1.9 1998/10/16 08:55:26 peter
  755. * findfirst is now more delphi alike
  756. Revision 1.8 1998/08/16 09:12:11 michael
  757. Corrected fexpand behaviour.
  758. Revision 1.7 1998/06/10 10:39:13 peter
  759. * working w32 rtl
  760. Revision 1.6 1998/06/08 23:07:45 peter
  761. * dos interface is now 100% compatible
  762. * fixed call PASCALMAIN which must be direct asm
  763. Revision 1.5 1998/05/06 12:36:50 michael
  764. + Removed log from before restored version.
  765. Revision 1.4 1998/04/27 14:01:38 florian
  766. * was uncompilable
  767. Revision 1.3 1998/04/26 22:37:02 florian
  768. + getftime, unpacktime, packtime
  769. Revision 1.2 1998/04/26 21:49:09 florian
  770. + first compiling and working version
  771. }