From 145033569ad19a9bddab4a228a81f5eaaed861dc Mon Sep 17 00:00:00 2001 From: paul Date: Mon, 30 Jun 2008 01:11:14 +0000 Subject: [PATCH] lcl: implement .icns (osx icon resource) graphic reader git-svn-id: trunk@15612 - --- .gitattributes | 2 + lcl/graphics.pp | 44 ++++- lcl/icnstypes.pas | 252 +++++++++++++++++++++++++++ lcl/include/icnsicon.inc | 246 +++++++++++++++++++++++++++ lcl/intfgraphics.pas | 356 ++++++++++++++++++++++++++++++++++++++- 5 files changed, 898 insertions(+), 2 deletions(-) create mode 100644 lcl/icnstypes.pas create mode 100644 lcl/include/icnsicon.inc diff --git a/.gitattributes b/.gitattributes index ae40811bec..d4826db150 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2811,6 +2811,7 @@ lcl/graphtype.pp svneol=native#text/pascal lcl/graphutil.pp svneol=native#text/pascal lcl/grids.pas svneol=native#text/pascal lcl/helpintfs.pas svneol=native#text/plain +lcl/icnstypes.pas svneol=native#text/pascal lcl/imagelistcache.pas svneol=native#text/pascal lcl/images/README.txt svneol=native#text/plain lcl/images/btncalccancel.xpm -text svneol=native#image/x-xpixmap @@ -2963,6 +2964,7 @@ lcl/include/graphiccontrol.inc svneol=native#text/pascal lcl/include/graphicsobject.inc svneol=native#text/pascal lcl/include/headercontrol.inc svneol=native#text/pascal lcl/include/hintwindow.inc svneol=native#text/pascal +lcl/include/icnsicon.inc svneol=native#text/pascal lcl/include/icon.inc svneol=native#text/pascal lcl/include/idletimer.inc svneol=native#text/pascal lcl/include/imglist.inc svneol=native#text/pascal diff --git a/lcl/graphics.pp b/lcl/graphics.pp index 45616d75fa..c7f074cfb5 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -42,7 +42,7 @@ uses IntfGraphics, AvgLvlTree, LCLStrConsts, LCLType, LCLProc, LMessages, LCLIntf, LResources, LCLResCache, - GraphType, GraphMath, InterfaceBase, WSReferences; + GraphType, IcnsTypes, GraphMath, InterfaceBase, WSReferences; type @@ -1489,6 +1489,8 @@ type property Current: Integer read FCurrent write SetCurrent; property Count: Integer read GetCount; end; + + { TIcon } TIcon = class(TCustomIcon) private @@ -1500,6 +1502,45 @@ type function ReleaseHandle: HICON; property Handle: HICON read GetIconHandle write SetIconHandle; end; + + TIcnsRec = record + IconType: TicnsIconType; + RawImage: TRawImage; + end; + PIcnsRec = ^TIcnsRec; + + { TIcnsList } + + TIcnsList = class(TList) + private + function GetItem(Index: Integer): PIcnsRec; + procedure SetItem(Index: Integer; const AValue: PIcnsRec); + protected + procedure Notify(Ptr: Pointer; Action: TListNotification); override; + public + function Add(AIconType: TicnsIconType; ARawImage: TRawImage): Integer; reintroduce; + property Items[Index: Integer]: PIcnsRec read GetItem write SetItem; default; + end; + + { TIcnsIcon } + + TIcnsIcon = class(TCustomIcon) + private + FImageList: TIcnsList; + FMaskList: TIcnsList; + procedure IcnsAdd(AIconType: TicnsIconType; ARawImage: TRawImage); + procedure IcnsProcess; + protected + procedure ReadData(Stream: TStream); override; + procedure ReadStream(AStream: TMemoryStream; ASize: Longint); override; + procedure WriteStream(AStream: TMemoryStream); override; + public + constructor Create; override; + destructor Destroy; override; + + class function GetFileExtensions: string; override; + function LazarusResourceTypeValid(const ResourceType: string): boolean; override; + end; { TSharedCursorImage } @@ -2173,6 +2214,7 @@ end; {$I jpegimage.inc} {$I cursorimage.inc} {$I icon.inc} +{$I icnsicon.inc} {$I fpimagebitmap.inc} {$I bitmap.inc} diff --git a/lcl/icnstypes.pas b/lcl/icnstypes.pas new file mode 100644 index 0000000000..aaa8c59ba8 --- /dev/null +++ b/lcl/icnstypes.pas @@ -0,0 +1,252 @@ +{ $Id$ } +{ + /*************************************************************************** + IcnsTypes.pas + --------------- + + ***************************************************************************/ + + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.modifiedLGPL, included in this distribution, * + * for details about the copyright. * + * * + * This program is distributed in the hope that it will be useful, * + * but WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * + * * + ***************************************************************************** + + Author: Paul Ishenin + + Abstract: + Types, consts and functions we need to read MAC osx icon resource files - icns + Most defines present here were taken from univint package of fpc +} +unit IcnsTypes; + +{$mode objfpc}{$H+} + +interface + +type + FourCharCode = array[0..3] of char; + +type + TIconFamilyElement = record + elementType: FourCharCode; { 'ICN#', 'icl8', etc... } + elementSize: LongInt; { Size of this element } + end; + + TIconFamilyResource = record + resourceType: FourCharCode; { Always 'icns' } + resourceSize: LongInt; { Total size of this resource } + end; + +const + kIconFamilyType = 'icns'; + + kIconServices512PixelDataARGB: FourCharCode = 'ic09'; + kIconServices256PixelDataARGB: FourCharCode = 'ic08'; + kThumbnail32BitData : FourCharCode = 'it32'; + kThumbnail8BitMask : FourCharCode = 't8mk'; + kHuge1BitMask : FourCharCode = 'ich#'; + kHuge4BitData : FourCharCode = 'ich4'; + kHuge8BitData : FourCharCode= 'ich8'; + kHuge32BitData : FourCharCode= 'ih32'; + kHuge8BitMask : FourCharCode= 'h8mk'; + { The following icon types can be used as a resource type } + { or as an icon element type inside a 'icns' icon family } + kLarge1BitMask : FourCharCode= 'ICN#'; + kLarge4BitData : FourCharCode= 'icl4'; + kLarge8BitData : FourCharCode= 'icl8'; + kLarge32BitData : FourCharCode= 'il32'; + kLarge8BitMask : FourCharCode= 'l8mk'; + kSmall1BitMask : FourCharCode= 'ics#'; + kSmall4BitData : FourCharCode= 'ics4'; + kSmall8BitData : FourCharCode= 'ics8'; + kSmall32BitData : FourCharCode= 'is32'; + kSmall8BitMask : FourCharCode= 's8mk'; + kMini1BitMask : FourCharCode= 'icm#'; + kMini4BitData : FourCharCode= 'icm4'; + kMini8BitData : FourCharCode= 'icm8'; + +type + // from lower to higher + TicnsIconType = + ( + iitNone, + // data icons + iitMini4BitData, + iitMini8BitData, + iitSmall4BitData, + iitSmall8BitData, + iitSmall32BitData, + iitLarge4BitData, + iitLarge8BitData, + iitLarge32BitData, + iitHuge4BitData, + iitHuge8BitData, + iitHuge32BitData, + iitThumbnail32BitData, + // mask icons + iitMini1BitMask, + iitSmall1BitMask, + iitSmall8BitMask, + iitLarge1BitMask, + iitLarge8BitMask, + iitHuge1BitMask, + iitHuge8BitMask, + iitThumbnail8BitMask, + // alpha icons + iit256PixelDataARGB, + iit512PixelDataARGB + ); + + TicnsIconTypes = set of TicnsIconType; + + TicnsIconInfo = record + Width: Integer; + Height: Integer; + Depth: Integer; + end; + +const + icnsDataTypes = + [ + iitMini4BitData, iitMini8BitData, iitSmall4BitData, iitSmall8BitData, + iitSmall32BitData, iitLarge4BitData, iitLarge8BitData, iitLarge32BitData, + iitHuge4BitData, iitHuge8BitData, iitHuge32BitData, iitThumbnail32BitData + ]; + icnsMaskTypes = + [ + iitMini1BitMask, iitSmall1BitMask, iitSmall8BitMask, iitLarge1BitMask, + iitLarge8BitMask, iitHuge1BitMask, iitHuge8BitMask, iitThumbnail8BitMask + ]; + icnsRGB = + [ + iitSmall32BitData, iitLarge32BitData, iitHuge32BitData, iitThumbnail32BitData + ]; + icnsWithAlpha = + [ + iit256PixelDataARGB, iit512PixelDataARGB + ]; + + icnsIconTypeInfo: array[TicnsIconType] of TicnsIconInfo = + ( + { iitNone } (Width: 000; Height: 000; Depth: 00), + { iitMini4BitData } (Width: 016; Height: 012; Depth: 04), + { iitMini8BitData } (Width: 016; Height: 012; Depth: 08), + { iitSmall4BitData } (Width: 016; Height: 016; Depth: 04), + { iitSmall8BitData } (Width: 016; Height: 016; Depth: 08), + { iitSmall32BitData } (Width: 016; Height: 016; Depth: 32), + { iitLarge4BitData } (Width: 032; Height: 032; Depth: 04), + { iitLarge8BitData } (Width: 032; Height: 032; Depth: 08), + { iitLarge32BitData } (Width: 032; Height: 032; Depth: 32), + { iitHuge4BitData } (Width: 048; Height: 048; Depth: 04), + { iitHuge8BitData } (Width: 048; Height: 048; Depth: 08), + { iitHuge32BitData } (Width: 048; Height: 048; Depth: 32), + { iitThumbnail32BitData } (Width: 128; Height: 128; Depth: 32), + { iitMini1BitMask } (Width: 016; Height: 012; Depth: 01), + { iitSmall1BitMask } (Width: 016; Height: 016; Depth: 01), + { iitSmall8BitMask } (Width: 016; Height: 016; Depth: 08), + { iitLarge1BitMask } (Width: 032; Height: 032; Depth: 01), + { iitLarge8BitMask } (Width: 032; Height: 032; Depth: 08), + { iitHuge1BitMask } (Width: 048; Height: 048; Depth: 01), + { iitHuge8BitMask } (Width: 048; Height: 048; Depth: 08), + { iitThumbnail8BitMask } (Width: 128; Height: 128; Depth: 08), + { iit256PixelDataARGB } (Width: 256; Height: 256; Depth: 32), + { iit512PixelDataARGB } (Width: 512; Height: 512; Depth: 32) + ); + + icnsMaskToImageMap: array[iitMini1BitMask..iitThumbnail8BitMask] of TicnsIconTypes = + ( + { iitMini1BitMask } [iitMini4BitData, iitMini8BitData], + { iitSmall1BitMask } [iitSmall4BitData, iitSmall8BitData, iitSmall32BitData], + { iitSmall8BitMask } [iitSmall4BitData, iitSmall8BitData, iitSmall32BitData], + { iitLarge1BitMask } [iitLarge4BitData, iitLarge8BitData, iitLarge32BitData], + { iitLarge8BitMask } [iitLarge4BitData, iitLarge8BitData, iitLarge32BitData], + { iitHuge1BitMask } [iitHuge4BitData, iitHuge8BitData, iitHuge32BitData], + { iitHuge8BitMask } [iitHuge4BitData, iitHuge8BitData, iitHuge32BitData], + { iitThumbnail8BitMask } [iitThumbnail32BitData] + ); + +function GetIcnsIconType(StrIconType: FourCharCode): TicnsIconType; + +implementation + +function GetIcnsIconType(StrIconType: FourCharCode): TicnsIconType; +begin + Result := iitNone; + + if StrIconType = kMini4BitData then + exit(iitMini4BitData); + + if StrIconType = kMini8BitData then + exit(iitMini8BitData); + + if StrIconType = kSmall4BitData then + exit(iitSmall4BitData); + + if StrIconType = kSmall8BitData then + exit(iitSmall8BitData); + + if StrIconType = kSmall32BitData then + exit(iitSmall32BitData); + + if StrIconType = kLarge4BitData then + exit(iitLarge4BitData); + + if StrIconType = kLarge8BitData then + exit(iitLarge8BitData); + + if StrIconType = kLarge32BitData then + exit(iitLarge32BitData); + + if StrIconType = kHuge4BitData then + exit(iitHuge4BitData); + + if StrIconType = kHuge8BitData then + exit(iitHuge8BitData); + + if StrIconType = kHuge32BitData then + exit(iitHuge32BitData); + + if StrIconType = kThumbnail32BitData then + exit(iitThumbnail32BitData); + + if StrIconType = kMini1BitMask then + exit(iitMini1BitMask); + + if StrIconType = kSmall1BitMask then + exit(iitSmall1BitMask); + + if StrIconType = kSmall8BitMask then + exit(iitSmall8BitMask); + + if StrIconType = kLarge1BitMask then + exit(iitLarge1BitMask); + + if StrIconType = kLarge8BitMask then + exit(iitLarge8BitMask); + + if StrIconType = kHuge1BitMask then + exit(iitHuge1BitMask); + + if StrIconType = kHuge8BitMask then + exit(iitHuge8BitMask); + + if StrIconType = kThumbnail8BitMask then + exit(iitThumbnail8BitMask); + + if StrIconType = kIconServices256PixelDataARGB then + exit(iit256PixelDataARGB); + + if StrIconType = kIconServices512PixelDataARGB then + exit(iit512PixelDataARGB); +end; + +end. + diff --git a/lcl/include/icnsicon.inc b/lcl/include/icnsicon.inc new file mode 100644 index 0000000000..9005a89d18 --- /dev/null +++ b/lcl/include/icnsicon.inc @@ -0,0 +1,246 @@ +{%MainUnit ../graphics.pp} + +{****************************************************************************** + TicnsIcon + ****************************************************************************** + + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.modifiedLGPL, included in this distribution, * + * for details about the copyright. * + * * + * This program is distributed in the hope that it will be useful, * + * but WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * + * * + ***************************************************************************** +} + +{ TIcnsList } + +function TIcnsList.GetItem(Index: Integer): PIcnsRec; +begin + Result := inherited Get(Index); +end; + +procedure TIcnsList.SetItem(Index: Integer; const AValue: PIcnsRec); +begin + inherited Put(Index, AValue); +end; + +procedure TIcnsList.Notify(Ptr: Pointer; Action: TListNotification); +begin + if Action = lnDeleted then + Dispose(PIcnsRec(Ptr)); + inherited Notify(Ptr, Action); +end; + +function TIcnsList.Add(AIconType: TicnsIconType; ARawImage: TRawImage): Integer; +var + Rec: PIcnsRec; +begin + New(Rec); + Rec^.IconType := AIconType; + Rec^.RawImage := ARawImage; + Result := inherited Add(Rec); +end; + +{ TIcnsIcon } + +procedure TIcnsIcon.IcnsAdd(AIconType: TicnsIconType; ARawImage: TRawImage); + + function GetMaskList: TIcnsList; + begin + if FMaskList = nil then + FMaskList := TIcnsList.Create; + Result := FMaskList; + end; + + function GetImageList: TIcnsList; + begin + if FImageList = nil then + FImageList := TIcnsList.Create; + Result := FImageList; + end; + +begin + if AIconType in icnsMaskTypes + then GetMaskList.Add(AIconType, ARawImage) + else GetImageList.Add(AIconType, ARawImage); +end; + +procedure TIcnsIcon.IcnsProcess; + + procedure MergeMask(var AImage, AMask: TRawImage); + var + LazIntfImage, LazIntfMask: TLazIntfImage; + Col, Row: Integer; + Color: TFpColor; + begin + if AMask.Description.Depth = 1 then + begin + // merge mask + AImage.Description.MaskBitOrder := AMask.Description.MaskBitOrder; + AImage.Description.MaskLineEnd := AMask.Description.MaskLineEnd; + AImage.Description.MaskBitsPerPixel := AMask.Description.MaskBitsPerPixel; + AImage.Description.MaskShift := AMask.Description.MaskShift; + AImage.MaskSize := AMask.MaskSize; + AImage.Mask := ReallocMem(AImage.Mask, AMask.MaskSize); + Move(AMask.Mask^, AImage.Mask^, AMask.MaskSize); + end + else + begin + LazIntfImage := TLazIntfImage.Create(AImage, False); + LazIntfMask := TLazIntfImage.Create(AMask, False); + for Row := 0 to LazIntfImage.Height - 1 do + for Col := 0 to LazIntfImage.Width - 1 do + begin + Color := LazIntfImage.Colors[Col,Row]; + Color.alpha := LazIntfMask.Colors[Col,Row].alpha; + LazIntfImage.Colors[Col,Row] := Color; + end; + LazIntfMask.Free; + LazIntfImage.Free; + end; + end; + +var + i, AIndex: integer; + IconType: TicnsIconType; + ImagesForMask: TicnsIconTypes; + IconImage: TIconImage; +begin + // merge separate image and masc rawdata together + + if FMaskList <> nil then + begin + for i := 0 to FMaskList.Count - 1 do + begin + ImagesForMask := icnsMaskToImageMap[FMaskList[i]^.IconType]; + for AIndex := 0 to FImageList.Count - 1 do + if FImageList[AIndex]^.IconType in ImagesForMask then + MergeMask(FImageList[AIndex]^.RawImage, FMaskList[i]^.RawImage); + // dispose RawImage since no more needed + FMaskList[i]^.RawImage.FreeData; + end; + FreeAndNil(FMaskList); + end; + + IconType := iitNone; + for i := 0 to FImageList.Count - 1 do + begin + // todo: we have no jpeg 2000 reader to decompress their data => skip for now + if FImageList[i]^.IconType in icnsWithAlpha then + Continue; + + // Add image + with TSharedIcon(FSharedImage) do + begin + IconImage := GetImagesClass.Create(FImageList[i]^.RawImage); + Add(IconImage); + end; + if FImageList[i]^.IconType > IconType then + begin + IconType := FImageList[i]^.IconType; + FCurrent := TSharedIcon(FSharedImage).Count - 1; + end; + end; + FreeAndNil(FImageList); +end; + +constructor TIcnsIcon.Create; +begin + inherited Create; + FImageList := nil; + FMaskList := nil; +end; + +destructor TIcnsIcon.Destroy; +begin + inherited Destroy; + FImageList.Free; + FMaskList.Free; +end; + +procedure TIcnsIcon.ReadData(Stream: TStream); +var + Resource: TIconFamilyResource; + Position: Int64; +begin + Position := Stream.Position; + Stream.Read(Resource, SizeOf(Resource)); + if Resource.resourceType = kIconFamilyType then + begin + Stream.Position := Position; + LoadFromStream(Stream, BEtoN(Resource.resourceSize)) + end else + begin + Stream.Position := Position; + LoadFromStream(Stream); + end; +end; + +procedure TIcnsIcon.ReadStream(AStream: TMemoryStream; ASize: Longint); +var + Resource: TIconFamilyResource; + + IntfImage: TLazIntfImage; + ImgReader: TLazReaderIcnsPart; + LazReader: ILazImageReader; + RawImage: TRawImage; +begin + AStream.Read(Resource, SizeOf(Resource)); + + if (Resource.resourceType <> kIconFamilyType) then + raise EInvalidGraphic.Create('Stream is not an ICNS type'); + + IntfImage := nil; + ImgReader := nil; + + Resource.resourceSize := BEtoN(Resource.resourceSize); + + if ASize > Resource.resourceSize then + ASize := Resource.resourceSize; + + while AStream.Position < ASize do + begin + if IntfImage = nil + then IntfImage := TLazIntfImage.Create(0,0) + else IntfImage.SetSize(0,0); + + if ImgReader = nil + then ImgReader := TLazReaderIcnsPart.Create; + + if Supports(ImgReader, ILazImageReader, LazReader) + then LazReader.UpdateDescription := True + else IntfImage.DataDescription := QueryDescription([riqfRGB, riqfAlpha, riqfMask]); // fallback to default + + ImgReader.ImageRead(AStream, IntfImage); + IntfImage.GetRawImage(RawImage, True); + + IcnsAdd(ImgReader.IconType, RawImage); + end; + + LazReader := nil; + IntfImage.Free; + ImgReader.Free; + + IcnsProcess; +end; + +procedure TIcnsIcon.WriteStream(AStream: TMemoryStream); +begin + // +end; + +class function TIcnsIcon.GetFileExtensions: string; +begin + Result := 'icns'; +end; + +function TIcnsIcon.LazarusResourceTypeValid(const ResourceType: string): boolean; +begin + Result := (UpperCase(ResourceType) = 'ICNS'); +end; diff --git a/lcl/intfgraphics.pas b/lcl/intfgraphics.pas index 556c91f6f4..1bb28a74f6 100644 --- a/lcl/intfgraphics.pas +++ b/lcl/intfgraphics.pas @@ -32,7 +32,7 @@ interface uses Classes, SysUtils, fpImage, FPReadBMP, BMPComn, FPCAdds, AvgLvlTree, LCLType, - LCLProc, GraphType, LCLIntf, FPReadPNG; + LCLProc, GraphType, LCLIntf, FPReadPNG, IcnsTypes; type { TLazIntfImage } @@ -515,6 +515,39 @@ type property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription; end; + { TLazReaderIcnsPart } + + TLazReaderIcnsPart = class(TFPCustomImageReader, ILazImageReader) + private + FUpdateDescription: Boolean; + FPalette: TFPPalette; + FImage: TLazIntfImage; + FData: PByte; + FCalcSize: Integer; + FDataSize: Integer; + FIconType: TicnsIconType; + FIconInfo: TicnsIconInfo; + protected + function InternalCheck(Str:TStream): boolean; override; + procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override; + function QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; + function _AddRef: LongInt; stdcall; + function _Release: LongInt; stdcall; + function GetUpdateDescription: Boolean; + procedure SetUpdateDescription(AValue: Boolean); + procedure SetupRead(AWidth, AHeight, ADepth: Integer; IsMask: Boolean); + function Create256ColorPalette: TFPPalette; + procedure DoReadRaw; + procedure DoReadRLE; + procedure DoReadJpeg2000; + procedure DoReadMask; + public + constructor Create; override; + destructor Destroy; override; + property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription; + property IconType: TicnsIconType read FIconType; + property DataSize: Integer read FDataSize; + end; // extra Rawimage utility functions @@ -5208,6 +5241,327 @@ begin Result := -1; end; +{ TLazReaderIcnsPart } + +function TLazReaderIcnsPart.InternalCheck(Str: TStream): boolean; +begin + // todo: write check code + Result := True; +end; + +procedure TLazReaderIcnsPart.InternalRead(Stream: TStream; Img: TFPCustomImage); +var + Desc: TRawImageDescription; + Element: TIconFamilyElement; + IsMask: Boolean; +begin + FImage := TheImage as TLazIntfImage; + + Stream.Read(Element, SizeOf(Element)); + Element.elementSize := BEtoN(Element.elementSize); + FIconType := GetIcnsIconType(Element.elementType); + FIconInfo := icnsIconTypeInfo[FIconType]; + IsMask := FIconType in icnsMaskTypes; + + if UpdateDescription + then begin + if IsMask then + begin + if FIconInfo.Depth = 1 then + DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, Desc) + else + DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, 32, Desc); + end + else + DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, Desc); + if (Desc.BitsPerPixel = 32) then + Desc.MaskBitsPerPixel := 0; + FImage.DataDescription := Desc; + end + else Desc := FImage.DataDescription; + + SetupRead(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, IsMask); + + FDataSize := Element.elementSize - SizeOf(Element); + + GetMem(FData, FDataSize); + try + Stream.Read(FData^, FDataSize); + if FIconType in icnsWithAlpha then + DoReadJpeg2000 + else + if IsMask then + DoReadMask + else + if FIconType in icnsRGB then + DoReadRLE + else + DoReadRaw; + finally + FreeMem(FData); + FData := nil; + end; +end; + +function TLazReaderIcnsPart.QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; +begin + if GetInterface(iid, obj) + then Result := S_OK + else Result := E_NOINTERFACE; +end; + +function TLazReaderIcnsPart._AddRef: LongInt; stdcall; +begin + Result := -1; +end; + +function TLazReaderIcnsPart._Release: LongInt; stdcall; +begin + Result := -1; +end; + +function TLazReaderIcnsPart.GetUpdateDescription: Boolean; +begin + Result := FUpdateDescription; +end; + +procedure TLazReaderIcnsPart.SetUpdateDescription(AValue: Boolean); +begin + FUpdateDescription := AValue; +end; + +procedure TLazReaderIcnsPart.SetupRead(AWidth, AHeight, ADepth: Integer; IsMask: Boolean); +begin + if FData <> nil then + FreeMem(FData); + FreeAndNil(FPalette); + if not IsMask then + case ADepth of + 4: FPalette := CreateVGAPalette; + 8: FPalette := Create256ColorPalette; + end; + + FCalcSize := ((AWidth * AHeight * ADepth) shr 3); + TheImage.SetSize(AWidth, AHeight); +end; + +procedure TLazReaderIcnsPart.DoReadRaw; +var + Row, Column: Integer; + shift: byte; + b: PByte; +begin + // only 4 and 8 are stored as raw image format + case FIconInfo.Depth of + 4 : + begin + b := FData; + shift := 4; + for Row := 0 to FIconInfo.Height - 1 do + for Column := 0 to FIconInfo.Width - 1 do + begin + FImage.colors[Column, Row] := FPalette[(b^ shr shift) mod 16]; + if shift = 0 then + begin + shift := 4; + inc(b); + end + else + shift := 0; + end; + end; + 8 : + begin + b := FData; + for Row := 0 to FIconInfo.Height - 1 do + for Column := 0 to FIconInfo.Width - 1 do + begin + FImage.colors[Column, Row] := FPalette[b^]; + inc(b); + end; + end; + end; +end; + +procedure TLazReaderIcnsPart.DoReadRLE; +var + ADecompData: PDWord; + ARGBAData: PRGBAQuad; + Component, Shift: Byte; + PixelCount, j, l: Integer; + RepeatValue: DWord; + SourcePtr: PByte; + DestPtr: PDWord; +begin + // only 24 bit RGB is RLE encoded the same way as TIFF or TGA RLE + // data is encoded channel by channel: + // high bit = 0 => length = low 0..6 bits + 1; read length times next value + // high bit = 1 => length = value - 125 ; read one value and repeat length times + + ADecompData := AllocMem(FCalcSize); + DestPtr := ADecompData; + + if FIconType = iitThumbnail32BitData + then SourcePtr := @FData[4] + else SourcePtr := FData; + + PixelCount := FIconInfo.Height * FIconInfo.Width; + + for Component := 0 to 2 do + begin + DestPtr := ADecompData; + Shift := (2 - Component) * 8; + while DestPtr - ADecompData < PixelCount do + begin + l := SourcePtr^; + inc(SourcePtr); + if (l and $80) = 0 then // high bit = 0 + begin + for j := 0 to l do + begin + DestPtr^ := DestPtr^ or (DWord(SourcePtr^) shl Shift); + inc(SourcePtr); + inc(DestPtr); + end; + end + else + begin // high bit = 1 + l := l - 126; + RepeatValue := DWord(SourcePtr^) shl Shift; + inc(SourcePtr); + for j := 0 to l do + begin + DestPtr^ := DestPtr^ or RepeatValue; + inc(DestPtr); + end; + end; + end; + end; + + ARGBAData := PRGBAQuad(ADecompData); + for l := 0 to FIconInfo.Height - 1 do + for j := 0 to FIconInfo.Width - 1 do + begin + FImage.Colors[j, l] := + FPColor(ARGBAData^.Red shl 8 or ARGBAData^.Red, + ARGBAData^.Green shl 8 or ARGBAData^.Green, + ARGBAData^.Blue shl 8 or ARGBAData^.Blue, + alphaOpaque); + inc(ARGBAData); + end; + FreeMem(ADecompData); +end; + +procedure TLazReaderIcnsPart.DoReadJpeg2000; +begin + // TODO: according to some research in the web we need to read jpeg 2000 data +end; + +procedure TLazReaderIcnsPart.DoReadMask; +var + Row, Column: Integer; + shift: byte; + b: PByte; +begin + case FIconInfo.Depth of + 1: + begin + // actually here is stored 2 1-bit images, but we will get only first + shift := 7; + b := FData; + for Row := 0 to FIconInfo.Height - 1 do + begin + for Column := 0 to FIconInfo.Width - 1 do + begin + FImage.colors[Column, Row] := FPColor(0, 0, 0); + FImage.Masked[Column, Row] := (b^ shr shift) mod 2 = 0; + if shift = 0 then + begin + shift := 7; + inc(b); + end + else + dec(shift); + end; + end; + end; + 8: + begin + b := FData; + for Row := 0 to FIconInfo.Height - 1 do + for Column := 0 to FIconInfo.Width - 1 do + begin + FImage.colors[Column, Row] := FPColor(0, 0, 0, (b^ shl 8) or b^); + inc(b); + end; + end; + end; +end; + +function TLazReaderIcnsPart.Create256ColorPalette: TFPPalette; +const + CHANNELVAL: array[0..15] of Word = ( + $FFFF, $CCCC, $9999, $6666, $3333, $0000, + $EEEE, $DDDD, $BBBB, $AAAA, $8888, + $7777, $5555, $4444, $2222, $1111 + ); + +var + rIdx, gIdx, bIdx: byte; + PalIdx: Byte; +begin + Result := TFPPalette.Create(256); + PalIdx := 0; + for rIdx := 0 to 5 do + begin + for gIdx := 0 to 5 do + begin + for bIdx := 0 to 5 do + begin + Result[PalIdx] := FPColor(CHANNELVAL[rIdx], CHANNELVAL[gIdx], CHANNELVAL[bIdx]); + Inc(PalIdx); + end; + end; + end; + for rIdx := 6 to 15 do + begin + Result[PalIdx] := FPColor(CHANNELVAL[rIdx], 0, 0); + Inc(PalIdx); + end; + for gIdx := 6 to 15 do + begin + Result[PalIdx] := FPColor(0, CHANNELVAL[gIdx], 0); + Inc(PalIdx); + end; + for bIdx := 6 to 15 do + begin + Result[PalIdx] := FPColor(0, 0, CHANNELVAL[bIdx]); + Inc(PalIdx); + end; + for rIdx := 6 to 15 do + begin + Result[PalIdx] := FPColor(CHANNELVAL[rIdx], CHANNELVAL[rIdx], CHANNELVAL[rIdx]); + Inc(PalIdx); + end; + Result[PalIdx] := FPColor(0, 0, 0); +end; + +constructor TLazReaderIcnsPart.Create; +begin + inherited Create; + FData := nil; + FPalette := nil; + FCalcSize := 0; + FIconType := iitNone; +end; + +destructor TLazReaderIcnsPart.Destroy; +begin + FPalette.Free; + FreeMem(FData); + inherited Destroy; +end; + //------------------------------------------------------------------------------ procedure InternalInit; var