fpc/ide/wutils.pas

{
    $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
{$ifdef win32}
  windows,
{$endif win32}
{$ifdef Unix}
  {$ifdef VER1_0}
    linux,
  {$else}
    unix,
  {$endif}
{$endif Unix}
{$ifdef FVISION}
  Common,
{$endif FVISION}
  Dos,Objects;

const
      kbCtrlGrayPlus         = $9000;
      kbCtrlGrayMinus        = $8e00;
      kbCtrlGrayMul          = $9600;

  TempFirstChar = {$ifndef Unix}'~'{$else}'_'{$endif};
  TempExt       = '.tmp';
  TempNameLen   = 8;
  EOL : String[2] = {$ifdef Unix}#10;{$else}#13#10;{$endif}

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;
    procedure   InsertStr(const S: string);
  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;

  PFastBufStream = ^TFastBufStream;
  TFastBufStream = object(TBufStream)
    procedure   Seek(Pos: Longint); virtual;
  private
    BasePos: longint;
  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;

  PIntCollection = ^TIntCollection;
  TIntCollection = object(TSortedCollection)
    function  Compare(Key1, Key2: Pointer): sw_Integer; virtual;
    procedure FreeItem(Item: Pointer); virtual;
    procedure Add(Item: longint);
    function  Contains(Item: longint): boolean;
    function  AtInt(Index: sw_integer): longint;
  end;

{$ifdef TPUNIXLF}
  procedure readln(var t:text;var s:string);
{$endif}

procedure ReadlnFromStream(Stream: PStream; var s:string;var linecomplete,hasCR : 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 FloatToStr(D: Double; Decimals: byte): string;
function FloatToStrL(D: Double; Decimals: byte; MinLen: byte): string;
function HexToInt(S: string): longint;
function IntToHex(L: longint; MinLen: integer): string;
function GetStr(P: PString): string;
function GetPChar(P: PChar): string;
function BoolToStr(B: boolean; const TrueS, FalseS: string): string;
function LExtendString(S: string; MinLen: byte): 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 CompleteDir(const Path: string): string;
function GetCurDir: string;
function OptimizePath(Path: string; MaxLen: integer): string;
function CompareText(S1, S2: string): integer;
function ExistsDir(const DirName: string): boolean;
function ExistsFile(const FileName: string): boolean;
function DeleteFile(const FileName: string): integer;
function CopyFile(const SrcFileName, DestFileName: string): boolean;
function GenTempFileName: string;

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;

{$ifdef TP}
function StrPas(C: PChar): string;
{$endif}
function MemToStr(var B; Count: byte): string;
procedure StrToMem(S: string; var B);

procedure GiveUpTimeSlice;

const LastStrToIntResult : integer = 0;
      LastHexToIntResult : integer = 0;
      DirSep             : char    = {$ifdef Unix}'/'{$else}'\'{$endif};

procedure RegisterWUtils;

implementation

uses
{$IFDEF OS2}
  DosCalls,
{$ENDIF OS2}
  Strings;

{$ifndef NOOBJREG}
const
   SpaceStr = '                                                            '+
              '                                                            '+
              '                                                            '+
              '                                                            ' ;


  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) and (i<High(S)) 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,hasCR : boolean);
  var
    c : char;
    i,pos : 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 }
    { changed implicit 255 to High(S), so it will be automatically extended
      when longstrings eventually become default - Gabor }
    while (not eofstream(stream)) and (c<>#10) and (i<High(S)) do
     begin
       stream^.read(c,sizeof(c));
       if c<>#10 then
        begin
          inc(i);
          s[i]:=c;
        end;
     end;
    { if there was a CR LF then remove the CR Dos newline style }
    if (i>0) and (s[i]=#13) then
      begin
        dec(i);
      end;
    if (c=#13) and (not eofstream(stream)) then
      stream^.read(c,sizeof(c));
    if (i=High(S)) and not eofstream(stream) then
      begin
        pos:=stream^.getpos;
        stream^.read(c,sizeof(c));
        if (c=#13) and not eofstream(stream) then
          stream^.read(c,sizeof(c));
        if c<>#10 then
          stream^.seek(pos);
      end;
    if (c=#10) or eofstream(stream) then
      linecomplete:=true;
    if (c=#10) then
      hasCR:=true;
    s[0]:=chr(i);
  end;

{$ifdef TP}
{ TP's own StrPas() is buggy, because it causes GPF with strings longer than
  255 chars }
function StrPas(C: PChar): string;
var S: string;
    I: longint;
begin
  if Assigned(C)=false then
    S:=''
  else
    begin
      I:=StrLen(C); if I>High(S) then I:=High(S);
      S[0]:=chr(I); Move(C^,S[1],I);
    end;
  StrPas:=S;
end;
{$endif}

function MemToStr(var B; Count: byte): string;
var S: string;
begin
  S[0]:=chr(Count);
  if Count>0 then Move(B,S[1],Count);
  MemToStr:=S;
end;

procedure StrToMem(S: string; var B);
begin
  if length(S)>0 then Move(S[1],B,length(S));
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,High(S));
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 HexToInt(S: string): longint;
var L,I: longint;
    C: char;
const HexNums: string[16] = '0123456789ABCDEF';
begin
  S:=Trim(S); L:=0; I:=1; LastHexToIntResult:=0;
  while (I<=length(S)) and (LastHexToIntResult=0) do
  begin
    C:=Upcase(S[I]);
    if C in['0'..'9','A'..'F'] then
    begin
      L:=L*16+(Pos(C,HexNums)-1);
    end else LastHexToIntResult:=I;
    Inc(I);
  end;
  HexToInt:=L;
end;


function IntToHex(L: longint; MinLen: integer): 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;
  while length(S)<MinLen do S:='0'+S;
  IntToHex:=S;
end;

function FloatToStr(D: Double; Decimals: byte): string;
var S: string;
    L: byte;
begin
  Str(D:0:Decimals,S);
  if length(S)>0 then
  while (S[1]=' ') do Delete(S,1,1);
  FloatToStr:=S;
end;

function FloatToStrL(D: Double; Decimals: byte; MinLen: byte): string;
begin
  FloatToStrL:=LExtendString(FloatToStr(D,Decimals),MinLen);
end;

function LExtendString(S: string; MinLen: byte): string;
begin
  LExtendString:=copy(SpaceStr,1,MinLen-length(S))+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; Dos.DosError:=0;
      Assign(f,FileName);
      {$I-}
      Reset(f);
      if InOutRes=0 then
        begin
          GetFTime(f,T);
          Close(f);
        end;
      {$I+}
      if (EatIO<>0) or (Dos.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<=high(hs)) 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;

procedure TUnsortedStringCollection.InsertStr(const S: string);
begin
  Insert(NewStr(S));
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;

function TIntCollection.Contains(Item: longint): boolean;
var Index: sw_integer;
begin
  Contains:=Search(pointer(Item),Index);
end;

function TIntCollection.AtInt(Index: sw_integer): longint;
begin
  AtInt:=longint(At(Index));
end;

procedure TIntCollection.Add(Item: longint);
begin
  Insert(pointer(Item));
end;

function TIntCollection.Compare(Key1, Key2: Pointer): sw_Integer;
var K1: longint absolute Key1;
    K2: longint absolute Key2;
    R: integer;
begin
  if K1<K2 then R:=-1 else
  if K1>K2 then R:= 1 else
  R:=0;
  Compare:=R;
end;

procedure TIntCollection.FreeItem(Item: Pointer);
begin
  { do nothing here }
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;

procedure TFastBufStream.Seek(Pos: Longint);
function BufStartPos: longint;
begin
  BufStartPos:=Position-BufPtr;
end;
var RelOfs: longint;
begin
  RelOfs:=Pos-{BufStartPos}BasePos;
  if (RelOfs<0) or (RelOfs>=BufEnd) or (BufEnd=0) then
    begin
      inherited Seek(Pos);
      BasePos:=Pos-BufPtr;
    end
  else
    begin
      BufPtr:=RelOfs;
      Position:=Pos;
    end;
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);
  while Left<=Right do
    begin
      OLI:=Left; ORI:=Right;
      Mid:=Left+(Right-Left) div 2;
      MidP:=At(Mid);
      MidS:=UpCaseStr(MidP^);
      if copy(MidS,1,length(UpS))=UpS then
        begin
          Idx:=Mid; FoundS:=GetStr(MidP);
        end;
      if UpS<MidS then
        Right:=Mid
      else
        Left:=Mid;
      if (OLI=Left) and (ORI=Right) then
        begin
          if (Left<Right) then
            Left:=Right
          else
            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;
    Ref: string;
    Bookmark: string;
begin
  IsComplete:=false; Ref:=URLRef;
  P:=Pos(':',Ref);
  if P=0 then Drive:='' else Drive:=UpcaseStr(copy(Ref,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:=Ref else
  begin
    P:=Pos('#',Ref);
    if P=0 then
      Bookmark:=''
    else
      begin
        Bookmark:=copy(Ref,P+1,length(Ref));
        Ref:=copy(Ref,1,P-1);
      end;
    S:=CompletePath(Base,Ref);
    if Bookmark<>'' then
      S:=S+'#'+Bookmark;
  end;
  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;

function DeleteFile(const FileName: string): integer;
var f: file;
begin
{$I-}
  Assign(f,FileName);
  Erase(f);
  DeleteFile:=EatIO;
{$I+}
end;

function ExistsFile(const FileName: string): boolean;
var
  Dir : SearchRec;
begin
  Dos.FindFirst(FileName,Archive+ReadOnly,Dir);
  ExistsFile:=(Dos.DosError=0);
{$ifdef FPC}
  Dos.FindClose(Dir);
{$endif def FPC}
end;

function ExistsDir(const DirName: string): boolean;
var
  Dir : SearchRec;
begin
  Dos.FindFirst(TrimEndSlash(DirName),Directory,Dir);
  { if a file is found it is also reported
    at least for some Dos version
    so we need to check the attributes PM }
  ExistsDir:=(Dos.DosError=0) and ((Dir.attr and Directory) <> 0);
{$ifdef FPC}
  Dos.FindClose(Dir);
{$endif def FPC}
end;

function CompleteDir(const Path: string): string;
begin
  { keep c: untouched PM }
  if (Path<>'') and (Path[Length(Path)]<>DirSep) and
     (Path[Length(Path)]<>':') then
   CompleteDir:=Path+DirSep
  else
   CompleteDir:=Path;
end;

function GetCurDir: string;
var S: string;
begin
  GetDir(0,S);
  if copy(S,length(S),1)<>DirSep then S:=S+DirSep;
  GetCurDir:=S;
end;

function GenTempFileName: string;
var Dir: string;
    Name: string;
    I: integer;
    OK: boolean;
    Path: string;
begin
  Dir:=GetEnv('TEMP');
  if Dir='' then Dir:=GetEnv('TMP');
  if (Dir<>'') then if not ExistsDir(Dir) then Dir:='';
  if Dir='' then Dir:=GetCurDir;
  repeat
    Name:=TempFirstChar;
    for I:=2 to TempNameLen do
      Name:=Name+chr(ord('a')+random(ord('z')-ord('a')+1));
    Name:=Name+TempExt;
    Path:=CompleteDir(Dir)+Name;
    OK:=not ExistsFile(Path);
  until OK;
  GenTempFileName:=Path;
end;

function CopyFile(const SrcFileName, DestFileName: string): boolean;
var SrcF,DestF: PBufStream;
    OK: boolean;
begin
  SrcF:=nil; DestF:=nil;
  New(SrcF, Init(SrcFileName,stOpenRead,4096));
  OK:=Assigned(SrcF) and (SrcF^.Status=stOK);
  if OK then
  begin
    New(DestF, Init(DestFileName,stCreate,1024));
    OK:=Assigned(DestF) and (DestF^.Status=stOK);
  end;
  if OK then DestF^.CopyFrom(SrcF^,SrcF^.GetSize);
  if Assigned(DestF) then Dispose(DestF, Done);
  if Assigned(SrcF) then Dispose(SrcF, Done);
  CopyFile:=OK;
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 Unix}
  var
    req,rem : timespec;
begin
  req.tv_sec:=0;
  req.tv_nsec:=10000000;{ 10 ms }
  nanosleep(req,rem);
end;
{$endif}
{$IFDEF OS2}
begin
 DosSleep (5);
end;
{$ENDIF}
{$ifdef Win32}
begin
  { if the return value of this call is non zero then
    it means that a ReadFileEx or WriteFileEx have completed
    unused for now ! }
  { wait for 10 ms }
  if SleepEx(10,true)=WAIT_IO_COMPLETION then
    begin
      { here we should handle the completion of the routines
        if we use them }
    end;
end;
{$endif}
{$undef DOS}

procedure RegisterWUtils;
begin
{$ifndef NOOBJREG}
  RegisterType(RUnsortedStringCollection);
{$endif}
end;

BEGIN
  Randomize;
END.
{
  $Log$
  Revision 1.1  2001-08-04 11:30:26  peter
    * ide works now with both compiler versions

  Revision 1.1.2.14  2001/06/20 22:56:31  pierre
   * check that the Dir in ExistsDir is really a directory and not a file

  Revision 1.1.2.13  2001/02/05 14:45:42  pierre
   * fix for bug 1370

  Revision 1.1.2.12  2000/11/29 18:28:54  pierre
   + add save to file capability for list boxes

  Revision 1.1.2.11  2000/11/27 12:06:52  pierre
   New bunch of Gabor fixes

  Revision 1.1.2.10  2000/11/14 09:08:51  marco
   * First batch IDE renamefest

  Revision 1.1.2.9  2000/11/13 16:59:10  pierre
   * some function in double removed from fputils unit

  Revision 1.1.2.8  2000/11/12 19:50:36  hajny
    * OS/2 changes from the main branch merged

  Revision 1.1.2.7  2000/11/06 17:19:58  pierre
   * avoid eating of last carriage return

  Revision 1.1.2.6  2000/10/24 12:31:40  pierre
   * fix the last commit for linux

  Revision 1.1.2.5  2000/10/24 12:24:03  pierre
   + GiveUpTimeSlice for linux and win32

  Revision 1.1.2.4  2000/09/18 13:20:56  pierre
   New bunch of Gabor changes

  Revision 1.2  2000/08/22 09:41:42  pierre
   * first big merge from fixes branch

  Revision 1.1.2.3  2000/08/20 15:00:23  peter
    * windows fix

  Revision 1.1.2.2  2000/08/16 18:46:15  peter
   [*] double clicking on a droplistbox caused GPF (due to invalid recurson)
   [*] Make, Build now possible even in Compiler Messages Window
   [+] when started in a new dir the IDE now ask whether to create a local
       config, or to use the one located in the IDE dir

  Revision 1.1.2.1  2000/07/20 11:02:16  michael
  + Fixes from gabor. See fixes.txt

  Revision 1.1  2000/07/13 09:48:37  michael
  + Initial import

  Revision 1.27  2000/07/03 08:54:54  pierre
   * Some enhancements for WinHelp support by G abor

  Revision 1.26  2000/06/26 07:29:23  pierre
   * new bunch of Gabor's changes

  Revision 1.25  2000/06/22 09:07:15  pierre
   * Gabor changes: see fixes.txt

  Revision 1.24  2000/06/16 21:16:41  pierre
   * allow to read until 255 chars per line

  Revision 1.23  2000/06/16 08:50:45  pierre
   + new bunch of Gabor's changes

  Revision 1.22  2000/05/29 11:09:14  pierre
   + New bunch of Gabor's changes: see fixes.txt

  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

}