wutils.pas 23 KB

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