Changeset 521 for GraphicTest/Packages/bgrabitmap/bgrabitmaptypes.pas

Timestamp:

Apr 17, 2019, 12:58:41 AM (5 years ago)

Author:

chronos

Message:

• Modified: Propagate project build mode options to used packages.
• Added: Check memory leaks using heaptrc.
• Modified: Update BGRABitmap package.

Location:

GraphicTest

Files:

• . (modified) (1 prop)
• Packages/bgrabitmap/bgrabitmaptypes.pas (modified) (25 diffs)

GraphicTest

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

GraphicTest/Packages/bgrabitmap/bgrabitmaptypes.pas

@@ -33 +33 @@
 uses
   Classes, Types, BGRAGraphics,
-  FPImage, FPImgCanv{$IFDEF BGRABITMAP_USE_LCL}, GraphType{$ENDIF},
+  FPImage, FPImgCanv{$IFDEF BGRABITMAP_USE_LCL}, LCLType, GraphType, LResources{$ENDIF},
   BGRAMultiFileType;
 
@@ -40 +40 @@
   Int32or64 = {$IFDEF CPU64}Int64{$ELSE}LongInt{$ENDIF};
   UInt32or64 = {$IFDEF CPU64}UInt64{$ELSE}LongWord{$ENDIF};
+  HDC = {$IFDEF BGRABITMAP_USE_LCL}LCLType.HDC{$ELSE}PtrUInt{$ENDIF};
 
 {=== Miscellaneous types ===}
@@ -78 +79 @@
 
   TTextLayout = BGRAGraphics.TTextLayout;
+  TFontBidiMode = (fbmAuto, fbmLeftToRight, fbmRightToLeft);
+  TBidiTextAlignment = (btaNatural, btaOpposite, btaLeftJustify, btaRightJustify, btaCenter);
 
 const
+  RadialBlurTypeToStr: array[TRadialBlurType] of string =
+  ('Normal','Disk','Corona','Precise','Fast','Box');
+
+
   tlTop = BGRAGraphics.tlTop;
   tlCenter = BGRAGraphics.tlCenter;
@@ -285 +292 @@
     {** Returns the total size of the string provided using the current font.
         Orientation is not taken into account, so that the width is along the text }
-    function TextSize(sUTF8: string): TSize; virtual; abstract;
+    function TextSize(sUTF8: string): TSize; overload; virtual; abstract;
+    function TextSize(sUTF8: string; AMaxWidth: integer; ARightToLeft: boolean): TSize; overload; virtual; abstract;
+
+    function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; virtual; abstract;
+    function TextSizeAngle(sUTF8: string; {%H-}orientationTenthDegCCW: integer): TSize; virtual;
 
     {** Draws the UTF8 encoded string, with color ''c''.
@@ -292 +303 @@
         If align is taRightJustify, (''x'',''y'') is the top-right corner.
         The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
-    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); virtual; abstract;
+    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
+    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
 
     {** Same as above functions, except that the text is filled using texture.
         The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
-    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract;
+    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
+    procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
 
     {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
-    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); virtual; abstract;
+    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
     {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
-    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); virtual; abstract;
+    procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
 
     {** Draw the UTF8 encoded string at the coordinate (''x'',''y''), clipped inside the rectangle ''ARect''.
         Additional style information is provided by the style parameter.
         The color ''c'' is used to fill the text. No rotation is applied. }
-    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); virtual; abstract;
+    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; virtual; abstract;
 
     {** Same as above except a ''texture'' is used to fill the text }
-    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); virtual; abstract;
+    procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; virtual; abstract;
 
     {** Copy the path for the UTF8 encoded string into ''ADest''.
@@ -316 +329 @@
         If ''align'' is ''taRightJustify'', (''x'',''y'') is the top-right corner. }
     procedure CopyTextPathTo({%H-}ADest: IBGRAPath; {%H-}x, {%H-}y: single; {%H-}s: string; {%H-}align: TAlignment); virtual; //optional
+    function HandlesTextPath: boolean; virtual;
   end;
 
@@ -332 +346 @@
     byte index }
 function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
-{** Default word break handler, that simply divide when there is a space }
+{** Default word break handler }
 procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
 
@@ -395 +409 @@
     ifGif,
     {** BMP format, transparency, no compression. Note that transparency is
-        not supported by all BMP readers so it is not recommended to avoid
+        not supported by all BMP readers so it is recommended to avoid
         storing images with transparency in this format }
     ifBmp,
+    {** iGO BMP (16-bit, rudimentary lossless compression) }
+    ifBmpMioMap,
     {** ICO format, contains different sizes of the same image }
     ifIco,
+    {** CUR format, has hotspot, contains different sizes of the same image }
+    ifCur,
     {** PCX format, opaque, rudimentary lossless compression }
     ifPcx,
@@ -420 +438 @@
     {** X-Pixmap, text encoded image, limited support }
     ifXPixMap,
-    {** iGO BMP, limited support }
-    ifBmpMioMap);
+    {** Scalable Vector Graphic, vectorial, read-only as raster }
+    ifSvg);
+
+  {* Image information from superficial analysis }
+  TQuickImageInfo = record
+    {** Width in pixels }
+    Width,
+    {** Height in pixels }
+    Height,
+    {** Bitdepth for colors (1, 2, 4, 8 for images with palette/grayscale, 16, 24 or 48 if each channel is present) }
+    ColorDepth,
+    {** Bitdepth for alpha (0 if no alpha channel, 1 if bit mask, 8 or 16 if alpha channel) }
+    AlphaDepth: integer;
+  end;
+
+  {* Bitmap reader with additional features }
+  TBGRAImageReader = class(TFPCustomImageReader)
+    {** Return bitmap information (size, bit depth) }
+    function GetQuickInfo(AStream: TStream): TQuickImageInfo; virtual; abstract;
+    {** Return a draft of the bitmap, the ratio may change compared to the original width and height (useful to make thumbnails) }
+    function GetBitmapDraft(AStream: TStream; AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; virtual; abstract;
+  end;
 
   {* Options when loading an image }
@@ -458 +496 @@
 {$I bgracustombitmap.inc}
 
+operator =(const AGuid1, AGuid2: TGuid): boolean;
+
+type
+  { TBGRAResourceManager }
+
+  TBGRAResourceManager = class
+  protected
+    function GetWinResourceType(AExtension: string): pchar;
+  public
+    function GetResourceStream(AFilename: string): TStream; virtual;
+    function IsWinResource(AFilename: string): boolean; virtual;
+  end;
+
+var
+  BGRAResource : TBGRAResourceManager;
+
 implementation
 
-uses Math, SysUtils, BGRAUTF8,
-  FPReadTiff, FPReadXwd, FPReadXPM,
+uses Math, SysUtils, BGRAUTF8, BGRAUnicode,
+  FPReadXwd, FPReadXPM,
   FPWriteTiff, FPWriteJPEG, BGRAWritePNG, FPWriteBMP, FPWritePCX,
   FPWriteTGA, FPWriteXPM;
@@ -532 +586 @@
 
 procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
-var p: integer;
-begin
-  if (AAfter <> '') and (ABefore <> '') and (AAfter[1]<> ' ') and (ABefore[length(ABefore)] <> ' ') then
+const spacingChars = [' '];
+  wordBreakChars = [' ',#9,'-','?','!'];
+var p, charLen: integer;
+  u: Cardinal;
+begin
+  if (AAfter <> '') and (ABefore <> '') and not (AAfter[1] in spacingChars) and not (ABefore[length(ABefore)] in wordBreakChars) then
   begin
     p := length(ABefore);
-    while (p > 1) and (ABefore[p-1] <> ' ') do dec(p);
+    while (p > 1) and not (ABefore[p-1] in wordBreakChars) do dec(p);
+    while (p < length(ABefore)+1) and (ABefore[p] in [#$80..#$BF]) do inc(p); //do not split UTF8 char
+    //keep non-spacing mark together
+    while p <= length(ABefore) do
+    begin
+      charLen := UTF8CharacterLength(@ABefore[p]);
+      if p+charLen > length(ABefore)+1 then charLen := length(ABefore)+1-p;
+      u := UTF8CodepointToUnicode(@ABefore[p],charLen);
+      if GetUnicodeBidiClass(u) = ubcNonSpacingMark then
+        inc(p,charLen)
+      else
+        break;
+    end;
+
+    if p = 1 then
+    begin
+      //keep ideographic punctuation together
+      charLen := UTF8CharacterLength(@AAfter[p]);
+      if charLen > length(AAfter) then charLen := length(AAfter);
+      u := UTF8CodepointToUnicode(@AAfter[p],charLen);
+      case u of
+      UNICODE_IDEOGRAPHIC_COMMA,
+      UNICODE_IDEOGRAPHIC_FULL_STOP,
+      UNICODE_FULLWIDTH_COMMA,
+      UNICODE_HORIZONTAL_ELLIPSIS:
+        begin
+          p := length(ABefore)+1;
+          while p > 1 do
+          begin
+            charLen := 1;
+            dec(p);
+            while (p > 0) and (ABefore[p] in [#$80..#$BF]) do
+            begin
+              dec(p); //do not split UTF8 char
+              inc(charLen);
+            end;
+            if charLen <= 4 then
+              u := UTF8CodepointToUnicode(@ABefore[p],charLen)
+            else
+              u := ord('A');
+            case GetUnicodeBidiClass(u) of
+              ubcNonSpacingMark: ;   // include NSM
+              ubcOtherNeutrals, ubcWhiteSpace, ubcCommonSeparator, ubcEuropeanNumberSeparator:
+                begin
+                  p := 1;
+                  break;
+                end
+            else
+              break;
+            end;
+          end;
+        end;
+      end;
+    end;
+
     if p > 1 then //can put the word after
     begin
@@ -547 +658 @@
     end;
   end;
-  while (ABefore <> '') and (ABefore[length(ABefore)] =' ') do delete(ABefore,length(ABefore),1);
-  while (AAfter <> '') and (AAfter[1] =' ') do delete(AAfter,1,1);
+  while (ABefore <> '') and (ABefore[length(ABefore)] in spacingChars) do delete(ABefore,length(ABefore),1);
+  while (AAfter <> '') and (AAfter[1] in spacingChars) do delete(AAfter,1,1);
 end;
 
@@ -567 +678 @@
 { TBGRACustomFontRenderer }
 
+function TBGRACustomFontRenderer.TextSizeAngle(sUTF8: string;
+  orientationTenthDegCCW: integer): TSize;
+begin
+  result := TextSize(sUTF8); //ignore orientation by default
+end;
+
+procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
+  y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment;
+  ARightToLeft: boolean);
+begin
+  //if RightToLeft is not handled
+  TextOut(ADest,x,y,sUTF8,c,align);
+end;
+
+procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
+  y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment;
+  ARightToLeft: boolean);
+begin
+  //if RightToLeft is not handled
+  TextOut(ADest,x,y,sUTF8,texture,align);
+end;
+
 procedure TBGRACustomFontRenderer.CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment);
 begin {optional implementation} end;
+
+function TBGRACustomFontRenderer.HandlesTextPath: boolean;
+begin
+  result := false;
+end;
 
 
@@ -825 +963 @@
     end;
 
-    if (magic[0] = $00) and (magic[1] = $00) and (magic[2] in[$01,$02]) and (magic[3] = $00) and
-      (magic[4] + (magic[5] shl 8) > 0) then inc(scores[ifIco]);
+    if (magic[0] = $00) and (magic[1] = $00) and (magic[3] = $00) and
+      (magic[4] + (magic[5] shl 8) > 0) then
+    begin
+      if magic[2] = $01 then
+        inc(scores[ifIco])
+      else if magic[2] = $02 then
+        inc(scores[ifCur]);
+    end;
 
     if (copy(magicAsText,1,4) = 'PDN3') then
@@ -852 +996 @@
       with CreateBGRAImageReader(ifOpenRaster) do
         try
+          AStream.Position := streamStartPos;
           if CheckContents(AStream) then inc(scores[ifOpenRaster],2);
         finally
@@ -866 +1011 @@
 
     if (copy(magicAsText,1,8) = '/* XPM *') or (copy(magicAsText,1,6) = '! XPM2') then inc(scores[ifXPixMap]);
+
+    if (copy(magicAsText,1,6) = '<?xml ') then inc(scores[ifSvg]);
 
     AStream.Position := streamStartPos;
@@ -915 +1062 @@
   if (ext = '.pcx') then result := ifPcx else
   if (ext = '.bmp') then result := ifBmp else
-  if (ext = '.ico') or (ext = '.cur') then result := ifIco else
+  if (ext = '.ico') then result := ifIco else
+  if (ext = '.cur') then result := ifCur else
   if (ext = '.pdn') then result := ifPaintDotNet else
   if (ext = '.lzp') then result := ifLazPaint else
@@ -924 +1072 @@
   if (ext = '.xwd') then result := ifXwd else
   if (ext = '.xpm') then result := ifXPixMap else
-  if (ext = '.oxo') then result := ifPhoxo;
+  if (ext = '.oxo') then result := ifPhoxo else
+  if (ext = '.svg') then result := ifSvg;
 end;
 
@@ -934 +1083 @@
     ifGif: result := 'gif';
     ifBmp: result := 'bmp';
+    ifBmpMioMap: result := 'bmp';
     ifIco: result := 'ico';
+    ifCur: result := 'ico';
     ifPcx: result := 'pcx';
     ifPaintDotNet: result := 'pdn';
     ifLazPaint: result := 'lzp';
     ifOpenRaster: result := 'ora';
+    ifPhoxo: result := 'oXo';
     ifPsd: result := 'psd';
     ifTarga: result := 'tga';
@@ -944 +1096 @@
     ifXwd: result := 'xwd';
     ifXPixMap: result := 'xpm';
-    ifBmpMioMap: result := 'bmp';
+    ifSvg: result := 'svg';
     else result := '?';
   end;
@@ -957 +1109 @@
       ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to read this image.');
       ifPaintDotNet: raise exception.Create('You need to call BGRAPaintNet.RegisterPaintNetFormat to read this image.');
+      ifSvg: raise exception.Create('You need to call BGRA.RegisterSvgFormat to read this image.');
     else
       raise exception.Create('The image reader is not registered for this image format.');
@@ -971 +1124 @@
       ifUnknown: raise exception.Create('The image format is unknown');
       ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to write with this image format.');
+      ifPhoxo: raise exception.Create('You need to call BGRAPhoxo.RegisterPhoxoFormat to write with this image format.');
     else
       raise exception.Create('The image writer is not registered for this image format.');
@@ -995 +1149 @@
     result := DefaultBGRAImageWriter[AFormat].Create;
 end;
+
+operator =(const AGuid1, AGuid2: TGuid): boolean;
+begin
+  result := CompareMem(@AGuid1, @AGuid2, sizeof(TGuid));
+end;
+
+type
+  TResourceType = record
+    ext: string;
+    code: pchar;
+  end;
+
+const
+  ResourceTypes: array[1..7] of TResourceType =
+   ((ext: 'CUR'; code: RT_GROUP_CURSOR),
+    (ext: 'BMP'; code: RT_BITMAP),
+    (ext: 'ICO'; code: RT_GROUP_ICON),
+    (ext: 'DAT'; code: RT_RCDATA),
+    (ext: 'DATA'; code: RT_RCDATA),
+    (ext: 'HTM'; code: RT_HTML),
+    (ext: 'HTML'; code: RT_HTML));
+
+{ TBGRAResourceManager }
+
+function TBGRAResourceManager.GetWinResourceType(AExtension: string): pchar;
+var
+  i: Integer;
+begin
+  if (AExtension <> '') and (AExtension[1]='.') then delete(AExtension,1,1);
+  for i := low(ResourceTypes) to high(ResourceTypes) do
+    if AExtension = ResourceTypes[i].ext then
+      exit(ResourceTypes[i].code);
+
+  exit(RT_RCDATA);
+end;
+
+function TBGRAResourceManager.GetResourceStream(AFilename: string): TStream;
+var
+  name,ext: RawByteString;
+  rt: PChar;
+begin
+  ext := UpperCase(ExtractFileExt(AFilename));
+  name := ChangeFileExt(AFilename,'');
+  rt := GetWinResourceType(ext);
+
+  if (rt = RT_GROUP_CURSOR) or (rt = RT_GROUP_ICON) then
+    raise exception.Create('Not implemented');
+
+  result := TResourceStream.Create(HINSTANCE, name, rt);
+end;
+
+function TBGRAResourceManager.IsWinResource(AFilename: string): boolean;
+var
+  name,ext: RawByteString;
+  rt: PChar;
+begin
+  ext := UpperCase(ExtractFileExt(AFilename));
+  name := ChangeFileExt(AFilename,'');
+  rt := GetWinResourceType(ext);
+  result := FindResource(HINSTANCE, pchar(name), rt)<>0;
+end;
+
+{$IFDEF BGRABITMAP_USE_LCL}
+type
+
+  { TLCLResourceManager }
+
+  TLCLResourceManager = class(TBGRAResourceManager)
+  protected
+    function FindLazarusResource(AFilename: string): TLResource;
+  public
+    function GetResourceStream(AFilename: string): TStream; override;
+    function IsWinResource(AFilename: string): boolean; override;
+  end;
+
+function TLCLResourceManager.FindLazarusResource(AFilename: string): TLResource;
+var
+  name,ext: RawByteString;
+begin
+  ext := UpperCase(ExtractFileExt(AFilename));
+  if (ext<>'') and (ext[1]='.') then Delete(ext,1,1);
+  name := ChangeFileExt(AFilename,'');
+  if ext<>'' then
+    result := LazarusResources.Find(name,ext)
+  else
+    result := LazarusResources.Find(name);
+end;
+
+function TLCLResourceManager.GetResourceStream(AFilename: string): TStream;
+var
+  res: TLResource;
+begin
+  res := FindLazarusResource(AFilename);
+  if Assigned(res) then
+    result := TLazarusResourceStream.CreateFromHandle(res)
+  else
+    result := inherited GetResourceStream(AFilename);
+end;
+
+function TLCLResourceManager.IsWinResource(AFilename: string): boolean;
+begin
+  if FindLazarusResource(AFilename)<>nil then
+    result := false
+  else
+    Result:=inherited IsWinResource(AFilename);
+end;
+
+{$ENDIF}
 
 initialization
@@ -1013 +1275 @@
   //writing XWD not implemented
 
-  DefaultBGRAImageReader[ifTiff] := TFPReaderTiff;
   DefaultBGRAImageReader[ifXwd] := TFPReaderXWD;
   //the other readers are registered by their unit
 
+  {$IFDEF BGRABITMAP_USE_LCL}
+  BGRAResource := TLCLResourceManager.Create;
+  {$ELSE}
+  BGRAResource := TBGRAResourceManager.Create;
+  {$ENDIF}
+
 finalization
 
@@ -1024 +1291 @@
   {$DEFINE INCLUDE_FINAL}
   {$I bgrapixel.inc}
+
+  BGRAResource.Free;
 end.

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc