{ $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 A0) 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)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 RCountS2 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 Left0) 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 S1S2 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 Jobb1 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 }