{ 
    SemTel version 1.0.0 ... comfortable telnet client
    Copyright (C) 1995-2000 Jan Tomasek <jan@tomasek.cz>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    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.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
Unit C3216;

Interface
Uses
  Classes, WinTypes;
Type
  PString =^String;

  PFontData =^TFontData;
  TFontData = record
    Height : Integer;
    Width  : Integer;
    Size   : Integer;
  End;

  {$IFDEF WIN32}
  TSortedList = class(TList)
  End;
  {$ELSE}
  ShortString = String;
  TListSortCompare = function (Item1, Item2: Pointer): Integer;
  TSortedList = class(TList)
    procedure Sort(Compare: TListSortCompare);
  End;
  {$ENDIF}

Function FileSize(FileName:String):LongInt;
Procedure strTrim(Var P:PChar);
Function strUpper(S:String):String;
Function GetTMPFile(Prefix:String):String;
Function GetToChar(Var S:String;C:Char;DeleteChar:Boolean):String;
Function Min(I1,I2:Longint):Longint;
Function Max(I1,I2:Longint):Longint;
Function ValidFontHeight(FontName:String;Size:Integer):Integer;
procedure FontData_Enum(FontData:TSortedList;FontName:PChar; Bold: Boolean);
procedure FontData_Clear(FontData:TSortedList);
Function CanBeRewriten(FileName:String):Boolean;
{function HeightToSize(Height:Integer):integer;}
{$IFNDEF Win32}
Function Trim(S:String):String;
Function DirectoryExists(Name:String):Boolean;
Function ExtractFileDir(Const Name:String):String;
Procedure ForceDirectories(Const Path:String);
Procedure SetLength(Var S:String;L:Longint);
{$ELSE}
{$ENDIF}

Implementation
Uses
  SysUtils, WinProcs, Forms, STConfig, kUnits, SafeMem;

Function FileSize(FileName:String):LongInt;
Var
  SR   : TSearchRec;
Begin
  If FindFirst(FileName, faReadOnly or faHidden or faSysFile or faArchive, SR) in [0, 18] Then
    Result := SR.Size
  Else Result := -1;
End;

Function Trim(S:String):String;
Begin
  While (S[1]<=#32)and(Length(S)>0) Do System.Delete(S, 1, 1);
  While (S[Length(S)]<=#32)and(Length(S)>0) Do System.Delete(S, Length(S), 1);
  Result:=S;
End;

Procedure strTrim(Var P:PChar);
Begin
  If P[0]=#0 Then Exit;
  While P[0]=' ' Do Inc(P);
  While P[strLen(P)-1]<=' ' Do P[strLen(P)-1]:=#0;
End;

Function strUpper(S:String):String;
Var
  I : Integer;
Begin
  If Length(S)=0 Then Result:='';
  For I:=1 To Length(S) Do S[I]:=UpCase(S[I]);
  Result:=S;
End;

Function Min(I1,I2:LongInt):LongInt;
Begin
  If I1<I2 Then Result:=I1 Else Result:=I2;
End;

Function GetToChar(Var S:String;C:Char;DeleteChar:Boolean):String;
Begin
  If Pos(C,S)>0 Then Begin
    Result:=Copy(S,1,Pos(C,S)-1);
    Delete(S,1,Pos(C,S)-1*Byte(not DeleteChar));
  End Else Begin
    Result:=S;
    S:='';
  End;
End;

Function Max(I1,I2:LongInt):LongInt;
Begin
  If I1>I2 Then Result:=I1 Else Result:=I2;
End;


{$IFNDEF Win32}
Function GetTMPFile(Prefix:String):String;
Var
  Name : String;
Begin
  GetTempFileName(GetTempDrive(#0),'S',0,@Name[1]);
  Result:=strPas(@Name[1]);
End;
Function DirectoryExists(Name:String):Boolean;
Var
  OldDir : String;
Begin
  If Name[Length(Name)]='\' Then System.Delete(Name,Length(Name),1);
  {$I-}
  GetDir(Ord(Name[1])-Ord('A')+1,OldDir);
  ChDir(Name);
  {$I+}
  Result := IOResult=0;
  {$I-}
  ChDir(OldDir);
  {$I+}
  If (IOResult=0) Then;
End;

Function ExtractFileDir(Const Name:String):String;
Begin
  Result := ExtractFilePath(Name);
End;

Procedure ForceDirectories(Const Path:String);
Var
  S : String;
  C : Char;
  I : Byte;
Begin
  If Length(Path)<=3 Then Exit; If DirectoryExists(Path) Then Exit;
  I:=1;
  Repeat
    C:=Path[I];S[I]:=C;S[0]:=Char(I);
    If (C='\')or(Length(Path)<=I) Then Begin
      If not DirectoryExists(S) Then
        {!!! Trikrat fuj}
        If S[Length(S)]='\' Then {$I-}MkDir(Copy(S,1,Length(S)-1)){$I+}
        Else {$I-}MkDir(S){$I+};
      If IOResult<>0 Then Exit;
    End;
    Inc(I);
  Until I>Length(Path);
End;

Procedure SetLength(Var S:String;L:Longint);
Begin
  S[0]:=Char(L);
End;
{$ELSE}
Function GetTMPFile(Prefix:String):String;
Var
  Path : PChar;
  Name : PChar;
Begin
  Prefix:=Prefix+#0;
  Path:=strAlloc(300);
  Name:=strAlloc(300);
  GetTempPath(strBufSize(Path),Path);
  GetTempFileName(Path,@Prefix[1],0,Name);
  Result:=strPas(Name);
  strDispose(Path);
  strDispose(Name);
End;
{$ENDIF}

{function HeightToSize(Height:Integer):Integer;
Var
  DC          : HDC;
  LogPixelsY  : Integer;
Begin
  DC          := GetDC(0);
  Result      := Height*72 div LogPixelsY;
  If (Height*72/LogPixelsY)-(Height*72 div LogPixelsY) >0.5 Then Inc(Result);
  ReleaseDC(0, DC);
End;}

function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; {$IFDEF Win32}stdcall;{$ELSE}far;{$ENDIF}
Var
  _Height     : Integer;
  _LogPixelsY : Integer;
  _Size       : Integer;
  Valid       : Array[0..1] of Integer;
  DC          : HDC;
begin
  Move(Data^,Valid,SizeOf(Valid));

  _Size       := 0;
  DC          := GetDC(0);
  _LogPixelsY := GetDeviceCaps(DC,LOGPIXELSY);

  If FontType = TRUETYPE_FONTTYPE Then Begin
    Valid[1]:=-Valid[0]
  End Else Begin
    If FontType = RASTER_FONTTYPE Then Begin
      {lfHeight = -MulDiv(PointSize, GetDeviceCaps(hDC, LOGPIXELSY), 72);}
      _Height := LogFont.lfHeight{TextMetric.tmHeight-TextMetric.tmInternalLeading};
{      _Size       := MulDiv(_Height,72,_LogPixelsY);}
      _Size       := _Height*72 div _LogPixelsY;
      If (_Height*72/_LogPixelsY)-(_Height*72 div _LogPixelsY) >0.5 Then Inc(_Size);
      Valid[1]:=_Height;
    End;
  End;
  ReleaseDC(0, DC);

  If Valid[0]=_Size Then Result:=0 Else Result := 1;
  Move(Valid,Data^,SizeOf(Valid));
end;

Function ValidFontHeight(FontName:String;Size:Integer):Integer;
Var
  {$IFNDEF Win32}
  X       : TFarProc;
  {$ENDIF}
  DC      : HDC;
  L       : Array[0..1] of Integer;
begin
  DC := GetDC(0);
  FontName:=FontName+#0;
  L[0]    :=Size;
  {$IFDEF Win32}
  EnumFonts(DC, @FontName[1], @EnumFontsProc, @L);
  {$ELSE}
  X := MakeProcInstance(@EnumFontsProc,0);
  EnumFonts(DC, @FontName[1], X, @L);
  FreeProcInstance(X);
  {$ENDIF}

  ReleaseDC(0, DC);
  Result:=L[1];
end;




{$IFNDEF WIN32}
procedure TSortedList.Sort(Compare: TListSortCompare);
Var
  Sorted : Boolean;
  I, J   : Integer;
Begin
  If Count<2 Then Exit;

  Sorted := False;
  J      := 0;
  While not Sorted Do Begin
    Sorted:=True;Inc(J);
    For I:=0 To Count-J-1 Do
      If Compare(Items[I], Items[I+1])>0 Then Begin
        Exchange(I, I+1);
        Sorted:=False;
      End;
  End;
End;{$ENDIF}

Function FontData_Sort(Item1, Item2: Pointer): Integer; far;
Var
  I1, I2 : PFontData;
Begin
  I1 := Item1;
  I2 := Item2;
  Result :=  0;
  If I1^.Height<I2^.Height Then Result := -1;
  If I1^.Height>I2^.Height Then Result :=  1;
End;

function MyGetTextMetrics(FaceName:PChar; Height:Integer; Bold:Boolean):TTextMetric;
Var
  _LogPixelsY : Integer;
  _HDC        : HDC;
  _HFONT      : HFONT;
  _HoldFONT   : HFONT;
Begin
  _LogPixelsY := Screen.PixelsPerInch;
  If Bold Then
    _HFONT   := CreateFont(MulDiv(Height,_LogPixelsY,72),
                  0, 0, 0, FW_BOLD,
                  0, 0, 0,
                  DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
                  DEFAULT_QUALITY, DEFAULT_PITCH, FaceName)
  Else
    _HFONT   := CreateFont(MulDiv(Height,_LogPixelsY,72),
                  0, 0, 0, FW_NORMAL,
                  0, 0, 0,
                  DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
                  DEFAULT_QUALITY, DEFAULT_PITCH, FaceName);

  _HDC     := GetDC(GetDesktopWindow);
  _HoldFONT := SelectObject(_HDC, _HFONT);
  GetTextMetrics(_HDC, Result);
  SelectObject(_HDC, _HoldFONT);
  ReleaseDC(GetDesktopWindow, _HDC);
  DeleteObject(_HFONT);
End;

Var
  FontBold : Boolean;
  
function FontData_EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  FontType: Integer; Data: Pointer): Integer; {$IFDEF WIN32}stdcall;{$ELSE}export;{$ENDIF}
Var
  _LogPixelsY : Integer;
  _Height     : Integer;
  _Size       : Integer;
  I           : Integer;
  FD          : PFontData;
  TM          : TTextMetric;
begin
  Result := 1;

  If FontType = TRUETYPE_FONTTYPE Then Begin If TList(Data).Count=0 Then Begin
    _LogPixelsY := Screen.PixelsPerInch;
    For I:=4 To 34 Do Begin
      TM := MyGetTextMetrics(LogFont.lfFaceName, I, FontBold);

      SafeGetMem(FD, SizeOf(FD^));
      FD^.Size  := I;
      FD^.Height:= TM.tmHeight;
      FD^.Width := TM.tmAveCharWidth;
      TList(Data).Add(FD);
    End;
    Result := 0;
  End End Else Begin
    If FontType = RASTER_FONTTYPE Then Begin
      _LogPixelsY := Screen.PixelsPerInch;
      _Height     := LogFont.lfHeight;
      _Size       := _Height*72 div _LogPixelsY;
      If (_Height*72/_LogPixelsY)-(_Height*72 div _LogPixelsY) >0.5 Then Inc(_Size);
      TM := MyGetTextMetrics(LogFont.lfFaceName, _Size, FontBold);

      SafeGetMem(FD, SizeOf(FD^));
      FD^.Size  := _Size;
      FD^.Height:= TM.tmHeight;
      FD^.Width := TM.tmAveCharWidth;
      TSortedList(Data).Add(FD);
    End;
  End;
end;

procedure FontData_Enum(FontData:TSortedList; FontName:PChar; Bold: Boolean);
function GetX(Var S:String):String;
Begin
  Result := Copy(S, 1, Pos(';', S));
  Delete(S, 1, Pos(';', S));
End;
Var
  {$IFNDEF Win32}
  X       : TFarProc;
  {$ENDIF}
  DC      : HDC;
  FD      : PFontData;
begin
  {$IFDEF DEBUGMSG}WriteToLog(DebugDetailed, kuC3216, 'FontData_Enum', 'Begin');{$ENDIF}
  {Clear last result}
  While FontData.Count>0 Do Begin
    FD:=FontData.Items[0];
    FontData.Delete(0);
    SafeFreeMem(FD, SizeOf(FD^));
  End;

  DC := GetDC(0);
  FontBold := Bold; {Global variable}
  try
   {$IFDEF Win32}
   EnumFontFamilies(DC, FontName, @FontData_EnumFontsProc, LongInt(FontData));
   {$ELSE}
   X := MakeProcInstance(@FontData_EnumFontsProc,0);
   EnumFontFamilies(DC, FontName, X, Pointer(FontData));
   FreeProcInstance(X);
   {$ENDIF}
  except
   {$IFDEF DEBUGMSG}WriteToLog(DebugDetailed, kuC3216, 'FontData_Enum', 'exception while enumerating');{$ENDIF}
   
  end;
  ReleaseDC(0, DC);

  FontData.Sort(FontData_Sort);
  {$IFDEF DEBUGMSG}WriteToLog(DebugDetailed, kuC3216, 'FontData_Enum', 'End');{$ENDIF}
end;

procedure FontData_Clear(FontData:TSortedList);
Var
  FD      : PFontData;
Begin
  If not Assigned(FontData) Then Exit;
  While FontData.Count>0 Do Begin
    FD:=FontData.Items[0];
    FontData.Delete(0);
    SafeFreeMem(FD, SizeOf(FD^));
  End;
End;

Function CanBeRewriten(FileName:String):Boolean;
Var
  F   : File;
  OFM : Integer;
Begin
  Result   := False;
  OFM      := FileMode;
  FileMode := 1; {Write only}
  System.Assign(F,FileName);
  {$I-}
  If FileExists(FileName) Then System.Reset(F,1) Else System.Rewrite(F,1);
  {$I+}
  If IOResult=0 Then Begin
    Result := True;
    System.Close(F);
  End;
  FileMode := OFM;
End;{-- CanBeRewriten --}

End.
