123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974 |
- {
- $Id$
- This file is part of the Free Pascal Integrated Development Environment
- Copyright (c) 1998 by Berczi Gabor
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- unit WUtils;
- interface
- {$ifndef FPC}
- {$define TPUNIXLF}
- {$endif}
- uses
- Dos,Objects;
- type
- PByteArray = ^TByteArray;
- TByteArray = array[0..MaxBytes] of byte;
- PNoDisposeCollection = ^TNoDisposeCollection;
- TNoDisposeCollection = object(TCollection)
- procedure FreeItem(Item: Pointer); virtual;
- end;
- PUnsortedStringCollection = ^TUnsortedStringCollection;
- TUnsortedStringCollection = object(TCollection)
- constructor CreateFrom(ALines: PUnsortedStringCollection);
- procedure Assign(ALines: PUnsortedStringCollection);
- function At(Index: Integer): PString;
- procedure FreeItem(Item: Pointer); virtual;
- function GetItem(var S: TStream): Pointer; virtual;
- procedure PutItem(var S: TStream; Item: Pointer); virtual;
- end;
- PNulStream = ^TNulStream;
- TNulStream = object(TStream)
- constructor Init;
- function GetPos: Longint; virtual;
- function GetSize: Longint; virtual;
- procedure Read(var Buf; Count: Word); virtual;
- procedure Seek(Pos: Longint); virtual;
- procedure Write(var Buf; Count: Word); virtual;
- end;
- PSubStream = ^TSubStream;
- TSubStream = object(TStream)
- constructor Init(AStream: PStream; AStartPos, ASize: longint);
- function GetPos: Longint; virtual;
- function GetSize: Longint; virtual;
- procedure Read(var Buf; Count: Word); virtual;
- procedure Seek(Pos: Longint); virtual;
- procedure Write(var Buf; Count: Word); virtual;
- private
- StartPos: longint;
- S : PStream;
- end;
- PTextCollection = ^TTextCollection;
- TTextCollection = object(TStringCollection)
- function LookUp(const S: string; var Idx: sw_integer): string;
- function Compare(Key1, Key2: Pointer): sw_Integer; virtual;
- end;
- {$ifdef TPUNIXLF}
- procedure readln(var t:text;var s:string);
- {$endif}
- procedure ReadlnFromStream(Stream: PStream; var s:string;var linecomplete : boolean);
- function eofstream(s: pstream): boolean;
- function Min(A,B: longint): longint;
- function Max(A,B: longint): longint;
- function CharStr(C: char; Count: integer): string;
- function UpcaseStr(const S: string): string;
- function LowCase(C: char): char;
- function LowcaseStr(S: string): string;
- function RExpand(const S: string; MinLen: byte): string;
- function LExpand(const S: string; MinLen: byte): string;
- function LTrim(const S: string): string;
- function RTrim(const S: string): string;
- function Trim(const S: string): string;
- function IntToStr(L: longint): string;
- function IntToStrL(L: longint; MinLen: sw_integer): string;
- function IntToStrZ(L: longint; MinLen: sw_integer): string;
- function StrToInt(const S: string): longint;
- function IntToHex(L: longint): string;
- function GetStr(P: PString): string;
- function GetPChar(P: PChar): string;
- function BoolToStr(B: boolean; const TrueS, FalseS: string): string;
- function DirOf(const S: string): string;
- function ExtOf(const S: string): string;
- function NameOf(const S: string): string;
- function NameAndExtOf(const S: string): string;
- function DirAndNameOf(const S: string): string;
- { return Dos GetFTime value or -1 if the file does not exist }
- function GetFileTime(const FileName: string): longint;
- { copied from compiler global unit }
- function GetShortName(const n:string):string;
- function GetLongName(const n:string):string;
- function TrimEndSlash(const Path: string): string;
- function OptimizePath(Path: string; MaxLen: integer): string;
- function CompareText(S1, S2: string): integer;
- function FormatPath(Path: string): string;
- function CompletePath(const Base, InComplete: string): string;
- function CompleteURL(const Base, URLRef: string): string;
- function EatIO: integer;
- function Now: longint;
- function FormatDateTimeL(L: longint; const Format: string): string;
- function FormatDateTime(const D: DateTime; const Format: string): string;
- procedure GiveUpTimeSlice;
- const LastStrToIntResult : integer = 0;
- DirSep : char = {$ifdef Linux}'/'{$else}'\'{$endif};
- procedure RegisterWUtils;
- implementation
- uses
- {$ifdef win32}
- windows,
- {$endif win32}
- Strings;
- {$ifndef NOOBJREG}
- const
- RUnsortedStringCollection: TStreamRec = (
- ObjType: 22500;
- VmtLink: Ofs(TypeOf(TUnsortedStringCollection)^);
- Load: @TUnsortedStringCollection.Load;
- Store: @TUnsortedStringCollection.Store
- );
- {$endif}
- {$ifdef TPUNIXLF}
- procedure readln(var t:text;var s:string);
- var
- c : char;
- i : longint;
- begin
- if TextRec(t).UserData[1]=2 then
- system.readln(t,s)
- else
- begin
- c:=#0;
- i:=0;
- while (not eof(t)) and (c<>#10) do
- begin
- read(t,c);
- if c<>#10 then
- begin
- inc(i);
- s[i]:=c;
- end;
- end;
- if (i>0) and (s[i]=#13) then
- begin
- dec(i);
- TextRec(t).UserData[1]:=2;
- end;
- s[0]:=chr(i);
- end;
- end;
- {$endif}
- function eofstream(s: pstream): boolean;
- begin
- eofstream:=(s^.getpos>=s^.getsize);
- end;
- procedure ReadlnFromStream(Stream: PStream; var S:string;var linecomplete : boolean);
- var
- c : char;
- i : longint;
- begin
- linecomplete:=false;
- c:=#0;
- i:=0;
- { this created problems for lines longer than 255 characters
- now those lines are cutted into pieces without warning PM }
- while (not eofstream(stream)) and (c<>#10) and (i<255) do
- begin
- stream^.read(c,sizeof(c));
- if c<>#10 then
- begin
- inc(i);
- s[i]:=c;
- end;
- end;
- if (c=#10) or eofstream(stream) then
- linecomplete:=true;
- { if there was a CR LF then remove the CR Dos newline style }
- if (i>0) and (s[i]=#13) then
- dec(i);
- s[0]:=chr(i);
- end;
- function Max(A,B: longint): longint;
- begin
- if A>B then Max:=A else Max:=B;
- end;
- function Min(A,B: longint): longint;
- begin
- if A<B then Min:=A else Min:=B;
- end;
- function CharStr(C: char; Count: integer): string;
- {$ifndef FPC}
- var S: string;
- {$endif}
- begin
- {$ifdef FPC}
- CharStr[0]:=chr(Count);
- FillChar(CharStr[1],Count,C);
- {$else}
- S[0]:=chr(Count);
- FillChar(S[1],Count,C);
- CharStr:=S;
- {$endif}
- end;
- function UpcaseStr(const S: string): string;
- var
- I: Longint;
- begin
- for I:=1 to length(S) do
- if S[I] in ['a'..'z'] then
- UpCaseStr[I]:=chr(ord(S[I])-32)
- else
- UpCaseStr[I]:=S[I];
- UpcaseStr[0]:=S[0];
- end;
- function RExpand(const S: string; MinLen: byte): string;
- begin
- if length(S)<MinLen then
- RExpand:=S+CharStr(' ',MinLen-length(S))
- else
- RExpand:=S;
- end;
- function LExpand(const S: string; MinLen: byte): string;
- begin
- if length(S)<MinLen then
- LExpand:=CharStr(' ',MinLen-length(S))+S
- else
- LExpand:=S;
- end;
- function LTrim(const S: string): string;
- var
- i : longint;
- begin
- i:=1;
- while (i<length(s)) and (s[i]=' ') do
- inc(i);
- LTrim:=Copy(s,i,255);
- end;
- function RTrim(const S: string): string;
- var
- i : longint;
- begin
- i:=length(s);
- while (i>0) and (s[i]=' ') do
- dec(i);
- RTrim:=Copy(s,1,i);
- end;
- function Trim(const S: string): string;
- begin
- Trim:=RTrim(LTrim(S));
- end;
- function IntToStr(L: longint): string;
- var S: string;
- begin
- Str(L,S);
- IntToStr:=S;
- end;
- function IntToStrL(L: longint; MinLen: sw_integer): string;
- begin
- IntToStrL:=LExpand(IntToStr(L),MinLen);
- end;
- function IntToStrZ(L: longint; MinLen: sw_integer): string;
- var S: string;
- begin
- S:=IntToStr(L);
- if length(S)<MinLen then
- S:=CharStr('0',MinLen-length(S))+S;
- IntToStrZ:=S;
- end;
- function StrToInt(const S: string): longint;
- var L: longint;
- C: integer;
- begin
- Val(S,L,C); if C<>0 then L:=-1;
- LastStrToIntResult:=C;
- StrToInt:=L;
- end;
- function IntToHex(L: longint): string;
- const HexNums : string[16] = '0123456789ABCDEF';
- var S: string;
- R: real;
- function DivF(Mit,Mivel: real): longint;
- begin
- DivF:=trunc(Mit/Mivel);
- end;
- function ModF(Mit,Mivel: real): longint;
- begin
- ModF:=trunc(Mit-DivF(Mit,Mivel)*Mivel);
- end;
- begin
- S:='';
- R:=L; if R<0 then begin R:=R+2147483647+2147483647+2; end;
- repeat
- S:=HexNums[ModF(R,16)+1]+S;
- R:=DivF(R,16);
- until R=0;
- IntToHex:=S;
- end;
- function GetStr(P: PString): string;
- begin
- if P=nil then GetStr:='' else GetStr:=P^;
- end;
- function GetPChar(P: PChar): string;
- begin
- if P=nil then GetPChar:='' else GetPChar:=StrPas(P);
- end;
- function DirOf(const S: string): string;
- var D: DirStr; E: ExtStr; N: NameStr;
- begin
- FSplit(S,D,N,E);
- if (D<>'') and (D[Length(D)]<>DirSep) then
- DirOf:=D+DirSep
- else
- DirOf:=D;
- end;
- function ExtOf(const S: string): string;
- var D: DirStr; E: ExtStr; N: NameStr;
- begin
- FSplit(S,D,N,E);
- ExtOf:=E;
- end;
- function NameOf(const S: string): string;
- var D: DirStr; E: ExtStr; N: NameStr;
- begin
- FSplit(S,D,N,E);
- NameOf:=N;
- end;
- function NameAndExtOf(const S: string): string;
- var D: DirStr; E: ExtStr; N: NameStr;
- begin
- FSplit(S,D,N,E);
- NameAndExtOf:=N+E;
- end;
- function DirAndNameOf(const S: string): string;
- var D: DirStr; E: ExtStr; N: NameStr;
- begin
- FSplit(S,D,N,E);
- DirAndNameOf:=D+N;
- end;
- { return Dos GetFTime value or -1 if the file does not exist }
- function GetFileTime(const FileName: string): longint;
- var T: longint;
- f: file;
- FM: integer;
- begin
- if FileName='' then
- T:=-1
- else
- begin
- FM:=FileMode; FileMode:=0;
- EatIO; DosError:=0;
- Assign(f,FileName);
- {$I-}
- Reset(f);
- if InOutRes=0 then
- begin
- GetFTime(f,T);
- Close(f);
- end;
- {$I+}
- if (EatIO<>0) or (DosError<>0) then T:=-1;
- FileMode:=FM;
- end;
- GetFileTime:=T;
- end;
- function GetShortName(const n:string):string;
- {$ifdef win32}
- var
- hs,hs2 : string;
- i : longint;
- {$endif}
- {$ifdef go32v2}
- var
- hs : string;
- {$endif}
- begin
- GetShortName:=n;
- {$ifdef win32}
- hs:=n+#0;
- i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2));
- if (i>0) and (i<=high(hs2)) then
- begin
- hs2[0]:=chr(strlen(@hs2[1]));
- GetShortName:=hs2;
- end;
- {$endif}
- {$ifdef go32v2}
- hs:=n;
- if Dos.GetShortName(hs) then
- GetShortName:=hs;
- {$endif}
- end;
- function GetLongName(const n:string):string;
- {$ifdef win32}
- var
- hs : string;
- hs2 : Array [0..255] of char;
- i : longint;
- j : pchar;
- {$endif}
- {$ifdef go32v2}
- var
- hs : string;
- {$endif}
- begin
- GetLongName:=n;
- {$ifdef win32}
- hs:=n+#0;
- i:=Windows.GetFullPathName(@hs[1],256,hs2,j);
- if (i>0) and (i<=255) then
- begin
- hs:=strpas(hs2);
- GetLongName:=hs;
- end;
- {$endif}
- {$ifdef go32v2}
- hs:=n;
- if Dos.GetLongName(hs) then
- GetLongName:=hs;
- {$endif}
- end;
- function EatIO: integer;
- begin
- EatIO:=IOResult;
- end;
- function LowCase(C: char): char;
- begin
- if ('A'<=C) and (C<='Z') then C:=chr(ord(C)+32);
- LowCase:=C;
- end;
- function LowcaseStr(S: string): string;
- var I: Longint;
- begin
- for I:=1 to length(S) do
- S[I]:=Lowcase(S[I]);
- LowcaseStr:=S;
- end;
- function BoolToStr(B: boolean; const TrueS, FalseS: string): string;
- begin
- if B then BoolToStr:=TrueS else BoolToStr:=FalseS;
- end;
- procedure TNoDisposeCollection.FreeItem(Item: Pointer);
- begin
- { don't do anything here }
- end;
- constructor TUnsortedStringCollection.CreateFrom(ALines: PUnsortedStringCollection);
- begin
- if Assigned(ALines)=false then Fail;
- inherited Init(ALines^.Count,ALines^.Count div 10);
- Assign(ALines);
- end;
- procedure TUnsortedStringCollection.Assign(ALines: PUnsortedStringCollection);
- procedure AddIt(P: PString); {$ifndef FPC}far;{$endif}
- begin
- Insert(NewStr(GetStr(P)));
- end;
- begin
- FreeAll;
- if Assigned(ALines) then
- ALines^.ForEach(@AddIt);
- end;
- function TUnsortedStringCollection.At(Index: Integer): PString;
- begin
- At:=inherited At(Index);
- end;
- procedure TUnsortedStringCollection.FreeItem(Item: Pointer);
- begin
- if Item<>nil then DisposeStr(Item);
- end;
- function TUnsortedStringCollection.GetItem(var S: TStream): Pointer;
- begin
- GetItem:=S.ReadStr;
- end;
- procedure TUnsortedStringCollection.PutItem(var S: TStream; Item: Pointer);
- begin
- S.WriteStr(Item);
- end;
- constructor TNulStream.Init;
- begin
- inherited Init;
- Position:=0;
- end;
- function TNulStream.GetPos: Longint;
- begin
- GetPos:=Position;
- end;
- function TNulStream.GetSize: Longint;
- begin
- GetSize:=Position;
- end;
- procedure TNulStream.Read(var Buf; Count: Word);
- begin
- Error(stReadError,0);
- end;
- procedure TNulStream.Seek(Pos: Longint);
- begin
- if Pos<=Position then
- Position:=Pos;
- end;
- procedure TNulStream.Write(var Buf; Count: Word);
- begin
- Inc(Position,Count);
- end;
- constructor TSubStream.Init(AStream: PStream; AStartPos, ASize: longint);
- begin
- inherited Init;
- if Assigned(AStream)=false then Fail;
- S:=AStream; StartPos:=AStartPos; StreamSize:=ASize;
- Seek(0);
- end;
- function TSubStream.GetPos: Longint;
- var Pos: longint;
- begin
- Pos:=S^.GetPos; Dec(Pos,StartPos);
- GetPos:=Pos;
- end;
- function TSubStream.GetSize: Longint;
- begin
- GetSize:=StreamSize;
- end;
- procedure TSubStream.Read(var Buf; Count: Word);
- var Pos: longint;
- RCount: word;
- begin
- Pos:=GetPos;
- if Pos+Count>StreamSize then RCount:=StreamSize-Pos else RCount:=Count;
- S^.Read(Buf,RCount);
- if RCount<Count then
- Error(stReadError,0);
- end;
- procedure TSubStream.Seek(Pos: Longint);
- var RPos: longint;
- begin
- if (Pos<=StreamSize) then RPos:=Pos else RPos:=StreamSize;
- S^.Seek(StartPos+RPos);
- end;
- procedure TSubStream.Write(var Buf; Count: Word);
- begin
- S^.Write(Buf,Count);
- end;
- function TTextCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
- var K1: PString absolute Key1;
- K2: PString absolute Key2;
- R: Sw_integer;
- S1,S2: string;
- begin
- S1:=UpCaseStr(K1^);
- S2:=UpCaseStr(K2^);
- if S1<S2 then R:=-1 else
- if S1>S2 then R:=1 else
- R:=0;
- Compare:=R;
- end;
- function TTextCollection.LookUp(const S: string; var Idx: sw_integer): string;
- var OLI,ORI,Left,Right,Mid: integer;
- LeftP,RightP,MidP: PString;
- {LeftS,}MidS{,RightS}: string;
- FoundS: string;
- UpS : string;
- begin
- Idx:=-1; FoundS:='';
- Left:=0; Right:=Count-1;
- UpS:=UpCaseStr(S);
- if Left<Right then
- begin
- while (Left<Right) do
- begin
- OLI:=Left; ORI:=Right;
- Mid:=Left+(Right-Left) div 2;
- LeftP:=At(Left); RightP:=At(Right); MidP:=At(Mid);
- { LeftS:=UpCaseStr(LeftP^); }MidS:=UpCaseStr(MidP^);
- { RightS:=UpCaseStr(RightP^);}
- if copy(MidS,1,length(UpS))=UpS then
- begin
- Idx:=Mid; FoundS:=GetStr(MidP);
- end;
- { else}
- if UpS<MidS then
- Right:=Mid
- else
- Left:=Mid;
- if (OLI=Left) and (ORI=Right) then
- Break;
- end;
- end;
- LookUp:=FoundS;
- end;
- function TrimEndSlash(const Path: string): string;
- var S: string;
- begin
- S:=Path;
- if (length(S)>0) and (S<>DirSep) and (copy(S,length(S),1)=DirSep) and
- (S[length(S)-1]<>':') then
- S:=copy(S,1,length(S)-1);
- TrimEndSlash:=S;
- end;
- function CompareText(S1, S2: string): integer;
- var R: integer;
- begin
- S1:=UpcaseStr(S1); S2:=UpcaseStr(S2);
- if S1<S2 then R:=-1 else
- if S1>S2 then R:= 1 else
- R:=0;
- CompareText:=R;
- end;
- function FormatPath(Path: string): string;
- var P: sw_integer;
- SC: char;
- begin
- if ord(DirSep)=ord('/') then
- SC:='\'
- else
- SC:='/';
- repeat
- P:=Pos(SC,Path);
- if P>0 then Path[P]:=DirSep;
- until P=0;
- FormatPath:=Path;
- end;
- function CompletePath(const Base, InComplete: string): string;
- var Drv,BDrv: string[40]; D,BD: DirStr; N,BN: NameStr; E,BE: ExtStr;
- P: sw_integer;
- Complete: string;
- begin
- Complete:=FormatPath(InComplete);
- FSplit(FormatPath(InComplete),D,N,E);
- P:=Pos(':',D); if P=0 then Drv:='' else begin Drv:=copy(D,1,P); Delete(D,1,P); end;
- FSplit(FormatPath(Base),BD,BN,BE);
- P:=Pos(':',BD); if P=0 then BDrv:='' else begin BDrv:=copy(BD,1,P); Delete(BD,1,P); end;
- if copy(D,1,1)<>DirSep then
- Complete:=BD+D+N+E;
- if Drv='' then
- Complete:=BDrv+Complete;
- Complete:=FExpand(Complete);
- CompletePath:=Complete;
- end;
- function CompleteURL(const Base, URLRef: string): string;
- var P: integer;
- Drive: string[20];
- IsComplete: boolean;
- S: string;
- begin
- IsComplete:=false;
- P:=Pos(':',URLRef);
- if P=0 then Drive:='' else Drive:=UpcaseStr(copy(URLRef,1,P-1));
- if Drive<>'' then
- if (Drive='MAILTO') or (Drive='FTP') or (Drive='HTTP') or
- (Drive='GOPHER') or (Drive='FILE') then
- IsComplete:=true;
- if IsComplete then S:=URLRef else
- S:=CompletePath(Base,URLRef);
- CompleteURL:=S;
- end;
- function OptimizePath(Path: string; MaxLen: integer): string;
- var i : integer;
- BackSlashs : array[1..20] of integer;
- BSCount : integer;
- Jobbra : boolean;
- Jobb, Bal : byte;
- Hiba : boolean;
- begin
- if length(Path)>MaxLen then
- begin
- BSCount:=0; Jobbra:=true;
- for i:=1 to length(Path) do if Path[i]=DirSep then
- begin
- Inc(BSCount);
- BackSlashs[BSCount]:=i;
- end;
- i:=BSCount div 2;
- Hiba:=false;
- Bal:=i; Jobb:=i+1;
- case i of 0 : ;
- 1 : Path:=copy(Path, 1, BackSlashs[1])+'..'+
- copy(Path, BackSlashs[2], length(Path));
- else begin
- while (BackSlashs[Bal]+(length(Path)-BackSlashs[Jobb]) >=
- MaxLen) and not Hiba do
- begin
- if Jobbra then begin
- if Jobb<BSCount then inc(Jobb)
- else Hiba:=true;
- Jobbra:=false;
- end
- else begin
- if Bal>1 then dec(Bal)
- else Hiba:=true;
- Jobbra:=true;
- end;
- end;
- Path:=copy(Path, 1, BackSlashs[Bal])+'..'+
- copy(Path, BackSlashs[Jobb], length(Path));
- end;
- end;
- end;
- if length(Path)>MaxLen then
- begin
- i:=Pos('\..\',Path);
- if i>0 then Path:=copy(Path,1,i-1)+'..'+copy(Path,i+length('\..\'),length(Path));
- end;
- OptimizePath:=Path;
- end;
- function Now: longint;
- var D: DateTime;
- W: word;
- L: longint;
- begin
- FillChar(D,sizeof(D),0);
- GetDate(D.Year,D.Month,D.Day,W);
- GetTime(D.Hour,D.Min,D.Sec,W);
- PackTime(D,L);
- Now:=L;
- end;
- function FormatDateTimeL(L: longint; const Format: string): string;
- var D: DateTime;
- begin
- UnpackTime(L,D);
- FormatDateTimeL:=FormatDateTime(D,Format);
- end;
- function FormatDateTime(const D: DateTime; const Format: string): string;
- var I: sw_integer;
- CurCharStart: sw_integer;
- CurChar: char;
- CurCharCount: integer;
- DateS: string;
- C: char;
- procedure FlushChars;
- var S: string;
- I: sw_integer;
- begin
- S:='';
- for I:=1 to CurCharCount do
- S:=S+CurChar;
- case CurChar of
- 'y' : S:=IntToStrL(D.Year,length(S));
- 'm' : S:=IntToStrZ(D.Month,length(S));
- 'd' : S:=IntToStrZ(D.Day,length(S));
- 'h' : S:=IntToStrZ(D.Hour,length(S));
- 'n' : S:=IntToStrZ(D.Min,length(S));
- 's' : S:=IntToStrZ(D.Sec,length(S));
- end;
- DateS:=DateS+S;
- end;
- begin
- DateS:='';
- CurCharStart:=-1; CurCharCount:=0; CurChar:=#0;
- for I:=1 to length(Format) do
- begin
- C:=Format[I];
- if (C<>CurChar) or (CurCharStart=-1) then
- begin
- if CurCharStart<>-1 then FlushChars;
- CurCharCount:=1; CurCharStart:=I;
- end
- else
- Inc(CurCharCount);
- CurChar:=C;
- end;
- FlushChars;
- FormatDateTime:=DateS;
- end;
- procedure GiveUpTimeSlice;
- {$ifdef GO32V2}{$define DOS}{$endif}
- {$ifdef TP}{$define DOS}{$endif}
- {$ifdef DOS}
- var r: registers;
- begin
- r.ax:=$1680;
- intr($2f,r);
- end;
- {$endif}
- {$ifdef Linux}
- begin
- end;
- {$endif}
- {$ifdef Win32}
- begin
- end;
- {$endif}
- {$undef DOS}
- procedure RegisterWUtils;
- begin
- {$ifndef NOOBJREG}
- RegisterType(RUnsortedStringCollection);
- {$endif}
- end;
- END.
- {
- $Log$
- Revision 1.21 2000-05-02 08:42:29 pierre
- * new set of Gabor changes: see fixes.txt
- Revision 1.20 2000/04/25 08:42:36 pierre
- * New Gabor changes : see fixes.txt
- Revision 1.19 2000/04/18 11:42:39 pierre
- lot of Gabor changes : see fixes.txt
- Revision 1.18 2000/03/21 23:19:13 pierre
- + TrimEndSlash and CompareText by Gabor
- Revision 1.17 2000/03/20 19:19:45 pierre
- * LFN support in streams
- Revision 1.16 2000/03/14 13:36:12 pierre
- * error for unexistant file in GetFileTime fixed
- Revision 1.15 2000/02/07 11:45:11 pierre
- + TUnsortedStringCollection CreateFrom/Assign/GetItem/PutItem from Gabor
- Revision 1.14 2000/01/20 00:30:32 pierre
- * Result of GetShortPathName is checked
- Revision 1.13 2000/01/17 12:20:03 pierre
- * uses windows needed for GetShortName
- Revision 1.12 2000/01/14 15:36:43 pierre
- + GetShortFileName used for tcodeeditor file opening
- Revision 1.11 2000/01/05 17:27:20 pierre
- + linecomplete arg for ReadlnFromStream
- Revision 1.10 2000/01/03 11:38:35 michael
- Changes from Gabor
- Revision 1.9 1999/12/01 16:19:46 pierre
- + GetFileTime moved here
- Revision 1.8 1999/10/25 16:39:03 pierre
- + GetPChar to avoid nil pointer problems
- Revision 1.7 1999/09/13 11:44:00 peter
- * fixes from gabor, idle event, html fix
- Revision 1.6 1999/08/24 22:01:48 pierre
- * readlnfromstream length check added
- Revision 1.5 1999/08/03 20:22:45 peter
- + TTab acts now on Ctrl+Tab and Ctrl+Shift+Tab...
- + Desktop saving should work now
- - History saved
- - Clipboard content saved
- - Desktop saved
- - Symbol info saved
- * syntax-highlight bug fixed, which compared special keywords case sensitive
- (for ex. 'asm' caused asm-highlighting, while 'ASM' didn't)
- * with 'whole words only' set, the editor didn't found occourences of the
- searched text, if the text appeared previously in the same line, but didn't
- satisfied the 'whole-word' condition
- * ^QB jumped to (SelStart.X,SelEnd.X) instead of (SelStart.X,SelStart.Y)
- (ie. the beginning of the selection)
- * when started typing in a new line, but not at the start (X=0) of it,
- the editor inserted the text one character more to left as it should...
- * TCodeEditor.HideSelection (Ctrl-K+H) didn't update the screen
- * Shift shouldn't cause so much trouble in TCodeEditor now...
- * Syntax highlight had problems recognizing a special symbol if it was
- prefixed by another symbol character in the source text
- * Auto-save also occours at Dos shell, Tool execution, etc. now...
- Revision 1.4 1999/04/07 21:56:06 peter
- + object support for browser
- * html help fixes
- * more desktop saving things
- * NODEBUG directive to exclude debugger
- Revision 1.2 1999/03/08 14:58:22 peter
- + prompt with dialogs for tools
- Revision 1.1 1999/03/01 15:51:43 peter
- + Log
- }
|