dos.pp 22 KB

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