- Updated Vampyre Imaging Lib

- Added font rendering
- Added height display in flat mode

Client/CentrED.lpi

@@ -56,7 +56,7 @@
         <MinVersion Major="4" Minor="5" Release="1" Valid="True"/>
       </Item5>
     </RequiredPackages>
-    <Units Count="35">
+    <Units Count="36">
       <Unit0>
         <Filename Value="CentrED.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -273,6 +273,11 @@
         <IsPartOfProject Value="True"/>
         <UnitName Value="UTiledata"/>
       </Unit34>
+      <Unit35>
+        <Filename Value="UGLFont.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="UGLFont"/>
+      </Unit35>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

Client/CentrED.lpr

@@ -40,7 +40,7 @@ uses
   UfrmLargeScaleCommand, UfrmVirtualLayer, UfrmFilter, UfrmTileInfo,
   UGUIPlatformUtils, UPlatformTypes, UfrmRegionControl, UPackets,
   UPacketHandlers, UAdminHandling, UGameResources, ULandscape, UfrmToolWindow,
-  Logging, UMap, UWorldItem, UStatics, UTiledata;
+  Logging, UMap, UWorldItem, UStatics, UTiledata, UGLFont;
 
 {$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF}
 

Client/ResourceList.txt

@@ -1,3 +1,5 @@
 Overlay/LeftTopArrow.tga
 Overlay/TopArrow.tga
 Overlay/VirtualLayer.tga
+GLFont/DejaVu.png
+GLFont/DejaVu.fnt

Client/UGLFont.pas

@@ -0,0 +1,205 @@
+(*
+ * CDDL HEADER START
+ *
+ * The contents of this file are subject to the terms of the
+ * Common Development and Distribution License, Version 1.0 only
+ * (the "License").  You may not use this file except in compliance
+ * with the License.
+ *
+ * You can obtain a copy of the license at
+ * http://www.opensource.org/licenses/cddl1.php.
+ * See the License for the specific language governing permissions
+ * and limitations under the License.
+ *
+ * When distributing Covered Code, include this CDDL HEADER in each
+ * file and include the License file at
+ * http://www.opensource.org/licenses/cddl1.php.  If applicable,
+ * add the following below this CDDL HEADER, with the fields enclosed
+ * by brackets "[]" replaced with your own identifying * information:
+ *      Portions Copyright [yyyy] [name of copyright owner]
+ *
+ * CDDL HEADER END
+ *
+ *
+ *      Portions Copyright 2009 Andreas Schneider
+ *)
+unit UGLFont;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Math, ImagingClasses, ImagingTypes, ImagingOpenGL, GL;
+
+type
+
+  TFontInfo = packed record
+    Character: Char;
+    LeftOffset: SmallInt;
+    CharWidth: Word;
+    Width: Word;
+    Height: Word;
+    X1: Single;
+    Y1: Single;
+    X2: Single;
+    Y2: Single;
+  end;
+
+  { TGLFont }
+
+  TGLFont = class
+    constructor Create;
+    destructor Destroy; override;
+  protected
+    FFontImage: TSingleImage;
+    FFontTexture: TGLuint;
+    FSpaceWidth: Word;
+    FFontInfo: array of TFontInfo;
+    function FindCharInfo(AChar: Char): Integer;
+  public
+    function GetTextHeight(AText: String): Integer;
+    function GetTextWidth(AText: String): Integer;
+    procedure DrawText(AX, AY: Integer; AText: String);
+    procedure LoadImage(AImage: TStream);
+    procedure LoadFontInfo(AFontInfo: TStream);
+    procedure UpdateTexture;
+  end;
+
+implementation
+
+uses
+  Logging;
+
+{ TGLFont }
+
+
+constructor TGLFont.Create;
+begin
+  FFontTexture := 0;
+end;
+
+destructor TGLFont.Destroy;
+begin
+  FreeAndNil(FFontImage);
+  if FFontTexture <> 0 then
+    glDeleteTextures(1, @FFontTexture);
+  inherited Destroy;
+end;
+
+function TGLFont.FindCharInfo(AChar: Char): Integer;
+var
+  i: Integer;
+begin
+  Result := -1;
+  i := 0;
+  while (i < Length(FFontInfo)) and (Result = -1) do
+  begin
+    if FFontInfo[i].Character = AChar then
+      Result := i
+    else
+      Inc(i);
+  end;
+end;
+
+function TGLFont.GetTextHeight(AText: String): Integer;
+var
+  i, charInfo: Integer;
+begin
+  Result := 0;
+  for i := 1 to Length(AText) do
+  begin
+    if AText[i] <> ' ' then
+    begin
+      charInfo := FindCharInfo(AText[i]);
+      if charInfo > -1 then
+        Result := Max(Result, FFontInfo[charInfo].Height);
+    end;
+  end;
+end;
+
+function TGLFont.GetTextWidth(AText: String): Integer;
+var
+  i, charInfo: Integer;
+begin
+  Result := 0;
+  for i := 1 to Length(AText) do
+  begin
+    if AText[i] = ' ' then
+      Inc(Result, FSpaceWidth)
+    else
+    begin
+      charInfo := FindCharInfo(AText[i]);
+      if charInfo > -1 then
+        Result := Result + FFontInfo[charInfo].LeftOffset +
+          FFontInfo[charInfo].CharWidth;
+    end;
+  end;
+end;
+
+procedure TGLFont.DrawText(AX, AY: Integer; AText: String);
+var
+  i, charInfo: Integer;
+  curX: Integer;
+  x1, y1, x2, y2: Single;
+begin
+  if FFontTexture = 0 then UpdateTexture;
+  glBindTexture(GL_TEXTURE_2D, FFontTexture);
+
+  curX := AX;
+  for i := 1 to Length(AText) do
+  begin
+    if AText[i] = ' ' then
+      Inc(curX, FSpaceWidth)
+    else
+    begin
+      charInfo := FindCharInfo(AText[i]);
+      if charInfo > -1 then
+      begin
+        x1 := FFontInfo[charInfo].X1;
+        y1 := FFontInfo[charInfo].Y1;
+        x2 := FFontInfo[charInfo].X2;
+        y2 := FFontInfo[charInfo].Y2;
+
+        Inc(curX, FFontInfo[charInfo].LeftOffset);
+        glBegin(GL_QUADS);
+          glTexCoord2f(x1, y1); glVertex2i(curX, AY);
+          glTexCoord2f(x2, y1); glVertex2i(curX + FFontInfo[charInfo].Width, AY);
+          glTexCoord2f(x2, y2); glVertex2i(curX + FFontInfo[charInfo].Width,
+                                           AY + FFontInfo[charInfo].Height);
+          glTexCoord2f(x1, y2); glVertex2i(curX, AY + FFontInfo[charInfo].Height);
+        glEnd;
+        Inc(curX, FFontInfo[charInfo].CharWidth);
+      end;
+    end;
+  end;
+end;
+
+procedure TGLFont.LoadImage(AImage: TStream);
+begin
+  FFontImage := TSingleImage.CreateFromStream(AImage);
+end;
+
+procedure TGLFont.LoadFontInfo(AFontInfo: TStream);
+begin
+  AFontInfo.Read(FSpaceWidth, SizeOf(FSpaceWidth));
+  SetLength(FFontInfo, (AFontInfo.Size - AFontInfo.Position) div
+    SizeOf(TFontInfo));
+  AFontInfo.Read(FFontInfo[0], Length(FFontInfo) * SizeOf(TFontInfo));
+end;
+
+procedure TGLFont.UpdateTexture;
+begin
+  Logger.Send('UpdateTexture');
+  if FFontTexture <> 0 then glDeleteTextures(1, @FFontTexture);
+
+  FFontTexture := CreateGLTextureFromImage(FFontImage.ImageDataPointer^, 0, 0,
+    True, ifUnknown);
+  glBindTexture(GL_TEXTURE_2D, FFontTexture);
+  glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
+  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
+  glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
+end;
+
+end.
+

Client/ULandscape.pas

@@ -30,11 +30,11 @@ unit ULandscape;
 interface
 
 uses
-  SysUtils, Classes, math, LCLIntf, GL, GLU, ImagingOpenGL, Imaging,
+  SysUtils, Classes, math, LCLIntf, GL, GLu, ImagingOpenGL, Imaging,
   ImagingClasses, ImagingTypes, ImagingUtility,
   UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem,
   UMulBlock,
-  UVector, UEnhancedMemoryStream,
+  UVector, UEnhancedMemoryStream, UGLFont,
   UCacheManager;
 
 type
@@ -196,6 +196,19 @@ type
     procedure UpdateWriteMap(AStream: TEnhancedMemoryStream);
   end;
 
+  { TGLText }
+
+  TGLText = class
+    constructor Create(AFont: TGLFont; AText: String);
+  protected
+    FFont: TGLFont;
+    FText: String;
+    FWidth: Integer;
+    FHeight: Integer;
+  public
+    procedure Render(AScreenRect: TRect);
+  end;
+
   TScreenState = (ssNormal, ssFiltered, ssGhost);
 
   PBlockInfo = ^TBlockInfo;
@@ -212,6 +225,7 @@ type
     HueOverride: Boolean;
     CheckRealQuad: Boolean;
     Translucent: Boolean;
+    Text: TGLText;
     Next: PBlockInfo;
   end;
 
@@ -1213,6 +1227,7 @@ begin
   Result^.State := ssNormal;
   Result^.Highlighted := False;
   Result^.Translucent := False;
+  Result^.Text := nil;
   Result^.Next := nil;
 
   if FShortCuts[0] = nil then //First element
@@ -1239,6 +1254,7 @@ begin
     current^.Item.Locked := False;
     current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved);
     if current^.Normals <> nil then Dispose(current^.Normals);
+    current^.Text.Free;
     Dispose(current);
     current := next;
   end;
@@ -1266,6 +1282,7 @@ begin
       if last <> nil then last^.Next := current^.Next;
 
       if current^.Normals <> nil then Dispose(current^.Normals);
+      current^.Text.Free;
 
       Dispose(current);
       Dec(FCount);
@@ -1356,6 +1373,7 @@ begin
   Result^.State := ssNormal;
   Result^.Highlighted := False;
   Result^.Translucent := False;
+  Result^.Text := nil;
 
   if (FShortCuts[0] = nil) or (CompareWorldItems(AItem, FShortCuts[0]^.Item) < 0) then
   begin
@@ -1490,5 +1508,27 @@ begin
   Delete(TWorldItem(ATile));
 end;
 
+{ TGLText }
+
+constructor TGLText.Create(AFont: TGLFont; AText: String);
+var
+  i: Integer;
+begin
+  FFont := AFont;
+  FText := AText;
+  FWidth := FFont.GetTextWidth(AText);
+  FHeight := FFont.GetTextHeight('A');
+end;
+
+procedure TGLText.Render(AScreenRect: TRect);
+var
+  x, y: Integer;
+  i: Integer;
+begin
+  y := AScreenRect.Top + (AScreenRect.Bottom - AScreenRect.Top - FHeight) div 2;
+  x := AScreenRect.Left + (AScreenRect.Right - AScreenRect.Left - FWidth) div 2;
+  FFont.DrawText(x, y, FText);
+end;
+
 end.
 

Client/UResourceManager.pas

@@ -21,7 +21,7 @@
  * CDDL HEADER END
  *
  *
- *      Portions Copyright 2007 Andreas Schneider
+ *      Portions Copyright 2009 Andreas Schneider
  *)
 unit UResourceManager;
 
@@ -69,8 +69,8 @@ end;
 
 destructor TResourceManager.Destroy;
 begin
-  if FFileStream <> nil then FreeAndNil(FFileStream);
+  FreeAndNil(FFileStream);
-  if FResourceStream <> nil then FreeAndNil(FResourceStream);
+  FreeAndNil(FResourceStream);
   inherited Destroy;
 end;
 
@@ -81,7 +81,6 @@ begin
   if AIndex <> FCurrentResource then
   begin
     FFileStream.Position := FLookupTable[AIndex];
-    if FResourceStream <> nil then
     FResourceStream.Free;
     FResourceStream := TMemoryStream.Create;
     FFileStream.Read(size, SizeOf(Cardinal));

Client/UfrmMain.pas

@@ -31,10 +31,10 @@ interface
 
 uses
   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Menus,
-  ComCtrls, OpenGLContext, GL, GLU, UGameResources, ULandscape, ExtCtrls,
+  ComCtrls, OpenGLContext, GL, GLu, UGameResources, ULandscape, ExtCtrls,
   StdCtrls, Spin, UEnums, VirtualTrees, Buttons, UMulBlock, UWorldItem, math,
   LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList, fgl,
-  ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket;
+  ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket, UGLFont;
 
 type
   TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object;
@@ -269,6 +269,7 @@ type
       Node: PVirtualNode; Stream: TStream);
   protected
     { Members }
+    FAppDir: String;
     FX: Integer;
     FY: Integer;
     FDrawDistance: Integer;
@@ -294,6 +295,7 @@ type
     FRepaintNeeded: Boolean;
     FSelection: TRect;
     FUndoList: TPacketList;
+    FGLFont: TGLFont;
     { Methods }
     procedure BuildTileList;
     function  ConfirmAction: Boolean;
@@ -784,6 +786,8 @@ var
   virtualLayerGraphic: TSingleImage;
   searchRec: TSearchRec;
 begin
+  FAppDir := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName));
+
   FLandscape := ResMan.Landscape;
   FLandscape.OnChange := @OnLandscapeChanged;
   FLandscape.OnMapChanged := @OnMapChanged;
@@ -812,8 +816,7 @@ begin
   vstChat.NodeDataSize := SizeOf(TChatInfo);
   pnlChatHeader.AnchorSide[akBottom].Control := pnlBottom;
   
-  FLocationsFile := IncludeTrailingPathDelimiter(ExtractFilePath(
+  FLocationsFile := FAppDir + 'Locations.dat';
-                    Application.ExeName)) + 'Locations.dat';
   vstLocations.NodeDataSize := SizeOf(TLocationInfo);
   if FileExists(FLocationsFile) then vstLocations.LoadFromFile(FLocationsFile);
 
@@ -824,11 +827,14 @@ begin
     virtualLayerGraphic.Height, virtualLayerGraphic);
   virtualLayerGraphic.Free;
 
+  FGLFont := TGLFont.Create;
+  FGLFont.LoadImage(ResourceManager.GetResource(3));
+  FGLFont.LoadFontInfo(ResourceManager.GetResource(4));
+
   FVirtualTiles := TWorldItemList.Create(True);
   FUndoList := TPacketList.Create(True);
   
-  FRandomPresetLocation := IncludeTrailingPathDelimiter(ExtractFilePath(
+  FRandomPresetLocation := FAppDir + 'RandomPresets' + PathDelim;
-    Application.ExeName)) + 'RandomPresets' + PathDelim;
   if not DirectoryExists(FRandomPresetLocation) then
     CreateDir(FRandomPresetLocation);
 
@@ -1116,6 +1122,7 @@ begin
   FreeAndNil(FVLayerMaterial);
   FreeAndNil(FVirtualTiles);
   FreeAndNil(FUndoList);
+  FreeAndNil(FGLFont);
   
   RegisterPacketHandler($0C, nil);
 end;
@@ -1783,9 +1790,11 @@ procedure TfrmMain.InitSize;
 begin
   glViewport(0, 0, oglGameWindow.Width, oglGameWindow.Height);
   glMatrixMode(GL_PROJECTION);
+  glPushMatrix;
   glLoadIdentity;
   gluOrtho2D(0, oglGameWindow.Width, oglGameWindow.Height, 0);
   glMatrixMode(GL_MODELVIEW);
+  glPushMatrix;
   glLoadIdentity;
 end;
 
@@ -1923,6 +1932,10 @@ begin
           CheckRealQuad := True;
         end;
       end;
+    end else
+    begin
+      ABlockInfo^.Text.Free;
+      ABlockInfo^.Text := TGLText.Create(FGLFont, IntToStr(item.Z));
     end;
 
     if not ABlockInfo^.CheckRealQuad then
@@ -2082,6 +2095,9 @@ begin
 
     if highlight then
       glDisable(GL_COLOR_LOGIC_OP);
+
+    if (blockInfo^.Text <> nil) then
+      blockInfo^.Text.Render(blockInfo^.ScreenRect);
   end;
 
   FOverlayUI.Draw(oglGameWindow);

Imaging/Imaging.pas

@@ -1,5 +1,5 @@
 {
-  $Id: Imaging.pas 124 2008-04-21 09:47:07Z galfar $
+  $Id: Imaging.pas 173 2009-09-04 17:05:52Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -203,9 +203,8 @@ function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray;
   Pal must be allocated to have at least MaxColors entries.}
 function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
   MaxColors: LongInt; ConvertImages: Boolean): Boolean;
-{ Rotates image by 90, 180, 270, -90, -180, or -270 degrees counterclockwise.
+{ Rotates image by Angle degrees counterclockwise. All angles are allowed.}
-  Only multiples of 90 degrees are allowed.}
+function RotateImage(var Image: TImageData; Angle: Single): Boolean;
-function RotateImage(var Image: TImageData; Angle: LongInt): Boolean;
 
 { Drawing/Pixel functions }
 
@@ -303,7 +302,7 @@ function PopOptions: Boolean;
 { Image Format Functions }
 
 { Returns short information about given image format.}
-function GetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
+function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean;
 { Returns size in bytes of Width x Height area of pixels. Works for all formats.}
 function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
 
@@ -534,28 +533,28 @@ procedure RaiseImaging(const Msg: string; const Args: array of const);
 implementation
 
 uses
-{$IFDEF LINK_BITMAP}
+{$IFNDEF DONT_LINK_BITMAP}
   ImagingBitmap,
 {$ENDIF}
-{$IFDEF LINK_JPEG}
+{$IFNDEF DONT_LINK_JPEG}
   ImagingJpeg,
 {$ENDIF}
-{$IF Defined(LINK_PNG) or Defined(LINK_MNG) or Defined(LINK_JNG)}
+{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
   ImagingNetworkGraphics,
 {$IFEND}
-{$IFDEF LINK_GIF}
+{$IFNDEF DONT_LINK_GIF}
   ImagingGif,
 {$ENDIF}
-{$IFDEF LINK_DDS}
+{$IFNDEF DONT_LINK_DDS}
   ImagingDds,
 {$ENDIF}
-{$IFDEF LINK_TARGA}
+{$IFNDEF DONT_LINK_TARGA}
   ImagingTarga,
 {$ENDIF}
-{$IFDEF LINK_PNM}
+{$IFNDEF DONT_LINK_PNM}
   ImagingPortableMaps,
 {$ENDIF}
-{$IFDEF LINK_EXTRAS}
+{$IFNDEF DONT_LINK_EXTRAS}
   ImagingExtras,
 {$ENDIF}
   ImagingFormats, ImagingUtility, ImagingIO;
@@ -606,8 +605,9 @@ resourcestring
   SErrorFreePalette = 'Error while freeing palette @%p';
   SErrorCopyPalette = 'Error while copying %d entries from palette @%p to @%p';
   SErrorReplaceColor = 'Error while replacing colors in rectangle X:%d Y:%d W:%d H:%d of image %s';
-  SErrorRotateImage = 'Error while rotating image %s by %d degrees';
+  SErrorRotateImage = 'Error while rotating image %s by %.2n degrees';
   SErrorStretchRect = 'Error while stretching rect from image %s to image %s.';
+  SErrorEmptyStream = 'Input stream has no data. Check Position property.';
 
 const
   // initial size of array with options information
@@ -727,7 +727,7 @@ function NewImage(Width, Height: LongInt; Format: TImageFormat; var Image:
 var
   FInfo: PImageFormatInfo;
 begin
-  Assert((Width >= 0) and (Height >= 0));
+  Assert((Width > 0) and (Height >0));
   Assert(IsImageFormatValid(Format));
   Result := False;
   FreeImage(Image);
@@ -996,6 +996,8 @@ var
   I: LongInt;
 begin
   Assert(Stream <> nil);
+  if Stream.Size - Stream.Position = 0 then
+    RaiseImaging(SErrorEmptyStream, []);
   Result := False;
   Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
   if Format <> nil then
@@ -1057,6 +1059,8 @@ var
   Format: TImageFileFormat;
 begin
   Assert(Stream <> nil);
+  if Stream.Size - Stream.Position = 0 then
+    RaiseImaging(SErrorEmptyStream, []);
   Result := False;
   Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
   if Format <> nil then
@@ -1416,7 +1420,10 @@ begin
     // Free old image and assign new image to it
     FreeMemNil(Image.Bits);
     if Image.Palette <> nil then
+    begin
+      FreeMem(WorkImage.Palette);
       WorkImage.Palette := Image.Palette;
+    end;
     Image := WorkImage;
     Result := True;
   except
@@ -1854,33 +1861,154 @@ begin
   end;
 end;
 
-function RotateImage(var Image: TImageData; Angle: LongInt): Boolean;
+function RotateImage(var Image: TImageData; Angle: Single): Boolean;
 var
-  X, Y, BytesPerPixel: LongInt;
-  RotImage: TImageData;
-  Pix, RotPix: PByte;
   OldFmt: TImageFormat;
-begin
-  Assert(Angle mod 90 = 0);
-  Result := False;
 
-  if TestImage(Image) then
+  procedure XShear(var Src, Dst: TImageData; Row, Offset, Weight, Bpp: Integer);
-  try
+  var
-    if (Angle < -360) or (Angle > 360) then Angle := Angle mod 360;
+    I, J, XPos: Integer;
-    if (Angle = 0) or (Abs(Angle) = 360) then
+    PixSrc, PixLeft, PixOldLeft: TColor32Rec;
+    LineDst: PByteArray;
+    SrcPtr: PColor32;
   begin
-      Result := True;
+    SrcPtr := @PByteArray(Src.Bits)[Row * Src.Width * Bpp];
-      Exit;
+    LineDst := @PByteArray(Dst.Bits)[Row * Dst.Width * Bpp];
+    PixOldLeft.Color := 0;
+
+    for I := 0 to Src.Width - 1 do
+    begin
+      CopyPixel(SrcPtr, @PixSrc, Bpp);
+      for J := 0 to Bpp - 1 do
+        PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256);
+
+      XPos := I + Offset;
+      if (XPos >= 0) and (XPos < Dst.Width) then
+      begin
+        for J := 0 to Bpp - 1 do
+          PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
+        CopyPixel(@PixSrc, @LineDst[XPos * Bpp], Bpp);
+      end;
+      PixOldLeft := PixLeft;
+      Inc(PByte(SrcPtr), Bpp);
     end;
 
-    Angle := Iff(Angle = -90, 270, Angle);
+    XPos := Src.Width + Offset;
-    Angle := Iff(Angle = -270, 90, Angle);
+    if XPos < Dst.Width then
-    Angle := Iff(Angle = -180, 180, Angle);
+      CopyPixel(@PixOldLeft, @LineDst[XPos * Bpp], Bpp);
+  end;
 
-    OldFmt := Image.Format;
+  procedure YShear(var Src, Dst: TImageData; Col, Offset, Weight, Bpp: Integer);
-    if ImageFormatInfos[Image.Format].IsSpecial then
+  var
-      ConvertImage(Image, ifDefault);
+    I, J, YPos: Integer;
+    PixSrc, PixLeft, PixOldLeft: TColor32Rec;
+    SrcPtr: PByte;
+  begin
+    SrcPtr := @PByteArray(Src.Bits)[Col * Bpp];
+    PixOldLeft.Color := 0;
 
+    for I := 0 to Src.Height - 1 do
+    begin
+      CopyPixel(SrcPtr, @PixSrc, Bpp);
+      for J := 0 to Bpp - 1 do
+        PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256);
+
+      YPos := I + Offset;
+      if (YPos >= 0) and (YPos < Dst.Height) then
+      begin
+        for J := 0 to Bpp - 1 do
+          PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
+        CopyPixel(@PixSrc, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp);
+      end;
+      PixOldLeft := PixLeft;
+      Inc(SrcPtr, Src.Width * Bpp);
+    end;
+
+    YPos := Src.Height + Offset;
+    if YPos < Dst.Height then
+      CopyPixel(@PixOldLeft, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp);
+  end;
+
+  procedure Rotate45(var Image: TImageData; Angle: Single);
+  var
+    TempImage1, TempImage2: TImageData;
+    AngleRad, AngleTan, AngleSin, AngleCos, Shear: Single;
+    I, DstWidth, DstHeight, SrcWidth, SrcHeight, Bpp: Integer;
+    SrcFmt, TempFormat: TImageFormat;
+    Info: TImageFormatInfo;
+  begin
+    AngleRad := Angle * Pi / 180;
+    AngleSin := Sin(AngleRad);
+    AngleCos := Cos(AngleRad);
+    AngleTan := Sin(AngleRad / 2) / Cos(AngleRad / 2);
+    SrcWidth := Image.Width;
+    SrcHeight := Image.Height;
+    SrcFmt := Image.Format;
+
+    if not (SrcFmt in [ifR8G8B8..ifX8R8G8B8, ifGray8..ifGray32, ifA16Gray16]) then
+      ConvertImage(Image, ifA8R8G8B8);
+
+    TempFormat := Image.Format;
+    GetImageFormatInfo(TempFormat, Info);
+    Bpp := Info.BytesPerPixel;
+
+    // 1st shear (horizontal)
+    DstWidth := Trunc(SrcWidth + SrcHeight * Abs(AngleTan) + 0.5);
+    DstHeight := SrcHeight;
+    NewImage(DstWidth, DstHeight, TempFormat, TempImage1);
+
+    for I := 0 to DstHeight - 1 do
+    begin
+      if AngleTan >= 0 then
+        Shear := (I + 0.5) * AngleTan
+      else
+        Shear := (I - DstHeight + 0.5) * AngleTan;
+      XShear(Image, TempImage1, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
+    end;
+
+    // 2nd shear  (vertical)
+    FreeImage(Image);
+    DstHeight := Trunc(SrcWidth * Abs(AngleSin) + SrcHeight * AngleCos + 0.5) + 1;
+    NewImage(DstWidth, DstHeight, TempFormat, TempImage2);
+
+    if AngleSin >= 0 then
+      Shear := (SrcWidth - 1) * AngleSin
+    else
+      Shear := (SrcWidth - DstWidth) * -AngleSin;
+
+    for I := 0 to DstWidth - 1 do
+    begin
+      YShear(TempImage1, TempImage2, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
+      Shear := Shear - AngleSin;
+    end;
+
+    // 3rd shear (horizontal)
+    FreeImage(TempImage1);
+    DstWidth := Trunc(SrcHeight * Abs(AngleSin) + SrcWidth * AngleCos + 0.5) + 1;
+    NewImage(DstWidth, DstHeight, TempFormat, Image);
+
+    if AngleSin >= 0 then
+      Shear := (SrcWidth - 1) * AngleSin * -AngleTan
+    else
+      Shear := ((SrcWidth - 1) * -AngleSin + (1 - DstHeight)) * AngleTan;
+
+    for I := 0 to DstHeight - 1 do
+    begin
+      XShear(TempImage2, Image, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
+      Shear := Shear + AngleTan;
+    end;
+
+    FreeImage(TempImage2);
+    if Image.Format <> SrcFmt then
+      ConvertImage(Image, SrcFmt);
+  end;
+
+  procedure RotateMul90(var Image: TImageData; Angle: Integer);
+  var
+    RotImage: TImageData;
+    X, Y, BytesPerPixel: Integer;
+    RotPix, Pix: PByte;
+  begin
     InitImage(RotImage);
     BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel;
 
@@ -1920,8 +2048,7 @@ begin
         begin
           for Y := 0 to RotImage.Height - 1 do
           begin
-            Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width +
+            Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Y) * BytesPerPixel];
-              Y) * BytesPerPixel];
             for X := 0 to RotImage.Width - 1 do
             begin
               CopyPixel(Pix, RotPix, BytesPerPixel);
@@ -1935,6 +2062,46 @@ begin
     FreeMemNil(Image.Bits);
     RotImage.Palette := Image.Palette;
     Image := RotImage;
+  end;
+
+begin
+  Result := False;
+
+  if TestImage(Image) then
+  try
+    while Angle >= 360 do
+      Angle := Angle - 360;
+    while Angle < 0 do
+      Angle := Angle + 360;
+
+    if (Angle = 0) or (Abs(Angle) = 360) then
+    begin
+      Result := True;
+      Exit;
+    end;
+
+    OldFmt := Image.Format;
+    if ImageFormatInfos[Image.Format].IsSpecial then
+      ConvertImage(Image, ifDefault);
+
+    if (Angle > 45) and (Angle <= 135) then
+    begin
+      RotateMul90(Image, 90);
+      Angle := Angle - 90;
+    end
+    else if (Angle > 135) and (Angle <= 225) then
+    begin
+      RotateMul90(Image, 180);
+      Angle := Angle - 180;
+    end
+    else if (Angle > 225) and (Angle <= 315) then
+    begin
+      RotateMul90(Image, 270);
+      Angle := Angle - 270;
+    end;
+
+    if Angle <> 0 then
+      Rotate45(Image, Angle);
 
     if OldFmt <> Image.Format then
       ConvertImage(Image, OldFmt);
@@ -2421,7 +2588,7 @@ end;
 
 { Image Format Functions }
 
-function GetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
+function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean;
 begin
   FillChar(Info, SizeOf(Info), 0);
   if ImageFormatInfos[Format] <> nil then
@@ -2527,7 +2694,7 @@ begin
 
   if OptionId >= Length(Options) then
     SetLength(Options, OptionId + InitialOptions);
-  if (OptionId >= 0) and (OptionId < Length(Options)) and (Options[OptionId] = nil) then
+  if (OptionId >= 0) and (OptionId < Length(Options)) {and (Options[OptionId] = nil) - must be able to override existing } then
   begin
     Options[OptionId] := Variable;
     Result := True;
@@ -2539,7 +2706,7 @@ var
   I: LongInt;
 begin
   Result := nil;
-  for I := 0 to ImageFileFormats.Count - 1 do
+  for I := ImageFileFormats.Count - 1 downto 0 do
     if TImageFileFormat(ImageFileFormats[I]).Extensions.IndexOf(Ext) >= 0 then
     begin
       Result := TImageFileFormat(ImageFileFormats[I]);
@@ -2552,7 +2719,7 @@ var
   I: LongInt;
 begin
   Result := nil;
-  for I := 0 to ImageFileFormats.Count - 1 do
+  for I := ImageFileFormats.Count - 1 downto 0 do
     if TImageFileFormat(ImageFileFormats[I]).TestFileName(FileName) then
     begin
       Result := TImageFileFormat(ImageFileFormats[I]);
@@ -3289,6 +3456,19 @@ finalization
   -- TODOS ----------------------------------------------------
     - nothing now
 
+  -- 0.26.3 Changes/Bug Fixes ---------------------------------
+    - Extended RotateImage to allow arbitrary angle rotations.
+    - Reversed the order file formats list is searched so
+      if you register a new one it will be found sooner than
+      built in formats.
+    - Fixed memory leak in ResizeImage ocurring when resizing
+      indexed images.
+
+  -- 0.26.1 Changes/Bug Fixes ---------------------------------
+    - Added position/size checks to LoadFromStream functions.
+    - Changed conditional compilation in impl. uses section to reflect changes
+      in LINK symbols.
+
   -- 0.24.3 Changes/Bug Fixes ---------------------------------
     - GenerateMipMaps now generates all smaller levels from
       original big image (better results when using more advanced filters).

Imaging/ImagingCanvases.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingCanvases.pas 131 2008-08-14 15:14:24Z galfar $
+  $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $
   Vampyre Imaging Library
   by Marek Mauder
   http://imaginglib.sourceforge.net
@@ -118,6 +118,8 @@ type
 
   TDynFPPixelArray = array of TColorFPRec;
 
+  THistogramArray = array[Byte] of Integer;
+
   TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec;
 
   { Base canvas class for drawing objects, applying effects, and other.
@@ -128,7 +130,7 @@ type
     recompute some data size related stuff).
 
     TImagingCanvas works for all image data formats except special ones
-    (compressed). Because of this its methods are quite slow (they work
+    (compressed). Because of this its methods are quite slow (they usually work
     with colors in ifA32R32G32B32F format). If you want fast drawing you
     can use one of fast canvas clases. These descendants of TImagingCanvas
     work only for few select formats (or only one) but they are optimized thus
@@ -216,6 +218,12 @@ type
       filled by using the current fill settings. Rect specifies bounding rectangle
       of ellipse to be drawn.}
     procedure Ellipse(const Rect: TRect);
+    { Fills area of canvas with current fill color starting at point [X, Y] and
+      coloring its neighbors. Default flood fill mode changes color of all
+      neighbors with the same color as pixel [X, Y]. With BoundaryFillMode
+      set to True neighbors are recolored regardless of their old color,
+      but area which will be recolored has boundary (specified by current pen color).}
+    procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False);         
 
     { Draws contents of this canvas onto another canvas with pixel blending.
       Blending factors are chosen using TBlendingFactor parameters.
@@ -225,7 +233,7 @@ type
       DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
     { Draws contents of this canvas onto another one with typical alpha
       blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
-    procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
+    procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); virtual;
     { Draws contents of this canvas onto another one using additive blending
       (source and dest factors are bfOne).}
     procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
@@ -239,7 +247,7 @@ type
     { Draws contents of this canvas onto another one with typical alpha
       blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
     procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
-      const DestRect: TRect; Filter: TResizeFilter = rfBilinear);
+      const DestRect: TRect; Filter: TResizeFilter = rfBilinear); virtual;
     { Draws contents of this canvas onto another one using additive blending
       (source and dest factors are bfOne).}
     procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas;
@@ -286,10 +294,36 @@ type
     { Gamma correction of individual color channels. Range is (0, +inf),
       1.0 means no change.}
     procedure GammaCorection(Red, Green, Blue: Single);
-    { Inverts colors of all image pixels, makes negative image.}
+    { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
-    procedure InvertColors;
+    procedure InvertColors; virtual;
-    { Simple single level thresholding with threshold level for each color channel.}
+    { Simple single level thresholding with threshold level (in range [0, 1])
+      for each color channel.}
     procedure Threshold(Red, Green, Blue: Single);
+    { Adjusts the color levels of the image by scaling the
+      colors falling between specified white and black points to full [0, 1] range.
+      The black point specifies the darkest color in the image, white point
+      specifies the lightest color, and mid point is gamma aplied to image.
+      Black and white point must be in range [0, 1].}
+    procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0);
+    { Premultiplies color channel values by alpha. Needed for some platforms/APIs
+      to display images with alpha properly.}
+    procedure PremultiplyAlpha;
+    { Reverses PremultiplyAlpha operation.}
+    procedure UnPremultiplyAlpha;
+
+    { Calculates image histogram for each channel and also gray values. Each
+      channel has 256 values available. Channel values of data formats with higher
+      precision are scaled and rounded. Example: Red[126] specifies number of pixels
+      in image with red channel = 126.}
+    procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray);
+    { Fills image channel with given value leaving other channels intact.
+      Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
+      channel identifier.}
+    procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload;
+    { Fills image channel with given value leaving other channels intact.
+      Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
+      channel identifier.}
+    procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload;
 
     { Color used when drawing lines, frames, and outlines of objects.}
     property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
@@ -337,6 +371,7 @@ type
   TFastARGB32Canvas = class(TImagingCanvas)
   protected
     FScanlines: PScanlineArray;
+    procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF}
     function GetPixel32(X, Y: LongInt): TColor32; override;
     procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override;
   public
@@ -344,6 +379,11 @@ type
 
     procedure UpdateCanvasState; override;
 
+    procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override;
+    procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+      const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override;
+    procedure InvertColors; override;
+
     property Scanlines: PScanlineArray read FScanlines;
 
     class function GetSupportedFormats: TImageFormats; override;
@@ -600,13 +640,16 @@ procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte;
   DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
 var
   DestPix: TColorFPRec;
+  SrcAlpha, DestAlpha: Single;
 begin
   DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
   // Blend the two pixels (Src 'over' Dest alpha composition operation)
-  DestPix.R := SrcPix.R * SrcPix.A + DestPix.R * DestPix.A * (1.0 - SrcPix.A);
+  DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
-  DestPix.G := SrcPix.G * SrcPix.A + DestPix.G * DestPix.A * (1.0 - SrcPix.A);
+  SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
-  DestPix.B := SrcPix.B * SrcPix.A + DestPix.B * DestPix.A * (1.0 - SrcPix.A);
+  DestAlpha := 1.0 - SrcAlpha;
-  DestPix.A := SrcPix.A + DestPix.A * (1.0 - SrcPix.A);
+  DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
+  DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
+  DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha;
   // Write blended pixel
   DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
 end;
@@ -691,7 +734,7 @@ begin
   end;
 end;
 
-function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, Ignore: Single): TColorFPRec;
+function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, P3: Single): TColorFPRec;
 begin
   Result.A := Pixel.A;
   Result.R := Pixel.R * C + B;
@@ -707,7 +750,7 @@ begin
   Result.B := Power(Pixel.B, 1.0 / B);
 end;
 
-function TransformInvert(const Pixel: TColorFPRec; A, B, C: Single): TColorFPRec;
+function TransformInvert(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
 begin
   Result.A := Pixel.A;
   Result.R := 1.0 - Pixel.R;
@@ -723,6 +766,49 @@ begin
   Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0);
 end;
 
+function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec;
+begin
+  Result.A := Pixel.A;
+  if Pixel.R > BlackPoint then
+    Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+  else
+    Result.R := 0.0;
+  if Pixel.G > BlackPoint then
+    Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+  else
+    Result.G := 0.0;
+  if Pixel.B > BlackPoint then
+    Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+  else
+    Result.B := 0.0;
+end;
+
+function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
+begin
+  Result.A := Pixel.A;
+  Result.R := Result.R * Pixel.A;
+  Result.G := Result.G * Pixel.A;
+  Result.B := Result.B * Pixel.A;
+end;
+
+function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
+begin
+  Result.A := Pixel.A;
+  if Pixel.A <> 0.0 then
+  begin
+    Result.R := Result.R / Pixel.A;
+    Result.G := Result.G / Pixel.A;
+    Result.B := Result.B / Pixel.A;
+  end
+  else
+  begin
+    Result.R := 0;
+    Result.G := 0;
+    Result.B := 0;
+  end;
+end;
+
+
 { TImagingCanvas class implementation }
 
 constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
@@ -1175,6 +1261,98 @@ begin
   end;
 end;
 
+procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean);
+var
+  Stack: array of TPoint;
+  StackPos, Y1: Integer;
+  OldColor: TColor32;
+  SpanLeft, SpanRight: Boolean;
+
+  procedure Push(AX, AY: Integer);
+  begin
+    if StackPos < High(Stack) then
+    begin
+      Inc(StackPos);
+      Stack[StackPos].X := AX;
+      Stack[StackPos].Y := AY;
+    end
+    else
+    begin
+      SetLength(Stack, Length(Stack) + FPData.Width);
+      Push(AX, AY);
+    end;
+  end;
+
+  function Pop(out AX, AY: Integer): Boolean;
+  begin
+    if StackPos > 0 then
+    begin
+      AX := Stack[StackPos].X;
+      AY := Stack[StackPos].Y;
+      Dec(StackPos);
+      Result := True;
+    end
+    else
+      Result := False;
+  end;
+
+  function Compare(AX, AY: Integer): Boolean;
+  var
+    Color: TColor32;
+  begin
+    Color := GetPixel32(AX, AY);
+    if BoundaryFillMode then
+      Result := (Color <> FFillColor32) and (Color <> FPenColor32)
+    else
+      Result := Color = OldColor;
+  end;
+
+begin
+  // Scanline Floodfill Algorithm With Stack
+  // http://student.kuleuven.be/~m0216922/CG/floodfill.html
+
+  if not PtInRect(FClipRect, Point(X, Y)) then Exit;
+
+  SetLength(Stack, FPData.Width * 4);
+  StackPos := 0;
+
+  OldColor := GetPixel32(X, Y);
+
+  Push(X, Y);
+
+  while Pop(X, Y) do
+  begin
+    Y1 := Y;
+    while (Y1 >= FClipRect.Top) and Compare(X, Y1) do
+      Dec(Y1);
+
+    Inc(Y1);
+    SpanLeft := False;
+    SpanRight := False;
+
+    while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do
+    begin
+      SetPixel32(X, Y1, FFillColor32);
+      if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then
+      begin
+        Push(X - 1, Y1);
+        SpanLeft := True;
+      end
+      else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then
+        SpanLeft := False
+      else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then
+      begin
+        Push(X + 1, Y1);
+        SpanRight := True;
+      end
+      else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then
+        SpanRight := False;
+
+      Inc(Y1);
+    end;
+  end;
+end;
+
 procedure TImagingCanvas.DrawInternal(const SrcRect: TRect;
   DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor,
   DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
@@ -1533,7 +1711,7 @@ end;
 procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single);
 begin
   PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100,
-    Brightness / 100, 0.0);
+    Brightness / 100, 0);
 end;
 
 procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single);
@@ -1551,6 +1729,98 @@ begin
   PointTransform(TransformThreshold, Red, Green, Blue);
 end;
 
+procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single);
+begin
+  PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint);
+end;
+
+procedure TImagingCanvas.PremultiplyAlpha;
+begin
+  PointTransform(TransformPremultiplyAlpha, 0, 0, 0);
+end;
+
+procedure TImagingCanvas.UnPremultiplyAlpha;
+begin
+  PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0);
+end;
+
+procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha,
+  Gray: THistogramArray);
+var
+  X, Y, Bpp: Integer;
+  PixPointer: PByte;
+  Color32: TColor32Rec;
+begin
+  FillChar(Red,   SizeOf(Red), 0);
+  FillChar(Green, SizeOf(Green), 0);
+  FillChar(Blue,  SizeOf(Blue), 0);
+  FillChar(Alpha, SizeOf(Alpha), 0);
+  FillChar(Gray,  SizeOf(Gray), 0);
+
+  Bpp := FFormatInfo.BytesPerPixel;
+
+  for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+  begin
+    PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+    for X := FClipRect.Left to FClipRect.Right - 1 do
+    begin
+      Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
+
+      Inc(Red[Color32.R]);
+      Inc(Green[Color32.G]);
+      Inc(Blue[Color32.B]);
+      Inc(Alpha[Color32.A]);
+      Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]);
+
+      Inc(PixPointer, Bpp);
+    end;
+  end;
+end;
+
+procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte);
+var
+  X, Y, Bpp: Integer;
+  PixPointer: PByte;
+  Color32: TColor32Rec;
+begin
+  Bpp := FFormatInfo.BytesPerPixel;
+
+  for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+  begin
+    PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+    for X := FClipRect.Left to FClipRect.Right - 1 do
+    begin
+      Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
+      Color32.Channels[ChannelId] := NewChannelValue;
+      FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32);
+
+      Inc(PixPointer, Bpp);
+    end;
+  end;
+end;
+
+procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single);
+var
+  X, Y, Bpp: Integer;
+  PixPointer: PByte;
+  ColorFP: TColorFPRec;
+begin
+  Bpp := FFormatInfo.BytesPerPixel;
+
+  for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+  begin
+    PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+    for X := FClipRect.Left to FClipRect.Right - 1 do
+    begin
+      ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
+      ColorFP.Channels[ChannelId] := NewChannelValue;
+      FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP);
+
+      Inc(PixPointer, Bpp);
+    end;
+  end;
+end;
+
 class function TImagingCanvas.GetSupportedFormats: TImageFormats;
 begin
   Result := [ifIndex8..Pred(ifDXT1)];
@@ -1564,6 +1834,55 @@ begin
   inherited Destroy;
 end;
 
+procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec);
+var
+  SrcAlpha, DestAlpha, FinalAlpha: Integer;
+begin
+  FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8;
+  if FinalAlpha = 0 then
+    SrcAlpha := 0
+  else
+    SrcAlpha := (SrcPix.A shl 8) div FinalAlpha;
+  DestAlpha := 256 - SrcAlpha;
+
+  DestPix.A := ClampToByte(FinalAlpha);
+  DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8;
+  DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8;
+  DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8;
+end;
+
+procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect;
+  DestCanvas: TImagingCanvas; DestX, DestY: Integer);
+var
+  X, Y, SrcX, SrcY, Width, Height: Integer;
+  SrcPix, DestPix: PColor32Rec;
+begin
+  if DestCanvas.ClassType <> Self.ClassType then
+  begin
+    inherited;
+    Exit;
+  end;
+
+  SrcX := SrcRect.Left;
+  SrcY := SrcRect.Top;
+  Width := SrcRect.Right - SrcRect.Left;
+  Height := SrcRect.Bottom - SrcRect.Top;
+  ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY,
+    FPData.Width, FPData.Height, DestCanvas.ClipRect);
+
+  for Y := 0 to Height - 1 do
+  begin
+    SrcPix := @FScanlines[SrcY + Y, SrcX];
+    DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX];
+    for X := 0 to Width - 1 do
+    begin
+      AlphaBlendPixels(SrcPix, DestPix);
+      Inc(SrcPix);
+      Inc(DestPix);
+    end;
+  end;
+end;
+
 function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32;
 begin
   Result := FScanlines[Y, X].Color;
@@ -1578,6 +1897,189 @@ begin
   end;
 end;
 
+procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
+  DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
+var
+  X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4,
+    FracX, FracY, InvFracY, T1, T2: Integer;
+  SrcX, SrcY, SrcWidth, SrcHeight: Integer;
+  DestX, DestY, DestWidth, DestHeight: Integer;
+  SrcLine, SrcLine2: PColor32RecArray;
+  DestPix: PColor32Rec;
+  Accum: TColor32Rec;
+begin
+  if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then
+  begin
+    inherited;
+    Exit;
+  end;
+
+  SrcX := SrcRect.Left;
+  SrcY := SrcRect.Top;
+  SrcWidth := SrcRect.Right - SrcRect.Left;
+  SrcHeight := SrcRect.Bottom - SrcRect.Top;
+  DestX := DestRect.Left;
+  DestY := DestRect.Top;
+  DestWidth := DestRect.Right - DestRect.Left;
+  DestHeight := DestRect.Bottom - DestRect.Top;
+  // Clip src and dst rects
+  ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight,
+      FPData.Width, FPData.Height, DestCanvas.ClipRect);
+  ScaleX := (SrcWidth shl 16) div DestWidth;
+  ScaleY := (SrcHeight shl 16) div DestHeight;
+
+  // Nearest and linear filtering using fixed point math
+
+  if Filter = rfNearest then
+  begin
+    Yp := 0;
+    for Y := DestY to DestY + DestHeight - 1 do
+    begin
+      Xp := 0;
+      SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX];
+      DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
+      for X := 0 to DestWidth - 1 do
+      begin
+        AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix);
+        Inc(DestPix);
+        Inc(Xp, ScaleX);
+      end;
+      Inc(Yp, ScaleY);
+    end;
+  end
+  else
+  begin
+    Yp := (ScaleY shr 1) - $8000;
+    for Y := DestY to DestY + DestHeight - 1 do
+    begin
+      DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
+      if Yp < 0 then
+      begin
+        T1 := 0;
+        FracY := 0;
+        InvFracY := $10000;
+      end
+      else
+      begin
+        T1 := Yp shr 16;
+        FracY := Yp and $FFFF;
+        InvFracY := (not Yp and $FFFF) + 1;
+      end;
+
+      T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1);
+      SrcLine :=  @Scanlines[T1 + SrcY, SrcX];
+      SrcLine2 := @Scanlines[T2 + SrcY, SrcX];
+      Xp := (ScaleX shr 1) - $8000;
+
+      for X := 0 to DestWidth - 1 do
+      begin
+        if Xp < 0 then
+        begin
+          T1 := 0;
+          FracX := 0;
+        end
+        else
+        begin
+          T1 := Xp shr 16;
+          FracX := Xp and $FFFF;
+        end;
+
+        T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1);
+        Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere
+        Weight1:= InvFracY - Weight2;
+        Weight4:= (Cardinal(FracY) * FracX) shr 16;
+        Weight3:= FracY - Weight4;
+
+        Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
+          SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16;
+        Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 +
+          SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16;
+        Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 +
+          SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16;
+        Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 +
+          SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16;
+
+        AlphaBlendPixels(@Accum, DestPix);
+
+        Inc(Xp, ScaleX);
+        Inc(DestPix);
+      end;
+      Inc(Yp, ScaleY);
+     end;
+  end;
+         {
+
+  // Generate mapping tables
+  MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
+    FPData.Width, FilterFunction, Radius, False);
+  MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
+    FPData.Height, FilterFunction, Radius, False);
+  FindExtremes(MapX, XMinimum, XMaximum);
+  SetLength(LineBuffer, XMaximum - XMinimum + 1);
+
+  for J := 0 to DestHeight - 1 do
+  begin
+    ClusterY := MapY[J];
+    for X := XMinimum to XMaximum do
+    begin
+      AccumA := 0;
+      AccumR := 0;
+      AccumG := 0;
+      AccumB := 0;
+      for Y := 0 to Length(ClusterY) - 1 do
+      begin
+        Weight := Round(ClusterY[Y].Weight * 256);
+        SrcColor := FScanlines[ClusterY[Y].Pos, X];
+
+        AccumB := AccumB + SrcColor.B * Weight;
+        AccumG := AccumG + SrcColor.G * Weight;
+        AccumR := AccumR + SrcColor.R * Weight;
+        AccumA := AccumA + SrcColor.A * Weight;
+      end;
+      with LineBuffer[X - XMinimum] do
+      begin
+        A := AccumA;
+        R := AccumR;
+        G := AccumG;
+        B := AccumB;
+      end;
+    end;
+
+    DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
+
+    for I := 0 to DestWidth - 1 do
+    begin
+      ClusterX := MapX[I];
+      AccumA := 0;
+      AccumR := 0;
+      AccumG := 0;
+      AccumB := 0;
+      for X := 0 to Length(ClusterX) - 1 do
+      begin
+        Weight := Round(ClusterX[X].Weight * 256);
+        with LineBuffer[ClusterX[X].Pos - XMinimum] do
+        begin
+          AccumB := AccumB + B * Weight;
+          AccumG := AccumG + G * Weight;
+          AccumR := AccumR + R * Weight;
+          AccumA := AccumA + A * Weight;
+        end;
+      end;
+
+      AccumA := ClampInt(AccumA, 0, $00FF0000);
+      AccumR := ClampInt(AccumR, 0, $00FF0000);
+      AccumG := ClampInt(AccumG, 0, $00FF0000);
+      AccumB := ClampInt(AccumB, 0, $00FF0000);
+      SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
+        (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
+
+      AlphaBlendPixels(@SrcColor, DestPtr);
+
+      Inc(DestPtr);
+    end;
+  end;   }
+end;
+
 procedure TFastARGB32Canvas.UpdateCanvasState;
 var
   I: LongInt;
@@ -1601,6 +2103,24 @@ begin
   Result := [ifA8R8G8B8];
 end;
 
+procedure TFastARGB32Canvas.InvertColors;
+var
+  X, Y: Integer;
+  PixPtr: PColor32Rec;
+begin
+  for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+  begin
+    PixPtr := @FScanlines[Y, FClipRect.Left];
+    for X := FClipRect.Left to FClipRect.Right - 1 do
+    begin
+      PixPtr.R := not PixPtr.R;
+      PixPtr.G := not PixPtr.G;
+      PixPtr.B := not PixPtr.B;
+      Inc(PixPtr);
+    end;
+  end;
+end;
+
 initialization
   RegisterCanvas(TFastARGB32Canvas);
 
@@ -1616,6 +2136,19 @@ finalization
     - add blending (*image and object drawing)
     - more objects (arc, polygon)
 
+  -- 0.26.3 Changes/Bug Fixes ---------------------------------
+    - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
+    - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
+    - Added PremultiplyAlpha and UnPremultiplyAlpha methods.
+
+  -- 0.26.1 Changes/Bug Fixes ---------------------------------
+    - Added FillChannel methods.
+    - Added FloodFill method.
+    - Added GetHistogram method.
+    - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
+      (thanks to Carlos González).
+    - Added TImagingCanvas.AdjustColorLevels method.
+
   -- 0.25.0 Changes/Bug Fixes ---------------------------------
     - Fixed error that could cause AV in linear and nonlinear filters.
     - Added blended rect filling function FillRectBlend.

Imaging/ImagingClasses.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingClasses.pas 124 2008-04-21 09:47:07Z galfar $
+  $Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -68,7 +68,7 @@ type
     constructor CreateFromImage(AImage: TBaseImage);
     destructor Destroy; override;
     { Returns info about current image.}
-    function ToString: string;
+    function ToString: string; {$IF Defined(DCC) and (CompilerVersion >= 20.0)}override;{$IFEND}
 
     { Creates a new image data with the given size and format. Old image
       data is lost. Works only for the current image of TMultiImage.}
@@ -81,8 +81,8 @@ type
     { Mirrors current image. Reverses the image along its vertical axis the left
       side becomes the right and vice versa.}
     procedure Mirror;
-    { Rotates image by 90, 180, 270, -90, -180, or -270 degrees counterclockwise.}
+    { Rotates image by Angle degrees counterclockwise.}
-    procedure Rotate(Angle: LongInt);
+    procedure Rotate(Angle: Single);
     { Copies rectangular part of SrcImage to DstImage. No blending is performed -
       alpha is simply copied to destination image. Operates also with
       negative X and Y coordinates.
@@ -451,7 +451,7 @@ begin
     DoPixelsChanged;
 end;
 
-procedure TBaseImage.Rotate(Angle: LongInt);
+procedure TBaseImage.Rotate(Angle: Single);
 begin
   if Valid and Imaging.RotateImage(FPData^, Angle) then
     DoPixelsChanged;

Imaging/ImagingColors.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingColors.pas 74 2007-03-12 15:04:04Z galfar $
+  $Id: ImagingColors.pas 173 2009-09-04 17:05:52Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -68,6 +68,12 @@ procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
 { Converts CMYK to RGB color.}
 procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
 
+{ Converts RGB color to YCoCg.}
+procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
+{ Converts YCoCg to RGB color.}
+procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
+
+
 implementation
 
 procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
@@ -149,11 +155,17 @@ procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
 begin
   RGBToCMY(R, G, B, C, M, Y);
   K := Min(C, Min(M, Y));
-  if K > 0 then
+  if K = 255 then
   begin
-    C := C - K;
+    C := 0;
-    M := M - K;
+    M := 0;
-    Y := Y - K;
+    Y := 0;
+  end
+  else
+  begin
+    C := ClampToByte(Round((C - K) / (255 - K) * 255));
+    M := ClampToByte(Round((M - K) / (255 - K) * 255));
+    Y := ClampToByte(Round((Y - K) / (255 - K) * 255));
   end;
 end;
 
@@ -168,11 +180,17 @@ procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
 begin
   RGBToCMY16(R, G, B, C, M, Y);
   K := Min(C, Min(M, Y));
-  if K > 0 then
+  if K = 65535 then
   begin
-    C := C - K;
+    C := 0;
-    M := M - K;
+    M := 0;
-    Y := Y - K;
+    Y := 0;
+  end
+  else
+  begin
+    C := ClampToWord(Round((C - K) / (65535 - K) * 65535));
+    M := ClampToWord(Round((M - K) / (65535 - K) * 65535));
+    Y := ClampToWord(Round((Y - K) / (65535 - K) * 65535));
   end;
 end;
 
@@ -183,12 +201,35 @@ begin
   B := 65535 - (Y - MulDiv(Y, K, 65535) + K);
 end;
 
+procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
+begin
+  // C and Delphi's SHR behaviour differs for negative numbers, use div instead.
+  Y  := ClampToByte(( R +     G shl 1 + B       + 2) div 4);
+  Co := ClampToByte(( R shl 1         - B shl 1 + 2) div 4 + 128);
+  Cg := ClampToByte((-R +     G shl 1 - B       + 2) div 4 + 128);
+end;
+
+procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
+var
+  CoInt, CgInt: Integer;
+begin
+  CoInt := Co - 128;
+  CgInt := Cg - 128;
+  R := ClampToByte(Y + CoInt - CgInt);
+  G := ClampToByte(Y + CgInt);
+  B := ClampToByte(Y - CoInt - CgInt);
+end;
+
 {
   File Notes:
 
   -- TODOS ----------------------------------------------------
     - nothing now
 
+  -- 0.26.3 Changes/Bug Fixes ---------------------------------
+    - Added RGB<>YCoCg conversion functions.
+    - Fixed RGB>>CMYK conversions.
+
   -- 0.23 Changes/Bug Fixes -----------------------------------
     - Added RGB<>CMY(K) converion functions for 16 bit channels
       (needed by PSD loading code).

Imaging/ImagingComponents.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingComponents.pas 132 2008-08-27 20:37:38Z galfar $
+  $Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -26,7 +26,7 @@
   For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
 }
 
-{ This unit contains VCL/CLX/LCL TGraphic descendant which uses Imaging library
+{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library
   for saving and loading.}
 unit ImagingComponents;
 
@@ -34,6 +34,17 @@ unit ImagingComponents;
 
 interface
 
+{$IFDEF LCL}
+  {$DEFINE COMPONENT_SET_LCL}
+{$ENDIF}
+
+{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
+// If no component sets should be used just include empty unit.
+//DOC-IGNORE-BEGIN
+implementation
+//DOC-IGNORE-END
+{$ELSE}
+
 uses
   SysUtils, Types, Classes,
 {$IFDEF MSWINDOWS}
@@ -42,10 +53,6 @@ uses
 {$IFDEF COMPONENT_SET_VCL}
   Graphics,
 {$ENDIF}
-{$IFDEF COMPONENT_SET_CLX}
-  Qt,
-  QGraphics,
-{$ENDIF}
 {$IFDEF COMPONENT_SET_LCL}
   InterfaceBase,
   GraphType,
@@ -71,6 +78,8 @@ type
     procedure ReadDataFromStream(Stream: TStream); virtual;
     procedure AssignTo(Dest: TPersistent); override;
   public
+    constructor Create; override;
+
     { Loads new image from the stream. It can load all image
       file formats supported by Imaging (and enabled of course)
       even though it is called by descendant class capable of
@@ -114,8 +123,7 @@ type
     { Returns file extensions of this graphic class.}
     class function GetFileExtensions: string; override;
     { Returns default MIME type of this graphic class.}
-    function GetMimeType: string; override;  // uncomment for Laz 0.9.25 if you get error here
+    function GetMimeType: string; override;
-    //function GetDefaultMimeType: string; override;
   {$ENDIF}
     { Default (the most common) file extension of this graphic class.}
     property DefaultFileExt: string read FDefaultFileExt;
@@ -123,7 +131,7 @@ type
 
   TImagingGraphicForSaveClass = class of TImagingGraphicForSave;
 
-{$IFDEF LINK_BITMAP}
+{$IFNDEF DONT_LINK_BITMAP}
   { TImagingGraphic descendant for loading/saving Windows bitmaps.
     VCL/CLX/LCL all have native support for bitmaps so you might
     want to disable this class (although you can save bitmaps with
@@ -140,7 +148,7 @@ type
   end;
 {$ENDIF}
 
-{$IFDEF LINK_JPEG}
+{$IFNDEF DONT_LINK_JPEG}
   { TImagingGraphic descendant for loading/saving JPEG images.}
   TImagingJpeg = class(TImagingGraphicForSave)
   protected
@@ -151,8 +159,7 @@ type
     procedure SaveToStream(Stream: TStream); override;
     class function GetFileFormat: TImageFileFormat; override;
   {$IFDEF COMPONENT_SET_LCL}
-    //function GetMimeType: string; override;  // uncomment for Laz 0.9.25 if you get error here
+    function GetMimeType: string; override;
-    function GetDefaultMimeType: string; override;
   {$ENDIF}
     { See ImagingJpegQuality option for details.}
     property Quality: LongInt read FQuality write FQuality;
@@ -161,7 +168,7 @@ type
   end;
 {$ENDIF}
 
-{$IFDEF LINK_PNG}
+{$IFNDEF DONT_LINK_PNG}
   { TImagingGraphic descendant for loading/saving PNG images.}
   TImagingPNG = class(TImagingGraphicForSave)
   protected
@@ -178,7 +185,7 @@ type
   end;
 {$ENDIF}
 
-{$IFDEF LINK_GIF}
+{$IFNDEF DONT_LINK_GIF}
   { TImagingGraphic descendant for loading/saving GIF images.}
   TImagingGIF = class(TImagingGraphicForSave)
   public
@@ -186,7 +193,7 @@ type
   end;
 {$ENDIF}
 
-{$IFDEF LINK_TARGA}
+{$IFNDEF DONT_LINK_TARGA}
   { TImagingGraphic descendant for loading/saving Targa images.}
   TImagingTarga = class(TImagingGraphicForSave)
   protected
@@ -200,7 +207,7 @@ type
   end;
 {$ENDIF}
 
-{$IFDEF LINK_DDS}
+{$IFNDEF DONT_LINK_DDS}
   { Compresssion type used when saving DDS files by TImagingDds.}
   TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5);
 
@@ -218,7 +225,7 @@ type
   end;
 {$ENDIF}
 
-{$IFDEF LINK_MNG}
+{$IFNDEF DONT_LINK_MNG}
   { TImagingGraphic descendant for loading/saving MNG images.}
   TImagingMNG = class(TImagingGraphicForSave)
   protected
@@ -233,8 +240,7 @@ type
     procedure SaveToStream(Stream: TStream); override;
     class function GetFileFormat: TImageFileFormat; override;
   {$IFDEF COMPONENT_SET_LCL}
-    //function GetMimeType: string; override;  // uncomment for Laz 0.9.25 if you get error here
+    function GetMimeType: string; override;
-    function GetDefaultMimeType: string; override;
   {$ENDIF}
     { See ImagingMNGLossyCompression option for details.}
     property LossyCompression: Boolean read FLossyCompression write FLossyCompression;
@@ -251,7 +257,7 @@ type
   end;
 {$ENDIF}
 
-{$IFDEF LINK_JNG}
+{$IFNDEF DONT_LINK_JNG}
   { TImagingGraphic descendant for loading/saving JNG images.}
   TImagingJNG = class(TImagingGraphicForSave)
   protected
@@ -328,29 +334,29 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T
 implementation
 
 uses
-{$IF Defined(UNIX) and Defined(COMPONENT_SET_LCL)}
+{$IF Defined(LCL)}
-  {$IFDEF LCLGTK2}
+  {$IF Defined(LCLGTK2)}
     GLib2, GDK2, GTK2, GTKDef, GTKProc,
-  {$ELSE}
+  {$ELSEIF Defined(LCLGTK)}
     GDK, GTK, GTKDef, GTKProc,
-  {$ENDIF}
+  {$IFEND}
 {$IFEND}
-{$IFDEF LINK_BITMAP}
+{$IFNDEF DONT_LINK_BITMAP}
   ImagingBitmap,
 {$ENDIF}
-{$IFDEF LINK_JPEG}
+{$IFNDEF DONT_LINK_JPEG}
   ImagingJpeg,
 {$ENDIF}
-{$IFDEF LINK_GIF}
+{$IFNDEF DONT_LINK_GIF}
   ImagingGif,
 {$ENDIF}
-{$IFDEF LINK_TARGA}
+{$IFNDEF DONT_LINK_TARGA}
   ImagingTarga,
 {$ENDIF}
-{$IFDEF LINK_DDS}
+{$IFNDEF DONT_LINK_DDS}
   ImagingDds,
 {$ENDIF}
-{$IF Defined(LINK_PNG) or Defined(LINK_MNG) or Defined(LINK_JNG)}
+{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
   ImagingNetworkGraphics,
 {$IFEND}
   ImagingUtility;
@@ -359,9 +365,10 @@ resourcestring
   SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
   SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p';
   SBadFormatDisplay = 'Unsupported image format passed';
+  SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
   SImagingGraphicName = 'Imaging Graphic AllInOne';
 
-{ Registers types to VCL/CLX/LCL.}
+{ Registers types to VCL/LCL.}
 procedure RegisterTypes;
 var
   I: LongInt;
@@ -387,87 +394,85 @@ var
 begin
   for I := Imaging.GetFileFormatCount - 1 downto 0 do
     RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGraphic);{$ENDIF}
+  Classes.RegisterClass(TImagingGraphic);
 
-{$IFDEF LINK_TARGA}
+{$IFNDEF DONT_LINK_TARGA}
   RegisterFileFormat(TImagingTarga);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingTarga);{$ENDIF}
+  Classes.RegisterClass(TImagingTarga);
 {$ENDIF}
-{$IFDEF LINK_DDS}
+{$IFNDEF DONT_LINK_DDS}
   RegisterFileFormat(TImagingDDS);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingDDS);{$ENDIF}
+  Classes.RegisterClass(TImagingDDS);
 {$ENDIF}
-{$IFDEF LINK_JNG}
+{$IFNDEF DONT_LINK_JNG}
   RegisterFileFormat(TImagingJNG);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJNG);{$ENDIF}
+  Classes.RegisterClass(TImagingJNG);
 {$ENDIF}
-{$IFDEF LINK_MNG}
+{$IFNDEF DONT_LINK_MNG}
   RegisterFileFormat(TImagingMNG);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingMNG);{$ENDIF}
+  Classes.RegisterClass(TImagingMNG);
 {$ENDIF}
-{$IFDEF LINK_GIF}
+{$IFNDEF DONT_LINK_GIF}
   RegisterFileFormat(TImagingGIF);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGIF);{$ENDIF}
+  Classes.RegisterClass(TImagingGIF);
 {$ENDIF}
-{$IFDEF LINK_PNG}
+{$IFNDEF DONT_LINK_PNG}
   {$IFDEF COMPONENT_SET_LCL}
     // Unregister Lazarus´ default PNG loader which crashes on some PNG files
     TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
   {$ENDIF}
   RegisterFileFormat(TImagingPNG);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingPNG);{$ENDIF}
+  Classes.RegisterClass(TImagingPNG);
 {$ENDIF}
-{$IFDEF LINK_JPEG}
+{$IFNDEF DONT_LINK_JPEG}
   RegisterFileFormat(TImagingJpeg);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJpeg);{$ENDIF}
+  Classes.RegisterClass(TImagingJpeg);
 {$ENDIF}
-{$IFDEF LINK_BITMAP}
+{$IFNDEF DONT_LINK_BITMAP}
   RegisterFileFormat(TImagingBitmap);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingBitmap);{$ENDIF}
+  Classes.RegisterClass(TImagingBitmap);
 {$ENDIF}   
 end;
 
-{ Unregisters types from VCL/CLX/LCL.}
+{ Unregisters types from VCL/LCL.}
 procedure UnRegisterTypes;
 begin
-{$IFDEF LINK_BITMAP}
+{$IFNDEF DONT_LINK_BITMAP}
   TPicture.UnregisterGraphicClass(TImagingBitmap);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingBitmap);{$ENDIF}
+  Classes.UnRegisterClass(TImagingBitmap);
 {$ENDIF}
-{$IFDEF LINK_JPEG}
+{$IFNDEF DONT_LINK_JPEG}
   TPicture.UnregisterGraphicClass(TImagingJpeg);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingJpeg);{$ENDIF}
+  Classes.UnRegisterClass(TImagingJpeg);
 {$ENDIF}
-{$IFDEF LINK_PNG}
+{$IFNDEF DONT_LINK_PNG}
   TPicture.UnregisterGraphicClass(TImagingPNG);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingPNG);{$ENDIF}
+  Classes.UnRegisterClass(TImagingPNG);
 {$ENDIF}
-{$IFDEF LINK_GIF}
+{$IFNDEF DONT_LINK_GIF}
   TPicture.UnregisterGraphicClass(TImagingGIF);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGIF);{$ENDIF}
+  Classes.UnRegisterClass(TImagingGIF);
 {$ENDIF}
-{$IFDEF LINK_TARGA}
+{$IFNDEF DONT_LINK_TARGA}
   TPicture.UnregisterGraphicClass(TImagingTarga);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingTarga);{$ENDIF}
+  Classes.UnRegisterClass(TImagingTarga);
 {$ENDIF}
-{$IFDEF LINK_DDS}
+{$IFNDEF DONT_LINK_DDS}
   TPicture.UnregisterGraphicClass(TImagingDDS);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingDDS);{$ENDIF}
+  Classes.UnRegisterClass(TImagingDDS);
 {$ENDIF}
   TPicture.UnregisterGraphicClass(TImagingGraphic);
-  {$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGraphic);{$ENDIF}
+  Classes.UnRegisterClass(TImagingGraphic);
 end;
 
 function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
 begin
   case Format of
-{$IFNDEF COMPONENT_SET_LCL}
+{$IFDEF COMPONENT_SET_VCL}
     ifIndex8: Result := pf8bit;
-{$ENDIF}
-{$IF (not Defined(COMPONENT_SET_CLX)) and (not Defined(COMPONENT_SET_LCL))}
     ifR5G6B5: Result := pf16bit;
     ifR8G8B8: Result := pf24bit;
-{$IFEND}
+{$ENDIF}
     ifA8R8G8B8,
     ifX8R8G8B8: Result := pf32bit;
   else
@@ -479,11 +484,9 @@ function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
 begin
   case Format of
     pf8bit: Result := ifIndex8;
-{$IFNDEF COMPONENT_SET_CLX}
     pf15bit: Result := ifA1R5G5B5;
     pf16bit: Result := ifR5G6B5;
     pf24bit: Result := ifR8G8B8;
-{$ENDIF}
     pf32bit: Result := ifA8R8G8B8;
   else
     Result := ifUnknown;
@@ -499,9 +502,6 @@ var
 {$IFDEF COMPONENT_SET_VCL}
   LogPalette: TMaxLogPalette;
 {$ENDIF}
-{$IFDEF COMPONENT_SET_CLX}
-  ColorTable: PPalette32;
-{$ENDIF}
 {$IFDEF COMPONENT_SET_LCL}
   RawImage: TRawImage;
   ImgHandle, ImgMaskHandle: HBitmap;
@@ -517,19 +517,16 @@ begin
     if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
       Imaging.ConvertImage(WorkData, ifA8R8G8B8)
     else
-{$IFNDEF COMPONENT_SET_LCL}
+{$IFDEF COMPONENT_SET_VCL}
       if Info.IsIndexed or Info.HasGrayChannel then
         Imaging.ConvertImage(WorkData, ifIndex8)
-      else
+      else if Info.UsePixelFormat then
-{$ENDIF}
-{$IF (not Defined(COMPONENT_SET_CLX)) and (not Defined(COMPONENT_SET_LCL))}
-        if Info.UsePixelFormat then
         Imaging.ConvertImage(WorkData, ifR5G6B5)
       else
         Imaging.ConvertImage(WorkData, ifR8G8B8);
 {$ELSE}
         Imaging.ConvertImage(WorkData, ifA8R8G8B8);
-{$IFEND}
+{$ENDIF}
 
     PF := DataFormatToPixelFormat(WorkData.Format);
     GetImageFormatInfo(WorkData.Format, Info);
@@ -565,27 +562,13 @@ begin
   // Copy scanlines
   for I := 0 to WorkData.Height - 1 do
     Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
-{$ENDIF}
-{$IFDEF COMPONENT_SET_CLX}
-  Bitmap.Width := WorkData.Width;
-  Bitmap.Height := WorkData.Height;
-  Bitmap.PixelFormat := PF;
 
-  if (PF = pf8bit) and (WorkData.Palette <> nil) then
+  // Delphi 2009 and newer support alpha transparency fro TBitmap
-  begin
+{$IF Defined(DELPHI) and (CompilerVersion >= 20.0)}
-    // Copy palette
+  if Bitmap.PixelFormat = pf32bit then
-    ColorTable := Bitmap.ColorTable;
+    Bitmap.AlphaFormat := afDefined;
-    for I := 0 to Info.PaletteEntries - 1 do
+{$IFEND}
-    with ColorTable[I] do
+
-    begin
-      R := WorkData.Palette[I].R;
-      G := WorkData.Palette[I].G;
-      B := WorkData.Palette[I].B;
-    end;
-  end;
-  // Copy scanlines
-  for I := 0 to WorkData.Height - 1 do
-    Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
 {$ENDIF}
 {$IFDEF COMPONENT_SET_LCL}
   // Create 32bit raw image from image data
@@ -594,9 +577,9 @@ begin
   begin
     Width := WorkData.Width;
     Height := WorkData.Height;
-    BitsPerPixel := Info.BytesPerPixel * 8;
+    BitsPerPixel := 32;
     Format := ricfRGBA;
-    LineEnd := rileByteBoundary;
+    LineEnd := rileDWordBoundary;
     BitOrder := riboBitsInOrder;
     ByteOrder := riboLSBFirst;
     LineOrder := riloTopToBottom;
@@ -608,14 +591,13 @@ begin
     RedShift := 16;
     GreenShift := 8;
     BlueShift := 0;
-    Depth := 24;
+    Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon)
   end;
   RawImage.Data := WorkData.Bits;
   RawImage.DataSize := WorkData.Size;
 
   // Create bitmap from raw image
-  { If you get complitation error here upgrade to Lazarus 0.9.24+ }
+  if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then
-  if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle, False) then
   begin
     Bitmap.Handle := ImgHandle;
     Bitmap.MaskHandle := ImgMaskHandle;
@@ -634,9 +616,6 @@ var
   Colors: Word;
   LogPalette: TMaxLogPalette;
 {$ENDIF}
-{$IFDEF COMPONENT_SET_CLX}
-  ColorTable: PPalette32;
-{$ENDIF}
 {$IFDEF COMPONENT_SET_LCL}
   RawImage: TRawImage;
   LineLazBytes: LongInt;
@@ -650,7 +629,6 @@ begin
   // trough RawImage api and cannot be changed to mirror some Imaging format
   // (so formats with no coresponding Imaging format cannot be saved now).
 
-  { If you get complitation error here upgrade to Lazarus 0.9.24+ }
   if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
     case RawImage.Description.BitsPerPixel of
       8: Format := ifIndex8;
@@ -707,28 +685,9 @@ begin
   for I := 0 to Data.Height - 1 do
     Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
 {$ENDIF}
-{$IFDEF COMPONENT_SET_CLX}
-  if Format = ifIndex8 then
-  begin
-    // Copy palette
-    ColorTable := Bitmap.ColorTable;
-    for I := 0 to Info.PaletteEntries - 1 do
-    with ColorTable[I] do
-    begin
-      Data.Palette[I].A := $FF;
-      Data.Palette[I].R := R;
-      Data.Palette[I].G := G;
-      Data.Palette[I].B := B;
-    end;
-  end;
-  // Copy scanlines
-  for I := 0 to Data.Height - 1 do
-    Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
-{$ENDIF}
 {$IFDEF COMPONENT_SET_LCL}
   // Get raw image from bitmap (mask handle must be 0 or expect violations)
-  if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then // uncommnet for Laz 0.9.25 if you get error here
+  if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then
-  //if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, Classes.Rect(0, 0, Data.Width, Data.Height)) then
   begin
     LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
       RawImage.Description.LineEnd);
@@ -757,6 +716,7 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T
 var
   OldMode: Integer;
   BitmapInfo: Windows.TBitmapInfo;
+  Bmp: TBitmap;
 begin
   if TestImage(ImageData) then
   begin
@@ -781,9 +741,21 @@ begin
 
     try
        with SrcRect, ImageData do
-        Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
+        if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
           DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left,
-          Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY);
+          Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then
+        begin
+          // StretchDIBits may fail on some ocassions (error 487, http://support.microsoft.com/kb/269585).
+          // This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix.
+          Bmp := TBitmap.Create;
+          try
+            ConvertDataToBitmap(ImageData, Bmp);
+            StretchBlt(DC, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
+              Bmp.Canvas.Handle, 0, 0, Width, Height, SRCCOPY);
+          finally
+            Bmp.Free;
+          end;
+        end;
     finally
       Windows.SetStretchBltMode(DC, OldMode);
     end;
@@ -792,50 +764,21 @@ end;
 {$ENDIF}
 
 procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
-{$IF Defined(MSWINDOWS) and not Defined(COMPONENT_SET_CLX)}
+{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32
 begin
   DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
 end;
-{$ELSEIF Defined(COMPONENT_SET_CLX)}
+{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)}
-var
-  Bitmap: TBitmap;
-  //Handle: LongWord;
-begin
-  (*
-  // It would be nice if this worked:
-  DstCanvas.Start;
-  Handle := QPainter_handle(DstCanvas.Handle);
-  {$IFDEF MSWINDOWS}
-  DisplayImageDataOnDC(Handle, DstRect, ImageData, SrcRect);
-  {$ELSE}
-  DisplayImageDataOnX(Handle, DstRect, ImageData, SrcRect);
-  {$ENDIF}
-  DstCanvas.Stop;
-  *)
-  Bitmap := TBitmap.Create;
-  try
-    ConvertDataToBitmap(ImageData, Bitmap);
-    DstCanvas.CopyRect(DstRect, Bitmap.Canvas, SrcRect);
-  finally
-    Bitmap.Free;
-  end;  
-end;
-{$ELSEIF Defined(UNIX) and Defined(COMPONENT_SET_LCL)}
 
   procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
     SrcWidth, SrcHeight: Integer; ImageData: TImageData);
   var
     P: TPoint;
   begin
-    // If you get compilation errors here with new Lazarus (rev 14368+)
-    // uncomment commented code and comment the active code below:
-
     P := TGtkDeviceContext(Dest).Offset;
-    //P := GetDCOffset(TDeviceContext(Dest));
     Inc(DstX, P.X);
     Inc(DstY, P.Y);
     gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
-    //gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
       DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
       @PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
   end;
@@ -890,6 +833,10 @@ begin
     end;
   end;
 end;
+{$ELSE}
+begin
+  raise Exception.Create(SUnsupportedLCLWidgetSet);
+end;
 {$IFEND}
 
 procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage);
@@ -911,6 +858,12 @@ end;
 
 { TImagingGraphic class implementation }
 
+constructor TImagingGraphic.Create;
+begin
+  inherited Create;
+  PixelFormat := pf24Bit;
+end;
+
 procedure TImagingGraphic.LoadFromStream(Stream: TStream);
 begin
   ReadDataFromStream(Stream);
@@ -1020,14 +973,13 @@ begin
   Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
 end;
 
-function TImagingGraphicForSave.GetMimeType: string;  // uncomment for Laz 0.9.25 if you get error here
+function TImagingGraphicForSave.GetMimeType: string;
-//function TImagingGraphicForSave.GetDefaultMimeType: string;
 begin
   Result := 'image/' + FDefaultFileExt;
 end;
 {$ENDIF}
 
-{$IFDEF LINK_BITMAP}
+{$IFNDEF DONT_LINK_BITMAP}
 
 { TImagingBitmap class implementation }
 
@@ -1051,7 +1003,7 @@ begin
 end;
 {$ENDIF}
 
-{$IFDEF LINK_JPEG}
+{$IFNDEF DONT_LINK_JPEG}
 
 { TImagingJpeg class implementation }
 
@@ -1068,8 +1020,7 @@ begin
 end;
 
 {$IFDEF COMPONENT_SET_LCL}
-//function TImagingJpeg.GetMimeType: string;  // uncomment for Laz 0.9.25 if you get error here
+function TImagingJpeg.GetMimeType: string;
-function TImagingJpeg.GetDefaultMimeType: string;
 begin
   Result := 'image/jpeg';
 end;
@@ -1086,7 +1037,7 @@ end;
 
 {$ENDIF}
 
-{$IFDEF LINK_PNG}
+{$IFNDEF DONT_LINK_PNG}
 
 { TImagingPNG class implementation }
 
@@ -1112,7 +1063,7 @@ begin
 end;
 {$ENDIF}
 
-{$IFDEF LINK_GIF}
+{$IFNDEF DONT_LINK_GIF}
 
 { TImagingGIF class implementation}
 
@@ -1123,7 +1074,7 @@ end;
 
 {$ENDIF}
 
-{$IFDEF LINK_TARGA}
+{$IFNDEF DONT_LINK_TARGA}
 
 { TImagingTarga class implementation }
 
@@ -1147,7 +1098,7 @@ begin
 end;
 {$ENDIF}
 
-{$IFDEF LINK_DDS}
+{$IFNDEF DONT_LINK_DDS}
 
 { TImagingDDS class implementation }
 
@@ -1180,7 +1131,7 @@ begin
 end;
 {$ENDIF}
 
-{$IFDEF LINK_MNG}
+{$IFNDEF DONT_LINK_MNG}
 
 { TImagingMNG class implementation }
 
@@ -1201,8 +1152,7 @@ begin
 end;
 
 {$IFDEF COMPONENT_SET_LCL}
-//function TImagingMNG.GetMimeType: string;  // uncomment for Laz 0.9.25 if you get error here
+function TImagingMNG.GetMimeType: string;
-function TImagingMNG.GetDefaultMimeType: string;
 begin
   Result := 'video/mng';
 end;
@@ -1222,7 +1172,7 @@ begin
 end;
 {$ENDIF}
 
-{$IFDEF LINK_JNG}
+{$IFNDEF DONT_LINK_JNG}
 
 { TImagingJNG class implementation }
 
@@ -1259,12 +1209,30 @@ initialization
 finalization
   UnRegisterTypes;
 
+{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
+
 {
   File Notes:
 
   -- TODOS ----------------------------------------------------
     - nothing now
 
+  -- 0.26.3 Changes/Bug Fixes ---------------------------------
+    - Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
+      when using Delphi 2009+.
+    - Fixed garbled LCL TBitmaps created by ConvertDataToBitmap
+      in Mac OS X (Carbon).
+
+  -- 0.26.1 Changes/Bug Fixes ---------------------------------
+    - Added some more IFDEFs for Lazarus widget sets.
+    - Removed CLX code.
+    - GTK version of Unix DisplayImageData only used with LCL GTK so the
+      the rest of the unit can be used with Qt or other LCL interfaces. 
+    - Fallback mechanism for DisplayImageDataOnDC, it may fail on occasions.
+    - Changed file format conditional compilation to reflect changes
+      in LINK symbols.
+    - Lazarus 0.9.26 compatibility changes.
+
   -- 0.24.1 Changes/Bug Fixes ---------------------------------
     - Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
       with GTK2 target.

Imaging/ImagingExport.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingExport.pas 71 2007-03-08 00:10:10Z galfar $
+  $Id: ImagingExport.pas 173 2009-09-04 17:05:52Z galfar $
   Vampyre Imaging Library
   by Marek Mauder
   http://imaginglib.sourceforge.net
@@ -52,14 +52,14 @@ function ImTestImage(var Image: TImageData): Boolean; cdecl;
 function ImFreeImage(var Image: TImageData): Boolean; cdecl;
 { Look at DetermineFileFormat for details. Ext should have enough space for
   result file extension.}
-function ImDetermineFileFormat(FileName, Ext: PChar): Boolean; cdecl;
+function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; cdecl;
 { Look at DetermineMemoryFormat for details. Ext should have enough space for
   result file extension.}
-function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean; cdecl;
+function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl;
 { Look at IsFileFormatSupported for details.}
-function ImIsFileFormatSupported(FileName: PChar): Boolean; cdecl;
+function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
 { Look at EnumFileFormats for details.}
-function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar;
+function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
   var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
 
 { Inits image list.}
@@ -82,24 +82,24 @@ function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
 function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
 
 { Look at LoadImageFromFile for details.}
-function ImLoadImageFromFile(FileName: PChar; var Image: TImageData): Boolean; cdecl;
+function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; cdecl;
 { Look at LoadImageFromMemory for details.}
 function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
 { Look at LoadMultiImageFromFile for details.}
-function ImLoadMultiImageFromFile(FileName: PChar; var ImageList: TImageDataList): Boolean; cdecl;
+function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): Boolean; cdecl;
 { Look at LoadMultiImageFromMemory for details.}
 function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
   var ImageList: TImageDataList): Boolean; cdecl;
 
 { Look at SaveImageToFile for details.}
-function ImSaveImageToFile(FileName: PChar; const Image: TImageData): Boolean; cdecl;
+function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; cdecl;
 { Look at SaveImageToMemory for details.}
-function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt;
+function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
   const Image: TImageData): Boolean; cdecl;
 { Look at SaveMultiImageToFile for details.}
-function ImSaveMultiImageToFile(FileName: PChar; ImageList: TImageDataList): Boolean; cdecl;
+function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl;
 { Look at SaveMultiImageToMemory for details.}
-function ImSaveMultiImageToMemory(Ext: PChar; Data: Pointer; Size: PLongInt;
+function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
   ImageList: TImageDataList): Boolean; cdecl;
 
 { Look at CloneImage for details.}
@@ -131,7 +131,7 @@ function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
 function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
   MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
 { Look at RotateImage for details.}
-function ImRotateImage(var Image: TImageData; Angle: LongInt): Boolean; cdecl;
+function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; cdecl;
 
 { Look at CopyRect for details.}
 function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
@@ -262,33 +262,33 @@ begin
   end;
 end;
 
-function ImDetermineFileFormat(FileName, Ext: PChar): Boolean;
+function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean;
 var
   S: string;
 begin
   try
     S := Imaging.DetermineFileFormat(FileName);
     Result := S <> '';
-    StrCopy(Ext, PChar(S));
+    StrCopy(Ext, PAnsiChar(AnsiString(S)));
   except
     Result := False;
   end;
 end;
 
-function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean;
+function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
 var
   S: string;
 begin
   try
     S := Imaging.DetermineMemoryFormat(Data, Size);
     Result := S <> '';
-    StrCopy(Ext, PChar(S));
+    StrCopy(Ext, PAnsiChar(AnsiString(S)));
   except
     Result := False;
   end;
 end;
 
-function ImIsFileFormatSupported(FileName: PChar): Boolean;
+function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
 begin
   try
     Result := Imaging.IsFileFormatSupported(FileName);
@@ -297,7 +297,7 @@ begin
   end;
 end;
 
-function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar;
+function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
   var CanSave, IsMultiImageFormat: Boolean): Boolean;
 var
   StrName, StrDefaultExt, StrMasks: string;
@@ -305,9 +305,9 @@ begin
   try
     Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
       IsMultiImageFormat);
-    StrCopy(Name, PChar(StrName));
+    StrCopy(Name, PAnsiChar(AnsiString(StrName)));
-    StrCopy(DefaultExt, PChar(StrDefaultExt));
+    StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
-    StrCopy(Masks, PChar(StrMasks));
+    StrCopy(Masks, PAnsiChar(AnsiString(StrMasks)));
   except
     Result := False;
   end;
@@ -419,7 +419,7 @@ begin
   end;
 end;
 
-function ImLoadImageFromFile(FileName: PChar; var Image: TImageData): Boolean;
+function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean;
 begin
   try
     Result := Imaging.LoadImageFromFile(FileName, Image);
@@ -437,7 +437,7 @@ begin
   end;
 end;
 
-function ImLoadMultiImageFromFile(FileName: PChar; var ImageList: TImageDataList):
+function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList):
   Boolean;
 begin
   try
@@ -460,7 +460,7 @@ begin
   end;
 end;
 
-function ImSaveImageToFile(FileName: PChar; const Image: TImageData): Boolean;
+function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean;
 begin
   try
     Result := Imaging.SaveImageToFile(FileName, Image);
@@ -469,7 +469,7 @@ begin
   end;
 end;
 
-function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt;
+function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
   const Image: TImageData): Boolean;
 begin
   try
@@ -479,7 +479,7 @@ begin
   end;
 end;
 
-function ImSaveMultiImageToFile(FileName: PChar;
+function ImSaveMultiImageToFile(FileName: PAnsiChar;
   ImageList: TImageDataList): Boolean;
 begin
   try
@@ -490,7 +490,7 @@ begin
   end;
 end;
 
-function ImSaveMultiImageToMemory(Ext: PChar; Data: Pointer; Size: PLongInt;
+function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
   ImageList: TImageDataList): Boolean;
 begin
   try
@@ -612,7 +612,7 @@ begin
   end;
 end;
 
-function ImRotateImage(var Image: TImageData; Angle: LongInt): Boolean;
+function ImRotateImage(var Image: TImageData; Angle: Single): Boolean;
 begin
   try
     Result := Imaging.RotateImage(Image, Angle);
@@ -864,6 +864,10 @@ end;
   -- TODOS ----------------------------------------------------
     - nothing now 
 
+  -- 0.26.3 ---------------------------------------------------
+    - changed PChars to PAnsiChars and some more D2009 friendly
+      casts.
+
   -- 0.19 -----------------------------------------------------
     - updated to reflect changes in low level interface (added pixel set/get, ...)
     - changed ImInitImage to procedure to reflect change in Imaging.pas

Imaging/ImagingFormats.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingFormats.pas 129 2008-08-06 20:01:30Z galfar $
+  $Id: ImagingFormats.pas 176 2009-10-12 10:53:17Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -388,6 +388,7 @@ var
     BytesPerPixel: 1;
     ChannelCount: 1;
     PaletteEntries: 256;
+    HasAlphaChannel: True;
     IsIndexed: True;
     GetPixelsSize: GetStdPixelsSize;
     CheckDimensions: CheckStdDimensions;
@@ -1617,8 +1618,7 @@ begin
     Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
     Result[0][0].Weight := 1.0;
   end
-  else
+  else if Scale < 1.0 then
-  if Scale < 1.0 then
   begin
     // Sub-sampling - scales from bigger to smaller 
     Radius := Radius / Scale;
@@ -1649,8 +1649,7 @@ begin
         Result[I][0].Pos := Floor(Center);
         Result[I][0].Weight := 1.0;
       end
-      else
+      else if Count <> 0.0 then
-      if Count <> 0.0 then
         Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
     end;
   end
@@ -1680,8 +1679,7 @@ begin
           begin
             if J < 0 then
               N := SrcImageWidth + J
-            else
+            else if J >= SrcImageWidth then
-            if J >= SrcImageWidth then
               N := J - SrcImageWidth
             else
               N := ClampInt(J, SrcLow, SrcHigh - 1);
@@ -1723,13 +1721,19 @@ procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
   DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
 const
   Channel8BitMax: Single = 255.0;
+type
+  TBufferItem = record
+    A, R, G, B: Integer;
+  end;
 var
   MapX, MapY: TMappingTable;
   I, J, X, Y: LongInt;
   XMinimum, XMaximum: LongInt;
-  LineBuffer: array of TColorFPRec;
+  LineBufferFP: array of TColorFPRec;
+  LineBufferInt: array of TBufferItem;
   ClusterX, ClusterY: TCluster;
   Weight, AccumA, AccumR, AccumG, AccumB: Single;
+  IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer;
   DstLine: PByte;
   SrcColor: TColor32Rec;
   SrcFloat: TColorFPRec;
@@ -1759,10 +1763,10 @@ begin
   try
     // Find min and max X coords of pixels that will contribute to target image
     FindExtremes(MapX, XMinimum, XMaximum);
-    SetLength(LineBuffer, XMaximum - XMinimum + 1);
 
     if not UseOptimizedVersion then
     begin
+      SetLength(LineBufferFP, XMaximum - XMinimum + 1);
       // Following code works for the rest of data formats
       for J := 0 to DstHeight - 1 do
       begin
@@ -1773,10 +1777,10 @@ begin
         for X := XMinimum to XMaximum do
         begin
           // Clear accumulators
-          AccumA := 0.0;
+          AccumA := 0;
-          AccumR := 0.0;
+          AccumR := 0;
-          AccumG := 0.0;
+          AccumG := 0;
-          AccumB := 0.0;
+          AccumB := 0;
           // For each pixel in line compute weighted sum of pixels
           // in source column that will contribute to this pixel
           for Y := 0 to Length(ClusterY) - 1 do
@@ -1790,7 +1794,7 @@ begin
             AccumA := AccumA + SrcFloat.A * Weight;
           end;
           // Store accumulated value for this pixel in buffer
-          with LineBuffer[X - XMinimum] do
+          with LineBufferFP[X - XMinimum] do
           begin
             A := AccumA;
             R := AccumR;
@@ -1806,17 +1810,17 @@ begin
         begin
           ClusterX := MapX[I];
           // Clear accumulator
-          AccumA := 0.0;
+          AccumA := 0;
-          AccumR := 0.0;
+          AccumR := 0;
-          AccumG := 0.0;
+          AccumG := 0;
-          AccumB := 0.0;
+          AccumB := 0;
           // Compute weighted sum of values (which are already
           // computed weighted sums of pixels in source columns stored in LineBuffer)
           // that will contribute to the current target pixel
           for X := 0 to Length(ClusterX) - 1 do
           begin
             Weight := ClusterX[X].Weight;
-            with LineBuffer[ClusterX[X].Pos - XMinimum] do
+            with LineBufferFP[ClusterX[X].Pos - XMinimum] do
             begin
               AccumB := AccumB + B * Weight;
               AccumG := AccumG + G * Weight;
@@ -1838,37 +1842,35 @@ begin
     end
     else
     begin
+      SetLength(LineBufferInt, XMaximum - XMinimum + 1);
       // Following code is optimized for images with 8 bit channels
       for J := 0 to DstHeight - 1 do
       begin
         ClusterY := MapY[J];
         for X := XMinimum to XMaximum do
         begin
-          AccumA := 0.0;
+          IAccumA := 0;
-          AccumR := 0.0;
+          IAccumR := 0;
-          AccumG := 0.0;
+          IAccumG := 0;
-          AccumB := 0.0;
+          IAccumB := 0;
           for Y := 0 to Length(ClusterY) - 1 do
           begin
-            Weight := ClusterY[Y].Weight;
+            IWeight := Round(256 * ClusterY[Y].Weight);
             CopyPixel(
               @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
               @SrcColor, Info.BytesPerPixel);
 
-            AccumB := AccumB + SrcColor.B * Weight;
+            IAccumB := IAccumB + SrcColor.B * IWeight;
-            if Info.ChannelCount > 1 then
+            IAccumG := IAccumG + SrcColor.G * IWeight;
-              AccumG := AccumG + SrcColor.G * Weight;
+            IAccumR := IAccumR + SrcColor.R * IWeight;
-            if Info.ChannelCount > 2 then
+            IAccumA := IAccumA + SrcColor.A * IWeight;
-              AccumR := AccumR + SrcColor.R * Weight;
-            if Info.ChannelCount > 3 then
-              AccumA := AccumA + SrcColor.A * Weight;
           end;
-          with LineBuffer[X - XMinimum] do
+          with LineBufferInt[X - XMinimum] do
           begin
-            A := AccumA;
+            A := IAccumA;
-            R := AccumR;
+            R := IAccumR;
-            G := AccumG;
+            G := IAccumG;
-            B := AccumB;
+            B := IAccumB;
           end;
         end;
 
@@ -1877,31 +1879,26 @@ begin
         for I := 0 to DstWidth - 1 do
         begin
           ClusterX := MapX[I];
-          AccumA := 0.0;
+          IAccumA := 0;
-          AccumR := 0.0;
+          IAccumR := 0;
-          AccumG := 0.0;
+          IAccumG := 0;
-          AccumB := 0.0;
+          IAccumB := 0;
           for X := 0 to Length(ClusterX) - 1 do
           begin
-            Weight := ClusterX[X].Weight;
+            IWeight := Round(256 * ClusterX[X].Weight);
-            with LineBuffer[ClusterX[X].Pos - XMinimum] do
+            with LineBufferInt[ClusterX[X].Pos - XMinimum] do
             begin
-              AccumB := AccumB + B * Weight;
+              IAccumB := IAccumB + B * IWeight;
-              if Info.ChannelCount > 1 then
+              IAccumG := IAccumG + G * IWeight;
-                AccumG := AccumG + G * Weight;
+              IAccumR := IAccumR + R * IWeight;
-              if Info.ChannelCount > 2 then
+              IAccumA := IAccumA + A * IWeight;
-                AccumR := AccumR + R * Weight;
-              if Info.ChannelCount > 3 then
-                AccumA := AccumA + A * Weight;
             end;
           end;
-          SrcColor.B := ClampToByte(Round(AccumB));
+
-          if Info.ChannelCount > 1 then
+          SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16;
-            SrcColor.G := ClampToByte(Round(AccumG));
+          SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16;
-          if Info.ChannelCount > 2 then
+          SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16;
-            SrcColor.R := ClampToByte(Round(AccumR));
+          SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16;
-          if Info.ChannelCount > 3 then
-            SrcColor.A := ClampToByte(Round(AccumA));
 
           CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
           Inc(DstLine, Info.BytesPerPixel);
@@ -3234,11 +3231,11 @@ type
 
   TPixelBlock = array[0..15] of TPixelInfo;
 
-function DecodeCol(Color : Word): TColor32Rec;
+function DecodeCol(Color: Word): TColor32Rec;
 {$IFDEF USE_INLINE} inline; {$ENDIF}
 begin
   Result.A := $FF;
-  {Result.R := ((Color and $F800) shr 11) shl 3;
+{  Result.R := ((Color and $F800) shr 11) shl 3;
   Result.G := ((Color and $07E0) shr 5) shl 2;
   Result.B := (Color and $001F) shl 3;}
   // this color expansion is slower but gives better results
@@ -3663,7 +3660,7 @@ begin
       GetBlock(Pixels, SrcBits, X, Y, Width, Height);
       for I := 0 to 7 do
         PByteArray(@AlphaBlock.Alphas)[I] :=
-          ((Pixels[I shl 1].Alpha shr 4) shl 4) or (Pixels[I shl 1 + 1].Alpha shr 4);
+          (Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4);
       GetEndpoints(Pixels, Block.Color0, Block.Color1);
       FixEndpoints(Block.Color0, Block.Color1, False);
       Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
@@ -4222,7 +4219,11 @@ initialization
 
   -- TODOS ----------------------------------------------------
     - nothing now
-    - rewrite StretchRect for 8bit channels to use integer math?
+
+  -- 0.26.3 Changes/Bug Fixes -----------------------------------
+    - Filtered resampling ~10% faster now.
+    - Fixed DXT3 alpha encoding.
+    - ifIndex8 format now has HasAlphaChannel=True.
 
   -- 0.25.0 Changes/Bug Fixes -----------------------------------
     - Made some resampling stuff public so that it can be used in canvas class.

Imaging/ImagingGif.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingGif.pas 132 2008-08-27 20:37:38Z galfar $
+  $Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -44,9 +44,11 @@ type
     its own color palette. GIF uses lossless LZW compression
     (patent expired few years ago).
     Imaging can load and save all GIFs with all frames and supports
-    transparency.}
+    transparency. Imaging can load just raw ifIndex8 frames or
+    also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
   TGIFFileFormat = class(TImageFileFormat)
   private
+    FLoadAnimated: LongBool;
     function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
     procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
       Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
@@ -62,6 +64,8 @@ type
   public
     constructor Create; override;
     function TestFormat(Handle: TImagingHandle): Boolean; override;
+  published
+    property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
   end;
 
 implementation
@@ -70,10 +74,11 @@ const
   SGIFFormatName = 'Graphics Interchange Format';
   SGIFMasks      = '*.gif';
   GIFSupportedFormats: TImageFormats = [ifIndex8];
+  GIFDefaultLoadAnimated = True;
 
 type
   TGIFVersion = (gv87, gv89);
-  TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground,
+  TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
     dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
 
 const
@@ -144,6 +149,19 @@ type
     Terminator: Byte;
   end;
 
+const
+  // Netscape sub block types
+  GIFAppLoopExtension = 1;
+  GIFAppBufferExtension = 2;
+
+type
+  TGIFIdentifierCode = array[0..7] of AnsiChar;
+  TGIFAuthenticationCode = array[0..2] of AnsiChar;
+  TGIFApplicationRec = packed record
+    Identifier: TGIFIdentifierCode;
+    Authentication: TGIFAuthenticationCode;
+  end;
+
 const
   CodeTableSize = 4096;
   HashTableSize = 17777;
@@ -206,8 +224,10 @@ begin
   FCanSave := True;
   FIsMultiImageFormat := True;
   FSupportedFormats := GIFSupportedFormats;
+  FLoadAnimated := GIFDefaultLoadAnimated;
 
   AddMasks(SGIFMasks);
+  RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
 end;
 
 function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
@@ -644,28 +664,56 @@ end;
 
 function TGIFFileFormat.LoadData(Handle: TImagingHandle;
   var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+type
+  TFrameInfo = record
+    Left, Top: Integer;
+    Width, Height: Integer;
+    Disposal: TDisposalMethod;
+    HasTransparency: Boolean;
+    HasLocalPal: Boolean;
+    TransIndex: Integer;
+    BackIndex: Integer;
+  end;
 var
   Header: TGIFHeader;
   HasGlobalPal: Boolean;
   GlobalPalLength: Integer;
   GlobalPal: TPalette32Size256;
-  I: Integer;
+  ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
   BlockID: Byte;
   HasGraphicExt: Boolean;
   GraphicExt: TGraphicControlExtension;
-  Disposals: array of TDisposalMethod;
+  FrameInfos: array of TFrameInfo;
+  AppRead: Boolean;
+  CachedFrame: TImageData;
+  AnimFrames: TDynImageDataArray;
 
   function ReadBlockID: Byte;
   begin
     Result := GIFTrailer;
-    GetIO.Read(Handle, @Result, SizeOf(Result));
+    if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
+      Result := GIFTrailer;
   end;
 
   procedure ReadExtensions;
   var
-    BlockSize, ExtType: Byte;
+    BlockSize, BlockType, ExtType: Byte;
+    AppRec: TGIFApplicationRec;
+    LoopCount: SmallInt;
+
+    procedure SkipBytes;
+    begin
+      with GetIO do
+      repeat
+        // Read block sizes and skip them
+        Read(Handle, @BlockSize, SizeOf(BlockSize));
+        Seek(Handle, BlockSize, smFromCurrent);
+      until BlockSize = 0;
+    end;
+
   begin
     HasGraphicExt := False;
+    AppRead := False;
 
     // Read extensions until image descriptor is found. Only graphic extension
     // is stored now (for transparency), others are skipped.
@@ -674,11 +722,58 @@ var
     begin
       Read(Handle, @ExtType, SizeOf(ExtType));
 
+      while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
+      begin
         if ExtType = GIFGraphicControlExtension then
         begin
           HasGraphicExt := True;
           Read(Handle, @GraphicExt, SizeOf(GraphicExt));
         end
+        else if (ExtType = GIFApplicationExtension) and not AppRead then
+        begin
+          Read(Handle, @BlockSize, SizeOf(BlockSize));
+          if BlockSize >= SizeOf(AppRec) then
+          begin
+            Read(Handle, @AppRec, SizeOf(AppRec));
+            if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then
+            begin
+              Read(Handle, @BlockSize, SizeOf(BlockSize));
+              while BlockSize <> 0 do
+              begin
+                BlockType := ReadBlockID;
+                Dec(BlockSize);
+
+                case BlockType of
+                  GIFAppLoopExtension:
+                    if (BlockSize >= SizeOf(LoopCount)) then
+                    begin
+                      // Read loop count
+                      Read(Handle, @LoopCount, SizeOf(LoopCount));
+                      Dec(BlockSize, SizeOf(LoopCount));
+                    end;
+                  GIFAppBufferExtension:
+                    begin
+                      Dec(BlockSize, SizeOf(Word));
+                      Seek(Handle, SizeOf(Word), smFromCurrent);
+                    end;
+                end;
+              end;
+              SkipBytes;
+              AppRead := True;
+            end
+            else
+              begin
+                // Revert all bytes reading
+                Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
+                SkipBytes;
+              end;
+          end
+          else
+            begin
+              Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
+              SkipBytes;
+            end;
+        end
         else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
         repeat
           // Read block sizes and skip them
@@ -688,33 +783,8 @@ var
 
         // Read ID of following block
         BlockID := ReadBlockID;
-    end;
+        ExtType := BlockID;
-  end;
+      end
-
-  procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top,
-    TransIndex: Integer; Disposal: TDisposalMethod);
-  var
-    X, Y: Integer;
-    Src, Dst: PByte;
-  begin
-    Src := Frame.Bits;
-
-    // Copy all pixels from frame to log screen but ignore the transparent ones
-    for Y := 0 to Frame.Height - 1 do
-    begin
-      Dst := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left];
-      for X := 0 to Frame.Width - 1 do
-      begin
-        // If disposal methos is undefined copy all pixels regardless of
-        // transparency (transparency of whole image will be determined by TranspIndex
-        // in image palette) - same effect as filling the image with trasp color
-        // instead of backround color beforehand.
-        // For other methods don't copy transparent pixels from frame to image.
-        if (Src^ <> TransIndex) or (Disposal = dmUndefined) then
-          Dst^ := Src^;
-        Inc(Src);
-        Inc(Dst);
-      end;
     end;
   end;
 
@@ -743,33 +813,49 @@ var
   procedure ReadFrame;
   var
     ImageDesc: TImageDescriptor;
-    HasLocalPal, Interlaced, HasTransparency: Boolean;
+    Interlaced: Boolean;
-    I, Idx, LocalPalLength, TransIndex: Integer;
+    I, Idx, LocalPalLength: Integer;
     LocalPal: TPalette32Size256;
-    BlockTerm: Byte;
-    Frame: TImageData;
     LZWStream: TMemoryStream;
+
+    procedure RemoveBadFrame;
+    begin
+      FreeImage(Images[Idx]);
+      SetLength(Images, Length(Images) - 1);
+    end;
+
   begin
     Idx := Length(Images);
     SetLength(Images, Idx + 1);
+    SetLength(FrameInfos, Idx + 1);
     FillChar(LocalPal, SizeOf(LocalPal), 0);
+
     with GetIO do
     begin
       // Read and parse image descriptor
       Read(Handle, @ImageDesc, SizeOf(ImageDesc));
-      HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
+      FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
       Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
       LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
       LocalPalLength := 1 shl (LocalPalLength + 1);   // Total pal length is 2^(n+1)
 
-      // Create new logical screen
+      // From Mozilla source
-      NewImage(Header.ScreenWidth, Header.ScreenHeight, ifIndex8, Images[Idx]);
+      if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
+        ImageDesc.Width := Header.ScreenWidth;
+      if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight)  then
+        ImageDesc.Height := Header.ScreenHeight;
+
+      FrameInfos[Idx].Left := ImageDesc.Left;
+      FrameInfos[Idx].Top := ImageDesc.Top;
+      FrameInfos[Idx].Width := ImageDesc.Width;
+      FrameInfos[Idx].Height := ImageDesc.Height;
+      FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;
+
       // Create new image for this frame which would be later pasted onto logical screen
-      InitImage(Frame);
+      NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
-      NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Frame);
 
       // Load local palette if there is any
-      if HasLocalPal then
+      if FrameInfos[Idx].HasLocalPal then
         for I := 0 to LocalPalLength - 1 do
         begin
           LocalPal[I].A := 255;
@@ -780,87 +866,174 @@ var
 
       // Use local pal if present or global pal if present or create
       // default pal if neither of them is present
-      if HasLocalPal then
+      if FrameInfos[Idx].HasLocalPal then
         Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
       else if HasGlobalPal then
         Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
       else
         FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
 
-      // Add default disposal method for this frame
+      if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
-      SetLength(Disposals, Length(Disposals) + 1);
+      begin
-      Disposals[High(Disposals)] := dmUndefined;
+        // Resize the screen if needed to fit the frame
+        ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
+        ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
+      end
+      else
+      begin
+        // Remove frame outside logical screen
+        RemoveBadFrame;
+        Exit;
+      end;
 
       // If Grahic Control Extension is present make use of it
       if HasGraphicExt then
       begin
-        HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
+        FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
-        Disposals[High(Disposals)] := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
+        FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
-        if HasTransparency then
+        if FrameInfos[Idx].HasTransparency then
-          Images[Idx].Palette[GraphicExt.TransparentColorIndex].A := 0;
-      end
-      else
-        HasTransparency := False;
-
-      if Idx >= 1 then
         begin
-        // If previous frame had some special disposal method we take it into
+          FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
-        // account now
+          Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
-        case Disposals[Idx - 1] of
-          dmUndefined: ; // Do nothing
-          dmLeave:
-            begin
-              // Leave previous frame on log screen
-              CopyRect(Images[Idx - 1], 0, 0, Images[Idx].Width,
-                Images[Idx].Height, Images[Idx], 0, 0);
-            end;
-          dmRestoreBackground:
-            begin
-              // Clear log screen with background color
-              FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,
-                @Header.BackgroundColorIndex);
-            end;
-          dmRestorePrevious:
-            if Idx >= 2 then
-            begin
-              // Set log screen to "previous of previous" frame
-              CopyRect(Images[Idx - 2], 0, 0, Images[Idx].Width,
-                Images[Idx].Height, Images[Idx], 0, 0);
-            end;
         end;
       end
       else
-      begin
+        FrameInfos[Idx].HasTransparency := False;
-        // First frame - just fill with background color
-        FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,
-          @Header.BackgroundColorIndex);
-      end;
 
       LZWStream := TMemoryStream.Create;
+      try
         try
           // Copy LZW data to temp stream, needed for correct decompression
           CopyLZWData(LZWStream);
           LZWStream.Position := 0;
           // Data decompression finally
-        LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits);
+          LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
-        // Now copy frame to logical screen with skipping of transparent pixels (if enabled)
+        except
-        TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt);
+          RemoveBadFrame;
-        CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top,
+          Exit;
-          TransIndex, Disposals[Idx]);
+        end;
       finally
-        FreeImage(Frame);
         LZWStream.Free;
       end;
     end;
   end;
 
+  procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
+  var
+    X, Y: Integer;
+    Src: PByte;
+    Dst: PColor32;
+  begin
+    Src := Frame.Bits;
+
+    // Copy all pixels from frame to log screen but ignore the transparent ones
+    for Y := 0 to Frame.Height - 1 do
+    begin
+      Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
+      for X := 0 to Frame.Width - 1 do
+      begin
+        if (Frame.Palette[Src^].A <> 0) then
+          Dst^ := Frame.Palette[Src^].Color;
+        Inc(Src);
+        Inc(Dst);
+      end;
+    end;
+  end;
+
+  procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
+  var
+    I, First, Last: Integer;
+    UseCache: Boolean;
+    BGColor: TColor32;
+  begin
+    // We may need to use raw frame 0 to n to correctly animate n-th frame
+    Last := Index;
+    First := Max(0, Last);
+    // See if we can use last animate frame as a basis for this one
+    // (so we don't have to use previous raw frames).
+    UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
+      (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);
+
+    // Reuse or release cache
+    if UseCache then
+      CloneImage(CachedFrame, AnimFrame)
+    else
+      FreeImage(CachedFrame);
+
+    // Default color for clearing of the screen
+    BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;
+
+    // Now prepare logical screen for drawing of raw frame at Index.
+    // We may need to use all previous raw frames to get the screen
+    // to proper state (according to their disposal methods).
+
+    if not UseCache then
+    begin
+      if FrameInfos[Index].HasTransparency then
+        BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
+      // Clear whole screen
+      FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
+
+      // Try to maximize First so we don't have to use all 0 to n raw frames
+      while First > 0 do
+      begin
+        if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
+        begin
+          if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
+            Break;
+        end;
+        Dec(First);
+      end;
+
+      for I := First to Last - 1 do
+      begin
+        case FrameInfos[I].Disposal of
+          dmNoRemoval, dmLeave:
+            begin
+              // Copy previous raw frame  onto screen
+              CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
+            end;
+          dmRestoreBackground:
+            if (I > First) then
+            begin
+              // Restore background color
+              FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
+                FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
+            end;
+          dmRestorePrevious: ; // Do nothing - previous state is already on screen
+        end;
+      end;
+    end
+    else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
+    begin
+      // We have our cached result but also need to restore
+      // background in a place of cached frame
+      if FrameInfos[CachedIndex].HasTransparency then
+        BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
+      FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
+        FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
+    end;
+
+    // Copy current raw frame to prepared screen
+    CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);
+
+    // Cache animated result
+    CloneImage(AnimFrame, CachedFrame);
+    CachedIndex := Index;
+  end;
+
 begin
+  AppRead := False;
+
   SetLength(Images, 0);
   FillChar(GlobalPal, SizeOf(GlobalPal), 0);
+
   with GetIO do
   begin
     // Read GIF header
     Read(Handle, @Header, SizeOf(Header));
+    ScreenWidth := Header.ScreenWidth;
+    ScreenHeight := Header.ScreenHeight;
     HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
     GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
     GlobalPalLength := 1 shl (GlobalPalLength + 1);   // Total pal length is 2^(n+1)
@@ -883,6 +1056,9 @@ begin
     // Now read all data blocks in the file until file trailer is reached
     while BlockID <> GIFTrailer do
     begin
+      // Read blocks until we find the one of known type
+      while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
+        BlockID := ReadBlockID;
       // Read supported and skip unsupported extensions
       ReadExtensions;
       // If image frame is found read it
@@ -895,6 +1071,31 @@ begin
         BlockID := GIFTrailer;
     end;
 
+    if FLoadAnimated then
+    begin
+      // Aniated frames will be stored in AnimFrames
+      SetLength(AnimFrames, Length(Images));
+      InitImage(CachedFrame);
+      CachedIndex := -1;
+
+      for I := 0 to High(Images) do
+      begin
+        // Create new logical screen
+        NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
+        // Animate frames to current log screen
+        AnimateFrame(I, AnimFrames[I]);
+      end;
+
+      // Now release raw 8bit frames and put animated 32bit ones
+      // to output array
+      FreeImage(CachedFrame);
+      for I := 0 to High(AnimFrames) do
+      begin
+        FreeImage(Images[I]);
+        Images[I] := AnimFrames[I];
+      end;
+    end;
+
     Result := True;
   end;
 end;
@@ -1007,6 +1208,14 @@ initialization
  -- TODOS ----------------------------------------------------
     - nothing now
 
+  -- 0.26.3 Changes/Bug Fixes ---------------------------------
+    - Fixed bug - loading of GIF with NETSCAPE app extensions
+      failed with Delphi 2009.
+
+  -- 0.26.1 Changes/Bug Fixes ---------------------------------
+    - GIF loading and animation mostly rewritten, based on
+      modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).
+
   -- 0.25.0 Changes/Bug Fixes ---------------------------------
     - Fixed loading of some rare GIFs, problems with LZW
       decompression.

Imaging/ImagingJpeg.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingJpeg.pas 128 2008-07-23 11:57:36Z galfar $
+  $Id: ImagingJpeg.pas 180 2009-10-16 01:07:26Z galfar $
   Vampyre Imaging Library
   by Marek Mauder
   http://imaginglib.sourceforge.net
@@ -43,22 +43,22 @@ unit ImagingJpeg;
 {$DEFINE IMJPEGLIB}
 { $DEFINE PASJPEG}
 
-{ Automatically use FPC's PasJpeg when compiling with Lazarus.}
+{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
-
+  WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
-{$IFDEF LCL}
+{$IF Defined(LCL) and not Defined(WINDOWS)}
   {$UNDEF IMJPEGLIB}
   {$DEFINE PASJPEG}
-{$ENDIF}
+{$IFEND}
 
 interface
 
 uses
   SysUtils, ImagingTypes, Imaging, ImagingColors,
 {$IF Defined(IMJPEGLIB)}
-  imjpeglib, imjmorecfg, imjcomapi, imjdapimin,
+  imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
   imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
 {$ELSEIF Defined(PASJPEG)}
-  jpeglib, jmorecfg, jcomapi, jdapimin,
+  jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
   jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
 {$IFEND}
   ImagingUtility;
@@ -70,7 +70,10 @@ uses
 
 type
   { Class for loading/saving Jpeg images. Supports load/save of
-    8 bit grayscale and 24 bit RGB images.}
+    8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional
+    progressive encoding.
+    Based on IJG's JpegLib so doesn't support alpha channels and lossless
+    coding.}
   TJpegFileFormat = class(TImageFileFormat)
   private
     FGrayScale: Boolean;
@@ -110,10 +113,11 @@ const
 const
   { Jpeg file identifiers.}
   JpegMagic: TChar2 = #$FF#$D8;
-  JFIFSignature: TChar4 = 'JFIF';
-  EXIFSignature: TChar4 = 'Exif';
   BufferSize = 16384;
 
+resourcestring
+  SJpegError = 'JPEG Error';
+
 type
   TJpegContext = record
     case Byte of
@@ -139,40 +143,23 @@ type
 
 var
   JIO: TIOFunctions;
-
+  JpegErrorMgr: jpeg_error_mgr;
 
 { Intenal unit jpeglib support functions }
 
-procedure JpegError(CurInfo: j_common_ptr);
+procedure JpegError(CInfo: j_common_ptr);
-begin
+var
-end;
+  Buffer: string;
-
-procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
 begin
+  { Create the message and raise exception }
+  CInfo^.err^.format_message(CInfo, buffer);
+  raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
 end;
 
 procedure OutputMessage(CurInfo: j_common_ptr);
 begin
 end;
 
-procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
-begin
-end;
-
-procedure ResetErrorMgr(CurInfo: j_common_ptr);
-begin
-  CurInfo^.err^.num_warnings := 0;
-  CurInfo^.err^.msg_code := 0;
-end;
-
-var
-  JpegErrorRec: jpeg_error_mgr = (
-    error_exit: JpegError;
-    emit_message: EmitMessage;
-    output_message: OutputMessage;
-    format_message: FormatMessage;
-    reset_error_mgr: ResetErrorMgr);
-
 procedure ReleaseContext(var jc: TJpegContext);
 begin
   if jc.common.err = nil then
@@ -221,7 +208,7 @@ begin
       FillInputBuffer(cinfo);
     end;
     Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
-//    Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
+    //Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
     Dec(Src.Pub.bytes_in_buffer, num_bytes);
   end;
 end;
@@ -311,7 +298,11 @@ end;
 procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
 begin
   FillChar(jc, sizeof(jc), 0);
-  jc.common.err := @JpegErrorRec;
+  // Set standard error handlers and then override some
+  jc.common.err := jpeg_std_error(JpegErrorMgr);
+  jc.common.err.error_exit := JpegError;
+  jc.common.err.output_message := OutputMessage;
+
   jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
   JpegStdioSrc(jc.d, Handle);
   jpeg_read_header(@jc.d, True);
@@ -329,15 +320,19 @@ procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
   Saver: TJpegFileFormat);
 begin
   FillChar(jc, sizeof(jc), 0);
-  jc.common.err := @JpegErrorRec;
+  // Set standard error handlers and then override some
+  jc.common.err := jpeg_std_error(JpegErrorMgr);
+  jc.common.err.error_exit := JpegError;
+  jc.common.err.output_message := OutputMessage;
+
   jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
   JpegStdioDest(jc.c, Handle);
+  if Saver.FGrayScale then
+    jc.c.in_color_space := JCS_GRAYSCALE
+  else
+    jc.c.in_color_space := JCS_RGB;
   jpeg_set_defaults(@jc.c);
   jpeg_set_quality(@jc.c, Saver.FQuality, True);
-  if Saver.FGrayScale then
-    jpeg_set_colorspace(@jc.c, JCS_GRAYSCALE)
-  else
-    jpeg_set_colorspace(@jc.c, JCS_YCbCr);
   if Saver.FProgressive then
     jpeg_simple_progression(@jc.c);
 end;
@@ -376,13 +371,14 @@ var
   jc: TJpegContext;
   Info: TImageFormatInfo;
   Col32: PColor32Rec;
-{$IFDEF RGBSWAPPED}
+  NeedsRedBlueSwap: Boolean;
   Pix: PColor24Rec;
-{$ENDIF}
 begin
   // Copy IO functions to global var used in JpegLib callbacks
+  Result := False;
   SetJpegIO(GetIO);
   SetLength(Images, 1);
+  
   with JIO, Images[0] do
   try
     InitDecompressor(Handle, jc);
@@ -390,6 +386,8 @@ begin
       JCS_GRAYSCALE: Format := ifGray8;
       JCS_RGB:       Format := ifR8G8B8;
       JCS_CMYK:      Format := ifA8R8G8B8;
+    else
+      Exit;
     end;
     NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
     jpeg_start_decompress(@jc.d);
@@ -398,11 +396,18 @@ begin
     LinesPerCall := 1;
     Dest := Bits;
 
+    // If Jpeg's colorspace is RGB and not YCbCr we need to swap
+    // R and B to get Imaging's native order
+    NeedsRedBlueSwap := jc.d.jpeg_color_space = JCS_RGB;
+  {$IFDEF RGBSWAPPED}
+    // Force R-B swap for FPC's PasJpeg
+    NeedsRedBlueSwap := True;
+  {$ENDIF}
+
     while jc.d.output_scanline < jc.d.output_height do
     begin
       LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
-    {$IFDEF RGBSWAPPED}
+      if NeedsRedBlueSwap and (Format = ifR8G8B8) then
-      if Format = ifR8G8B8 then
       begin
         Pix := PColor24Rec(Dest);
         for I := 0 to Width - 1 do
@@ -411,7 +416,6 @@ begin
           Inc(Pix);
         end;
       end;
-    {$ENDIF}
       Inc(Dest, PtrInc * LinesRead);
     end;
 
@@ -526,7 +530,7 @@ end;
 function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
 var
   ReadCount: LongInt;
-  ID: array[0..9] of Char;
+  ID: array[0..9] of AnsiChar;
 begin
   Result := False;
   if Handle <> nil then
@@ -554,8 +558,20 @@ initialization
  -- TODOS ----------------------------------------------------
     - nothing now
 
+  -- 0.26.5 Changes/Bug Fixes ---------------------------------
+    - Fixed swapped Red-Blue order when loading Jpegs with
+      jc.d.jpeg_color_space = JCS_RGB.
+
+  -- 0.26.3 Changes/Bug Fixes ---------------------------------
+    - Changed the Jpeg error manager, messages were not properly formated.
+
+  -- 0.26.1 Changes/Bug Fixes ---------------------------------
+    - Fixed wrong color space setting in InitCompressor.
+    - Fixed problem with progressive Jpegs in FPC (modified JpegLib,
+      can't use FPC's PasJpeg in Windows).
+
   -- 0.25.0 Changes/Bug Fixes ---------------------------------
-    -- FPC's PasJpeg wasn't really used in last version, fixed.
+    - FPC's PasJpeg wasn't really used in last version, fixed.
 
   -- 0.24.1 Changes/Bug Fixes ---------------------------------
     - Fixed loading of CMYK jpeg images. Could cause heap corruption

Imaging/ImagingOpenGL.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingOpenGL.pas 128 2008-07-23 11:57:36Z galfar $
+  $Id: ImagingOpenGL.pas 165 2009-08-14 12:34:40Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -33,17 +33,20 @@ unit ImagingOpenGL;
 {$I ImagingOptions.inc}
 
 { Define this symbol if you want to use dglOpenGL header.}
-{.$DEFINE USE_DGL_HEADERS}
+{ $DEFINE USE_DGL_HEADERS}
+{ $DEFINE USE_GLSCENE_HEADERS}
 
 interface
 
 uses
   SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats,
-{$IFDEF USE_DGL_HEADERS}
+{$IF Defined(USE_DGL_HEADERS)}
   dglOpenGL,
+{$ELSEIF Defined(USE_GLSCENE_HEADERS)}
+  OpenGL1x,
 {$ELSE}
   gl, glext,
-{$ENDIF}
+{$IFEND}
  ImagingUtility;
 
 type
@@ -278,6 +281,10 @@ const
   GL_UNSIGNED_INT_2_10_10_10_REV    = $8368;
   GL_HALF_FLOAT_ARB                 = $140B;
 
+  // Other GL constants
+  GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS = $8B4C;
+
+
 {$IFDEF MSWINDOWS}
   GLLibName = 'opengl32.dll';
 {$ENDIF}
@@ -880,6 +887,9 @@ initialization
       not only A8R8G8B8
     - support for cube and 3D maps
 
+  -- 0.26.1 Changes/Bug Fixes ---------------------------------
+    - Added support for GLScene's OpenGL header.
+
   -- 0.25.0 Changes/Bug Fixes ---------------------------------
     - Added 3Dc compressed texture formats support.
     - Added detection of 3Dc formats to texture caps.

Imaging/ImagingOptions.inc

@@ -1,47 +1,53 @@
-{ $Id: ImagingOptions.inc 132 2008-08-27 20:37:38Z galfar $ }
+{ $Id: ImagingOptions.inc 174 2009-09-08 09:37:59Z galfar $ }
 
 {
   User Options
   Following defines and options can be changed by user.
 }
 
-{ Source options. }
+{ Source options }
 
-{$DEFINE USE_INLINE}          // use function inlining for some functions
+{$DEFINE USE_INLINE}          // Use function inlining for some functions
-                              // works in Free Pascal and Delphi 9+
+                              // works in Free Pascal and Delphi 9+.
-{$DEFINE USE_ASM}             // if defined, assembler versions of some
+{.$DEFINE USE_ASM}             // Ff defined, assembler versions of some
-                              // functions will be used (only for x86)
+                              // functions will be used (only for x86).
-{ $DEFINE DEBUG}               // if defined, debug info, range/IO/overflow
+
+                              // Debug options: If none of these two are defined
+                              // your project settings are used.
+{ $DEFINE IMAGING_DEBUG}      // If defined, debug info, range/IO/overflow
                               // checking, stack frames, assertions, and
-                              // other debugging options will be turned on
+                              // other debugging options will be turned on.
+{$DEFINE IMAGING_RELEASE}    // If defined, all debug info is off.
 
-{ File format support linking options. Undefine formats which you don't want
-  to be registred automatically. }
 
-{.$DEFINE LINK_JPEG}        // link support for Jpeg images
-{.$DEFINE LINK_PNG}         // link support for PNG images
-{$DEFINE LINK_TARGA}       // link support for Targa images
-{$DEFINE LINK_BITMAP}      // link support for Windows Bitmap images
-{.$DEFINE LINK_DDS}         // link support for DDS images
-{.$DEFINE LINK_GIF}         // link support for GIF images
-{.$DEFINE LINK_MNG}         // link support for MNG images
-{.$DEFINE LINK_JNG}         // link support for JNG images
-{.$DEFINE LINK_PNM}         // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
 
-{.$DEFINE LINK_EXTRAS}      // link support for file formats defined in
+(* File format support linking options.
+  Define formats which you don't want to be registred automatically.
+  Default: all formats are registered = no symbols defined.
+  Example: If you want to disable JPEG support just uncomment //{$DEFINE DONT_LINK_JPEG} line
+*)
+
+//{$DEFINE DONT_LINK_JPEG}        // link support for Jpeg images
+//{$DEFINE DONT_LINK_PNG}         // link support for PNG images
+//{$DEFINE DONT_LINK_TARGA}       // link support for Targa images
+//{$DEFINE DONT_LINK_BITMAP}      // link support for Windows Bitmap images
+{$DEFINE DONT_LINK_DDS}         // link support for DDS images
+{$DEFINE DONT_LINK_GIF}         // link support for GIF images
+{$DEFINE DONT_LINK_MNG}         // link support for MNG images
+{$DEFINE DONT_LINK_JNG}         // link support for JNG images
+{$DEFINE DONT_LINK_PNM}         // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
+
+{$DEFINE DONT_LINK_EXTRAS}  // link support for file formats defined in
                              // Extras package. Exactly which formats will be
                              // registered depends on settings in
                              // ImagingExtras.pas unit.
 
 { Component set used in ImagignComponents.pas unit. You usually don't need
   to be concerned with this - proper component library is selected automatically
-  according to your compiler (only exception is using CLX in Delphi 6/7). }
+  according to your compiler. }
 
-{$DEFINE COMPONENT_SET_VCL}   // use Borland's VCL
+{ $DEFINE COMPONENT_SET_VCL}   // use Delphi VCL
-{ $DEFINE COMPONENT_SET_CLX}   // use Borland's CLX (set automatically when using Kylix,
+{$DEFINE COMPONENT_SET_LCL}  // use Lazarus LCL (set automatically when compiling with FPC)
-                              // must be se manually when compiling with Delphi 6/7)
-{ $DEFINE COMPONENT_SET_LCL}   // use Lazarus' LCL (set automatically when
-                              // compiling with FPC)
 
 {
   Auto Options
@@ -85,7 +91,7 @@
   {$ENDIF}
 {$IFEND}
 
-{$IFDEF DEBUG}
+{$IF Defined(IMAGING_DEBUG)}
   {$ASSERTIONS ON}
   {$DEBUGINFO ON}
   {$RANGECHECKS ON}
@@ -95,13 +101,13 @@
     {$OPTIMIZATION OFF}
     {$STACKFRAMES ON}
     {$LOCALSYMBOLS ON}
-    { $DEFINE MEMCHECK}
+    {$DEFINE MEMCHECK}
   {$ENDIF}
   {$IFDEF FPC}
     {$S+}
     {$CHECKPOINTER ON}
   {$ENDIF}
-{$ELSE}
+{$ELSEIF Defined(IMAGING_RELEASE)}
   {$ASSERTIONS OFF}
   {$DEBUGINFO OFF}
   {$RANGECHECKS OFF}
@@ -115,7 +121,8 @@
   {$IFDEF FPC}
     {$S-}
   {$ENDIF}
-{$ENDIF}
+{$IFEND}
+
 
 { Compiler capabilities }
 
@@ -151,40 +158,11 @@
 {$IFDEF FPC}
   {$DEFINE COMPONENT_SET_LCL}
   {$UNDEF COMPONENT_SET_VCL}
-  {$UNDEF COMPONENT_SET_CLX}
-{$ENDIF}
-
-{$IFDEF KYLIX}
-  {$DEFINE COMPONENT_SET_CLX}
-  {$UNDEF COMPONENT_SET_VCL}
-  {$UNDEF COMPONENT_SET_LCL}
 {$ENDIF}
 
 {$IFDEF DELPHI}
   {$UNDEF COMPONENT_SET_LCL}
-  {$IF CompilerVersion >= 17}
+  {$DEFINE COMPONENT_SET_VCL}
-    {$UNDEF COMPONENT_SET_CLX}     // Delphi 9+ has no CLX
-  {$IFEND}
-  {$IFNDEF COMPONENT_SET_VCL}
-    {$IFNDEF COMPONENT_SET_CLX}
-      {$DEFINE COMPONENT_SET_VCL}  // use VCL as default if not set
-    {$ENDIF}
-  {$ENDIF}
-{$ENDIF}
-
-{$IFDEF COMPONENT_SET_VCL}
-  {$UNDEF COMPONENT_SET_CLX}
-  {$UNDEF COMPONENT_SET_LCL}
-{$ENDIF}
-
-{$IFDEF COMPONENT_SET_CLX}
-  {$UNDEF COMPONENT_SET_VCL}
-  {$UNDEF COMPONENT_SET_LCL}
-{$ENDIF}
-
-{$IFDEF COMPONENT_SET_LCL}
-  {$UNDEF COMPONENT_SET_VCL}
-  {$UNDEF COMPONENT_SET_CLX}
 {$ENDIF}
 
 { Platform options }
@@ -220,16 +198,4 @@
   {$INLINE ON}             // turns inlining on for compilers that support it
 {$ENDIF}
 
-{ Extension dependencies check }
-
-{$IFDEF LINK_MNG}          // MNG uses internaly both PNG and JNG
-  {$DEFINE LINK_JNG}
-  {$DEFINE LINK_PNG}
-{$ENDIF}
-
-{$IFDEF LINK_JNG}          // JNG uses internaly both PNG and JPEG
-  {$DEFINE LINK_PNG}
-  {$DEFINE LINK_JPEG}
-{$ENDIF}
-
 

Imaging/ImagingPortableMaps.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingPortableMaps.pas 127 2008-05-31 01:57:13Z galfar $
+  $Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $
   Vampyre Imaging Library
   by Marek Mauder
   http://imaginglib.sourceforge.net
@@ -46,7 +46,7 @@ type
   TPortableMapInfo = record
     Width: LongInt;
     Height: LongInt;
-    FormatId: Char;
+    FormatId: AnsiChar;
     MaxVal: LongInt;
     BitCount: LongInt;
     Depth: LongInt;
@@ -200,7 +200,7 @@ var
   MonoData: Pointer;
   Info: TImageFormatInfo;
   PixelFP: TColorFPRec;
-  LineBuffer: array[0..LineBufferCapacity - 1] of Char;
+  LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
   LineEnd, LinePos: LongInt;
   MapInfo: TPortableMapInfo;
   LineBreak: string;
@@ -228,7 +228,7 @@ var
   function ReadString: string;
   var
     S: AnsiString;
-    C: Char;
+    C: AnsiChar;
   begin
     // First skip all whitespace chars
     SetLength(S, 1);
@@ -266,7 +266,7 @@ var
     // Dec pos, current is the begining of the the string
     Dec(LinePos);
 
-    Result := S;
+    Result := string(S);
   end;
 
   function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@@ -276,7 +276,7 @@ var
 
   procedure FindLineBreak;
   var
-    C: Char;
+    C: AnsiChar;
   begin
     LineBreak := #10;
     repeat
@@ -586,7 +586,11 @@ var
   begin
     SetLength(S, Length(S) + 1);
     S[Length(S)] := Delimiter;
+  {$IF Defined(DCC) and Defined(UNICODE)}
+    GetIO.Write(Handle, @AnsiString(S)[1], Length(S));
+  {$ELSE}
     GetIO.Write(Handle, @S[1], Length(S));
+  {$IFEND}
     Inc(LineLength, Length(S));
   end;
 
@@ -807,7 +811,6 @@ begin
   FName := SPGMFormatName;
   FSupportedFormats := PGMSupportedFormats;
   AddMasks(SPGMMasks);
-
   RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
   FIdNumbers := '25';
 end;
@@ -818,7 +821,10 @@ var
   MapInfo: TPortableMapInfo;
 begin
   FillChar(MapInfo, SizeOf(MapInfo), 0);
-  MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
+  if FSaveBinary then
+    MapInfo.FormatId := FIdNumbers[1]
+  else
+    MapInfo.FormatId := FIdNumbers[0];
   MapInfo.Binary := FSaveBinary;
   Result := SaveDataInternal(Handle, Images, Index, MapInfo);
 end;
@@ -853,7 +859,6 @@ begin
   FName := SPPMFormatName;
   FSupportedFormats := PPMSupportedFormats;
   AddMasks(SPPMMasks);
-
   RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
   FIdNumbers := '36';
 end;
@@ -864,7 +869,10 @@ var
   MapInfo: TPortableMapInfo;
 begin
   FillChar(MapInfo, SizeOf(MapInfo), 0);
-  MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
+  if FSaveBinary then
+    MapInfo.FormatId := FIdNumbers[1]
+  else
+    MapInfo.FormatId := FIdNumbers[0];
   MapInfo.Binary := FSaveBinary;
   Result := SaveDataInternal(Handle, Images, Index, MapInfo);
 end;
@@ -952,11 +960,17 @@ var
 begin
   FillChar(MapInfo, SizeOf(MapInfo), 0);
   Info := GetFormatInfo(Images[Index].Format);
+
   if (Info.ChannelCount > 1) or Info.IsIndexed then
     MapInfo.TupleType := ttRGBFP
   else
     MapInfo.TupleType := ttGrayScaleFP;
-  MapInfo.FormatId := Iff(MapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]);
+
+  if MapInfo.TupleType = ttGrayScaleFP then
+    MapInfo.FormatId := FIdNumbers[1]
+  else
+    MapInfo.FormatId := FIdNumbers[0];
+
   MapInfo.Binary := True;
   Result := SaveDataInternal(Handle, Images, Index, MapInfo);
 end;
@@ -983,6 +997,9 @@ initialization
   -- TODOS ----------------------------------------------------
     - nothing now
 
+  -- 0.26.3 Changes/Bug Fixes -----------------------------------
+    - Fixed D2009 Unicode related bug in PNM saving.
+
   -- 0.24.3 Changes/Bug Fixes -----------------------------------
     - Improved compatibility of 16bit/component image loading.
     - Changes for better thread safety.

Imaging/ImagingTarga.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingTarga.pas 84 2007-05-27 13:54:27Z galfar $
+  $Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -91,7 +91,7 @@ type
   TTargaFooter = packed record
     ExtOff: LongWord;             // Extension Area Offset
     DevDirOff: LongWord;          // Developer Directory Offset
-    Signature: array[0..15] of Char;  // TRUEVISION-XFILE
+    Signature: TChar16;           // TRUEVISION-XFILE
     Reserved: Byte;               // ASCII period '.'
     NullChar: Byte;               // 0
   end;

Imaging/ImagingTypes.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingTypes.pas 132 2008-08-27 20:37:38Z galfar $
+  $Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -39,7 +39,7 @@ const
   { Current Minor version of Imaging.}
   ImagingVersionMinor = 26;
   { Current patch of Imaging.}
-  ImagingVersionPatch = 0;
+  ImagingVersionPatch = 4;
 
   { Imaging Option Ids whose values can be set/get by SetOption/
     GetOption functions.}
@@ -91,6 +91,11 @@ const
     Allowed values are in range 0 (no compresstion) to 9 (best compression).
     Default value is 5.}
   ImagingPNGCompressLevel      = 26;
+  { Boolean option that specifies whether PNG images with more frames (APNG format)
+    are animated by Imaging (according to frame disposal/blend methods) or just
+    raw frames are loaded and sent to user (if you want to animate APNG yourself).
+    Default value is 1.}
+  ImagingPNGLoadAnimated       = 27;
 
   { Specifies whether MNG animation frames are saved with lossy or lossless
     compression. Lossless frames are saved as PNG images and lossy frames are
@@ -140,10 +145,11 @@ const
   { Boolean option that specifies whether GIF images with more frames
     are animated by Imaging (according to frame disposal methods) or just
     raw frames are loaded and sent to user (if you want to animate GIF yourself).
-    Default value is 1.}
+    Default value is 1.
+    Raw frames are 256 color indexed images (ifIndex8), whereas
+    animated frames are always in 32bit ifA8R8G8B8 format (simplifies animating).}
   ImagingGIFLoadAnimated       = 56;
 
-
   { This option is used when reducing number of colors used in
     image (mainly when converting from ARGB image to indexed
     format). Mask is 'anded' (bitwise AND) with every pixel's

Imaging/ImagingUtility.pas

@@ -1,5 +1,5 @@
 {
-  $Id: ImagingUtility.pas 128 2008-07-23 11:57:36Z galfar $
+  $Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $
   Vampyre Imaging Library
   by Marek Mauder 
   http://imaginglib.sourceforge.net
@@ -56,6 +56,7 @@ type
   TBooleanArray = array[0..MaxInt - 1] of Boolean;
   PBooleanArray = ^TBooleanArray;
 
+  TDynByteArray = array of Byte;
   TDynIntegerArray = array of Integer;
   TDynBooleanArray = array of Boolean;
   
@@ -98,10 +99,11 @@ type
    end;
   PFloatHelper = ^TFloatHelper;
 
-  TChar2 = array[0..1] of Char;
+  TChar2 = array[0..1] of AnsiChar;
-  TChar3 = array[0..2] of Char;
+  TChar3 = array[0..2] of AnsiChar;
-  TChar4 = array[0..3] of Char;
+  TChar4 = array[0..3] of AnsiChar;
-  TChar8 = array[0..7] of Char;
+  TChar8 = array[0..7] of AnsiChar;
+  TChar16 = array[0..15] of AnsiChar;
 
   { Options for BuildFileList function:
     flFullNames - file names in result will have full path names
@@ -156,10 +158,13 @@ function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFD
 function StrToken(var S: string; Sep: Char): string;
 { Same as StrToken but searches from the end of S string.}
 function StrTokenEnd(var S: string; Sep: Char): string;
+{ Fills instance of TStrings with tokens from string S where tokens are separated by
+  one of Seps characters.}
+procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
 { Returns string representation of integer number (with digit grouping).}
-function IntToStrFmt(const I: Int64): string;
+function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
 { Returns string representation of float number (with digit grouping).}
-function FloatToStrFmt(const F: Double; Precision: Integer = 2): string;
+function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
 
 { Clamps integer value to range <Min, Max>}
 function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@@ -447,7 +452,7 @@ var
     if CaseSensitive then
       Result := A = B
     else
-      Result := UpCase(A) = UpCase(B);
+      Result := AnsiUpperCase (A) = AnsiUpperCase (B);
   end;
 
   function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
@@ -609,101 +614,6 @@ begin
 end;
 
 function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
-{$IFDEF USE_ASM}
-asm
-  // The Original ASM Code is (C) Fastcode project.
-       test  eax, eax
-       jz    @Nil
-       test  edx, edx
-       jz    @Nil
-       dec   ecx
-       jl    @Nil
-
-       push  esi
-       push  ebx
-
-       mov   esi, [edx-4]  //Length(Str)
-       mov   ebx, [eax-4]  //Length(Substr)
-       sub   esi, ecx      //effective length of Str
-       add   edx, ecx      //addr of the first char at starting position
-       cmp   esi, ebx
-       jl    @Past         //jump if EffectiveLength(Str)<Length(Substr)
-       test  ebx, ebx
-       jle   @Past         //jump if Length(Substr)<=0
-
-       add   esp, -12
-       add   ebx, -1       //Length(Substr)-1
-       add   esi, edx      //addr of the terminator
-       add   edx, ebx      //addr of the last char at starting position
-       mov   [esp+8], esi  //save addr of the terminator
-       add   eax, ebx      //addr of the last char of Substr
-       sub   ecx, edx      //-@Str[Length(Substr)]
-       neg   ebx           //-(Length(Substr)-1)
-       mov   [esp+4], ecx  //save -@Str[Length(Substr)]
-       mov   [esp], ebx    //save -(Length(Substr)-1)
-       movzx ecx, byte ptr [eax] //the last char of Substr
-
-@Loop:
-       cmp   cl, [edx]
-       jz    @Test0
-@AfterTest0:
-       cmp   cl, [edx+1]
-       jz    @TestT
-@AfterTestT:
-       add   edx, 4
-       cmp   edx, [esp+8]
-       jb   @Continue
-@EndLoop:
-       add   edx, -2
-       cmp   edx, [esp+8]
-       jb    @Loop
-@Exit:
-       add   esp, 12
-@Past:
-       pop   ebx
-       pop   esi
-@Nil:
-       xor   eax, eax
-       ret
-@Continue:
-       cmp   cl, [edx-2]
-       jz    @Test2
-       cmp   cl, [edx-1]
-       jnz   @Loop
-@Test1:
-       add   edx,  1
-@Test2:
-       add   edx, -2
-@Test0:
-       add   edx, -1
-@TestT:
-       mov   esi, [esp]
-       test  esi, esi
-       jz    @Found
-@String:
-       movzx ebx, word ptr [esi+eax]
-       cmp   bx, word ptr [esi+edx+1]
-       jnz   @AfterTestT
-       cmp   esi, -2
-       jge   @Found
-       movzx ebx, word ptr [esi+eax+2]
-       cmp   bx, word ptr [esi+edx+3]
-       jnz   @AfterTestT
-       add   esi, 4
-       jl    @String
-@Found:
-       mov   eax, [esp+4]
-       add   edx, 2
-
-       cmp   edx, [esp+8]
-       ja    @Exit
-
-       add   esp, 12
-       add   eax, edx
-       pop   ebx
-       pop   esi
-end;
-{$ELSE}
 var
   I, X: LongInt;
   Len, LenSubStr: LongInt;
@@ -728,11 +638,10 @@ begin
   end;
   Result := 0;
 end;
-{$ENDIF}
 
 function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
 begin
-  Result := PosEx(LowerCase(SubStr), LowerCase(S), Offset);
+  Result := PosEx(AnsiLowerCase(SubStr), AnsiLowerCase(S), Offset);
 end;
 
 function StrToken(var S: string; Sep: Char): string;
@@ -775,6 +684,19 @@ begin
   end;
 end;
 
+procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
+var
+  Token, Str: string;
+begin
+  Tokens.Clear;
+  Str := S;
+  while Str <> '' do
+  begin
+    Token := StrToken(Str, Sep);
+    Tokens.Add(Token);
+  end;
+end;
+
 function IntToStrFmt(const I: Int64): string;
 begin
   Result := Format('%.0n', [I * 1.0]);
@@ -790,8 +712,7 @@ begin
   Result := Number;
   if Result < Min then
     Result := Min
-  else
+  else if Result > Max then
-  if Result > Max then
     Result := Max;
 end;
 
@@ -800,8 +721,7 @@ begin
   Result := Number;
   if Result < Min then
     Result := Min
-  else
+  else if Result > Max then
-  if Result > Max then
     Result := Max;
 end;
 
@@ -831,7 +751,7 @@ end;
 function NextPow2(Num: LongInt): LongInt;
 begin
   Result := Num and -Num;
-  while (Result < Num) do
+  while Result < Num do
     Result := Result shl 1;
 end;
 
@@ -1552,6 +1472,12 @@ initialization
   -- TODOS ----------------------------------------------------
     - nothing now
 
+  -- 0.26.1 Changes/Bug Fixes -----------------------------------
+    - Some formatting changes.
+    - Changed some string functions to work with localized strings.
+    - ASM version of PosEx had bugs, removed it.
+    - Added StrTokensToList function.
+
   -- 0.25.0 Changes/Bug Fixes -----------------------------------
     - Fixed error in ClipCopyBounds which was causing ... bad clipping!
 

Imaging/JpegLib/imjmemmgr.pas

@@ -492,6 +492,7 @@ begin
   { Calculate max # of rows allowed in one allocation chunk }
   ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div
 	  (long(blocksperrow) * SIZEOF(JBLOCK));
+
   if (ltemp <= 0) then
     ERREXIT(cinfo, JERR_WIDTH_OVERFLOW);
   if (ltemp < long(numrows)) then

Imaging/JpegLib/imjmemnobs.pas

@@ -27,13 +27,8 @@ uses
   NB: jmemmgr.c expects that MAX_ALLOC_CHUNK will be representable as type
   size_t and will be a multiple of sizeof(align_type). }
 
-{$IFDEF WINDOWS}
-const
-  MAX_ALLOC_CHUNK = long(32752);
-{$ELSE}
 const
   MAX_ALLOC_CHUNK = long(1000000000);
-{$ENDIF}
 
 {GLOBAL}
 procedure jpeg_open_backing_store (cinfo : j_common_ptr;

Imaging/ZLib/dzlib.pas

@@ -124,7 +124,7 @@ type
     FStrmPos: Integer;
     FOnProgress: TNotifyEvent;
     FZRec: TZStreamRec;
-    FBuffer: array [Word] of Char;
+    FBuffer: array [Word] of Byte;
   protected
     procedure Progress(Sender: TObject); dynamic;
     property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
@@ -228,7 +228,7 @@ type
 implementation
 
 const
-  ZErrorMessages: array[0..9] of PChar = (
+  ZErrorMessages: array[0..9] of PAnsiChar = (
     'need dictionary',        // Z_NEED_DICT      (2)
     'stream end',             // Z_STREAM_END     (1)
     '',                       // Z_OK             (0)
@@ -491,7 +491,7 @@ end;
 function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
 var
   I: Integer;
-  Buf: array [0..4095] of Char;
+  Buf: array [0..4095] of Byte;
 begin
   if (Offset = 0) and (Origin = soFromBeginning) then
   begin

Imaging/ZLib/iminfcodes.pas

@@ -172,7 +172,7 @@ begin
         c^.sub.lit := t^.base;
        {$IFDEF DEBUG}
         if (t^.base >= $20) and (t^.base < $7f) then
-          Tracevv('inflate:         literal '+char(t^.base))
+          Tracevv('inflate:         literal '+AnsiChar(t^.base))
         else
           Tracevv('inflate:         literal '+IntToStr(t^.base));
         {$ENDIF}          

Imaging/ZLib/iminffast.pas

@@ -99,7 +99,7 @@ begin
       Dec(k, t^.bits);
      {$IFDEF DEBUG}
       if (t^.base >= $20) and (t^.base < $7f) then
-        Tracevv('inflate:         * literal '+char(t^.base))
+        Tracevv('inflate:         * literal '+AnsiChar(t^.base))
       else
         Tracevv('inflate:         * literal '+ IntToStr(t^.base));
       {$ENDIF}
@@ -241,7 +241,7 @@ begin
 
          {$IFDEF DEBUG}
           if (t^.base >= $20) and (t^.base < $7f) then
-            Tracevv('inflate:         * literal '+char(t^.base))
+            Tracevv('inflate:         * literal '+AnsiChar(t^.base))
           else
             Tracevv('inflate:         * literal '+IntToStr(t^.base));
           {$ENDIF}            

Imaging/ZLib/impaszlib.pas

@@ -376,23 +376,23 @@ const
 
 
   {$IFDEF DEBUG}
-  procedure Assert(cond : boolean; msg : string);
+  procedure Assert(cond : boolean; msg : AnsiString);
   {$ENDIF}
 
-  procedure Trace(x : string);
+  procedure Trace(x : AnsiString);
-  procedure Tracev(x : string);
+  procedure Tracev(x : AnsiString);
-  procedure Tracevv(x : string);
+  procedure Tracevv(x : AnsiString);
-  procedure Tracevvv(x : string);
+  procedure Tracevvv(x : AnsiString);
-  procedure Tracec(c : boolean; x : string);
+  procedure Tracec(c : boolean; x : AnsiString);
-  procedure Tracecv(c : boolean; x : string);
+  procedure Tracecv(c : boolean; x : AnsiString);
 
-function zlibVersion : string;
+function zlibVersion : AnsiString;
 { The application can compare zlibVersion and ZLIB_VERSION for consistency.
   If the first character differs, the library code actually used is
   not compatible with the zlib.h header file used by the application.
   This check is automatically made by deflateInit and inflateInit. }
 
-function zError(err : int) : string;
+function zError(err : int) : AnsiString;
 function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;
 procedure ZFREE (var strm : z_stream; ptr : voidpf);
 procedure TRY_FREE (var strm : z_stream; ptr : voidpf);
@@ -416,9 +416,9 @@ const
 const
   z_verbose : int = 1;
 
-function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: string;
+function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString;
   Stream_size: LongInt): LongInt;
-function inflateInit_(var Stream: z_stream; const Version: string;
+function inflateInit_(var Stream: z_stream; const Version: AnsiString;
   Stream_size: Longint): LongInt;
   
 {$IFDEF DEBUG}
@@ -430,29 +430,29 @@ implementation
 uses
   imzdeflate, imzinflate;
 
-function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: string;
+function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString;
   Stream_size: LongInt): LongInt;
 begin
   Result := imzdeflate.deflateInit_(@Stream, Level, Version, Stream_size);
 end;
 
-function inflateInit_(var Stream: z_stream; const Version: string;
+function inflateInit_(var Stream: z_stream; const Version: AnsiString;
   Stream_size: Longint): LongInt;
 begin
   Result := imzinflate.inflateInit_(@Stream, Version, Stream_size);
 end;
 
-function zError(err : int) : string;
+function zError(err : int) : AnsiString;
 begin
   zError := z_errmsg[Z_NEED_DICT-err];
 end;
 
-function zlibVersion : string;
+function zlibVersion : AnsiString;
 begin
   zlibVersion := ZLIB_VERSION;
 end;
 
-procedure z_error (m : string);
+procedure z_error (m : AnsiString);
 begin
   WriteLn(output, m);
   Write('Zlib - Halt...');
@@ -460,42 +460,42 @@ begin
   Halt(1);
 end;
 
-procedure Assert(cond : boolean; msg : string);
+procedure Assert(cond : boolean; msg : AnsiString);
 begin
   if not cond then
     z_error(msg);
 end;
 
-procedure Trace(x : string);
+procedure Trace(x : AnsiString);
 begin
   WriteLn(x);
 end;
 
-procedure Tracev(x : string);
+procedure Tracev(x : AnsiString);
 begin
  if (z_verbose>0) then
    WriteLn(x);
 end;
 
-procedure Tracevv(x : string);
+procedure Tracevv(x : AnsiString);
 begin
   if (z_verbose>1) then
     WriteLn(x);
 end;
 
-procedure Tracevvv(x : string);
+procedure Tracevvv(x : AnsiString);
 begin
   if (z_verbose>2) then
     WriteLn(x);
 end;
 
-procedure Tracec(c : boolean; x : string);
+procedure Tracec(c : boolean; x : AnsiString);
 begin
   if (z_verbose>0) and (c) then
     WriteLn(x);
 end;
 
-procedure Tracecv(c : boolean; x : string);
+procedure Tracecv(c : boolean; x : AnsiString);
 begin
   if (z_verbose>1) and c then
     WriteLn(x);

Imaging/ZLib/imtrees.pas

@@ -637,7 +637,7 @@ const
  }
 
 const
-  Buf_size = (8 * 2*sizeof(char));
+  Buf_size = (8 * 2*sizeof(uch));
 { Number of bits used within bi_buf. (bi_buf might be implemented on
   more than 16 bits on some systems.) }
 
@@ -916,7 +916,7 @@ begin
     {$ifdef DEBUG}
     if (n>31) and (n<128) then
       Tracecv(tree <> tree_ptr(@static_ltree),
-       (^M'n #'+IntToStr(n)+' '+char(n)+' l '+IntToStr(len)+' c '+
+       (^M'n #'+IntToStr(n)+' '+AnsiChar(n)+' l '+IntToStr(len)+' c '+
          IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'))
     else
       Tracecv(tree <> tree_ptr(@static_ltree),
@@ -1962,7 +1962,7 @@ begin
       { send a literal byte }
       {$ifdef DEBUG}
       Tracevvv(#13'cd '+IntToStr(lc));
-      Tracecv((lc > 31) and (lc < 128), ' '+char(lc)+' ');
+      Tracecv((lc > 31) and (lc < 128), ' '+AnsiChar(lc)+' ');
       {$ENDIF}
       send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len);
     end
@@ -2106,7 +2106,7 @@ begin
 {$endif} { STORED_FILE_OK }
 
 {$ifdef FORCE_STORED}
-  if (buf <> pchar(0)) then
+  if (buf <> pcharf(0)) then
   begin { force stored block }
 {$else}
   if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then

Imaging/ZLib/imzdeflate.pas

@@ -61,7 +61,7 @@ uses
 
 function deflateInit_(strm : z_streamp;
                       level : int;
-                      const version : string;
+                      const version : AnsiString;
                       stream_size : int) : int;
 
 
@@ -499,7 +499,7 @@ function deflateInit2_(var strm : z_stream;
                        windowBits : int;
                        memLevel : int;
                        strategy : int;
-                       const version : string;
+                       const version : AnsiString;
                        stream_size : int) : int;
 var
   s : deflate_state_ptr;
@@ -622,7 +622,7 @@ end;
 
 function deflateInit_(strm : z_streamp;
                       level : int;
-                      const version : string;
+                      const version : AnsiString;
                       stream_size : int) : int;
 begin
   if (strm = Z_NULL) then
@@ -1528,7 +1528,7 @@ begin
   begin
     WriteLn(' start ',start,', match ',match ,' length ', length);
     repeat
-      Write(char(s.window^[match]), char(s.window^[start]));
+      Write(AnsiChar(s.window^[match]), AnsiChar(s.window^[start]));
       Inc(match);
       Inc(start);
       Dec(length);
@@ -1539,7 +1539,7 @@ begin
   begin
     Write('\\[',start-match,',',length,']');
     repeat
-       Write(char(s.window^[start]));
+       Write(AnsiChar(s.window^[start]));
        Inc(start);
        Dec(length);
     Until (length = 0);
@@ -1910,7 +1910,7 @@ end;
     begin
       { No match, output a literal byte }
       {$IFDEF DEBUG}
-      Tracevv(char(s.window^[s.strstart]));
+      Tracevv(AnsiChar(s.window^[s.strstart]));
       {$ENDIF}
       {_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);}
       bflush := _tr_tally (s, 0, s.window^[s.strstart]);
@@ -2071,7 +2071,7 @@ begin
           single literal. If there was a match but the current match
           is longer, truncate the previous match to a single literal. }
         {$IFDEF DEBUG}
-        Tracevv(char(s.window^[s.strstart-1]));
+        Tracevv(AnsiChar(s.window^[s.strstart-1]));
         {$ENDIF}
         bflush := _tr_tally (s, 0, s.window^[s.strstart-1]);
 
@@ -2104,7 +2104,7 @@ begin
   if (s.match_available) then
   begin
     {$IFDEF DEBUG}
-    Tracevv(char(s.window^[s.strstart-1]));
+    Tracevv(AnsiChar(s.window^[s.strstart-1]));
     bflush :=
     {$ENDIF}
       _tr_tally (s, 0, s.window^[s.strstart-1]);

Imaging/ZLib/imzinflate.pas

@@ -31,13 +31,13 @@ function inflateInit(var z : z_stream) : int;
 
 
 function inflateInit_(z : z_streamp;
-                      const version : string;
+                      const version : AnsiString;
                       stream_size : int) : int; 
 
 
 function inflateInit2_(var z: z_stream;
                        w : int;
-                       const version : string;
+                       const version : AnsiString;
                        stream_size : int) : int;
 
 function inflateInit2(var z: z_stream;
@@ -246,7 +246,7 @@ end;
 
 function inflateInit2_(var z: z_stream;
                        w : int;
-                       const version : string;
+                       const version : AnsiString;
                        stream_size : int) : int;
 begin
   if (version = '') or (version[1] <> ZLIB_VERSION[1]) or
@@ -333,7 +333,7 @@ begin
 end;
 
 function inflateInit_(z : z_streamp;
-                      const version : string;
+                      const version : AnsiString;
                       stream_size : int) : int;
 begin
   { initialize state }

Tools/convertfontmap/ConvertFontMap.lpi

@@ -0,0 +1,88 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="\"/>
+    <Version Value="7"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+      </Flags>
+      <MainUnit Value="0"/>
+      <TargetFileExt Value=".exe"/>
+      <Icon Value="0"/>
+      <UseXPManifest Value="True"/>
+      <ActiveEditorIndexAtStart Value="0"/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="ConvertFontMap.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="ConvertFontMap"/>
+        <CursorPos X="25" Y="38"/>
+        <TopLine Value="33"/>
+        <EditorIndex Value="0"/>
+        <UsageCount Value="20"/>
+        <Loaded Value="True"/>
+      </Unit0>
+    </Units>
+    <JumpHistory Count="1" HistoryIndex="0">
+      <Position1>
+        <Filename Value="ConvertFontMap.lpr"/>
+        <Caret Line="82" Column="17" TopLine="54"/>
+      </Position1>
+    </JumpHistory>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="8"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="..\..\bin\ConvertFontMap"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)\"/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <SmartLinkUnit Value="True"/>
+    </CodeGeneration>
+    <Linking>
+      <Debugging>
+        <UseLineInfoUnit Value="False"/>
+        <StripSymbols Value="True"/>
+      </Debugging>
+      <LinkSmart Value="True"/>
+    </Linking>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

Tools/convertfontmap/ConvertFontMap.lpr

@@ -0,0 +1,91 @@
+(*
+ * CDDL HEADER START
+ *
+ * The contents of this file are subject to the terms of the
+ * Common Development and Distribution License, Version 1.0 only
+ * (the "License").  You may not use this file except in compliance
+ * with the License.
+ *
+ * You can obtain a copy of the license at
+ * http://www.opensource.org/licenses/cddl1.php.
+ * See the License for the specific language governing permissions
+ * and limitations under the License.
+ *
+ * When distributing Covered Code, include this CDDL HEADER in each
+ * file and include the License file at
+ * http://www.opensource.org/licenses/cddl1.php.  If applicable,
+ * add the following below this CDDL HEADER, with the fields enclosed
+ * by brackets "[]" replaced with your own identifying * information:
+ *      Portions Copyright [yyyy] [name of copyright owner]
+ *
+ * CDDL HEADER END
+ *
+ *
+ *      Portions Copyright 2009 Andreas Schneider
+ *)
+program ConvertFontMap;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, sysutils, DOM, XMLRead;
+
+{$IFDEF WINDOWS}{$R ConvertFontMap.rc}{$ENDIF}
+
+type
+  TFontInfo = packed record
+    Character: char;
+    LeftOffset: SmallInt;
+    CharWidth: Word;
+    Width: Word;
+    Height: Word;
+    X1: Single;
+    Y1: Single;
+    X2: Single;
+    Y2: Single;
+  end;
+
+var
+  xmlDoc: TXMLDocument;
+  chars: TDOMNodeList;
+  root, parent, charNode: TDOMElement;
+  outFile: TFileStream;
+  spaceWidth: Word;
+  fontInfo: TFontInfo;
+  i: Integer;
+
+begin
+  if ParamCount = 2 then
+  begin
+    ReadXMLFile(xmlDoc, ParamStr(1));
+    outFile := TFileStream.Create(ParamStr(2), fmCreate);
+
+    root := xmlDoc.DocumentElement;
+    parent := TDOMElement(root.FindNode('characters'));
+    chars := parent.ChildNodes;
+
+    spaceWidth := StrToInt(root.AttribStrings['spacewidth']);
+    outFile.Write(spaceWidth, SizeOf(spaceWidth));
+
+    for i := 0 to chars.Count - 1 do
+    begin
+      charNode := TDOMElement(chars[i]);
+      fontInfo.Character := Char(StrToInt(charNode.AttribStrings['char']));
+      fontInfo.LeftOffset := StrToInt(charNode.AttribStrings['A']);
+      fontInfo.CharWidth := StrToInt(charNode.AttribStrings['C']);
+      fontInfo.Width := StrToInt(charNode.AttribStrings['wid']);
+      fontInfo.Height := StrToInt(charNode.AttribStrings['hgt']);
+      fontInfo.X1 := StrToFloat(charNode.AttribStrings['X1']);
+      fontInfo.Y1 := StrToFloat(charNode.AttribStrings['Y1']);
+      fontInfo.X2 := StrToFloat(charNode.AttribStrings['X2']);
+      fontInfo.Y2 := StrToFloat(charNode.AttribStrings['Y2']);
+      outFile.Write(fontInfo, SizeOf(fontInfo));
+    end;
+
+    outFile.Free;
+    xmlDoc.Free;
+
+  end else
+    Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' <In Font XML> <Out Font Bin>');
+end.
+