wutils.pas 23 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012
  1. {
  2. $Id$
  3. This file is part of the Free Pascal Integrated Development Environment
  4. Copyright (c) 1998 by Berczi Gabor
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. unit WUtils;
  12. interface
  13. {$ifndef FPC}
  14. {$define TPUNIXLF}
  15. {$endif}
  16. uses
  17. Dos,Objects;
  18. type
  19. PByteArray = ^TByteArray;
  20. TByteArray = array[0..MaxBytes] of byte;
  21. PNoDisposeCollection = ^TNoDisposeCollection;
  22. TNoDisposeCollection = object(TCollection)
  23. procedure FreeItem(Item: Pointer); virtual;
  24. end;
  25. PUnsortedStringCollection = ^TUnsortedStringCollection;
  26. TUnsortedStringCollection = object(TCollection)
  27. constructor CreateFrom(ALines: PUnsortedStringCollection);
  28. procedure Assign(ALines: PUnsortedStringCollection);
  29. function At(Index: Integer): PString;
  30. procedure FreeItem(Item: Pointer); virtual;
  31. function GetItem(var S: TStream): Pointer; virtual;
  32. procedure PutItem(var S: TStream; Item: Pointer); virtual;
  33. procedure InsertStr(const S: string);
  34. end;
  35. PNulStream = ^TNulStream;
  36. TNulStream = object(TStream)
  37. constructor Init;
  38. function GetPos: Longint; virtual;
  39. function GetSize: Longint; virtual;
  40. procedure Read(var Buf; Count: Word); virtual;
  41. procedure Seek(Pos: Longint); virtual;
  42. procedure Write(var Buf; Count: Word); virtual;
  43. end;
  44. PSubStream = ^TSubStream;
  45. TSubStream = object(TStream)
  46. constructor Init(AStream: PStream; AStartPos, ASize: longint);
  47. function GetPos: Longint; virtual;
  48. function GetSize: Longint; virtual;
  49. procedure Read(var Buf; Count: Word); virtual;
  50. procedure Seek(Pos: Longint); virtual;
  51. procedure Write(var Buf; Count: Word); virtual;
  52. private
  53. StartPos: longint;
  54. S : PStream;
  55. end;
  56. PTextCollection = ^TTextCollection;
  57. TTextCollection = object(TStringCollection)
  58. function LookUp(const S: string; var Idx: sw_integer): string;
  59. function Compare(Key1, Key2: Pointer): sw_Integer; virtual;
  60. end;
  61. {$ifdef TPUNIXLF}
  62. procedure readln(var t:text;var s:string);
  63. {$endif}
  64. procedure ReadlnFromStream(Stream: PStream; var s:string;var linecomplete : boolean);
  65. function eofstream(s: pstream): boolean;
  66. function Min(A,B: longint): longint;
  67. function Max(A,B: longint): longint;
  68. function CharStr(C: char; Count: integer): string;
  69. function UpcaseStr(const S: string): string;
  70. function LowCase(C: char): char;
  71. function LowcaseStr(S: string): string;
  72. function RExpand(const S: string; MinLen: byte): string;
  73. function LExpand(const S: string; MinLen: byte): string;
  74. function LTrim(const S: string): string;
  75. function RTrim(const S: string): string;
  76. function Trim(const S: string): string;
  77. function IntToStr(L: longint): string;
  78. function IntToStrL(L: longint; MinLen: sw_integer): string;
  79. function IntToStrZ(L: longint; MinLen: sw_integer): string;
  80. function StrToInt(const S: string): longint;
  81. function IntToHex(L: longint): string;
  82. function GetStr(P: PString): string;
  83. function GetPChar(P: PChar): string;
  84. function BoolToStr(B: boolean; const TrueS, FalseS: string): string;
  85. function DirOf(const S: string): string;
  86. function ExtOf(const S: string): string;
  87. function NameOf(const S: string): string;
  88. function NameAndExtOf(const S: string): string;
  89. function DirAndNameOf(const S: string): string;
  90. { return Dos GetFTime value or -1 if the file does not exist }
  91. function GetFileTime(const FileName: string): longint;
  92. { copied from compiler global unit }
  93. function GetShortName(const n:string):string;
  94. function GetLongName(const n:string):string;
  95. function TrimEndSlash(const Path: string): string;
  96. function OptimizePath(Path: string; MaxLen: integer): string;
  97. function CompareText(S1, S2: string): integer;
  98. function FormatPath(Path: string): string;
  99. function CompletePath(const Base, InComplete: string): string;
  100. function CompleteURL(const Base, URLRef: string): string;
  101. function DeleteFile(const FileName: string): integer;
  102. function EatIO: integer;
  103. function Now: longint;
  104. function FormatDateTimeL(L: longint; const Format: string): string;
  105. function FormatDateTime(const D: DateTime; const Format: string): string;
  106. procedure GiveUpTimeSlice;
  107. const LastStrToIntResult : integer = 0;
  108. DirSep : char = {$ifdef Linux}'/'{$else}'\'{$endif};
  109. procedure RegisterWUtils;
  110. implementation
  111. uses
  112. {$ifdef win32}
  113. windows,
  114. {$endif win32}
  115. Strings;
  116. {$ifndef NOOBJREG}
  117. const
  118. RUnsortedStringCollection: TStreamRec = (
  119. ObjType: 22500;
  120. VmtLink: Ofs(TypeOf(TUnsortedStringCollection)^);
  121. Load: @TUnsortedStringCollection.Load;
  122. Store: @TUnsortedStringCollection.Store
  123. );
  124. {$endif}
  125. {$ifdef TPUNIXLF}
  126. procedure readln(var t:text;var s:string);
  127. var
  128. c : char;
  129. i : longint;
  130. begin
  131. if TextRec(t).UserData[1]=2 then
  132. system.readln(t,s)
  133. else
  134. begin
  135. c:=#0;
  136. i:=0;
  137. while (not eof(t)) and (c<>#10) do
  138. begin
  139. read(t,c);
  140. if c<>#10 then
  141. begin
  142. inc(i);
  143. s[i]:=c;
  144. end;
  145. end;
  146. if (i>0) and (s[i]=#13) then
  147. begin
  148. dec(i);
  149. TextRec(t).UserData[1]:=2;
  150. end;
  151. s[0]:=chr(i);
  152. end;
  153. end;
  154. {$endif}
  155. function eofstream(s: pstream): boolean;
  156. begin
  157. eofstream:=(s^.getpos>=s^.getsize);
  158. end;
  159. procedure ReadlnFromStream(Stream: PStream; var S:string;var linecomplete : boolean);
  160. var
  161. c : char;
  162. i : longint;
  163. begin
  164. linecomplete:=false;
  165. c:=#0;
  166. i:=0;
  167. { this created problems for lines longer than 255 characters
  168. now those lines are cutted into pieces without warning PM }
  169. while (not eofstream(stream)) and (c<>#10) and (i<255) do
  170. begin
  171. stream^.read(c,sizeof(c));
  172. if c<>#10 then
  173. begin
  174. inc(i);
  175. s[i]:=c;
  176. end;
  177. end;
  178. if (c=#10) or eofstream(stream) then
  179. linecomplete:=true;
  180. { if there was a CR LF then remove the CR Dos newline style }
  181. if (i>0) and (s[i]=#13) then
  182. dec(i);
  183. s[0]:=chr(i);
  184. end;
  185. function Max(A,B: longint): longint;
  186. begin
  187. if A>B then Max:=A else Max:=B;
  188. end;
  189. function Min(A,B: longint): longint;
  190. begin
  191. if A<B then Min:=A else Min:=B;
  192. end;
  193. function CharStr(C: char; Count: integer): string;
  194. {$ifndef FPC}
  195. var S: string;
  196. {$endif}
  197. begin
  198. {$ifdef FPC}
  199. CharStr[0]:=chr(Count);
  200. FillChar(CharStr[1],Count,C);
  201. {$else}
  202. S[0]:=chr(Count);
  203. FillChar(S[1],Count,C);
  204. CharStr:=S;
  205. {$endif}
  206. end;
  207. function UpcaseStr(const S: string): string;
  208. var
  209. I: Longint;
  210. begin
  211. for I:=1 to length(S) do
  212. if S[I] in ['a'..'z'] then
  213. UpCaseStr[I]:=chr(ord(S[I])-32)
  214. else
  215. UpCaseStr[I]:=S[I];
  216. UpcaseStr[0]:=S[0];
  217. end;
  218. function RExpand(const S: string; MinLen: byte): string;
  219. begin
  220. if length(S)<MinLen then
  221. RExpand:=S+CharStr(' ',MinLen-length(S))
  222. else
  223. RExpand:=S;
  224. end;
  225. function LExpand(const S: string; MinLen: byte): string;
  226. begin
  227. if length(S)<MinLen then
  228. LExpand:=CharStr(' ',MinLen-length(S))+S
  229. else
  230. LExpand:=S;
  231. end;
  232. function LTrim(const S: string): string;
  233. var
  234. i : longint;
  235. begin
  236. i:=1;
  237. while (i<length(s)) and (s[i]=' ') do
  238. inc(i);
  239. LTrim:=Copy(s,i,255);
  240. end;
  241. function RTrim(const S: string): string;
  242. var
  243. i : longint;
  244. begin
  245. i:=length(s);
  246. while (i>0) and (s[i]=' ') do
  247. dec(i);
  248. RTrim:=Copy(s,1,i);
  249. end;
  250. function Trim(const S: string): string;
  251. begin
  252. Trim:=RTrim(LTrim(S));
  253. end;
  254. function IntToStr(L: longint): string;
  255. var S: string;
  256. begin
  257. Str(L,S);
  258. IntToStr:=S;
  259. end;
  260. function IntToStrL(L: longint; MinLen: sw_integer): string;
  261. begin
  262. IntToStrL:=LExpand(IntToStr(L),MinLen);
  263. end;
  264. function IntToStrZ(L: longint; MinLen: sw_integer): string;
  265. var S: string;
  266. begin
  267. S:=IntToStr(L);
  268. if length(S)<MinLen then
  269. S:=CharStr('0',MinLen-length(S))+S;
  270. IntToStrZ:=S;
  271. end;
  272. function StrToInt(const S: string): longint;
  273. var L: longint;
  274. C: integer;
  275. begin
  276. Val(S,L,C); if C<>0 then L:=-1;
  277. LastStrToIntResult:=C;
  278. StrToInt:=L;
  279. end;
  280. function IntToHex(L: longint): string;
  281. const HexNums : string[16] = '0123456789ABCDEF';
  282. var S: string;
  283. R: real;
  284. function DivF(Mit,Mivel: real): longint;
  285. begin
  286. DivF:=trunc(Mit/Mivel);
  287. end;
  288. function ModF(Mit,Mivel: real): longint;
  289. begin
  290. ModF:=trunc(Mit-DivF(Mit,Mivel)*Mivel);
  291. end;
  292. begin
  293. S:='';
  294. R:=L; if R<0 then begin R:=R+2147483647+2147483647+2; end;
  295. repeat
  296. S:=HexNums[ModF(R,16)+1]+S;
  297. R:=DivF(R,16);
  298. until R=0;
  299. IntToHex:=S;
  300. end;
  301. function GetStr(P: PString): string;
  302. begin
  303. if P=nil then GetStr:='' else GetStr:=P^;
  304. end;
  305. function GetPChar(P: PChar): string;
  306. begin
  307. if P=nil then GetPChar:='' else GetPChar:=StrPas(P);
  308. end;
  309. function DirOf(const S: string): string;
  310. var D: DirStr; E: ExtStr; N: NameStr;
  311. begin
  312. FSplit(S,D,N,E);
  313. if (D<>'') and (D[Length(D)]<>DirSep) then
  314. DirOf:=D+DirSep
  315. else
  316. DirOf:=D;
  317. end;
  318. function ExtOf(const S: string): string;
  319. var D: DirStr; E: ExtStr; N: NameStr;
  320. begin
  321. FSplit(S,D,N,E);
  322. ExtOf:=E;
  323. end;
  324. function NameOf(const S: string): string;
  325. var D: DirStr; E: ExtStr; N: NameStr;
  326. begin
  327. FSplit(S,D,N,E);
  328. NameOf:=N;
  329. end;
  330. function NameAndExtOf(const S: string): string;
  331. var D: DirStr; E: ExtStr; N: NameStr;
  332. begin
  333. FSplit(S,D,N,E);
  334. NameAndExtOf:=N+E;
  335. end;
  336. function DirAndNameOf(const S: string): string;
  337. var D: DirStr; E: ExtStr; N: NameStr;
  338. begin
  339. FSplit(S,D,N,E);
  340. DirAndNameOf:=D+N;
  341. end;
  342. { return Dos GetFTime value or -1 if the file does not exist }
  343. function GetFileTime(const FileName: string): longint;
  344. var T: longint;
  345. f: file;
  346. FM: integer;
  347. begin
  348. if FileName='' then
  349. T:=-1
  350. else
  351. begin
  352. FM:=FileMode; FileMode:=0;
  353. EatIO; DosError:=0;
  354. Assign(f,FileName);
  355. {$I-}
  356. Reset(f);
  357. if InOutRes=0 then
  358. begin
  359. GetFTime(f,T);
  360. Close(f);
  361. end;
  362. {$I+}
  363. if (EatIO<>0) or (DosError<>0) then T:=-1;
  364. FileMode:=FM;
  365. end;
  366. GetFileTime:=T;
  367. end;
  368. function GetShortName(const n:string):string;
  369. {$ifdef win32}
  370. var
  371. hs,hs2 : string;
  372. i : longint;
  373. {$endif}
  374. {$ifdef go32v2}
  375. var
  376. hs : string;
  377. {$endif}
  378. begin
  379. GetShortName:=n;
  380. {$ifdef win32}
  381. hs:=n+#0;
  382. i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2));
  383. if (i>0) and (i<=high(hs2)) then
  384. begin
  385. hs2[0]:=chr(strlen(@hs2[1]));
  386. GetShortName:=hs2;
  387. end;
  388. {$endif}
  389. {$ifdef go32v2}
  390. hs:=n;
  391. if Dos.GetShortName(hs) then
  392. GetShortName:=hs;
  393. {$endif}
  394. end;
  395. function GetLongName(const n:string):string;
  396. {$ifdef win32}
  397. var
  398. hs : string;
  399. hs2 : Array [0..255] of char;
  400. i : longint;
  401. j : pchar;
  402. {$endif}
  403. {$ifdef go32v2}
  404. var
  405. hs : string;
  406. {$endif}
  407. begin
  408. GetLongName:=n;
  409. {$ifdef win32}
  410. hs:=n+#0;
  411. i:=Windows.GetFullPathName(@hs[1],256,hs2,j);
  412. if (i>0) and (i<=255) then
  413. begin
  414. hs:=strpas(hs2);
  415. GetLongName:=hs;
  416. end;
  417. {$endif}
  418. {$ifdef go32v2}
  419. hs:=n;
  420. if Dos.GetLongName(hs) then
  421. GetLongName:=hs;
  422. {$endif}
  423. end;
  424. function EatIO: integer;
  425. begin
  426. EatIO:=IOResult;
  427. end;
  428. function LowCase(C: char): char;
  429. begin
  430. if ('A'<=C) and (C<='Z') then C:=chr(ord(C)+32);
  431. LowCase:=C;
  432. end;
  433. function LowcaseStr(S: string): string;
  434. var I: Longint;
  435. begin
  436. for I:=1 to length(S) do
  437. S[I]:=Lowcase(S[I]);
  438. LowcaseStr:=S;
  439. end;
  440. function BoolToStr(B: boolean; const TrueS, FalseS: string): string;
  441. begin
  442. if B then BoolToStr:=TrueS else BoolToStr:=FalseS;
  443. end;
  444. procedure TNoDisposeCollection.FreeItem(Item: Pointer);
  445. begin
  446. { don't do anything here }
  447. end;
  448. constructor TUnsortedStringCollection.CreateFrom(ALines: PUnsortedStringCollection);
  449. begin
  450. if Assigned(ALines)=false then Fail;
  451. inherited Init(ALines^.Count,ALines^.Count div 10);
  452. Assign(ALines);
  453. end;
  454. procedure TUnsortedStringCollection.Assign(ALines: PUnsortedStringCollection);
  455. procedure AddIt(P: PString); {$ifndef FPC}far;{$endif}
  456. begin
  457. Insert(NewStr(GetStr(P)));
  458. end;
  459. begin
  460. FreeAll;
  461. if Assigned(ALines) then
  462. ALines^.ForEach(@AddIt);
  463. end;
  464. procedure TUnsortedStringCollection.InsertStr(const S: string);
  465. begin
  466. Insert(NewStr(S));
  467. end;
  468. function TUnsortedStringCollection.At(Index: Integer): PString;
  469. begin
  470. At:=inherited At(Index);
  471. end;
  472. procedure TUnsortedStringCollection.FreeItem(Item: Pointer);
  473. begin
  474. if Item<>nil then DisposeStr(Item);
  475. end;
  476. function TUnsortedStringCollection.GetItem(var S: TStream): Pointer;
  477. begin
  478. GetItem:=S.ReadStr;
  479. end;
  480. procedure TUnsortedStringCollection.PutItem(var S: TStream; Item: Pointer);
  481. begin
  482. S.WriteStr(Item);
  483. end;
  484. constructor TNulStream.Init;
  485. begin
  486. inherited Init;
  487. Position:=0;
  488. end;
  489. function TNulStream.GetPos: Longint;
  490. begin
  491. GetPos:=Position;
  492. end;
  493. function TNulStream.GetSize: Longint;
  494. begin
  495. GetSize:=Position;
  496. end;
  497. procedure TNulStream.Read(var Buf; Count: Word);
  498. begin
  499. Error(stReadError,0);
  500. end;
  501. procedure TNulStream.Seek(Pos: Longint);
  502. begin
  503. if Pos<=Position then
  504. Position:=Pos;
  505. end;
  506. procedure TNulStream.Write(var Buf; Count: Word);
  507. begin
  508. Inc(Position,Count);
  509. end;
  510. constructor TSubStream.Init(AStream: PStream; AStartPos, ASize: longint);
  511. begin
  512. inherited Init;
  513. if Assigned(AStream)=false then Fail;
  514. S:=AStream; StartPos:=AStartPos; StreamSize:=ASize;
  515. Seek(0);
  516. end;
  517. function TSubStream.GetPos: Longint;
  518. var Pos: longint;
  519. begin
  520. Pos:=S^.GetPos; Dec(Pos,StartPos);
  521. GetPos:=Pos;
  522. end;
  523. function TSubStream.GetSize: Longint;
  524. begin
  525. GetSize:=StreamSize;
  526. end;
  527. procedure TSubStream.Read(var Buf; Count: Word);
  528. var Pos: longint;
  529. RCount: word;
  530. begin
  531. Pos:=GetPos;
  532. if Pos+Count>StreamSize then RCount:=StreamSize-Pos else RCount:=Count;
  533. S^.Read(Buf,RCount);
  534. if RCount<Count then
  535. Error(stReadError,0);
  536. end;
  537. procedure TSubStream.Seek(Pos: Longint);
  538. var RPos: longint;
  539. begin
  540. if (Pos<=StreamSize) then RPos:=Pos else RPos:=StreamSize;
  541. S^.Seek(StartPos+RPos);
  542. end;
  543. procedure TSubStream.Write(var Buf; Count: Word);
  544. begin
  545. S^.Write(Buf,Count);
  546. end;
  547. function TTextCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
  548. var K1: PString absolute Key1;
  549. K2: PString absolute Key2;
  550. R: Sw_integer;
  551. S1,S2: string;
  552. begin
  553. S1:=UpCaseStr(K1^);
  554. S2:=UpCaseStr(K2^);
  555. if S1<S2 then R:=-1 else
  556. if S1>S2 then R:=1 else
  557. R:=0;
  558. Compare:=R;
  559. end;
  560. function TTextCollection.LookUp(const S: string; var Idx: sw_integer): string;
  561. var OLI,ORI,Left,Right,Mid: integer;
  562. LeftP,RightP,MidP: PString;
  563. {LeftS,}MidS{,RightS}: string;
  564. FoundS: string;
  565. UpS : string;
  566. begin
  567. Idx:=-1; FoundS:='';
  568. Left:=0; Right:=Count-1;
  569. UpS:=UpCaseStr(S);
  570. if Left<Right then
  571. begin
  572. while (Left<Right) do
  573. begin
  574. OLI:=Left; ORI:=Right;
  575. Mid:=Left+(Right-Left) div 2;
  576. LeftP:=At(Left); RightP:=At(Right); MidP:=At(Mid);
  577. { LeftS:=UpCaseStr(LeftP^); }MidS:=UpCaseStr(MidP^);
  578. { RightS:=UpCaseStr(RightP^);}
  579. if copy(MidS,1,length(UpS))=UpS then
  580. begin
  581. Idx:=Mid; FoundS:=GetStr(MidP);
  582. end;
  583. { else}
  584. if UpS<MidS then
  585. Right:=Mid
  586. else
  587. Left:=Mid;
  588. if (OLI=Left) and (ORI=Right) then
  589. Break;
  590. end;
  591. end;
  592. LookUp:=FoundS;
  593. end;
  594. function TrimEndSlash(const Path: string): string;
  595. var S: string;
  596. begin
  597. S:=Path;
  598. if (length(S)>0) and (S<>DirSep) and (copy(S,length(S),1)=DirSep) and
  599. (S[length(S)-1]<>':') then
  600. S:=copy(S,1,length(S)-1);
  601. TrimEndSlash:=S;
  602. end;
  603. function CompareText(S1, S2: string): integer;
  604. var R: integer;
  605. begin
  606. S1:=UpcaseStr(S1); S2:=UpcaseStr(S2);
  607. if S1<S2 then R:=-1 else
  608. if S1>S2 then R:= 1 else
  609. R:=0;
  610. CompareText:=R;
  611. end;
  612. function FormatPath(Path: string): string;
  613. var P: sw_integer;
  614. SC: char;
  615. begin
  616. if ord(DirSep)=ord('/') then
  617. SC:='\'
  618. else
  619. SC:='/';
  620. repeat
  621. P:=Pos(SC,Path);
  622. if P>0 then Path[P]:=DirSep;
  623. until P=0;
  624. FormatPath:=Path;
  625. end;
  626. function CompletePath(const Base, InComplete: string): string;
  627. var Drv,BDrv: string[40]; D,BD: DirStr; N,BN: NameStr; E,BE: ExtStr;
  628. P: sw_integer;
  629. Complete: string;
  630. begin
  631. Complete:=FormatPath(InComplete);
  632. FSplit(FormatPath(InComplete),D,N,E);
  633. P:=Pos(':',D); if P=0 then Drv:='' else begin Drv:=copy(D,1,P); Delete(D,1,P); end;
  634. FSplit(FormatPath(Base),BD,BN,BE);
  635. P:=Pos(':',BD); if P=0 then BDrv:='' else begin BDrv:=copy(BD,1,P); Delete(BD,1,P); end;
  636. if copy(D,1,1)<>DirSep then
  637. Complete:=BD+D+N+E;
  638. if Drv='' then
  639. Complete:=BDrv+Complete;
  640. Complete:=FExpand(Complete);
  641. CompletePath:=Complete;
  642. end;
  643. function CompleteURL(const Base, URLRef: string): string;
  644. var P: integer;
  645. Drive: string[20];
  646. IsComplete: boolean;
  647. S: string;
  648. Ref: string;
  649. Bookmark: string;
  650. begin
  651. IsComplete:=false; Ref:=URLRef;
  652. P:=Pos(':',Ref);
  653. if P=0 then Drive:='' else Drive:=UpcaseStr(copy(Ref,1,P-1));
  654. if Drive<>'' then
  655. if (Drive='MAILTO') or (Drive='FTP') or (Drive='HTTP') or
  656. (Drive='GOPHER') or (Drive='FILE') then
  657. IsComplete:=true;
  658. if IsComplete then S:=Ref else
  659. begin
  660. P:=Pos('#',Ref);
  661. if P=0 then
  662. Bookmark:=''
  663. else
  664. begin
  665. Bookmark:=copy(Ref,P+1,length(Ref));
  666. Ref:=copy(Ref,1,P-1);
  667. end;
  668. S:=CompletePath(Base,Ref);
  669. if Bookmark<>'' then
  670. S:=S+'#'+Bookmark;
  671. end;
  672. CompleteURL:=S;
  673. end;
  674. function OptimizePath(Path: string; MaxLen: integer): string;
  675. var i : integer;
  676. BackSlashs : array[1..20] of integer;
  677. BSCount : integer;
  678. Jobbra : boolean;
  679. Jobb, Bal : byte;
  680. Hiba : boolean;
  681. begin
  682. if length(Path)>MaxLen then
  683. begin
  684. BSCount:=0; Jobbra:=true;
  685. for i:=1 to length(Path) do if Path[i]=DirSep then
  686. begin
  687. Inc(BSCount);
  688. BackSlashs[BSCount]:=i;
  689. end;
  690. i:=BSCount div 2;
  691. Hiba:=false;
  692. Bal:=i; Jobb:=i+1;
  693. case i of 0 : ;
  694. 1 : Path:=copy(Path, 1, BackSlashs[1])+'..'+
  695. copy(Path, BackSlashs[2], length(Path));
  696. else begin
  697. while (BackSlashs[Bal]+(length(Path)-BackSlashs[Jobb]) >=
  698. MaxLen) and not Hiba do
  699. begin
  700. if Jobbra then begin
  701. if Jobb<BSCount then inc(Jobb)
  702. else Hiba:=true;
  703. Jobbra:=false;
  704. end
  705. else begin
  706. if Bal>1 then dec(Bal)
  707. else Hiba:=true;
  708. Jobbra:=true;
  709. end;
  710. end;
  711. Path:=copy(Path, 1, BackSlashs[Bal])+'..'+
  712. copy(Path, BackSlashs[Jobb], length(Path));
  713. end;
  714. end;
  715. end;
  716. if length(Path)>MaxLen then
  717. begin
  718. i:=Pos('\..\',Path);
  719. if i>0 then Path:=copy(Path,1,i-1)+'..'+copy(Path,i+length('\..\'),length(Path));
  720. end;
  721. OptimizePath:=Path;
  722. end;
  723. function Now: longint;
  724. var D: DateTime;
  725. W: word;
  726. L: longint;
  727. begin
  728. FillChar(D,sizeof(D),0);
  729. GetDate(D.Year,D.Month,D.Day,W);
  730. GetTime(D.Hour,D.Min,D.Sec,W);
  731. PackTime(D,L);
  732. Now:=L;
  733. end;
  734. function FormatDateTimeL(L: longint; const Format: string): string;
  735. var D: DateTime;
  736. begin
  737. UnpackTime(L,D);
  738. FormatDateTimeL:=FormatDateTime(D,Format);
  739. end;
  740. function FormatDateTime(const D: DateTime; const Format: string): string;
  741. var I: sw_integer;
  742. CurCharStart: sw_integer;
  743. CurChar: char;
  744. CurCharCount: integer;
  745. DateS: string;
  746. C: char;
  747. procedure FlushChars;
  748. var S: string;
  749. I: sw_integer;
  750. begin
  751. S:='';
  752. for I:=1 to CurCharCount do
  753. S:=S+CurChar;
  754. case CurChar of
  755. 'y' : S:=IntToStrL(D.Year,length(S));
  756. 'm' : S:=IntToStrZ(D.Month,length(S));
  757. 'd' : S:=IntToStrZ(D.Day,length(S));
  758. 'h' : S:=IntToStrZ(D.Hour,length(S));
  759. 'n' : S:=IntToStrZ(D.Min,length(S));
  760. 's' : S:=IntToStrZ(D.Sec,length(S));
  761. end;
  762. DateS:=DateS+S;
  763. end;
  764. begin
  765. DateS:='';
  766. CurCharStart:=-1; CurCharCount:=0; CurChar:=#0;
  767. for I:=1 to length(Format) do
  768. begin
  769. C:=Format[I];
  770. if (C<>CurChar) or (CurCharStart=-1) then
  771. begin
  772. if CurCharStart<>-1 then FlushChars;
  773. CurCharCount:=1; CurCharStart:=I;
  774. end
  775. else
  776. Inc(CurCharCount);
  777. CurChar:=C;
  778. end;
  779. FlushChars;
  780. FormatDateTime:=DateS;
  781. end;
  782. function DeleteFile(const FileName: string): integer;
  783. var f: file;
  784. begin
  785. {$I-}
  786. Assign(f,FileName);
  787. Erase(f);
  788. DeleteFile:=EatIO;
  789. {$I+}
  790. end;
  791. procedure GiveUpTimeSlice;
  792. {$ifdef GO32V2}{$define DOS}{$endif}
  793. {$ifdef TP}{$define DOS}{$endif}
  794. {$ifdef DOS}
  795. var r: registers;
  796. begin
  797. r.ax:=$1680;
  798. intr($2f,r);
  799. end;
  800. {$endif}
  801. {$ifdef Linux}
  802. begin
  803. end;
  804. {$endif}
  805. {$ifdef Win32}
  806. begin
  807. end;
  808. {$endif}
  809. {$undef DOS}
  810. procedure RegisterWUtils;
  811. begin
  812. {$ifndef NOOBJREG}
  813. RegisterType(RUnsortedStringCollection);
  814. {$endif}
  815. end;
  816. END.
  817. {
  818. $Log$
  819. Revision 1.23 2000-06-16 08:50:45 pierre
  820. + new bunch of Gabor's changes
  821. Revision 1.22 2000/05/29 11:09:14 pierre
  822. + New bunch of Gabor's changes: see fixes.txt
  823. Revision 1.21 2000/05/02 08:42:29 pierre
  824. * new set of Gabor changes: see fixes.txt
  825. Revision 1.20 2000/04/25 08:42:36 pierre
  826. * New Gabor changes : see fixes.txt
  827. Revision 1.19 2000/04/18 11:42:39 pierre
  828. lot of Gabor changes : see fixes.txt
  829. Revision 1.18 2000/03/21 23:19:13 pierre
  830. + TrimEndSlash and CompareText by Gabor
  831. Revision 1.17 2000/03/20 19:19:45 pierre
  832. * LFN support in streams
  833. Revision 1.16 2000/03/14 13:36:12 pierre
  834. * error for unexistant file in GetFileTime fixed
  835. Revision 1.15 2000/02/07 11:45:11 pierre
  836. + TUnsortedStringCollection CreateFrom/Assign/GetItem/PutItem from Gabor
  837. Revision 1.14 2000/01/20 00:30:32 pierre
  838. * Result of GetShortPathName is checked
  839. Revision 1.13 2000/01/17 12:20:03 pierre
  840. * uses windows needed for GetShortName
  841. Revision 1.12 2000/01/14 15:36:43 pierre
  842. + GetShortFileName used for tcodeeditor file opening
  843. Revision 1.11 2000/01/05 17:27:20 pierre
  844. + linecomplete arg for ReadlnFromStream
  845. Revision 1.10 2000/01/03 11:38:35 michael
  846. Changes from Gabor
  847. Revision 1.9 1999/12/01 16:19:46 pierre
  848. + GetFileTime moved here
  849. Revision 1.8 1999/10/25 16:39:03 pierre
  850. + GetPChar to avoid nil pointer problems
  851. Revision 1.7 1999/09/13 11:44:00 peter
  852. * fixes from gabor, idle event, html fix
  853. Revision 1.6 1999/08/24 22:01:48 pierre
  854. * readlnfromstream length check added
  855. Revision 1.5 1999/08/03 20:22:45 peter
  856. + TTab acts now on Ctrl+Tab and Ctrl+Shift+Tab...
  857. + Desktop saving should work now
  858. - History saved
  859. - Clipboard content saved
  860. - Desktop saved
  861. - Symbol info saved
  862. * syntax-highlight bug fixed, which compared special keywords case sensitive
  863. (for ex. 'asm' caused asm-highlighting, while 'ASM' didn't)
  864. * with 'whole words only' set, the editor didn't found occourences of the
  865. searched text, if the text appeared previously in the same line, but didn't
  866. satisfied the 'whole-word' condition
  867. * ^QB jumped to (SelStart.X,SelEnd.X) instead of (SelStart.X,SelStart.Y)
  868. (ie. the beginning of the selection)
  869. * when started typing in a new line, but not at the start (X=0) of it,
  870. the editor inserted the text one character more to left as it should...
  871. * TCodeEditor.HideSelection (Ctrl-K+H) didn't update the screen
  872. * Shift shouldn't cause so much trouble in TCodeEditor now...
  873. * Syntax highlight had problems recognizing a special symbol if it was
  874. prefixed by another symbol character in the source text
  875. * Auto-save also occours at Dos shell, Tool execution, etc. now...
  876. Revision 1.4 1999/04/07 21:56:06 peter
  877. + object support for browser
  878. * html help fixes
  879. * more desktop saving things
  880. * NODEBUG directive to exclude debugger
  881. Revision 1.2 1999/03/08 14:58:22 peter
  882. + prompt with dialogs for tools
  883. Revision 1.1 1999/03/01 15:51:43 peter
  884. + Log
  885. }