cfileutl.pas 36 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl and Peter Vreman
  3. This module provides some basic file/dir handling utils and classes
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  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. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit cfileutl;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. {$ifdef hasunix}
  22. Baseunix,unix,
  23. {$endif hasunix}
  24. {$ifdef win32}
  25. Windows,
  26. {$endif win32}
  27. {$if defined(go32v2) or defined(watcom)}
  28. Dos,
  29. {$endif}
  30. {$IFNDEF USE_FAKE_SYSUTILS}
  31. SysUtils,
  32. {$ELSE}
  33. fksysutl,
  34. {$ENDIF}
  35. GlobType,
  36. CUtils,CClasses,
  37. Systems;
  38. type
  39. TCachedDirectory = class(TFPHashObject)
  40. private
  41. FDirectoryEntries : TFPHashList;
  42. procedure FreeDirectoryEntries;
  43. function GetItemAttr(const AName: TCmdStr): byte;
  44. public
  45. constructor Create(AList:TFPHashObjectList;const AName:TCmdStr);
  46. destructor destroy;override;
  47. procedure Reload;
  48. function FileExists(const AName:TCmdStr):boolean;
  49. function FileExistsCaseAware(const AName:TCmdStr; out FoundName: TCmdStr):boolean;
  50. function DirectoryExists(const AName:TCmdStr):boolean;
  51. property DirectoryEntries:TFPHashList read FDirectoryEntries;
  52. end;
  53. TCachedSearchRec = record
  54. Name : TCmdStr;
  55. Attr : byte;
  56. Pattern : TCmdStr;
  57. CachedDir : TCachedDirectory;
  58. EntryIndex : longint;
  59. end;
  60. PCachedDirectoryEntry = ^TCachedDirectoryEntry;
  61. TCachedDirectoryEntry = record
  62. RealName: TCmdStr;
  63. Attr : byte;
  64. end;
  65. TDirectoryCache = class
  66. private
  67. FDirectories : TFPHashObjectList;
  68. function GetDirectory(const ADir:TCmdStr):TCachedDirectory;
  69. public
  70. constructor Create;
  71. destructor destroy;override;
  72. function FileExists(const AName:TCmdStr):boolean;
  73. function FileExistsCaseAware(const AName:TCmdStr; out FoundName: TCmdStr):boolean;
  74. function DirectoryExists(const AName:TCmdStr):boolean;
  75. function FindFirst(const APattern:TCmdStr;var Res:TCachedSearchRec):boolean;
  76. function FindNext(var Res:TCachedSearchRec):boolean;
  77. function FindClose(var Res:TCachedSearchRec):boolean;
  78. end;
  79. TSearchPathList = class(TCmdStrList)
  80. procedure AddPath(s:TCmdStr;addfirst:boolean);overload;
  81. procedure AddPath(SrcPath,s:TCmdStr;addfirst:boolean);overload;
  82. procedure AddList(list:TSearchPathList;addfirst:boolean);
  83. function FindFile(const f : TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  84. end;
  85. function bstoslash(const s : TCmdStr) : TCmdStr;
  86. {Gives the absolute path to the current directory}
  87. function GetCurrentDir:TCmdStr;
  88. {Gives the relative path to the current directory,
  89. with a trailing dir separator. E. g. on unix ./ }
  90. function CurDirRelPath(systeminfo: tsysteminfo): TCmdStr;
  91. function path_absolute(const s : TCmdStr) : boolean;
  92. Function PathExists (const F : TCmdStr;allowcache:boolean) : Boolean;
  93. Function FileExists (const F : TCmdStr;allowcache:boolean) : Boolean;
  94. function FileExistsNonCase(const path,fn:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  95. Function RemoveDir(d:TCmdStr):boolean;
  96. Function FixPath(s:TCmdStr;allowdot:boolean):TCmdStr;
  97. function FixFileName(const s:TCmdStr):TCmdStr;
  98. function TargetFixPath(s:TCmdStr;allowdot:boolean):TCmdStr;
  99. function TargetFixFileName(const s:TCmdStr):TCmdStr;
  100. procedure SplitBinCmd(const s:TCmdStr;var bstr: TCmdStr;var cstr:TCmdStr);
  101. function FindFile(const f : TCmdStr;path : TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  102. { function FindFilePchar(const f : TCmdStr;path : pchar;allowcache:boolean;var foundfile:TCmdStr):boolean;}
  103. function FindExe(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  104. function GetShortName(const n:TCmdStr):TCmdStr;
  105. procedure InitFileUtils;
  106. procedure DoneFileUtils;
  107. implementation
  108. uses
  109. Comphook,
  110. Globals;
  111. {$undef AllFilesMaskIsInRTL}
  112. {$if (FPC_VERSION > 2)}
  113. {$define AllFilesMaskIsInRTL}
  114. {$endif FPC_VERSION}
  115. {$if (FPC_VERSION = 2) and (FPC_RELEASE > 2)}
  116. {$define AllFilesMaskIsInRTL}
  117. {$endif}
  118. {$if (FPC_VERSION = 2) and (FPC_RELEASE = 2) and (FPC_PATCH > 0)}
  119. {$define AllFilesMaskIsInRTL}
  120. {$endif}
  121. {$ifndef AllFilesMaskIsInRTL}
  122. {$if defined(go32v2) or defined(watcom)}
  123. const
  124. AllFilesMask = '*.*';
  125. {$else}
  126. const
  127. AllFilesMask = '*';
  128. {$endif not (go32v2 or watcom)}
  129. {$endif not AllFilesMaskIsInRTL}
  130. var
  131. DirCache : TDirectoryCache;
  132. {****************************************************************************
  133. TCachedDirectory
  134. ****************************************************************************}
  135. constructor TCachedDirectory.create(AList:TFPHashObjectList;const AName:TCmdStr);
  136. begin
  137. inherited create(AList,AName);
  138. FDirectoryEntries:=TFPHashList.Create;
  139. end;
  140. destructor TCachedDirectory.destroy;
  141. begin
  142. FreeDirectoryEntries;
  143. FDirectoryEntries.Free;
  144. inherited destroy;
  145. end;
  146. procedure TCachedDirectory.FreeDirectoryEntries;
  147. var
  148. i: Integer;
  149. begin
  150. if not(tf_files_case_aware in source_info.flags) then
  151. exit;
  152. for i := 0 to DirectoryEntries.Count-1 do
  153. dispose(PCachedDirectoryEntry(DirectoryEntries[i]));
  154. end;
  155. function TCachedDirectory.GetItemAttr(const AName: TCmdStr): byte;
  156. var
  157. entry: PCachedDirectoryEntry;
  158. begin
  159. if not(tf_files_case_sensitive in source_info.flags) then
  160. if (tf_files_case_aware in source_info.flags) then
  161. begin
  162. entry:=PCachedDirectoryEntry(DirectoryEntries.Find(Lower(AName)));
  163. if assigned(entry) then
  164. Result:=entry^.Attr
  165. else
  166. Result:=0;
  167. end
  168. else
  169. Result:=PtrUInt(DirectoryEntries.Find(Lower(AName)))
  170. else
  171. Result:=PtrUInt(DirectoryEntries.Find(AName));
  172. end;
  173. procedure TCachedDirectory.Reload;
  174. var
  175. dir : TSearchRec;
  176. entry : PCachedDirectoryEntry;
  177. begin
  178. FreeDirectoryEntries;
  179. DirectoryEntries.Clear;
  180. if findfirst(IncludeTrailingPathDelimiter(Name)+AllFilesMask,faAnyFile or faDirectory,dir) = 0 then
  181. begin
  182. repeat
  183. if ((dir.attr and faDirectory)<>faDirectory) or
  184. ((dir.Name<>'.') and
  185. (dir.Name<>'..')) then
  186. begin
  187. if not(tf_files_case_sensitive in source_info.flags) then
  188. if (tf_files_case_aware in source_info.flags) then
  189. begin
  190. new(entry);
  191. entry^.RealName:=Dir.Name;
  192. entry^.Attr:=Dir.Attr;
  193. DirectoryEntries.Add(Lower(Dir.Name),entry)
  194. end
  195. else
  196. DirectoryEntries.Add(Lower(Dir.Name),Pointer(Ptrint(Dir.Attr)))
  197. else
  198. DirectoryEntries.Add(Dir.Name,Pointer(Ptrint(Dir.Attr)));
  199. end;
  200. until findnext(dir) <> 0;
  201. end;
  202. findclose(dir);
  203. end;
  204. function TCachedDirectory.FileExists(const AName:TCmdStr):boolean;
  205. var
  206. Attr : Longint;
  207. begin
  208. Attr:=GetItemAttr(AName);
  209. if Attr<>0 then
  210. Result:=((Attr and faDirectory)=0)
  211. else
  212. Result:=false;
  213. end;
  214. function TCachedDirectory.FileExistsCaseAware(const AName:TCmdStr; out FoundName: TCmdStr):boolean;
  215. var
  216. entry : PCachedDirectoryEntry;
  217. Attr : Longint;
  218. begin
  219. if (tf_files_case_aware in source_info.flags) then
  220. begin
  221. entry:=PCachedDirectoryEntry(DirectoryEntries.Find(Lower(AName)));
  222. if assigned(entry) then
  223. begin
  224. Attr:=entry^.Attr;
  225. FoundName:=entry^.RealName
  226. end
  227. else
  228. Attr:=0;
  229. if Attr<>0 then
  230. Result:=((Attr and faDirectory)=0)
  231. else
  232. Result:=false
  233. end
  234. else
  235. { should not be called in this case, use plain FileExists }
  236. Result:=False;
  237. end;
  238. function TCachedDirectory.DirectoryExists(const AName:TCmdStr):boolean;
  239. var
  240. Attr : Longint;
  241. begin
  242. Attr:=GetItemAttr(AName);
  243. if Attr<>0 then
  244. Result:=((Attr and faDirectory)=faDirectory)
  245. else
  246. Result:=false;
  247. end;
  248. {****************************************************************************
  249. TDirectoryCache
  250. ****************************************************************************}
  251. constructor TDirectoryCache.create;
  252. begin
  253. inherited create;
  254. FDirectories:=TFPHashObjectList.Create(true);
  255. end;
  256. destructor TDirectoryCache.destroy;
  257. begin
  258. FDirectories.Free;
  259. inherited destroy;
  260. end;
  261. function TDirectoryCache.GetDirectory(const ADir:TCmdStr):TCachedDirectory;
  262. var
  263. CachedDir : TCachedDirectory;
  264. DirName : TCmdStr;
  265. begin
  266. if ADir='' then
  267. DirName:='.'
  268. else
  269. DirName:=ADir;
  270. CachedDir:=TCachedDirectory(FDirectories.Find(DirName));
  271. if not assigned(CachedDir) then
  272. begin
  273. CachedDir:=TCachedDirectory.Create(FDirectories,DirName);
  274. CachedDir.Reload;
  275. end;
  276. Result:=CachedDir;
  277. end;
  278. function TDirectoryCache.FileExists(const AName:TCmdStr):boolean;
  279. var
  280. CachedDir : TCachedDirectory;
  281. begin
  282. Result:=false;
  283. CachedDir:=GetDirectory(ExtractFileDir(AName));
  284. if assigned(CachedDir) then
  285. Result:=CachedDir.FileExists(ExtractFileName(AName));
  286. end;
  287. function TDirectoryCache.FileExistsCaseAware(const AName:TCmdStr; out FoundName:TCmdStr):boolean;
  288. var
  289. CachedDir : TCachedDirectory;
  290. begin
  291. Result:=false;
  292. CachedDir:=GetDirectory(ExtractFileDir(AName));
  293. if assigned(CachedDir) then
  294. begin
  295. Result:=CachedDir.FileExistsCaseAware(ExtractFileName(AName),FoundName);
  296. if Result then
  297. FoundName:=ExtractFilePath(AName)+FoundName;
  298. end;
  299. end;
  300. function TDirectoryCache.DirectoryExists(const AName:TCmdStr):boolean;
  301. var
  302. CachedDir : TCachedDirectory;
  303. begin
  304. Result:=false;
  305. CachedDir:=GetDirectory(ExtractFilePath(AName));
  306. if assigned(CachedDir) then
  307. Result:=CachedDir.DirectoryExists(ExtractFileName(AName));
  308. end;
  309. function TDirectoryCache.FindFirst(const APattern:TCmdStr;var Res:TCachedSearchRec):boolean;
  310. begin
  311. Res.Pattern:=ExtractFileName(APattern);
  312. Res.CachedDir:=GetDirectory(ExtractFilePath(APattern));
  313. Res.EntryIndex:=0;
  314. if assigned(Res.CachedDir) then
  315. Result:=FindNext(Res)
  316. else
  317. Result:=false;
  318. end;
  319. function TDirectoryCache.FindNext(var Res:TCachedSearchRec):boolean;
  320. var
  321. entry: PCachedDirectoryEntry;
  322. begin
  323. if Res.EntryIndex<Res.CachedDir.DirectoryEntries.Count then
  324. begin
  325. if (tf_files_case_aware in source_info.flags) then
  326. begin
  327. entry:=Res.CachedDir.DirectoryEntries[Res.EntryIndex];
  328. Res.Name:=entry^.RealName;
  329. Res.Attr:=entry^.Attr;
  330. end
  331. else
  332. begin
  333. Res.Name:=Res.CachedDir.DirectoryEntries.NameOfIndex(Res.EntryIndex);
  334. Res.Attr:=PtrUInt(Res.CachedDir.DirectoryEntries[Res.EntryIndex]);
  335. end;
  336. inc(Res.EntryIndex);
  337. Result:=true;
  338. end
  339. else
  340. Result:=false;
  341. end;
  342. function TDirectoryCache.FindClose(var Res:TCachedSearchRec):boolean;
  343. begin
  344. { nothing todo }
  345. result:=true;
  346. end;
  347. {****************************************************************************
  348. Utils
  349. ****************************************************************************}
  350. function bstoslash(const s : TCmdStr) : TCmdStr;
  351. {
  352. return TCmdStr s with all \ changed into /
  353. }
  354. var
  355. i : longint;
  356. begin
  357. setlength(bstoslash,length(s));
  358. for i:=1to length(s) do
  359. if s[i]='\' then
  360. bstoslash[i]:='/'
  361. else
  362. bstoslash[i]:=s[i];
  363. end;
  364. {Gives the absolute path to the current directory}
  365. var
  366. CachedCurrentDir : TCmdStr;
  367. function GetCurrentDir:TCmdStr;
  368. begin
  369. if CachedCurrentDir='' then
  370. begin
  371. GetDir(0,CachedCurrentDir);
  372. CachedCurrentDir:=FixPath(CachedCurrentDir,false);
  373. end;
  374. result:=CachedCurrentDir;
  375. end;
  376. {Gives the relative path to the current directory,
  377. with a trailing dir separator. E. g. on unix ./ }
  378. function CurDirRelPath(systeminfo: tsysteminfo): TCmdStr;
  379. begin
  380. if systeminfo.system <> system_powerpc_macos then
  381. CurDirRelPath:= '.'+systeminfo.DirSep
  382. else
  383. CurDirRelPath:= ':'
  384. end;
  385. function path_absolute(const s : TCmdStr) : boolean;
  386. {
  387. is path s an absolute path?
  388. }
  389. begin
  390. result:=false;
  391. {$if defined(unix)}
  392. if (length(s)>0) and (s[1]='/') then
  393. result:=true;
  394. {$elseif defined(amiga) or defined(morphos)}
  395. if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or (Pos(':',s) = length(s)) then
  396. result:=true;
  397. {$elseif defined(macos)}
  398. if IsMacFullPath(s) then
  399. result:=true;
  400. if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
  401. ((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then
  402. result:=true;
  403. {$endif unix}
  404. end;
  405. Function FileExists ( Const F : TCmdStr;allowcache:boolean) : Boolean;
  406. begin
  407. {$ifdef usedircache}
  408. if allowcache then
  409. Result:=DirCache.FileExists(F)
  410. else
  411. {$endif usedircache}
  412. Result:=SysUtils.FileExists(F);
  413. if assigned(do_comment) then
  414. begin
  415. if Result then
  416. do_comment(V_Tried,'Searching file '+F+'... found')
  417. else
  418. do_comment(V_Tried,'Searching file '+F+'... not found');
  419. end;
  420. end;
  421. function FileExistsNonCase(const path,fn:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  422. var
  423. fn2 : TCmdStr;
  424. begin
  425. result:=false;
  426. if tf_files_case_sensitive in source_info.flags then
  427. begin
  428. {
  429. Search order for case sensitive systems:
  430. 1. NormalCase
  431. 2. lowercase
  432. 3. UPPERCASE
  433. }
  434. FoundFile:=path+fn;
  435. If FileExists(FoundFile,allowcache) then
  436. begin
  437. result:=true;
  438. exit;
  439. end;
  440. fn2:=Lower(fn);
  441. if fn2<>fn then
  442. begin
  443. FoundFile:=path+fn2;
  444. If FileExists(FoundFile,allowcache) then
  445. begin
  446. result:=true;
  447. exit;
  448. end;
  449. end;
  450. fn2:=Upper(fn);
  451. if fn2<>fn then
  452. begin
  453. FoundFile:=path+fn2;
  454. If FileExists(FoundFile,allowcache) then
  455. begin
  456. result:=true;
  457. exit;
  458. end;
  459. end;
  460. end
  461. else
  462. if tf_files_case_aware in source_info.flags then
  463. begin
  464. {
  465. Search order for case aware systems:
  466. 1. NormalCase
  467. }
  468. FoundFile:=path+fn;
  469. {$ifdef usedircache}
  470. if allowcache then
  471. begin
  472. result:=DirCache.FileExistsCaseAware(FoundFile,fn2);
  473. if result then
  474. begin
  475. FoundFile:=fn2;
  476. exit;
  477. end;
  478. end
  479. else
  480. {$endif usedircache}
  481. If FileExists(FoundFile,allowcache) then
  482. begin
  483. { don't know the real name in this case }
  484. result:=true;
  485. exit;
  486. end;
  487. end
  488. else
  489. begin
  490. { None case sensitive only lowercase }
  491. FoundFile:=path+Lower(fn);
  492. If FileExists(FoundFile,allowcache) then
  493. begin
  494. result:=true;
  495. exit;
  496. end;
  497. end;
  498. { Set foundfile to something usefull }
  499. FoundFile:=fn;
  500. end;
  501. Function PathExists (const F : TCmdStr;allowcache:boolean) : Boolean;
  502. Var
  503. i: longint;
  504. hs : TCmdStr;
  505. begin
  506. if F = '' then
  507. begin
  508. result := true;
  509. exit;
  510. end;
  511. hs := ExpandFileName(F);
  512. I := Pos (DriveSeparator, hs);
  513. if (hs [Length (hs)] = DirectorySeparator) and
  514. (((I = 0) and (Length (hs) > 1)) or (I <> Length (hs) - 1)) then
  515. Delete (hs, Length (hs), 1);
  516. {$ifdef usedircache}
  517. if allowcache then
  518. Result:=DirCache.DirectoryExists(hs)
  519. else
  520. {$endif usedircache}
  521. Result:=SysUtils.DirectoryExists(hs);
  522. end;
  523. Function RemoveDir(d:TCmdStr):boolean;
  524. begin
  525. if d[length(d)]=source_info.DirSep then
  526. Delete(d,length(d),1);
  527. {$I-}
  528. rmdir(d);
  529. {$I+}
  530. RemoveDir:=(ioresult=0);
  531. end;
  532. Function FixPath(s:TCmdStr;allowdot:boolean):TCmdStr;
  533. var
  534. i : longint;
  535. begin
  536. { Fix separator }
  537. for i:=1 to length(s) do
  538. if s[i] in ['/','\'] then
  539. s[i]:=source_info.DirSep;
  540. { Fix ending / }
  541. if (length(s)>0) and (s[length(s)]<>source_info.DirSep) and
  542. (s[length(s)]<>DriveSeparator) then
  543. s:=s+source_info.DirSep;
  544. { Remove ./ }
  545. if (not allowdot) and (s='.'+source_info.DirSep) then
  546. s:='';
  547. { return }
  548. if (tf_files_case_aware in source_info.flags) or
  549. (tf_files_case_sensitive in source_info.flags) then
  550. FixPath:=s
  551. else
  552. FixPath:=Lower(s);
  553. end;
  554. {Actually the version in macutils.pp could be used,
  555. but that would not work for crosscompiling, so this is a slightly modified
  556. version of it.}
  557. function TranslatePathToMac (const path: TCmdStr; mpw: Boolean): TCmdStr;
  558. function GetVolumeIdentifier: TCmdStr;
  559. begin
  560. GetVolumeIdentifier := '{Boot}'
  561. (*
  562. if mpw then
  563. GetVolumeIdentifier := '{Boot}'
  564. else
  565. GetVolumeIdentifier := macosBootVolumeName;
  566. *)
  567. end;
  568. var
  569. slashPos, oldpos, newpos, oldlen, maxpos: Longint;
  570. begin
  571. oldpos := 1;
  572. slashPos := Pos('/', path);
  573. if (slashPos <> 0) then {its a unix path}
  574. begin
  575. if slashPos = 1 then
  576. begin {its a full path}
  577. oldpos := 2;
  578. TranslatePathToMac := GetVolumeIdentifier;
  579. end
  580. else {its a partial path}
  581. TranslatePathToMac := ':';
  582. end
  583. else
  584. begin
  585. slashPos := Pos('\', path);
  586. if (slashPos <> 0) then {its a dos path}
  587. begin
  588. if slashPos = 1 then
  589. begin {its a full path, without drive letter}
  590. oldpos := 2;
  591. TranslatePathToMac := GetVolumeIdentifier;
  592. end
  593. else if (Length(path) >= 2) and (path[2] = ':') then {its a full path, with drive letter}
  594. begin
  595. oldpos := 4;
  596. TranslatePathToMac := GetVolumeIdentifier;
  597. end
  598. else {its a partial path}
  599. TranslatePathToMac := ':';
  600. end;
  601. end;
  602. if (slashPos <> 0) then {its a unix or dos path}
  603. begin
  604. {Translate "/../" to "::" , "/./" to ":" and "/" to ":" }
  605. newpos := Length(TranslatePathToMac);
  606. oldlen := Length(path);
  607. SetLength(TranslatePathToMac, newpos + oldlen); {It will be no longer than what is already}
  608. {prepended plus length of path.}
  609. maxpos := Length(TranslatePathToMac); {Get real maxpos, can be short if String is ShortString}
  610. {There is never a slash in the beginning, because either it was an absolute path, and then the}
  611. {drive and slash was removed, or it was a relative path without a preceding slash.}
  612. while oldpos <= oldlen do
  613. begin
  614. {Check if special dirs, ./ or ../ }
  615. if path[oldPos] = '.' then
  616. if (oldpos + 1 <= oldlen) and (path[oldPos + 1] = '.') then
  617. begin
  618. if (oldpos + 2 > oldlen) or (path[oldPos + 2] in ['/', '\']) then
  619. begin
  620. {It is "../" or ".." translates to ":" }
  621. if newPos = maxPos then
  622. begin {Shouldn't actually happen, but..}
  623. Exit('');
  624. end;
  625. newPos := newPos + 1;
  626. TranslatePathToMac[newPos] := ':';
  627. oldPos := oldPos + 3;
  628. continue; {Start over again}
  629. end;
  630. end
  631. else if (oldpos + 1 > oldlen) or (path[oldPos + 1] in ['/', '\']) then
  632. begin
  633. {It is "./" or "." ignor it }
  634. oldPos := oldPos + 2;
  635. continue; {Start over again}
  636. end;
  637. {Collect file or dir name}
  638. while (oldpos <= oldlen) and not (path[oldPos] in ['/', '\']) do
  639. begin
  640. if newPos = maxPos then
  641. begin {Shouldn't actually happen, but..}
  642. Exit('');
  643. end;
  644. newPos := newPos + 1;
  645. TranslatePathToMac[newPos] := path[oldPos];
  646. oldPos := oldPos + 1;
  647. end;
  648. {When we come here there is either a slash or we are at the end.}
  649. if (oldpos <= oldlen) then
  650. begin
  651. if newPos = maxPos then
  652. begin {Shouldn't actually happen, but..}
  653. Exit('');
  654. end;
  655. newPos := newPos + 1;
  656. TranslatePathToMac[newPos] := ':';
  657. oldPos := oldPos + 1;
  658. end;
  659. end;
  660. SetLength(TranslatePathToMac, newpos);
  661. end
  662. else if (path = '.') then
  663. TranslatePathToMac := ':'
  664. else if (path = '..') then
  665. TranslatePathToMac := '::'
  666. else
  667. TranslatePathToMac := path; {its a mac path}
  668. end;
  669. function FixFileName(const s:TCmdStr):TCmdStr;
  670. var
  671. i : longint;
  672. begin
  673. if source_info.system = system_powerpc_MACOS then
  674. FixFileName:= TranslatePathToMac(s, true)
  675. else
  676. if (tf_files_case_aware in source_info.flags) or
  677. (tf_files_case_sensitive in source_info.flags) then
  678. begin
  679. setlength(FixFileName,length(s));
  680. for i:=1 to length(s) do
  681. begin
  682. case s[i] of
  683. '/','\' :
  684. FixFileName[i]:=source_info.dirsep;
  685. else
  686. FixFileName[i]:=s[i];
  687. end;
  688. end;
  689. end
  690. else
  691. begin
  692. setlength(FixFileName,length(s));
  693. for i:=1 to length(s) do
  694. begin
  695. case s[i] of
  696. '/','\' :
  697. FixFileName[i]:=source_info.dirsep;
  698. 'A'..'Z' :
  699. FixFileName[i]:=char(byte(s[i])+32);
  700. else
  701. FixFileName[i]:=s[i];
  702. end;
  703. end;
  704. end;
  705. end;
  706. Function TargetFixPath(s:TCmdStr;allowdot:boolean):TCmdStr;
  707. var
  708. i : longint;
  709. begin
  710. { Fix separator }
  711. for i:=1 to length(s) do
  712. if s[i] in ['/','\'] then
  713. s[i]:=target_info.DirSep;
  714. { Fix ending / }
  715. if (length(s)>0) and (s[length(s)]<>target_info.DirSep) and
  716. (s[length(s)]<>':') then
  717. s:=s+target_info.DirSep;
  718. { Remove ./ }
  719. if (not allowdot) and (s='.'+target_info.DirSep) then
  720. s:='';
  721. { return }
  722. if (tf_files_case_aware in target_info.flags) or
  723. (tf_files_case_sensitive in target_info.flags) then
  724. TargetFixPath:=s
  725. else
  726. TargetFixPath:=Lower(s);
  727. end;
  728. function TargetFixFileName(const s:TCmdStr):TCmdStr;
  729. var
  730. i : longint;
  731. begin
  732. if target_info.system = system_powerpc_MACOS then
  733. TargetFixFileName:= TranslatePathToMac(s, true)
  734. else
  735. if (tf_files_case_aware in target_info.flags) or
  736. (tf_files_case_sensitive in target_info.flags) then
  737. begin
  738. setlength(TargetFixFileName,length(s));
  739. for i:=1 to length(s) do
  740. begin
  741. case s[i] of
  742. '/','\' :
  743. TargetFixFileName[i]:=target_info.dirsep;
  744. else
  745. TargetFixFileName[i]:=s[i];
  746. end;
  747. end;
  748. end
  749. else
  750. begin
  751. setlength(TargetFixFileName,length(s));
  752. for i:=1 to length(s) do
  753. begin
  754. case s[i] of
  755. '/','\' :
  756. TargetFixFileName[i]:=target_info.dirsep;
  757. 'A'..'Z' :
  758. TargetFixFileName[i]:=char(byte(s[i])+32);
  759. else
  760. TargetFixFileName[i]:=s[i];
  761. end;
  762. end;
  763. end;
  764. end;
  765. procedure SplitBinCmd(const s:TCmdStr;var bstr:TCmdStr;var cstr:TCmdStr);
  766. var
  767. i : longint;
  768. begin
  769. i:=pos(' ',s);
  770. if i>0 then
  771. begin
  772. bstr:=Copy(s,1,i-1);
  773. cstr:=Copy(s,i+1,length(s)-i);
  774. end
  775. else
  776. begin
  777. bstr:=s;
  778. cstr:='';
  779. end;
  780. end;
  781. procedure TSearchPathList.AddPath(s:TCmdStr;addfirst:boolean);
  782. begin
  783. AddPath('',s,AddFirst);
  784. end;
  785. procedure TSearchPathList.AddPath(SrcPath,s:TCmdStr;addfirst:boolean);
  786. var
  787. staridx,
  788. j : longint;
  789. prefix,
  790. suffix,
  791. CurrentDir,
  792. currPath : TCmdStr;
  793. subdirfound : boolean;
  794. {$ifdef usedircache}
  795. dir : TCachedSearchRec;
  796. {$else usedircache}
  797. dir : TSearchRec;
  798. {$endif usedircache}
  799. hp : TCmdStrListItem;
  800. procedure WarnNonExistingPath(const path : TCmdStr);
  801. begin
  802. if assigned(do_comment) then
  803. do_comment(V_Tried,'Path "'+path+'" not found');
  804. end;
  805. procedure AddCurrPath;
  806. begin
  807. if addfirst then
  808. begin
  809. Remove(currPath);
  810. Insert(currPath);
  811. end
  812. else
  813. begin
  814. { Check if already in path, then we don't add it }
  815. hp:=Find(currPath);
  816. if not assigned(hp) then
  817. Concat(currPath);
  818. end;
  819. end;
  820. begin
  821. if s='' then
  822. exit;
  823. { Support default macro's }
  824. DefaultReplacements(s);
  825. { get current dir }
  826. CurrentDir:=GetCurrentDir;
  827. repeat
  828. { get currpath }
  829. if addfirst then
  830. begin
  831. j:=length(s);
  832. while (j>0) and (s[j]<>';') do
  833. dec(j);
  834. currPath:= TrimSpace(Copy(s,j+1,length(s)-j));
  835. DePascalQuote(currPath);
  836. currPath:=FixPath(currPath,false);
  837. if j=0 then
  838. s:=''
  839. else
  840. System.Delete(s,j,length(s)-j+1);
  841. end
  842. else
  843. begin
  844. j:=Pos(';',s);
  845. if j=0 then
  846. j:=255;
  847. currPath:= TrimSpace(Copy(s,1,j-1));
  848. DePascalQuote(currPath);
  849. currPath:=SrcPath+FixPath(currPath,false);
  850. System.Delete(s,1,j);
  851. end;
  852. { fix pathname }
  853. if currPath='' then
  854. currPath:= CurDirRelPath(source_info)
  855. else
  856. begin
  857. currPath:=FixPath(ExpandFileName(currpath),false);
  858. if (CurrentDir<>'') and (Copy(currPath,1,length(CurrentDir))=CurrentDir) then
  859. begin
  860. {$if defined(amiga) and defined(morphos)}
  861. currPath:= CurrentDir+Copy(currPath,length(CurrentDir)+1,255);
  862. {$else}
  863. currPath:= CurDirRelPath(source_info)+Copy(currPath,length(CurrentDir)+1,255);
  864. {$endif}
  865. end;
  866. end;
  867. { wildcard adding ? }
  868. staridx:=pos('*',currpath);
  869. if staridx>0 then
  870. begin
  871. prefix:=ExtractFilePath(Copy(currpath,1,staridx));
  872. suffix:=Copy(currpath,staridx+1,length(currpath));
  873. subdirfound:=false;
  874. {$ifdef usedircache}
  875. if DirCache.FindFirst(Prefix+AllFilesMask,dir) then
  876. begin
  877. repeat
  878. if (dir.attr and faDirectory)<>0 then
  879. begin
  880. subdirfound:=true;
  881. currpath:=prefix+dir.name+suffix;
  882. if (suffix='') or PathExists(currpath,true) then
  883. begin
  884. hp:=Find(currPath);
  885. if not assigned(hp) then
  886. AddCurrPath;
  887. end;
  888. end;
  889. until not DirCache.FindNext(dir);
  890. end;
  891. DirCache.FindClose(dir);
  892. {$else usedircache}
  893. if findfirst(prefix+AllFilesMask,faDirectory,dir) = 0 then
  894. begin
  895. repeat
  896. if (dir.name<>'.') and
  897. (dir.name<>'..') and
  898. ((dir.attr and faDirectory)<>0) then
  899. begin
  900. subdirfound:=true;
  901. currpath:=prefix+dir.name+suffix;
  902. if (suffix='') or PathExists(currpath,false) then
  903. begin
  904. hp:=Find(currPath);
  905. if not assigned(hp) then
  906. AddCurrPath;
  907. end;
  908. end;
  909. until findnext(dir) <> 0;
  910. end;
  911. FindClose(dir);
  912. {$endif usedircache}
  913. if not subdirfound then
  914. WarnNonExistingPath(currpath);
  915. end
  916. else
  917. begin
  918. if PathExists(currpath,true) then
  919. AddCurrPath
  920. else
  921. WarnNonExistingPath(currpath);
  922. end;
  923. until (s='');
  924. end;
  925. procedure TSearchPathList.AddList(list:TSearchPathList;addfirst:boolean);
  926. var
  927. s : TCmdStr;
  928. hl : TSearchPathList;
  929. hp,hp2 : TCmdStrListItem;
  930. begin
  931. if list.empty then
  932. exit;
  933. { create temp and reverse the list }
  934. if addfirst then
  935. begin
  936. hl:=TSearchPathList.Create;
  937. hp:=TCmdStrListItem(list.first);
  938. while assigned(hp) do
  939. begin
  940. hl.insert(hp.Str);
  941. hp:=TCmdStrListItem(hp.next);
  942. end;
  943. while not hl.empty do
  944. begin
  945. s:=hl.GetFirst;
  946. Remove(s);
  947. Insert(s);
  948. end;
  949. hl.Free;
  950. end
  951. else
  952. begin
  953. hp:=TCmdStrListItem(list.first);
  954. while assigned(hp) do
  955. begin
  956. hp2:=Find(hp.Str);
  957. { Check if already in path, then we don't add it }
  958. if not assigned(hp2) then
  959. Concat(hp.Str);
  960. hp:=TCmdStrListItem(hp.next);
  961. end;
  962. end;
  963. end;
  964. function TSearchPathList.FindFile(const f :TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  965. Var
  966. p : TCmdStrListItem;
  967. begin
  968. FindFile:=false;
  969. p:=TCmdStrListItem(first);
  970. while assigned(p) do
  971. begin
  972. result:=FileExistsNonCase(p.Str,f,allowcache,FoundFile);
  973. if result then
  974. exit;
  975. p:=TCmdStrListItem(p.next);
  976. end;
  977. { Return original filename if not found }
  978. FoundFile:=f;
  979. end;
  980. function FindFile(const f : TCmdStr;path : TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  981. Var
  982. singlepathstring : TCmdStr;
  983. i : longint;
  984. begin
  985. if PathSeparator <> ';' then
  986. for i:=1 to length(path) do
  987. if path[i]=PathSeparator then
  988. path[i]:=';';
  989. FindFile:=false;
  990. repeat
  991. i:=pos(';',path);
  992. if i=0 then
  993. i:=Succ (Length (Path));
  994. singlepathstring:=FixPath(copy(path,1,i-1),false);
  995. delete(path,1,i);
  996. result:=FileExistsNonCase(singlepathstring,f,allowcache,FoundFile);
  997. if result then
  998. exit;
  999. until path='';
  1000. FoundFile:=f;
  1001. end;
  1002. {
  1003. function FindFilePchar(const f : TCmdStr;path : pchar;allowcache:boolean;var foundfile:TCmdStr):boolean;
  1004. Var
  1005. singlepathstring : TCmdStr;
  1006. startpc,pc : pchar;
  1007. begin
  1008. FindFilePchar:=false;
  1009. if Assigned (Path) then
  1010. begin
  1011. pc:=path;
  1012. repeat
  1013. startpc:=pc;
  1014. while (pc^<>PathSeparator) and (pc^<>';') and (pc^<>#0) do
  1015. inc(pc);
  1016. SetLength(singlepathstring, pc-startpc);
  1017. move(startpc^,singlepathstring[1],pc-startpc);
  1018. singlepathstring:=FixPath(ExpandFileName(singlepathstring),false);
  1019. result:=FileExistsNonCase(singlepathstring,f,allowcache,FoundFile);
  1020. if result then
  1021. exit;
  1022. if (pc^=#0) then
  1023. break;
  1024. inc(pc);
  1025. until false;
  1026. end;
  1027. foundfile:=f;
  1028. end;
  1029. }
  1030. function FindExe(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
  1031. var
  1032. Path : TCmdStr;
  1033. found : boolean;
  1034. begin
  1035. found:=FindFile(FixFileName(ChangeFileExt(bin,source_info.exeext)),'.;'+exepath,allowcache,foundfile);
  1036. if not found then
  1037. begin
  1038. {$ifdef macos}
  1039. Path:=GetEnvironmentVariable('Commands');
  1040. {$else}
  1041. Path:=GetEnvironmentVariable('PATH');
  1042. {$endif}
  1043. found:=FindFile(FixFileName(ChangeFileExt(bin,source_info.exeext)),Path,allowcache,foundfile);
  1044. end;
  1045. FindExe:=found;
  1046. end;
  1047. function GetShortName(const n:TCmdStr):TCmdStr;
  1048. {$ifdef win32}
  1049. var
  1050. hs,hs2 : TCmdStr;
  1051. i : longint;
  1052. {$endif}
  1053. {$if defined(go32v2) or defined(watcom)}
  1054. var
  1055. hs : shortstring;
  1056. {$endif}
  1057. begin
  1058. GetShortName:=n;
  1059. {$ifdef win32}
  1060. hs:=n+#0;
  1061. { may become longer in case of e.g. ".a" -> "a~1" or so }
  1062. setlength(hs2,length(hs)*2);
  1063. i:=Windows.GetShortPathName(@hs[1],@hs2[1],length(hs)*2);
  1064. if (i>0) and (i<=length(hs)*2) then
  1065. begin
  1066. setlength(hs2,strlen(@hs2[1]));
  1067. GetShortName:=hs2;
  1068. end;
  1069. {$endif}
  1070. {$if defined(go32v2) or defined(watcom)}
  1071. hs:=n;
  1072. if Dos.GetShortName(hs) then
  1073. GetShortName:=hs;
  1074. {$endif}
  1075. end;
  1076. {****************************************************************************
  1077. Init / Done
  1078. ****************************************************************************}
  1079. procedure InitFileUtils;
  1080. begin
  1081. DirCache:=TDirectoryCache.Create;
  1082. end;
  1083. procedure DoneFileUtils;
  1084. begin
  1085. DirCache.Free;
  1086. end;
  1087. end.