UtilsDos.pas 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915
  1. {
  2. This Delphi unit is part of TIGCC.
  3. Copyright (C) 2000-2004 Sebastian Reichelt
  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, or (at your option)
  7. 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 Foundation,
  14. Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  15. }
  16. unit UtilsDos;
  17. interface
  18. uses
  19. WinProcs, WinTypes, SysUtils, Classes;
  20. type
  21. TByteFile = file of Byte;
  22. TDrive = 'A'..'Z';
  23. TDrives = set of TDrive;
  24. function UCase (NormalChar: Char): Char;
  25. function LCase (NormalChar: Char): Char;
  26. function IsNormalChar (Ch: Char): Boolean;
  27. function ChangeText (var ChText: string; ToChange, ToInsert: string): Byte;
  28. function LastPos (const Substr, S: string): Integer;
  29. function PosEx (const Substr, S: string; StartPos: Integer; Backwards: Boolean = False): Integer;
  30. function FirstNonWhiteSpace (const S: string): Integer;
  31. function GetDriveDescription (Drive: TDrive): string;
  32. function DiskInDrive (Drive: TDrive): Boolean;
  33. function FileExistsWithCase (const FileName: string): Boolean;
  34. function DirExists (const Directory: string): Boolean;
  35. function DirExistsWithCase (const Directory: string): Boolean;
  36. function GetFileSize (const FileName: string): Integer;
  37. function GetSubDir (const Directory: string): string;
  38. function GetHigherDir (const Directory: string): string;
  39. function GetLowerName (const N: string): string;
  40. function SizeToStr (Size: Int64): string;
  41. function AttrToStr (Attr: Integer): string;
  42. procedure CreatePath (const Directory: string);
  43. procedure CreatePathFor (const FileName: string);
  44. procedure RemovePath (const Directory: string; const StopAt: string = '');
  45. procedure RemovePathFor (const FileName: string; const StopAt: string = '');
  46. procedure DelTree (const Directory: string);
  47. procedure DelAllFiles (const Directory: string);
  48. procedure PCSpeakerPlay (Frequency: Word);
  49. procedure PCSpeakerStop;
  50. procedure SetDate (a: Word; m, d: Byte);
  51. procedure SetTime (h, m, s, hs: Byte);
  52. procedure WrCStr (var F: TByteFile; Str: string);
  53. procedure WrPStr (var F: TByteFile; Str: string; Len: Byte);
  54. procedure WrVStr (var F: TByteFile; Str: string);
  55. procedure WrSInt (var F: TByteFile; Value: ShortInt);
  56. procedure WrByte (var F: TByteFile; Value: Byte);
  57. procedure WrNInt (var F: TByteFile; Value: SmallInt);
  58. procedure WrWord (var F: TByteFile; Value: Word);
  59. procedure RdCStr (var F: TByteFile; var Str: string; Len: Byte);
  60. procedure RdPStr (var F: TByteFile; var Str: string; Len: Byte);
  61. procedure RdVStr (var F: TByteFile; var Str: string);
  62. procedure RdSInt (var F: TByteFile; var Value: ShortInt);
  63. procedure RdByte (var F: TByteFile; var Value: Byte);
  64. procedure RdNInt (var F: TByteFile; var Value: SmallInt);
  65. procedure RdWord (var F: TByteFile; var Value: Word);
  66. type
  67. TFileAttribute = (atDirectory, atArchive, atReadOnly, atHidden, atSystem);
  68. // atDirectory only for internal use and property request
  69. TFileAttributes = set of TFileAttribute;
  70. const
  71. atStd: TFileAttributes = [atArchive, atReadOnly];
  72. atAll: TFileAttributes = [atArchive, atReadOnly, atHidden, atSystem];
  73. type
  74. TFileReferences = class;
  75. TFileReference = class(TPersistent)
  76. private
  77. FOwner: TFileReferences;
  78. FSearchRec: TSearchRec;
  79. function GetCreationTime: TDateTime;
  80. function GetFileAttr: TFileAttributes;
  81. function GetFileName: string;
  82. function GetFileSize: Integer;
  83. function GetFullName: string;
  84. function GetFullShortName: string;
  85. function GetLastAccessTime: TDateTime;
  86. function GetModificationTime: TDateTime;
  87. function GetShortFileName: string;
  88. public
  89. published
  90. property Owner: TFileReferences read FOwner;
  91. property RecData: TSearchRec read FSearchRec;
  92. property FullName: string read GetFullName;
  93. property FileName: string read GetFileName;
  94. property FullShortName: string read GetFullShortName;
  95. property ShortFileName: string read GetShortFileName;
  96. property CreationTime: TDateTime read GetCreationTime;
  97. property ModificationTime: TDateTime read GetModificationTime;
  98. property LastAccessTime: TDateTime read GetLastAccessTime;
  99. property FileSize: Integer read GetFileSize;
  100. property FileAttr: TFileAttributes read GetFileAttr;
  101. end;
  102. TFileReferences = class(TPersistent)
  103. private
  104. FList: TList;
  105. FDirectory: string;
  106. FWildCard: string;
  107. FSearchAttr: TFileAttributes;
  108. FSearchTime: TDateTime;
  109. function GetItem(ItemIndex: Integer): TFileReference;
  110. function GetCount: Integer;
  111. public
  112. constructor Create;
  113. destructor Destroy; override;
  114. function Add(const F: TSearchRec): Integer; virtual;
  115. procedure Delete(Index: Integer); virtual;
  116. procedure Clear;
  117. procedure SearchForFiles(FileName: string; FileAttr: TFileAttributes);
  118. procedure SearchForDirs(const ParentDir: string; FileAttr: TFileAttributes);
  119. procedure CopyToStrings(const S: TStrings);
  120. procedure CopyFullNamesToStrings(const S: TStrings);
  121. property Items[ItemIndex: Integer]: TFileReference read GetItem;
  122. property Count: Integer read GetCount;
  123. published
  124. property Directory: string read FDirectory;
  125. property WildCard: string read FWildCard;
  126. property SearchAttr: TFileAttributes read FSearchAttr;
  127. property SearchTime: TDateTime read FSearchTime;
  128. end;
  129. function WinFileTimeToDateTime(WinFileTime: TFileTime): TDateTime;
  130. function WinFileAttrToFileAttr(WinFileAttr: Integer): TFileAttributes;
  131. function FileAttrToWinFileAttr(FileAttr: TFileAttributes): Integer;
  132. procedure AddBackslash(var Dir: string);
  133. function WithBackslash(const Dir: string): string;
  134. function WithoutBackslash(const Dir: string): string;
  135. function WithoutExt(const FileName: string): string;
  136. implementation
  137. function UCase;
  138. begin
  139. Result := UpCase (NormalChar);
  140. case Result of
  141. 'ä': Result := 'Ä';
  142. 'ö': Result := 'Ö';
  143. 'ü': Result := 'Ü';
  144. end;
  145. end;
  146. function LCase;
  147. begin
  148. Result := LowerCase (NormalChar) [1];
  149. case Result of
  150. 'Ä': Result := 'ä';
  151. 'Ö': Result := 'ö';
  152. 'Ü': Result := 'ü';
  153. end;
  154. end;
  155. function IsNormalChar;
  156. begin
  157. Result := UCase (Ch) <> LCase (Ch);
  158. end;
  159. function LastPos;
  160. var
  161. I: Integer;
  162. begin
  163. Result := 0;
  164. for I := Length (S) - Length (Substr) + 1 downto 1 do
  165. if Copy (S, I, Length (Substr)) = Substr then begin
  166. Result := I;
  167. Break;
  168. end;
  169. end;
  170. function PosEx;
  171. var
  172. I: Integer;
  173. begin
  174. Result := 0;
  175. if Backwards then begin
  176. for I := StartPos downto 1 do
  177. if Copy (S, I, Length (Substr)) = Substr then begin
  178. Result := I;
  179. Break;
  180. end;
  181. end else begin
  182. for I := StartPos to Length (S) - Length (Substr) + 1 do
  183. if Copy (S, I, Length (Substr)) = Substr then begin
  184. Result := I;
  185. Break;
  186. end;
  187. end;
  188. end;
  189. function FirstNonWhiteSpace;
  190. var
  191. I: Integer;
  192. begin
  193. Result := Length (S) + 1;
  194. for I := 1 to Length (S) do
  195. if not (S [I] in [' ', #9]) then begin
  196. Result := I;
  197. Break;
  198. end;
  199. end;
  200. function GetDriveDescription;
  201. var
  202. F: Text;
  203. R,
  204. N: array [0..255] of Char;
  205. V: DWord;
  206. begin
  207. Result := '';
  208. if FileExists (Drive + ':\DiskID.clk') then begin
  209. AssignFile (F, Drive + ':\DiskID.clk');
  210. Reset (F);
  211. ReadLn (F, Result);
  212. CloseFile (F);
  213. end else begin
  214. StrPCopy (R, Drive + ':\');
  215. if GetVolumeInformation (R, N, 255, nil, V, V, nil, 0) then
  216. Result := StrPas (N);
  217. end;
  218. if Result = '' then
  219. Result := Drive + ':\';
  220. Result := GetLowerName (Result);
  221. end;
  222. function DiskInDrive;
  223. var
  224. V: DWord;
  225. begin
  226. Result := GetDiskFreeSpace (PChar (Drive + ':\'), V, V, V, V);
  227. end;
  228. procedure CreatePath;
  229. var
  230. SeedPath: string;
  231. CurPath: string;
  232. begin
  233. SeedPath := WithBackslash (Directory);
  234. CurPath := '';
  235. while Pos ('\', SeedPath) > 0 do begin
  236. CurPath := CurPath + Copy (SeedPath, 1, Pos ('\', SeedPath));
  237. Delete (SeedPath, 1, Pos ('\', SeedPath));
  238. if Length (CurPath) > 3 then
  239. if not DirExists (CurPath) then try
  240. MkDir (CurPath);
  241. except end;
  242. end;
  243. end;
  244. procedure CreatePathFor;
  245. begin
  246. CreatePath (ExtractFilePath (FileName));
  247. end;
  248. procedure RemovePath;
  249. var
  250. Dir: string;
  251. S: TSearchRec;
  252. Found: Boolean;
  253. begin
  254. Dir := WithBackslash (Directory);
  255. if (Length (Dir) > 3) and (Dir <> WithBackslash (StopAt)) and DirExists (Dir) then begin
  256. Found := False;
  257. if FindFirst (Dir + '*', faAnyFile, S) = 0 then begin
  258. repeat
  259. if (S.Name <> '.') and (S.Name <> '..') then
  260. Found := True;
  261. until (FindNext (S) <> 0) or Found;
  262. end;
  263. FindClose (S);
  264. if not Found then try
  265. RmDir (Dir);
  266. RemovePath (GetHigherDir (Directory), StopAt);
  267. except end;
  268. end;
  269. end;
  270. procedure RemovePathFor;
  271. begin
  272. RemovePath (ExtractFilePath (FileName), StopAt);
  273. end;
  274. procedure DelTree;
  275. var
  276. CurDelDir: string;
  277. begin
  278. CurDelDir := WithBackslash (Directory);
  279. repeat
  280. while GetSubDir (CurDelDir) <> '' do begin
  281. CurDelDir := CurDelDir + GetSubDir
  282. (CurDelDir) + '\';
  283. end;
  284. DelAllFiles (CurDelDir);
  285. if Length (CurDelDir) < 4 then
  286. RmDir (CurDelDir)
  287. else
  288. RmDir (Copy (CurDelDir, 1, Length (CurDelDir) - 1));
  289. CurDelDir := GetHigherDir (CurDelDir);
  290. until CurDelDir = GetHigherDir (Directory);
  291. end;
  292. function FileExistsWithCase;
  293. var
  294. S: TSearchRec;
  295. begin
  296. Result := (FindFirst (FileName, faAnyFile, S) = 0);
  297. if Result and (S.Name <> ExtractFileName (FileName)) then
  298. Result := False;
  299. FindClose (S);
  300. end;
  301. function DirExists;
  302. var
  303. S: TSearchRec;
  304. begin
  305. Result := (FindFirst (WithoutBackslash (Directory), faDirectory or faHidden or faSysFile, S) = 0);
  306. FindClose (S);
  307. end;
  308. function DirExistsWithCase;
  309. var
  310. S: TSearchRec;
  311. begin
  312. Result := (FindFirst (WithoutBackslash (Directory), faDirectory, S) = 0);
  313. if Result and (S.Name <> ExtractFileName (WithoutBackslash (Directory))) then
  314. Result := False;
  315. FindClose (S);
  316. end;
  317. function GetFileSize;
  318. var
  319. S: TSearchRec;
  320. begin
  321. if FindFirst (FileName, faAnyFile, S) = 0 then
  322. Result := S.Size
  323. else
  324. Result := 0;
  325. FindClose (S);
  326. end;
  327. function GetSubDir;
  328. var
  329. SR1: TSearchRec;
  330. GoOn: Boolean;
  331. begin
  332. GoOn := True;
  333. if FindFirst (Directory + '*.*', $10, SR1) = 0 then begin
  334. while GoOn and (((SR1.Attr and $10) = 0) or (SR1.Name = '.') or (SR1.Name = '..')) do begin
  335. if FindNext (SR1) <> 0 then begin
  336. SR1.Name := '';
  337. GoOn := False;
  338. end;
  339. end;
  340. GetSubDir := SR1.Name
  341. end else
  342. GetSubDir := '';
  343. FindClose (SR1);
  344. end;
  345. function GetHigherDir;
  346. begin
  347. Result := ExtractFilePath (WithoutBackslash (Directory));
  348. end;
  349. procedure DelAllFiles;
  350. var
  351. SR1: TSearchRec;
  352. begin
  353. if FindFirst (Directory + '*.*', $20, SR1) = 0 then begin
  354. SysUtils.DeleteFile (Directory + SR1.Name);
  355. while FindNext (SR1) = 0 do
  356. SysUtils.DeleteFile (Directory + SR1.Name);
  357. end;
  358. FindClose (SR1);
  359. end;
  360. function GetLowerName;
  361. var
  362. I: Integer;
  363. begin
  364. Result := N;
  365. if (Length (Result) > 0) and ((Result = UpperCase (Result)) or (Result = LowerCase (Result))) then begin
  366. Result := UpperCase (Result);
  367. for I := 2 to Length (Result) do begin
  368. if IsNormalChar (Result [I-1]) then
  369. Result [I] := LCase (Result [I]);
  370. end;
  371. end;
  372. end;
  373. function SizeToStr;
  374. var
  375. Sz: Real;
  376. M: Byte;
  377. begin
  378. M := 0;
  379. Sz := Size;
  380. while Sz >= 1000 do begin
  381. Sz := Sz / 1000;
  382. Inc (M);
  383. end;
  384. Result := FloatToStr (Sz);
  385. if Length (Result) > 4 then
  386. Result := Copy (Result, 1, 4);
  387. if Result [Length (Result)] = DecimalSeparator then
  388. Delete (Result, Length (Result), 1);
  389. case M of
  390. 0: Result := Result + ' B';
  391. 1: Result := Result + ' KB';
  392. 2: Result := Result + ' MB';
  393. 3: Result := Result + ' GB';
  394. 4: Result := Result + ' TB';
  395. else Result := Result + '...';
  396. end;
  397. end;
  398. function AttrToStr;
  399. begin
  400. Result := '';
  401. if (Attr and faArchive) <> 0 then Result := Result + 'A';
  402. if (Attr and faReadOnly) <> 0 then Result := Result + 'R';
  403. if (Attr and faHidden) <> 0 then Result := Result + 'H';
  404. if (Attr and faSysFile) <> 0 then Result := Result + 'S';
  405. end;
  406. function ChangeText;
  407. var
  408. TxtPs: Byte;
  409. begin
  410. TxtPs := 0;
  411. while Pos (ToChange, ChText) <> 0 do begin
  412. TxtPs := Pos (ToChange, ChText);
  413. Delete (Chtext, TxtPs, Length (ToChange));
  414. Insert (ToInsert, ChText, TxtPs);
  415. end;
  416. ChangeText := TxtPs;
  417. end;
  418. procedure PCSpeakerPlay (Frequency: Word); assembler;
  419. asm
  420. Mov BX, Frequency
  421. Mov AX, $34DD
  422. Mov DX, $0012
  423. Cmp DX, BX
  424. Jnb @EndOfProc
  425. Div BX
  426. Mov BX, AX
  427. In AL, $61
  428. Test AL, $03
  429. Jne @NearlyEndOfProc
  430. Or AL, $03
  431. Out $61, AL
  432. Mov AL, $B6
  433. Out $43, AL
  434. @NearlyEndOfProc:
  435. Mov AL, BL
  436. Out $42, AL
  437. Mov AL, BH
  438. Out $42, AL
  439. @EndOfProc:
  440. end;
  441. procedure PCSpeakerStop; assembler;
  442. asm
  443. In AL, $61
  444. And AL, $FC
  445. Out $61, AL
  446. end;
  447. procedure SetDate; assembler;
  448. asm
  449. Mov CX, a
  450. Mov DH, m
  451. Mov DL, d
  452. Mov AH, $2B
  453. Int $21
  454. end;
  455. procedure SetTime; assembler;
  456. asm
  457. Mov CH, h
  458. Mov CL, m
  459. Mov DH, s
  460. Mov DL, hs
  461. Mov AH, $2D
  462. Int $21
  463. end;
  464. procedure WrCStr;
  465. var
  466. VLp1,
  467. VHlp: Byte;
  468. begin
  469. for VLp1 := 1 to Length (Str) do begin
  470. VHlp := Ord (Str [VLp1]);
  471. Write (F, VHlp);
  472. end;
  473. end;
  474. procedure WrPStr;
  475. var
  476. VLp1,
  477. VHlp,
  478. VHp2: Byte;
  479. begin
  480. VHlp := Length (Str);
  481. if VHlp > Len then VHlp := Len;
  482. Write (F, VHlp);
  483. for VLp1 := 1 to VHlp do begin
  484. VHp2 := Ord (Str [VLp1]);
  485. Write (F, VHp2);
  486. end;
  487. VHp2 := 0;
  488. for VLp1 := VHlp + 1 to Len do Write (F, VHp2);
  489. end;
  490. procedure WrVStr;
  491. var
  492. VLp1,
  493. VHlp: Byte;
  494. begin
  495. VHlp := Length (Str);
  496. Write (F, VHlp);
  497. for VLp1 := 1 to VHlp do begin
  498. VHlp := Ord (Str [VLp1]);
  499. Write (F, VHlp);
  500. end;
  501. end;
  502. procedure WrSInt;
  503. var
  504. VHlp: Byte;
  505. begin
  506. VHlp := Byte (Value);
  507. Write (F, VHlp);
  508. end;
  509. procedure WrByte;
  510. var
  511. VHlp: Byte;
  512. begin
  513. VHlp := Value;
  514. Write (F, VHlp);
  515. end;
  516. procedure WrNInt;
  517. var
  518. VHlp: Byte;
  519. begin
  520. VHlp := Hi (Word (Value));
  521. Write (F, VHlp);
  522. VHlp := Lo (Word (Value));
  523. Write (F, VHlp);
  524. end;
  525. procedure WrWord;
  526. var
  527. VHlp: Byte;
  528. begin
  529. VHlp := Hi (Value);
  530. Write (F, VHlp);
  531. VHlp := Lo (Value);
  532. Write (F, VHlp);
  533. end;
  534. procedure RdCStr;
  535. var
  536. VLp1,
  537. VHlp: Byte;
  538. begin
  539. Str := '';
  540. for VLp1 := 1 to Len do begin
  541. Read (F, VHlp);
  542. Str := Str + Chr (VHlp);
  543. end;
  544. end;
  545. procedure RdPStr;
  546. var
  547. FPos,
  548. VLp1,
  549. VHlp: Byte;
  550. begin
  551. FPos := FilePos (F);
  552. Str := '';
  553. Read (F, VHlp);
  554. for VLp1 := 1 to VHlp do begin
  555. Read (F, VHlp);
  556. Str := Str + Chr (VHlp);
  557. end;
  558. Seek (F, FPos + Len + 1);
  559. end;
  560. procedure RdVStr;
  561. var
  562. VLp1,
  563. VHlp: Byte;
  564. begin
  565. Str := '';
  566. Read (F, VHlp);
  567. for VLp1 := 1 to VHlp do begin
  568. Read (F, VHlp);
  569. Str := Str + Chr (VHlp);
  570. end;
  571. end;
  572. procedure RdSInt;
  573. var
  574. VHlp: Byte;
  575. begin
  576. Read (F, VHlp);
  577. Value := ShortInt (VHlp);
  578. end;
  579. procedure RdByte;
  580. begin
  581. Read (F, Value);
  582. end;
  583. procedure RdNInt;
  584. var
  585. VHlp1: Byte;
  586. VHlp2: Word;
  587. begin
  588. Read (F, VHlp1);
  589. VHlp2 := VHlp1 * 256;
  590. Read (F, VHlp1);
  591. Inc (VHlp2, VHlp1);
  592. Value := SmallInt (VHlp2);
  593. end;
  594. procedure RdWord;
  595. var
  596. VHlp: Byte;
  597. begin
  598. Read (F, VHlp);
  599. Value := VHlp * 256;
  600. Read (F, VHlp);
  601. Inc (Value, VHlp);
  602. end;
  603. function WinFileTimeToDateTime(WinFileTime: TFileTime): TDateTime;
  604. var
  605. Time: Integer;
  606. LocalFileTime: TFileTime;
  607. begin
  608. FileTimeToLocalFileTime(WinFileTime, LocalFileTime);
  609. FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo);
  610. Result := FileDateToDateTime (Time);
  611. end;
  612. function WinFileAttrToFileAttr(WinFileAttr: Integer): TFileAttributes;
  613. begin
  614. Result := [];
  615. if (WinFileAttr and faDirectory) <> 0 then
  616. Include (Result, atDirectory);
  617. if (WinFileAttr and faArchive) <> 0 then
  618. Include (Result, atArchive);
  619. if (WinFileAttr and faReadOnly) <> 0 then
  620. Include (Result, atReadOnly);
  621. if (WinFileAttr and faHidden) <> 0 then
  622. Include (Result, atHidden);
  623. if (WinFileAttr and faSysFile) <> 0 then
  624. Include (Result, atSystem);
  625. end;
  626. function FileAttrToWinFileAttr(FileAttr: TFileAttributes): Integer;
  627. begin
  628. Result := 0;
  629. if atDirectory in FileAttr then
  630. Result := Result or faDirectory;
  631. if atArchive in FileAttr then
  632. Result := Result or faArchive;
  633. if atReadOnly in FileAttr then
  634. Result := Result or faReadOnly;
  635. if atHidden in FileAttr then
  636. Result := Result or faHidden;
  637. if atSystem in FileAttr then
  638. Result := Result or faSysFile;
  639. end;
  640. procedure AddBackslash(var Dir: string);
  641. begin
  642. if (Length (Dir) > 0) and (Dir [Length (Dir)] <> '\') then
  643. Dir := Dir + '\';
  644. end;
  645. function WithBackslash(const Dir: string): string;
  646. begin
  647. if (Length (Dir) > 0) and (Dir [Length (Dir)] <> '\') then
  648. Result := Dir + '\'
  649. else
  650. Result := Dir;
  651. end;
  652. function WithoutBackslash(const Dir: string): string;
  653. begin
  654. if (Length (Dir) > 0) and (Length (Dir) > 3) and (Dir [Length (Dir)] = '\') then
  655. Result := Copy (Dir, 1, Length (Dir) - 1)
  656. else
  657. Result := Dir;
  658. end;
  659. function WithoutExt(const FileName: string): string;
  660. begin
  661. Result := ChangeFileExt (FileName, '');
  662. end;
  663. { TFileReference }
  664. function TFileReference.GetCreationTime: TDateTime;
  665. begin
  666. Result := WinFileTimeToDateTime (FSearchRec.FindData.ftCreationTime);
  667. end;
  668. function TFileReference.GetFileAttr: TFileAttributes;
  669. begin
  670. Result := WinFileAttrToFileAttr (FSearchRec.Attr);
  671. end;
  672. function TFileReference.GetFileName: string;
  673. begin
  674. Result := FSearchRec.Name;
  675. end;
  676. function TFileReference.GetFileSize: Integer;
  677. begin
  678. Result := FSearchRec.Size;
  679. end;
  680. function TFileReference.GetFullName: string;
  681. begin
  682. Result := FOwner.Directory + FSearchRec.Name;
  683. end;
  684. function TFileReference.GetFullShortName: string;
  685. var
  686. TmpDir: string;
  687. F: TSearchRec;
  688. begin
  689. Result := ShortFileName;
  690. TmpDir := FOwner.Directory;
  691. Delete (TmpDir, Length (TmpDir), 1);
  692. while Length (TmpDir) > 2 do begin
  693. if FindFirst (TmpDir, faDirectory or faReadOnly or faHidden or faSysFile or faArchive, F) = 0 then begin
  694. if F.FindData.cAlternateFileName = '' then
  695. Result := F.Name + '\' + Result
  696. else
  697. Result := F.FindData.cAlternateFileName + '\' + Result
  698. end else
  699. Result := ExtractFileName (TmpDir) + '\' + Result;
  700. FindClose (F);
  701. Delete (TmpDir, LastPos ('\', TmpDir), Length (TmpDir));
  702. end;
  703. Result := TmpDir + '\' + Result;
  704. end;
  705. function TFileReference.GetLastAccessTime: TDateTime;
  706. begin
  707. Result := WinFileTimeToDateTime (FSearchRec.FindData.ftLastAccessTime);
  708. end;
  709. function TFileReference.GetModificationTime: TDateTime;
  710. begin
  711. Result := WinFileTimeToDateTime (FSearchRec.FindData.ftLastWriteTime);
  712. end;
  713. function TFileReference.GetShortFileName: string;
  714. begin
  715. Result := FSearchRec.FindData.cAlternateFileName;
  716. if Result = '' then
  717. Result := FSearchRec.Name;
  718. end;
  719. { TFileReferences }
  720. function TFileReferences.Add(const F: TSearchRec): Integer;
  721. var
  722. R: TFileReference;
  723. begin
  724. R := TFileReference.Create;
  725. with R do begin
  726. FOwner := Self;
  727. FSearchRec := F;
  728. end;
  729. Result := FList.Add (Pointer (R));
  730. end;
  731. procedure TFileReferences.Clear;
  732. begin
  733. while Count > 0 do
  734. Delete (Count - 1);
  735. end;
  736. procedure TFileReferences.CopyFullNamesToStrings(const S: TStrings);
  737. var
  738. I: Integer;
  739. begin
  740. S.BeginUpdate;
  741. for I := 0 to Count - 1 do
  742. S.AddObject (Items[I].FullName, Items [I]);
  743. S.EndUpdate;
  744. end;
  745. procedure TFileReferences.CopyToStrings(const S: TStrings);
  746. var
  747. I,
  748. P: Integer;
  749. N: string;
  750. begin
  751. S.BeginUpdate;
  752. for I := 0 to Count - 1 do begin
  753. N := Items[I].FileName;
  754. P := LastPos ('.', N);
  755. if P < 1 then
  756. P := Length (N)
  757. else
  758. Dec (P);
  759. S.AddObject (GetLowerName (Copy (N, 1, P)), Items [I]);
  760. end;
  761. S.EndUpdate;
  762. end;
  763. constructor TFileReferences.Create;
  764. begin
  765. inherited;
  766. FList := TList.Create;
  767. end;
  768. procedure TFileReferences.Delete(Index: Integer);
  769. begin
  770. with FList do begin
  771. TFileReference(Items[Index]).Free;
  772. Delete (Index);
  773. end;
  774. end;
  775. destructor TFileReferences.Destroy;
  776. begin
  777. inherited;
  778. Clear;
  779. FList.Free;
  780. end;
  781. function TFileReferences.GetCount: Integer;
  782. begin
  783. Result := FList.Count;
  784. end;
  785. function TFileReferences.GetItem(ItemIndex: Integer): TFileReference;
  786. begin
  787. Result := TFileReference (FList.Items [ItemIndex]);
  788. end;
  789. procedure TFileReferences.SearchForDirs(const ParentDir: string;
  790. FileAttr: TFileAttributes);
  791. var
  792. Mask: string;
  793. begin
  794. if Length (ParentDir) > 0 then
  795. Mask := WithBackslash (ParentDir)
  796. else
  797. Mask := '*.*';
  798. SearchForFiles (Mask, FileAttr + [atDirectory]);
  799. end;
  800. procedure TFileReferences.SearchForFiles(FileName: string;
  801. FileAttr: TFileAttributes);
  802. var
  803. F: TSearchRec;
  804. R: Integer;
  805. begin
  806. Clear;
  807. if (FileName = '') or (FileName [Length (FileName)] = '\') then
  808. FileName := FileName + '*.*';
  809. FileName := ExpandFileName (FileName);
  810. FDirectory := ExtractFilePath (FileName);
  811. FWildCard := ExtractFileName (FileName);
  812. FSearchAttr := FileAttr;
  813. R := FindFirst (FileName, FileAttrToWinFileAttr (FileAttr), F);
  814. while R = 0 do begin
  815. if (not ((atDirectory in FileAttr) and ((faDirectory and F.Attr) = 0))) and (F.Name [1] <> '.') and ((WinFileAttrToFileAttr (F.Attr) - FileAttr) = []) then
  816. Add (F);
  817. R := FindNext (F);
  818. end;
  819. FindClose (F);
  820. FSearchTime := Now;
  821. end;
  822. end.