paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 23:19:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Merging revisions r42143,r42144 from trunk:

Browse Source 
------------------------------------------------------------------------
    r42143 | marco | 2019-05-31 11:38:45 +0200 (Fri, 31 May 2019) | 2 lines
    
     * mantis #35586
    
    ------------------------------------------------------------------------
    r42144 | marco | 2019-05-31 11:41:28 +0200 (Fri, 31 May 2019) | 2 lines
    
     * freetype windows compat patch from Pascal Riekenberg, mantis #35644
    
    ------------------------------------------------------------------------

git-svn-id: branches/fixes_3_2@42428 -
This commit is contained in:
michael 2019-07-13 13:31:43 +00:00
parent 075eedd75a
commit 0dfec0d081
3 changed files with 33 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
packages/fcl-image/src/fpwritetiff.pas
View File

@ -82,6 +82,7 @@ type
fStream: TStream;
fPosition: DWord;
procedure ClearEntries;
procedure SortEntries;
procedure WriteTiff;
procedure WriteHeader;
procedure WriteIFDs;
@ -257,6 +258,29 @@ begin
WriteDWord(8);
end;
procedure TFPWriterTiff.SortEntries;
var
i, j: Integer;
Entry: TTiffWriterEntry;
List: TFPList;
begin
// Sort Entries by Tag Value Ascending
for i:= 0 to FEntries.Count-1 do begin
List := TFPList(FEntries[i]);
j := 0;
repeat
if TTiffWriterEntry(List[j]).Tag > TTiffWriterEntry(List[j+1]).Tag then begin
Entry := TTiffWriterEntry(List[j+1]);
List[j] := List[j+1];
List[j+1] := Entry;
j := 0;
end
else
j := j+1;
until j >= List.Count-2;
end;
end;
procedure TFPWriterTiff.WriteIFDs;
var
i: Integer;
@ -265,6 +289,8 @@ var
Entry: TTiffWriterEntry;
NextIFDPos: DWord;
begin
// Sort the Entries before writing!
SortEntries;
for i:=0 to FEntries.Count-1 do begin
List:=TFPList(FEntries[i]);
// write count
@ -553,7 +579,8 @@ begin
TilesDown:=(OrientedHeight+IFD.TileLength{%H-}-1) div IFD.TileLength;
ChunkCount:=TilesAcross*TilesDown;
{$IFDEF FPC_Debug_Image}
writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCount=',ChunkCount);
writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCoun
t=',ChunkCount);
{$ENDIF}
end else begin
ChunkCount:=(OrientedHeight+IFD.RowsPerStrip{%H-}-1) div IFD.RowsPerStrip;

10
packages/fcl-image/src/freetype.pp
View File

@ -31,7 +31,7 @@ uses sysutils, classes, {$IFDEF DYNAMIC}freetypehdyn{$ELSE}freetypeh{$ENDIF}, FP
fontfiles and faces available in a fontfile }
// determine if file comparison need to be case sensitive or not
{$ifdef WIN32}
{$ifdef windows}
{$undef CaseSense}
{$else}
{$define CaseSense}
@ -200,8 +200,6 @@ const
implementation
{$IFDEF win32}uses dos;{$ENDIF}
procedure FTError (Event:string; Err:integer);
begin
raise FreeTypeException.CreateFmt (sErrFreeType, [Err,Event]);
@ -1032,15 +1030,15 @@ begin
aRect := FBounds;
end;
{$ifdef win32}
{$ifdef WINDOWS}
procedure SetWindowsFontPath;
begin
DefaultSearchPath := includetrailingbackslash(GetEnv('windir')) + 'fonts';
DefaultSearchPath := includetrailingbackslash(GetEnvironmentVariable('windir')) + 'fonts';
end;
{$endif}
initialization
{$ifdef win32}
{$ifdef WINDOWS}
SetWindowsFontPath;
{$endif}
end.

2
packages/fcl-image/src/libfreetype.inc
View File

@ -6,7 +6,7 @@ Const
// Windows
{$ifdef windows}
FreeTypeDLL = 'freetype-6.dll'; // version 2.1.4
FreeTypeDLL = 'freetype.dll';
{$define ft_found_platform}
{$endif}