dos.pp 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Michael Van Canneyt and Peter Vreman,
  5. members of the Free Pascal development team
  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. Type
  15. SearchRec =
  16. {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
  17. packed
  18. {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
  19. Record
  20. {Fill : array[1..21] of byte; Fill replaced with below}
  21. SearchNum : LongInt; {to track which search this is}
  22. SearchPos : LongInt; {directory position}
  23. DirPtr : Pointer; {directory pointer for reading directory}
  24. SearchType : Byte; {0=normal, 1=open will close, 2=only 1 file}
  25. SearchAttr : Byte; {attribute we are searching for}
  26. Fill : Array[1..07] of Byte; {future use}
  27. {End of fill}
  28. Attr : Byte; {attribute of found file}
  29. Time : LongInt; {last modify date of found file}
  30. Size : LongInt; {file size of found file}
  31. Reserved : Word; {future use}
  32. Name : String[FileNameLen]; {name of found file}
  33. SearchSpec : String[FileNameLen]; {search pattern}
  34. NamePos : Word; {end of path, start of name position}
  35. End;
  36. {$i dosh.inc}
  37. {Extra Utils}
  38. function weekday(y,m,d : longint) : longint;
  39. Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime);
  40. Function DTToUnixDate(DT: DateTime): LongInt;
  41. {Disk}
  42. Procedure AddDisk(const path:string);
  43. Implementation
  44. Uses
  45. Strings,Unix,BaseUnix,{$ifdef FPC_USE_LIBC}initc{$ELSE}Syscall{$ENDIF};
  46. {$DEFINE HAS_GETMSCOUNT}
  47. {$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
  48. {$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
  49. {$I dos.inc}
  50. {$ifndef FPC_USE_LIBC}
  51. {$i sysnr.inc}
  52. {$endif}
  53. {$i settimeo.inc}
  54. {******************************************************************************
  55. --- Link C Lib if set ---
  56. ******************************************************************************}
  57. type
  58. RtlInfoType = Record
  59. FMode,
  60. FInode,
  61. FUid,
  62. FGid,
  63. FSize,
  64. FMTime : LongInt;
  65. End;
  66. {******************************************************************************
  67. --- Info / Date / Time ---
  68. ******************************************************************************}
  69. Const
  70. {Date Calculation}
  71. C1970 = 2440588;
  72. D0 = 1461;
  73. D1 = 146097;
  74. D2 = 1721119;
  75. type
  76. GTRec = packed Record
  77. Year,
  78. Month,
  79. MDay,
  80. WDay,
  81. Hour,
  82. Minute,
  83. Second : Word;
  84. End;
  85. Function GregorianToJulian(Year,Month,Day:Longint):LongInt;
  86. Var
  87. Century,XYear: LongInt;
  88. Begin
  89. If Month<=2 Then
  90. Begin
  91. Dec(Year);
  92. Inc(Month,12);
  93. End;
  94. Dec(Month,3);
  95. Century:=(longint(Year Div 100)*D1) shr 2;
  96. XYear:=(longint(Year Mod 100)*D0) shr 2;
  97. GregorianToJulian:=((((Month*153)+2) div 5)+Day)+D2+XYear+Century;
  98. End;
  99. Function LocalToEpoch(year,month,day,hour,minute,second:Word):Longint;
  100. {
  101. Transforms local time (year,month,day,hour,minutes,second) to Epoch time
  102. (seconds since 00:00, january 1 1970, corrected for local time zone)
  103. }
  104. Begin
  105. LocalToEpoch:=((GregorianToJulian(Year,Month,Day)-c1970)*86400)+
  106. (LongInt(Hour)*3600)+(Longint(Minute)*60)+Second-TZSeconds;
  107. End;
  108. Procedure JulianToGregorian(JulianDN:LongInt;Var Year,Month,Day:Word);
  109. Var
  110. YYear,XYear,Temp,TempMonth : LongInt;
  111. Begin
  112. Temp:=((JulianDN-D2) shl 2)-1;
  113. JulianDN:=Temp Div D1;
  114. XYear:=(Temp Mod D1) or 3;
  115. YYear:=(XYear Div D0);
  116. Temp:=((((XYear mod D0)+4) shr 2)*5)-3;
  117. Day:=((Temp Mod 153)+5) Div 5;
  118. TempMonth:=Temp Div 153;
  119. If TempMonth>=10 Then
  120. Begin
  121. inc(YYear);
  122. dec(TempMonth,12);
  123. End;
  124. inc(TempMonth,3);
  125. Month := TempMonth;
  126. Year:=YYear+(JulianDN*100);
  127. end;
  128. Procedure EpochToLocal(epoch:longint;var year,month,day,hour,minute,second:Word);
  129. {
  130. Transforms Epoch time into local time (hour, minute,seconds)
  131. }
  132. Var
  133. DateNum: LongInt;
  134. Begin
  135. inc(Epoch,TZSeconds);
  136. Datenum:=(Epoch Div 86400) + c1970;
  137. JulianToGregorian(DateNum,Year,Month,day);
  138. Epoch:=Abs(Epoch Mod 86400);
  139. Hour:=Epoch Div 3600;
  140. Epoch:=Epoch Mod 3600;
  141. Minute:=Epoch Div 60;
  142. Second:=Epoch Mod 60;
  143. End;
  144. Function DosVersion:Word;
  145. Var
  146. Buffer : Array[0..255] of Char;
  147. Tmp2,
  148. TmpStr : String[40];
  149. TmpPos,
  150. SubRel,
  151. Rel : LongInt;
  152. info : utsname;
  153. Begin
  154. FPUName(info);
  155. Move(info.release,buffer[0],40);
  156. TmpStr:=StrPas(Buffer);
  157. SubRel:=0;
  158. TmpPos:=Pos('.',TmpStr);
  159. if TmpPos>0 then
  160. begin
  161. Tmp2:=Copy(TmpStr,TmpPos+1,40);
  162. Delete(TmpStr,TmpPos,40);
  163. end;
  164. TmpPos:=Pos('.',Tmp2);
  165. if TmpPos>0 then
  166. Delete(Tmp2,TmpPos,40);
  167. Val(TmpStr,Rel);
  168. Val(Tmp2,SubRel);
  169. DosVersion:=Rel+(SubRel shl 8);
  170. End;
  171. function WeekDay (y,m,d:longint):longint;
  172. {
  173. Calculates th day of the week. returns -1 on error
  174. }
  175. var
  176. u,v : longint;
  177. begin
  178. if (m<1) or (m>12) or (y<1600) or (y>4000) or
  179. (d<1) or (d>30+((m+ord(m>7)) and 1)-ord(m=2)) or
  180. ((m*d=58) and (((y mod 4>0) or (y mod 100=0)) and (y mod 400>0))) then
  181. WeekDay:=-1
  182. else
  183. begin
  184. u:=m;
  185. v:=y;
  186. if m<3 then
  187. begin
  188. inc(u,12);
  189. dec(v);
  190. end;
  191. WeekDay:=(d+2*u+((3*(u+1)) div 5)+v+(v div 4)-(v div 100)+(v div 400)+1) mod 7;
  192. end;
  193. end;
  194. Procedure GetDate(Var Year, Month, MDay, WDay: Word);
  195. var
  196. tz:timeval;
  197. hour,min,sec : word;
  198. begin
  199. fpgettimeofday(@tz,nil);
  200. EpochToLocal(tz.tv_sec,year,month,mday,hour,min,sec);
  201. Wday:=weekday(Year,Month,MDay);
  202. end;
  203. procedure SetTime(Hour,Minute,Second,sec100:word);
  204. var
  205. dow,Year, Month, Day : Word;
  206. tv : timeval;
  207. begin
  208. GetDate (Year, Month, Day,dow);
  209. tv.tv_sec:= LocalToEpoch ( Year, Month, Day, Hour, Minute, Second ) ;
  210. fpSettimeofday(@tv,nil);
  211. end;
  212. procedure SetDate(Year,Month,Day:Word);
  213. var
  214. Hour, Min, Sec, Sec100 : Word;
  215. tv : timeval;
  216. begin
  217. GetTime ( Hour, Min, Sec, Sec100 );
  218. tv.tv_sec:= LocalToEpoch ( Year, Month, Day, Hour, Min, Sec ) ;
  219. fpSettimeofday(@tv,nil);
  220. end;
  221. Function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean;
  222. var
  223. tv : timeval;
  224. begin
  225. tv.tv_sec:= LocalToEpoch ( Year, Month, Day, Hour, Minute, Second ) ;
  226. SetDatetime:=fpSettimeofday(@tv,nil)=0;
  227. end;
  228. Procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
  229. var
  230. tz:timeval;
  231. year,month,day : word;
  232. begin
  233. fpgettimeofday(@tz,nil);
  234. EpochToLocal(tz.tv_sec,year,month,day,hour,minute,second);
  235. sec100:=tz.tv_usec div 10000;
  236. end;
  237. Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime);
  238. Begin
  239. EpochToLocal(SecsPast,dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec);
  240. End;
  241. Function DTToUnixDate(DT: DateTime): LongInt;
  242. Begin
  243. DTToUnixDate:=LocalToEpoch(dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec);
  244. End;
  245. function GetMsCount: int64;
  246. var
  247. tv : TimeVal;
  248. { tz : TimeZone;}
  249. begin
  250. FPGetTimeOfDay (@tv, nil {,tz});
  251. GetMsCount := tv.tv_Sec * 1000 + tv.tv_uSec div 1000;
  252. end;
  253. {******************************************************************************
  254. --- Exec ---
  255. ******************************************************************************}
  256. Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
  257. var
  258. pid : longint; // pid_t?
  259. cmdline2 : ppchar;
  260. commandline : ansistring;
  261. realpath : ansistring;
  262. // The Error-Checking in the previous Version failed, since halt($7F) gives an WaitPid-status of $7F00
  263. Begin
  264. LastDosExitCode:=0;
  265. pid:=fpFork;
  266. if pid=0 then
  267. begin
  268. cmdline2:=nil;
  269. realpath:=path;
  270. if Comline<>'' Then
  271. begin
  272. CommandLine:=ComLine; // conversion must live till after fpexec!
  273. cmdline2:=StringtoPPChar(CommandLine,1);
  274. cmdline2^:=pchar(realPath);
  275. end
  276. else
  277. begin
  278. getmem(cmdline2,2*sizeof(pchar));
  279. cmdline2^:=pchar(realPath);
  280. cmdline2[1]:=nil;
  281. end;
  282. {The child does the actual exec, and then exits}
  283. fpExecv(pchar(realPath),cmdline2);
  284. {If the execve fails, we return an exitvalue of 127, to let it be known}
  285. fpExit(127);
  286. end
  287. else
  288. if pid=-1 then {Fork failed}
  289. begin
  290. DosError:=8;
  291. exit
  292. end;
  293. {We're in the parent, let's wait.}
  294. LastDosExitCode:=WaitProcess(pid); // WaitPid and result-convert
  295. if (LastDosExitCode>=0) and (LastDosExitCode<>127) then
  296. DosError:=0
  297. else
  298. DosError:=8; // perhaps one time give an better error
  299. End;
  300. {******************************************************************************
  301. --- Disk ---
  302. ******************************************************************************}
  303. {
  304. The Diskfree and Disksize functions need a file on the specified drive, since this
  305. is required for the statfs system call.
  306. These filenames are set in drivestr[0..26], and have been preset to :
  307. 0 - '.' (default drive - hence current dir is ok.)
  308. 1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
  309. 2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
  310. 3 - '/' (C: equivalent of dos is the root partition)
  311. 4..26 (can be set by you're own applications)
  312. ! Use AddDisk() to Add new drives !
  313. They both return -1 when a failure occurs.
  314. }
  315. Const
  316. FixDriveStr : array[0..3] of pchar=(
  317. '.',
  318. '/fd0/.',
  319. '/fd1/.',
  320. '/.'
  321. );
  322. const
  323. Drives : byte = 4;
  324. var
  325. DriveStr : array[4..26] of pchar;
  326. Procedure AddDisk(const path:string);
  327. begin
  328. if not (DriveStr[Drives]=nil) then
  329. FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
  330. GetMem(DriveStr[Drives],length(Path)+1);
  331. StrPCopy(DriveStr[Drives],path);
  332. inc(Drives);
  333. if Drives>26 then
  334. Drives:=4;
  335. end;
  336. Function DiskFree(Drive: Byte): int64;
  337. var
  338. fs : tstatfs;
  339. Begin
  340. if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (StatFS(fixdrivestr[drive],fs)<>-1)) or
  341. ((not (drivestr[Drive]=nil)) and (StatFS(drivestr[drive],fs)<>-1)) then
  342. Diskfree:=int64(fs.bavail)*int64(fs.bsize)
  343. else
  344. Diskfree:=-1;
  345. End;
  346. Function DiskSize(Drive: Byte): int64;
  347. var
  348. fs : tstatfs;
  349. Begin
  350. if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and (StatFS(fixdrivestr[drive],fs)<>-1)) or
  351. ((not (drivestr[Drive]=nil)) and (StatFS(drivestr[drive],fs)<>-1)) then
  352. DiskSize:=int64(fs.blocks)*int64(fs.bsize)
  353. else
  354. DiskSize:=-1;
  355. End;
  356. {******************************************************************************
  357. --- Findfirst FindNext ---
  358. ******************************************************************************}
  359. Function FNMatch(const Pattern,Name:string):Boolean;
  360. Var
  361. LenPat,LenName : longint;
  362. Function DoFNMatch(i,j:longint):Boolean;
  363. Var
  364. Found : boolean;
  365. Begin
  366. Found:=true;
  367. While Found and (i<=LenPat) Do
  368. Begin
  369. Case Pattern[i] of
  370. '?' : Found:=(j<=LenName);
  371. '*' : Begin
  372. {find the next character in pattern, different of ? and *}
  373. while Found do
  374. begin
  375. inc(i);
  376. if i>LenPat then Break;
  377. case Pattern[i] of
  378. '*' : ;
  379. '?' : begin
  380. if j>LenName then begin DoFNMatch:=false; Exit; end;
  381. inc(j);
  382. end;
  383. else
  384. Found:=false;
  385. end;
  386. end;
  387. Assert((i>LenPat) or ( (Pattern[i]<>'*') and (Pattern[i]<>'?') ));
  388. {Now, find in name the character which i points to, if the * or ?
  389. wasn't the last character in the pattern, else, use up all the
  390. chars in name}
  391. Found:=false;
  392. if (i<=LenPat) then
  393. begin
  394. repeat
  395. {find a letter (not only first !) which maches pattern[i]}
  396. while (j<=LenName) and (name[j]<>pattern[i]) do
  397. inc (j);
  398. if (j<LenName) then
  399. begin
  400. if DoFnMatch(i+1,j+1) then
  401. begin
  402. i:=LenPat;
  403. j:=LenName;{we can stop}
  404. Found:=true;
  405. Break;
  406. end else
  407. inc(j);{We didn't find one, need to look further}
  408. end else
  409. if j=LenName then
  410. begin
  411. Found:=true;
  412. Break;
  413. end;
  414. { This 'until' condition must be j>LenName, not j>=LenName.
  415. That's because when we 'need to look further' and
  416. j = LenName then loop must not terminate. }
  417. until (j>LenName);
  418. end else
  419. begin
  420. j:=LenName;{we can stop}
  421. Found:=true;
  422. end;
  423. end;
  424. else {not a wildcard character in pattern}
  425. Found:=(j<=LenName) and (pattern[i]=name[j]);
  426. end;
  427. inc(i);
  428. inc(j);
  429. end;
  430. DoFnMatch:=Found and (j>LenName);
  431. end;
  432. Begin {start FNMatch}
  433. LenPat:=Length(Pattern);
  434. LenName:=Length(Name);
  435. FNMatch:=DoFNMatch(1,1);
  436. End;
  437. Const
  438. RtlFindSize = 15;
  439. Type
  440. RtlFindRecType = Record
  441. DirPtr : Pointer;
  442. SearchNum,
  443. LastUsed : LongInt;
  444. End;
  445. Var
  446. RtlFindRecs : Array[1..RtlFindSize] of RtlFindRecType;
  447. CurrSearchNum : LongInt;
  448. Procedure FindClose(Var f: SearchRec);
  449. {
  450. Closes dirptr if it is open
  451. }
  452. Var
  453. i : longint;
  454. Begin
  455. if f.SearchType=0 then
  456. begin
  457. i:=1;
  458. repeat
  459. if (RtlFindRecs[i].SearchNum=f.SearchNum) then
  460. break;
  461. inc(i);
  462. until (i>RtlFindSize);
  463. If i<=RtlFindSize Then
  464. Begin
  465. RtlFindRecs[i].SearchNum:=0;
  466. if f.dirptr<>nil then
  467. fpclosedir(pdir(f.dirptr)^);
  468. End;
  469. end;
  470. f.dirptr:=nil;
  471. End;
  472. Function FindGetFileInfo(const s:string;var f:SearchRec):boolean;
  473. var
  474. DT : DateTime;
  475. Info : RtlInfoType;
  476. st : baseunix.stat;
  477. begin
  478. FindGetFileInfo:=false;
  479. if not fpstat(s,st)>=0 then
  480. exit;
  481. info.FSize:=st.st_Size;
  482. info.FMTime:=st.st_mtime;
  483. if (st.st_mode and STAT_IFMT)=STAT_IFDIR then
  484. info.fmode:=$10
  485. else
  486. info.fmode:=$0;
  487. if (st.st_mode and STAT_IWUSR)=0 then
  488. info.fmode:=info.fmode or 1;
  489. if s[f.NamePos+1]='.' then
  490. info.fmode:=info.fmode or $2;
  491. If ((Info.FMode and Not(f.searchattr))=0) Then
  492. Begin
  493. f.Name:=Copy(s,f.NamePos+1,255);
  494. f.Attr:=Info.FMode;
  495. f.Size:=Info.FSize;
  496. UnixDateToDT(Info.FMTime, DT);
  497. PackTime(DT,f.Time);
  498. FindGetFileInfo:=true;
  499. End;
  500. end;
  501. Function FindLastUsed: Longint;
  502. {
  503. Find unused or least recently used dirpointer slot in findrecs array
  504. }
  505. Var
  506. BestMatch,i : Longint;
  507. Found : Boolean;
  508. Begin
  509. BestMatch:=1;
  510. i:=1;
  511. Found:=False;
  512. While (i <= RtlFindSize) And (Not Found) Do
  513. Begin
  514. If (RtlFindRecs[i].SearchNum = 0) Then
  515. Begin
  516. BestMatch := i;
  517. Found := True;
  518. End
  519. Else
  520. Begin
  521. If RtlFindRecs[i].LastUsed > RtlFindRecs[BestMatch].LastUsed Then
  522. BestMatch := i;
  523. End;
  524. Inc(i);
  525. End;
  526. FindLastUsed := BestMatch;
  527. End;
  528. Procedure FindNext(Var f: SearchRec);
  529. {
  530. re-opens dir if not already in array and calls FindWorkProc
  531. }
  532. Var
  533. DirName : Array[0..256] of Char;
  534. i,
  535. ArrayPos : Longint;
  536. FName,
  537. SName : string;
  538. Found,
  539. Finished : boolean;
  540. p : pdirent;
  541. Begin
  542. If f.SearchType=0 Then
  543. Begin
  544. ArrayPos:=0;
  545. For i:=1 to RtlFindSize Do
  546. Begin
  547. If RtlFindRecs[i].SearchNum = f.SearchNum Then
  548. ArrayPos:=i;
  549. Inc(RtlFindRecs[i].LastUsed);
  550. End;
  551. If ArrayPos=0 Then
  552. Begin
  553. If f.NamePos = 0 Then
  554. Begin
  555. DirName[0] := '.';
  556. DirName[1] := '/';
  557. DirName[2] := #0;
  558. End
  559. Else
  560. Begin
  561. Move(f.SearchSpec[1], DirName[0], f.NamePos);
  562. DirName[f.NamePos] := #0;
  563. End;
  564. f.DirPtr := fpopendir(@(DirName));
  565. If f.DirPtr <> nil Then
  566. begin
  567. ArrayPos:=FindLastUsed;
  568. If RtlFindRecs[ArrayPos].SearchNum > 0 Then
  569. FpCloseDir((pdir(rtlfindrecs[arraypos].dirptr)^));
  570. RtlFindRecs[ArrayPos].SearchNum := f.SearchNum;
  571. RtlFindRecs[ArrayPos].DirPtr := f.DirPtr;
  572. if f.searchpos>0 then
  573. seekdir(pdir(f.dirptr), f.searchpos);
  574. end;
  575. End;
  576. if ArrayPos>0 then
  577. RtlFindRecs[ArrayPos].LastUsed:=0;
  578. end;
  579. {Main loop}
  580. SName:=Copy(f.SearchSpec,f.NamePos+1,255);
  581. Found:=False;
  582. Finished:=(f.dirptr=nil);
  583. While Not Finished Do
  584. Begin
  585. p:=fpreaddir(pdir(f.dirptr)^);
  586. if p=nil then
  587. FName:=''
  588. else
  589. FName:=Strpas(@p^.d_name);
  590. If FName='' Then
  591. Finished:=True
  592. Else
  593. Begin
  594. If FNMatch(SName,FName) Then
  595. Begin
  596. Found:=FindGetFileInfo(Copy(f.SearchSpec,1,f.NamePos)+FName,f);
  597. if Found then
  598. Finished:=true;
  599. End;
  600. End;
  601. End;
  602. {Shutdown}
  603. If Found Then
  604. Begin
  605. f.searchpos:=telldir(pdir(f.dirptr));
  606. DosError:=0;
  607. End
  608. Else
  609. Begin
  610. FindClose(f);
  611. DosError:=18;
  612. End;
  613. End;
  614. Procedure FindFirst(Const Path: PathStr; Attr: Word; Var f: SearchRec);
  615. {
  616. opens dir and calls FindWorkProc
  617. }
  618. Begin
  619. fillchar(f,sizeof(f),0);
  620. if Path='' then
  621. begin
  622. DosError:=3;
  623. exit;
  624. end;
  625. {Create Info}
  626. f.SearchSpec := Path;
  627. {We always also search for readonly and archive, regardless of Attr:}
  628. f.SearchAttr := Attr or archive or readonly;
  629. f.SearchPos := 0;
  630. f.NamePos := Length(f.SearchSpec);
  631. while (f.NamePos>0) and (f.SearchSpec[f.NamePos]<>'/') do
  632. dec(f.NamePos);
  633. {Wildcards?}
  634. if (Pos('?',Path)=0) and (Pos('*',Path)=0) then
  635. begin
  636. if FindGetFileInfo(Path,f) then
  637. DosError:=0
  638. else
  639. begin
  640. { According to tdos2 test it should return 18
  641. if ErrNo=Sys_ENOENT then
  642. DosError:=3
  643. else }
  644. DosError:=18;
  645. end;
  646. f.DirPtr:=nil;
  647. f.SearchType:=1;
  648. f.searchnum:=-1;
  649. end
  650. else
  651. {Find Entry}
  652. begin
  653. Inc(CurrSearchNum);
  654. f.SearchNum:=CurrSearchNum;
  655. f.SearchType:=0;
  656. FindNext(f);
  657. end;
  658. End;
  659. {******************************************************************************
  660. --- File ---
  661. ******************************************************************************}
  662. Function FSearch(path : pathstr;dirlist : string) : pathstr;
  663. Var
  664. info : BaseUnix.stat;
  665. Begin
  666. if (length(Path)>0) and (path[1]='/') and (fpStat(path,info)>=0) then
  667. FSearch:=path
  668. else
  669. FSearch:=Unix.FSearch(path,dirlist);
  670. End;
  671. Procedure GetFAttr(var f; var attr : word);
  672. Var
  673. info : baseunix.stat;
  674. LinAttr : longint;
  675. Begin
  676. DosError:=0;
  677. if FPStat(@textrec(f).name,info)<0 then
  678. begin
  679. Attr:=0;
  680. DosError:=3;
  681. exit;
  682. end
  683. else
  684. LinAttr:=Info.st_Mode;
  685. if fpS_ISDIR(LinAttr) then
  686. Attr:=$10
  687. else
  688. Attr:=$0;
  689. if fpAccess(@textrec(f).name,W_OK)<0 then
  690. Attr:=Attr or $1;
  691. if filerec(f).name[0]='.' then
  692. Attr:=Attr or $2;
  693. end;
  694. Procedure getftime (var f; var time : longint);
  695. Var
  696. Info: baseunix.stat;
  697. DT: DateTime;
  698. Begin
  699. doserror:=0;
  700. if fpfstat(filerec(f).handle,info)<0 then
  701. begin
  702. Time:=0;
  703. doserror:=6;
  704. exit
  705. end
  706. else
  707. UnixDateToDT(Info.st_mTime,DT);
  708. PackTime(DT,Time);
  709. End;
  710. Procedure setftime(var f; time : longint);
  711. Var
  712. utim: utimbuf;
  713. DT: DateTime;
  714. Begin
  715. doserror:=0;
  716. with utim do
  717. begin
  718. actime:=fptime;
  719. UnPackTime(Time,DT);
  720. modtime:=DTToUnixDate(DT);
  721. end;
  722. if fputime(@filerec(f).name,@utim)<0 then
  723. begin
  724. Time:=0;
  725. doserror:=3;
  726. end;
  727. End;
  728. {******************************************************************************
  729. --- Environment ---
  730. ******************************************************************************}
  731. Function EnvCount: Longint;
  732. var
  733. envcnt : longint;
  734. p : ppchar;
  735. Begin
  736. envcnt:=0;
  737. p:=envp; {defined in syslinux}
  738. while (p^<>nil) do
  739. begin
  740. inc(envcnt);
  741. inc(p);
  742. end;
  743. EnvCount := envcnt
  744. End;
  745. Function EnvStr (Index: longint): String;
  746. Var
  747. i : longint;
  748. p : ppchar;
  749. Begin
  750. if Index <= 0 then
  751. envstr:=''
  752. else
  753. begin
  754. p:=envp; {defined in syslinux}
  755. i:=1;
  756. while (i<Index) and (p^<>nil) do
  757. begin
  758. inc(i);
  759. inc(p);
  760. end;
  761. if p=nil then
  762. envstr:=''
  763. else
  764. envstr:=strpas(p^)
  765. end;
  766. end;
  767. Function GetEnv(EnvVar: String): String;
  768. var
  769. p : pchar;
  770. Begin
  771. p:=BaseUnix.fpGetEnv(EnvVar);
  772. if p=nil then
  773. GetEnv:=''
  774. else
  775. GetEnv:=StrPas(p);
  776. End;
  777. Procedure setfattr (var f;attr : word);
  778. Begin
  779. {! No Unix equivalent !}
  780. { Fail for setting VolumeId }
  781. if (attr and VolumeID)<>0 then
  782. doserror:=5;
  783. End;
  784. {******************************************************************************
  785. --- Initialization ---
  786. ******************************************************************************}
  787. End.
  788. {
  789. $Log$
  790. Revision 1.40 2004-12-05 16:44:43 hajny
  791. * GetMsCount added, platform independent routines moved to single include file
  792. Revision 1.39 2004/12/02 18:24:35 marco
  793. * fpsettimeofday.
  794. Revision 1.38 2004/10/31 17:11:52 marco
  795. * FPC_USE_LIBC fixes
  796. Revision 1.37 2004/10/31 16:20:58 peter
  797. * remove sysutils
  798. Revision 1.36 2004/10/30 20:55:54 marco
  799. * unix interface cleanup
  800. Revision 1.35 2004/09/25 15:09:57 peter
  801. * remove strpas() before syscalls so it chooses the pchar overload
  802. Revision 1.34 2004/08/14 14:22:17 florian
  803. * alignment for sparc fixed
  804. Revision 1.33 2004/07/25 22:46:34 olle
  805. * envstr now returns empty string when index out of bounds
  806. Revision 1.32 2004/03/14 18:42:39 peter
  807. * reset searchrec info in findfirst
  808. Revision 1.31 2004/03/04 22:15:16 marco
  809. * UnixType changes. Please report problems to me.
  810. Revision 1.30 2004/02/18 22:00:45 peter
  811. * dirptr changed to pointer
  812. Revision 1.29 2004/02/18 19:08:27 florian
  813. * fixed bootstrapping with 1.9.2
  814. Revision 1.28 2004/02/17 17:37:26 daniel
  815. * Enable threadvars again
  816. Revision 1.27 2004/02/16 22:18:44 hajny
  817. * LastDosExitCode changed back from threadvar temporarily
  818. Revision 1.26 2004/02/15 21:36:10 hajny
  819. * overloaded ExecuteProcess added, EnvStr param changed to longint
  820. Revision 1.25 2004/02/09 17:01:28 marco
  821. * fixes to get it working under FreeBSD, and probably Linux too
  822. Revision 1.24 2004/02/09 12:03:16 michael
  823. + Switched to single interface in dosh.inc
  824. Revision 1.23 2004/01/31 16:15:14 florian
  825. * packing of searchrec for arm fixed
  826. Revision 1.22 2003/12/29 21:15:04 jonas
  827. * fixed setftime (sorry Marco :)
  828. Revision 1.21 2003/12/03 20:17:03 olle
  829. * files are not pretended to have attr ARCHIVED anymore
  830. + FindFirst etc now also filters on attr HIDDEN
  831. * files with attr READONLY and ARCHIVE are always returned by FindFirst etc
  832. Revision 1.19 2003/10/17 22:13:30 olle
  833. * changed i386 to cpui386
  834. Revision 1.18 2003/09/27 12:51:33 peter
  835. * fpISxxx macros renamed to C compliant fpS_ISxxx
  836. Revision 1.17 2003/09/17 17:30:46 marco
  837. * Introduction of unixutil
  838. Revision 1.16 2003/09/14 20:15:01 marco
  839. * Unix reform stage two. Remove all calls from Unix that exist in Baseunix.
  840. Revision 1.15 2003/05/16 20:56:06 florian
  841. no message
  842. Revision 1.14 2003/05/14 13:51:03 florian
  843. * ifdef'd code which i386 specific
  844. Revision 1.13 2002/12/08 16:05:34 peter
  845. * small error code fixes so tdos2 passes
  846. Revision 1.12 2002/09/07 16:01:27 peter
  847. * old logs removed and tabs fixed
  848. }