source: trunk/Packages/bgrabitmap/bgrabitmaptypes.pas

Last change on this file was 2, checked in by chronos, 6 years ago
File size: 45.0 KB
Line 
1{
2 /**************************************************************************\
3 bgrabitmaptypes.pas
4 -------------------
5 This unit defines basic types and it must be
6 included in the 'uses' clause.
7
8 --> Include BGRABitmap and BGRABitmapTypes in the 'uses' clause.
9 If you are using LCL types, add also BGRAGraphics unit.
10
11 ****************************************************************************
12 * *
13 * This file is part of BGRABitmap library which is distributed under the *
14 * modified LGPL. *
15 * *
16 * See the file COPYING.modifiedLGPL.txt, included in this distribution, *
17 * for details about the copyright. *
18 * *
19 * This program is distributed in the hope that it will be useful, *
20 * but WITHOUT ANY WARRANTY; without even the implied warranty of *
21 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
22 * *
23 ****************************************************************************
24}
25
26unit BGRABitmapTypes;
27
28{$mode objfpc}{$H+}
29{$i bgrabitmap.inc}
30
31interface
32
33uses
34 Classes, Types, BGRAGraphics,
35 FPImage, FPImgCanv{$IFDEF BGRABITMAP_USE_LCL}, LCLType, GraphType, LResources{$ENDIF},
36 BGRAMultiFileType;
37
38type
39 TMultiFileContainer = BGRAMultiFileType.TMultiFileContainer;
40 Int32or64 = {$IFDEF CPU64}Int64{$ELSE}LongInt{$ENDIF};
41 UInt32or64 = {$IFDEF CPU64}UInt64{$ELSE}LongWord{$ENDIF};
42 HDC = {$IFDEF BGRABITMAP_USE_LCL}LCLType.HDC{$ELSE}PtrUInt{$ENDIF};
43
44{=== Miscellaneous types ===}
45
46type
47 {* Options when doing a floodfill (also called bucket fill) }
48 TFloodfillMode = (
49 {** Pixels that are filled are replaced }
50 fmSet,
51 {** Pixels that are filled are drawn upon with the fill color }
52 fmDrawWithTransparency,
53 {** Pixels that are filled are drawn upon to the extent that the color underneath is similar to
54 the start color. The more different the different is, the less it is drawn upon }
55 fmProgressive);
56
57 {* Specifies how much smoothing is applied to the computation of the median }
58 TMedianOption = (moNone, moLowSmooth, moMediumSmooth, moHighSmooth);
59 {* Specifies the shape of a predefined blur }
60 TRadialBlurType = (
61 {** Gaussian-like, pixel importance decreases progressively }
62 rbNormal,
63 {** Disk blur, pixel importance does not decrease progressively }
64 rbDisk,
65 {** Pixel are considered when they are at a certain distance }
66 rbCorona,
67 {** Gaussian-like, but 10 times smaller than ''rbNormal'' }
68 rbPrecise,
69 {** Gaussian-like but simplified to be computed faster }
70 rbFast,
71 {** Box blur, pixel importance does not decrease progressively
72 and the pixels are included when they are in a square.
73 This is much faster than ''rbFast'' however you may get
74 square shapes in the resulting image }
75 rbBox);
76
77 TEmbossOption = (eoTransparent, eoPreserveHue);
78 TEmbossOptions = set of TEmbossOption;
79
80 TTextLayout = BGRAGraphics.TTextLayout;
81 TFontBidiMode = (fbmAuto, fbmLeftToRight, fbmRightToLeft);
82 TBidiTextAlignment = (btaNatural, btaOpposite, btaLeftJustify, btaRightJustify, btaCenter);
83
84const
85 RadialBlurTypeToStr: array[TRadialBlurType] of string =
86 ('Normal','Disk','Corona','Precise','Fast','Box');
87
88
89 tlTop = BGRAGraphics.tlTop;
90 tlCenter = BGRAGraphics.tlCenter;
91 tlBottom = BGRAGraphics.tlBottom;
92
93 // checks the bounds of an image in the given clipping rectangle
94 function CheckPutImageBounds(x, y, tx, ty: integer; out minxb, minyb, maxxb, maxyb, ignoreleft: integer; const cliprect: TRect): boolean;
95
96{==== Imported from GraphType ====}
97//if this unit is defined, otherwise
98//define here the types used by the library.
99{$IFDEF BGRABITMAP_USE_LCL}
100 type
101 { Order of the lines in an image }
102 TRawImageLineOrder = GraphType.TRawImageLineOrder;
103 { Order of the bits in a byte containing pixel values }
104 TRawImageBitOrder = GraphType.TRawImageBitOrder;
105 { Order of the bytes in a group of byte containing pixel values }
106 TRawImageByteOrder = GraphType.TRawImageByteOrder;
107 { Definition of a single line 3D bevel }
108 TGraphicsBevelCut = GraphType.TGraphicsBevelCut;
109
110 const
111 riloTopToBottom = GraphType.riloTopToBottom; // The first line (line 0) is the top line
112 riloBottomToTop = GraphType.riloBottomToTop; // The first line (line 0) is the bottom line
113
114 riboBitsInOrder = GraphType.riboBitsInOrder; // Bit 0 is pixel 0
115 riboReversedBits = GraphType.riboReversedBits; // Bit 0 is pixel 7 (Bit 1 is pixel 6, ...)
116
117 riboLSBFirst = GraphType.riboLSBFirst; // least significant byte first (little endian)
118 riboMSBFirst = GraphType.riboMSBFirst; // most significant byte first (big endian)
119
120 fsSurface = GraphType.fsSurface; //type is defined as Graphics.TFillStyle
121 fsBorder = GraphType.fsBorder;
122
123 bvNone = GraphType.bvNone;
124 bvLowered = GraphType.bvLowered;
125 bvRaised = GraphType.bvRaised;
126 bvSpace = GraphType.bvSpace;
127{$ELSE}
128 type
129 {* Order of the lines in an image }
130 TRawImageLineOrder = (
131 {** The first line in memory (line 0) is the top line }
132 riloTopToBottom,
133 {** The first line in memory (line 0) is the bottom line }
134 riloBottomToTop);
135
136 {* Order of the bits in a byte containing pixel values }
137 TRawImageBitOrder = (
138 {** The lowest bit is on the left. So with a monochrome picture, bit 0 would be pixel 0 }
139 riboBitsInOrder,
140 {** The lowest bit is on the right. So with a momochrome picture, bit 0 would be pixel 7 (bit 1 would be pixel 6, ...) }
141 riboReversedBits);
142
143 {* Order of the bytes in a group of byte containing pixel values }
144 TRawImageByteOrder = (
145 {** Least significant byte first (little endian) }
146 riboLSBFirst,
147 {** most significant byte first (big endian) }
148 riboMSBFirst);
149
150 {* Definition of a single line 3D bevel }
151 TGraphicsBevelCut =
152 (
153 {** No bevel }
154 bvNone,
155 {** Shape is lowered, light is on the bottom-right corner }
156 bvLowered,
157 {** Shape is raised, light is on the top-left corner }
158 bvRaised,
159 {** Shape is at the same level, there is no particular lighting }
160 bvSpace);
161{$ENDIF}
162
163{$DEFINE INCLUDE_INTERFACE}
164{$I bgrapixel.inc}
165
166{$DEFINE INCLUDE_INTERFACE}
167{$I geometrytypes.inc}
168
169{$DEFINE INCLUDE_INTERFACE}
170{$i csscolorconst.inc}
171
172{$DEFINE INCLUDE_SCANNER_INTERFACE }
173{$I bgracustombitmap.inc}
174
175{==== Integer math ====}
176
177 {* Computes the value modulo cycle, and if the ''value'' is negative, the result
178 is still positive }
179 function PositiveMod(value, cycle: Int32or64): Int32or64; inline; overload;
180
181 { Sin65536 and Cos65536 are fast routines to compute sine and cosine as integer values.
182 They use a table to store already computed values. The return value is an integer
183 ranging from 0 to 65536, so the mean value is 32768 and the half amplitude is
184 32768 instead of 1. The input has a period of 65536, so you can supply any integer
185 without applying a modulo. }
186
187 { Compute all values now }
188 procedure PrecalcSin65536;
189
190 {* Returns an integer approximation of the sine. Value ranges from 0 to 65535,
191 where 65536 corresponds to the next cycle }
192 function Sin65536(value: word): Int32or64; inline;
193 {* Returns an integer approximation of the cosine. Value ranges from 0 to 65535,
194 where 65536 corresponds to the next cycle }
195 function Cos65536(value: word): Int32or64; inline;
196
197 {* Returns the square root of the given byte, considering that
198 255 is equal to unity }
199 function ByteSqrt(value: byte): byte; inline;
200
201{==== Types provided for fonts ====}
202type
203 {* Quality to be used to render text }
204 TBGRAFontQuality = (
205 {** Use the system capabilities. It is rather fast however it may be
206 not be smoothed. }
207 fqSystem,
208 {** Use the system capabilities to render with ClearType. This quality is
209 of course better than fqSystem however it may not be perfect.}
210 fqSystemClearType,
211 {** Garanties a high quality antialiasing. }
212 fqFineAntialiasing,
213 {** Fine antialiasing with ClearType in assuming an LCD display in red/green/blue order }
214 fqFineClearTypeRGB,
215 {** Fine antialiasing with ClearType in assuming an LCD display in blue/green/red order }
216 fqFineClearTypeBGR);
217
218 {* Measurements of a font }
219 TFontPixelMetric = record
220 {** The values have been computed }
221 Defined: boolean;
222 {** Position of the baseline, where most letters lie }
223 Baseline,
224 {** Position of the top of the small letters (x being one of them) }
225 xLine,
226 {** Position of the top of the UPPERCASE letters }
227 CapLine,
228 {** Position of the bottom of letters like g and p }
229 DescentLine,
230 {** Total line height including line spacing defined by the font }
231 Lineheight: integer;
232 end;
233
234 {* Vertical anchoring of the font. When text is drawn, a start coordinate
235 is necessary. Text can be positioned in different ways. This enum
236 defines what position it is regarding the font }
237 TFontVerticalAnchor = (
238 {** The top of the font. Everything will be drawn below the start coordinate. }
239 fvaTop,
240 {** The center of the font }
241 fvaCenter,
242 {** The top of capital letters }
243 fvaCapLine,
244 {** The center of capital letters }
245 fvaCapCenter,
246 {** The top of small letters }
247 fvaXLine,
248 {** The center of small letters }
249 fvaXCenter,
250 {** The baseline, the bottom of most letters }
251 fvaBaseline,
252 {** The bottom of letters that go below the baseline }
253 fvaDescentLine,
254 {** The bottom of the font. Everything will be drawn above the start coordinate }
255 fvaBottom);
256
257 {* Definition of a function that handles work-break }
258 TWordBreakHandler = procedure(var ABeforeUTF8, AAfterUTF8: string) of object;
259
260 {* Alignment for a typewriter, that does not have any more information
261 than a square shape containing glyphs }
262 TBGRATypeWriterAlignment = (twaTopLeft, twaTop, twaTopRight, twaLeft, twaMiddle, twaRight, twaBottomLeft, twaBottom, twaBottomRight);
263 {* How a typewriter must render its content on a Canvas2d }
264 TBGRATypeWriterOutlineMode = (twoPath, twoFill, twoStroke, twoFillOverStroke, twoStrokeOverFill, twoFillThenStroke, twoStrokeThenFill);
265
266 { TBGRACustomFontRenderer }
267 {* Abstract class for all font renderers }
268 TBGRACustomFontRenderer = class
269 {** Specifies the font to use. Unless the font renderer accept otherwise,
270 the name is in human readable form, like 'Arial', 'Times New Roman', ... }
271 FontName: string;
272
273 {** Specifies the set of styles to be applied to the font.
274 These can be fsBold, fsItalic, fsStrikeOut, fsUnderline.
275 So the value [fsBold,fsItalic] means that the font must be bold and italic }
276 FontStyle: TFontStyles;
277
278 {** Specifies the quality of rendering. Default value is fqSystem }
279 FontQuality : TBGRAFontQuality;
280
281 {** Specifies the rotation of the text, for functions that support text rotation.
282 It is expressed in tenth of degrees, positive values going counter-clockwise }
283 FontOrientation: integer;
284
285 {** Specifies the height of the font without taking into account additional line spacing.
286 A negative value means that it is the full height instead }
287 FontEmHeight: integer;
288
289 {** Returns measurement for the current font in pixels }
290 function GetFontPixelMetric: TFontPixelMetric; virtual; abstract;
291
292 {** Returns the total size of the string provided using the current font.
293 Orientation is not taken into account, so that the width is along the text }
294 function TextSize(sUTF8: string): TSize; overload; virtual; abstract;
295 function TextSize(sUTF8: string; AMaxWidth: integer; ARightToLeft: boolean): TSize; overload; virtual; abstract;
296
297 function TextFitInfo(sUTF8: string; AMaxWidth: integer): integer; virtual; abstract;
298 function TextSizeAngle(sUTF8: string; {%H-}orientationTenthDegCCW: integer): TSize; virtual;
299
300 {** Draws the UTF8 encoded string, with color ''c''.
301 If align is taLeftJustify, (''x'',''y'') is the top-left corner.
302 If align is taCenter, (''x'',''y'') is at the top and middle of the text.
303 If align is taRightJustify, (''x'',''y'') is the top-right corner.
304 The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
305 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
306 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
307
308 {** Same as above functions, except that the text is filled using texture.
309 The value of ''FontOrientation'' is taken into account, so that the text may be rotated }
310 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
311 procedure TextOut(ADest: TBGRACustomBitmap; x, y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment; {%H-}ARightToLeft: boolean); overload; virtual;
312
313 {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
314 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; c: TBGRAPixel; align: TAlignment); overload; virtual; abstract;
315 {** Same as above, except that the orientation is specified, overriding the value of the property ''FontOrientation'' }
316 procedure TextOutAngle(ADest: TBGRACustomBitmap; x, y: single; orientationTenthDegCCW: integer; sUTF8: string; texture: IBGRAScanner; align: TAlignment); overload; virtual; abstract;
317
318 {** Draw the UTF8 encoded string at the coordinate (''x'',''y''), clipped inside the rectangle ''ARect''.
319 Additional style information is provided by the style parameter.
320 The color ''c'' is used to fill the text. No rotation is applied. }
321 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; c: TBGRAPixel); overload; virtual; abstract;
322
323 {** Same as above except a ''texture'' is used to fill the text }
324 procedure TextRect(ADest: TBGRACustomBitmap; ARect: TRect; x, y: integer; sUTF8: string; style: TTextStyle; texture: IBGRAScanner); overload; virtual; abstract;
325
326 {** Copy the path for the UTF8 encoded string into ''ADest''.
327 If ''align'' is ''taLeftJustify'', (''x'',''y'') is the top-left corner.
328 If ''align'' is ''taCenter'', (''x'',''y'') is at the top and middle of the text.
329 If ''align'' is ''taRightJustify'', (''x'',''y'') is the top-right corner. }
330 procedure CopyTextPathTo({%H-}ADest: IBGRAPath; {%H-}x, {%H-}y: single; {%H-}s: string; {%H-}align: TAlignment); virtual; //optional
331 function HandlesTextPath: boolean; virtual;
332 end;
333
334 {* Output mode for the improved renderer for readability. This is used by the font renderer based on LCL in ''BGRAText'' }
335 TBGRATextOutImproveReadabilityMode = (irMask, irNormal, irClearTypeRGB, irClearTypeBGR);
336
337{** Removes line ending and tab characters from a string (for a function
338 like ''TextOut'' that does not handle this). this works with UTF8 strings
339 as well }
340function CleanTextOutString(s: string): string;
341{** Remove the line ending at the specified position or return False.
342 This works with UTF8 strings however the index is the byte index }
343function RemoveLineEnding(var s: string; indexByte: integer): boolean;
344{** Remove the line ending at the specified position or return False.
345 The index is the character index, that may be different from the
346 byte index }
347function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
348{** Default word break handler }
349procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
350
351{==== Images and resampling ====}
352
353type
354 {* How the resample is to be computed }
355 TResampleMode = (
356 {** Low quality resample by repeating pixels, stretching them }
357 rmSimpleStretch,
358 {** Use resample filters. This gives high
359 quality resampling however this the proportion changes slightly because
360 the first and last pixel are considered to occupy only half a unit as
361 they are considered as the border of the picture
362 (pixel-centered coordinates) }
363 rmFineResample);
364
365 {* List of resample filter to be used with ''rmFineResample'' }
366 TResampleFilter = (
367 {** Equivalent of simple stretch with high quality and pixel-centered coordinates }
368 rfBox,
369 {** Linear interpolation giving slow transition between pixels }
370 rfLinear,
371 {** Mix of ''rfLinear'' and ''rfCosine'' giving medium speed stransition between pixels }
372 rfHalfCosine,
373 {** Cosine-like interpolation giving fast transition between pixels }
374 rfCosine,
375 {** Simple bi-cubic filter (blurry) }
376 rfBicubic,
377 {** Mitchell filter, good for downsizing interpolation }
378 rfMitchell,
379 {** Spline filter, good for upsizing interpolation, however slightly blurry }
380 rfSpline,
381 {** Lanczos with radius 2, blur is corrected }
382 rfLanczos2,
383 {** Lanczos with radius 3, high contrast }
384 rfLanczos3,
385 {** Lanczos with radius 4, high contrast }
386 rfLanczos4,
387 {** Best quality using rfMitchell or rfSpline }
388 rfBestQuality);
389
390const
391 {** List of strings to represent resample filters }
392 ResampleFilterStr : array[TResampleFilter] of string =
393 ('Box','Linear','HalfCosine','Cosine','Bicubic','Mitchell','Spline',
394 'Lanczos2','Lanczos3','Lanczos4','BestQuality');
395
396 {** Gives the sample filter represented by a string }
397 function StrToResampleFilter(str: string): TResampleFilter;
398
399type
400 {* List of image formats }
401 TBGRAImageFormat = (
402 {** Unknown format }
403 ifUnknown,
404 {** JPEG format, opaque, lossy compression }
405 ifJpeg,
406 {** PNG format, transparency, lossless compression }
407 ifPng,
408 {** GIF format, single transparent color, lossless in theory but only low number of colors allowed }
409 ifGif,
410 {** BMP format, transparency, no compression. Note that transparency is
411 not supported by all BMP readers so it is recommended to avoid
412 storing images with transparency in this format }
413 ifBmp,
414 {** iGO BMP (16-bit, rudimentary lossless compression) }
415 ifBmpMioMap,
416 {** ICO format, contains different sizes of the same image }
417 ifIco,
418 {** CUR format, has hotspot, contains different sizes of the same image }
419 ifCur,
420 {** PCX format, opaque, rudimentary lossless compression }
421 ifPcx,
422 {** Paint.NET format, layers, lossless compression }
423 ifPaintDotNet,
424 {** LazPaint format, layers, lossless compression }
425 ifLazPaint,
426 {** OpenRaster format, layers, lossless compression }
427 ifOpenRaster,
428 {** Phoxo format, layers }
429 ifPhoxo,
430 {** Photoshop format, layers, rudimentary lossless compression }
431 ifPsd,
432 {** Targa format (TGA), transparency, rudimentary lossless compression }
433 ifTarga,
434 {** TIFF format, limited support }
435 ifTiff,
436 {** X-Window capture, limited support }
437 ifXwd,
438 {** X-Pixmap, text encoded image, limited support }
439 ifXPixMap,
440 {** Scalable Vector Graphic, vectorial, read-only as raster }
441 ifSvg);
442
443 {* Image information from superficial analysis }
444 TQuickImageInfo = record
445 {** Width in pixels }
446 Width,
447 {** Height in pixels }
448 Height,
449 {** Bitdepth for colors (1, 2, 4, 8 for images with palette/grayscale, 16, 24 or 48 if each channel is present) }
450 ColorDepth,
451 {** Bitdepth for alpha (0 if no alpha channel, 1 if bit mask, 8 or 16 if alpha channel) }
452 AlphaDepth: integer;
453 end;
454
455 {* Bitmap reader with additional features }
456 TBGRAImageReader = class(TFPCustomImageReader)
457 {** Return bitmap information (size, bit depth) }
458 function GetQuickInfo(AStream: TStream): TQuickImageInfo; virtual; abstract;
459 {** Return a draft of the bitmap, the ratio may change compared to the original width and height (useful to make thumbnails) }
460 function GetBitmapDraft(AStream: TStream; AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; virtual; abstract;
461 end;
462
463 {* Options when loading an image }
464 TBGRALoadingOption = (
465 {** Do not clear RGB channels when alpha is zero (not recommended) }
466 loKeepTransparentRGB,
467 {** Consider BMP to be opaque if no alpha value is provided (for compatibility) }
468 loBmpAutoOpaque,
469 {** Load JPEG quickly however with a lower quality }
470 loJpegQuick);
471 TBGRALoadingOptions = set of TBGRALoadingOption;
472
473var
474 {** List of stream readers for images }
475 DefaultBGRAImageReader: array[TBGRAImageFormat] of TFPCustomImageReaderClass;
476 {** List of stream writers for images }
477 DefaultBGRAImageWriter: array[TBGRAImageFormat] of TFPCustomImageWriterClass;
478
479 {** Detect the file format of a given file }
480 function DetectFileFormat(AFilenameUTF8: string): TBGRAImageFormat;
481 {** Detect the file format of a given stream. ''ASuggestedExtensionUTF8'' can
482 be provided to guess the format }
483 function DetectFileFormat(AStream: TStream; ASuggestedExtensionUTF8: string = ''): TBGRAImageFormat;
484 {** Returns the file format that is most likely to be stored in the
485 given filename (according to its extension) }
486 function SuggestImageFormat(AFilenameOrExtensionUTF8: string): TBGRAImageFormat;
487 {** Returns a likely image extension for the format }
488 function SuggestImageExtension(AFormat: TBGRAImageFormat): string;
489 {** Create an image reader for the given format }
490 function CreateBGRAImageReader(AFormat: TBGRAImageFormat): TFPCustomImageReader;
491 {** Create an image writer for the given format. ''AHasTransparentPixels''
492 specifies if alpha channel must be supported }
493 function CreateBGRAImageWriter(AFormat: TBGRAImageFormat; AHasTransparentPixels: boolean): TFPCustomImageWriter;
494
495{$DEFINE INCLUDE_INTERFACE}
496{$I bgracustombitmap.inc}
497
498operator =(const AGuid1, AGuid2: TGuid): boolean;
499
500type
501 { TBGRAResourceManager }
502
503 TBGRAResourceManager = class
504 protected
505 function GetWinResourceType(AExtension: string): pchar;
506 public
507 function GetResourceStream(AFilename: string): TStream; virtual;
508 function IsWinResource(AFilename: string): boolean; virtual;
509 end;
510
511var
512 BGRAResource : TBGRAResourceManager;
513
514implementation
515
516uses Math, SysUtils, BGRAUTF8, BGRAUnicode,
517 FPReadXwd, FPReadXPM,
518 FPWriteTiff, FPWriteJPEG, BGRAWritePNG, FPWriteBMP, FPWritePCX,
519 FPWriteTGA, FPWriteXPM;
520
521{$DEFINE INCLUDE_IMPLEMENTATION}
522{$I geometrytypes.inc}
523
524{$DEFINE INCLUDE_IMPLEMENTATION}
525{$I csscolorconst.inc}
526
527{$DEFINE INCLUDE_IMPLEMENTATION}
528{$I bgracustombitmap.inc}
529
530{$DEFINE INCLUDE_IMPLEMENTATION}
531{$I bgrapixel.inc}
532
533function CleanTextOutString(s: string): string;
534var idxIn, idxOut: integer;
535begin
536 setlength(result, length(s));
537 idxIn := 1;
538 idxOut := 1;
539 while IdxIn <= length(s) do
540 begin
541 if not (s[idxIn] in[#13,#10,#9]) then //those characters are always 1 byte long so it is the same with UTF8
542 begin
543 result[idxOut] := s[idxIn];
544 inc(idxOut);
545 end;
546 inc(idxIn);
547 end;
548 setlength(result, idxOut-1);
549end;
550
551function RemoveLineEnding(var s: string; indexByte: integer): boolean;
552begin //we can ignore UTF8 character length because #13 and #10 are always 1 byte long
553 //so this function can be applied to UTF8 strings as well
554 result := false;
555 if length(s) >= indexByte then
556 begin
557 if s[indexByte] in[#13,#10] then
558 begin
559 result := true;
560 if length(s) >= indexByte+1 then
561 begin
562 if (s[indexByte+1] <> s[indexByte]) and (s[indexByte+1] in[#13,#10]) then
563 delete(s,indexByte,2)
564 else
565 delete(s,indexByte,1);
566 end
567 else
568 delete(s,indexByte,1);
569 end;
570 end;
571end;
572
573function RemoveLineEndingUTF8(var sUTF8: string; indexUTF8: integer): boolean;
574var indexByte: integer;
575 pIndex: PChar;
576begin
577 pIndex := UTF8CharStart(@sUTF8[1],length(sUTF8),indexUTF8);
578 if pIndex = nil then
579 begin
580 result := false;
581 exit;
582 end;
583 indexByte := pIndex - @sUTF8[1];
584 result := RemoveLineEnding(sUTF8, indexByte);
585end;
586
587procedure BGRADefaultWordBreakHandler(var ABefore, AAfter: string);
588const spacingChars = [' '];
589 wordBreakChars = [' ',#9,'-','?','!'];
590var p, charLen: integer;
591 u: Cardinal;
592begin
593 if (AAfter <> '') and (ABefore <> '') and not (AAfter[1] in spacingChars) and not (ABefore[length(ABefore)] in wordBreakChars) then
594 begin
595 p := length(ABefore);
596 while (p > 1) and not (ABefore[p-1] in wordBreakChars) do dec(p);
597 while (p < length(ABefore)+1) and (ABefore[p] in [#$80..#$BF]) do inc(p); //do not split UTF8 char
598 //keep non-spacing mark together
599 while p <= length(ABefore) do
600 begin
601 charLen := UTF8CharacterLength(@ABefore[p]);
602 if p+charLen > length(ABefore)+1 then charLen := length(ABefore)+1-p;
603 u := UTF8CodepointToUnicode(@ABefore[p],charLen);
604 if GetUnicodeBidiClass(u) = ubcNonSpacingMark then
605 inc(p,charLen)
606 else
607 break;
608 end;
609
610 if p = 1 then
611 begin
612 //keep ideographic punctuation together
613 charLen := UTF8CharacterLength(@AAfter[p]);
614 if charLen > length(AAfter) then charLen := length(AAfter);
615 u := UTF8CodepointToUnicode(@AAfter[p],charLen);
616 case u of
617 UNICODE_IDEOGRAPHIC_COMMA,
618 UNICODE_IDEOGRAPHIC_FULL_STOP,
619 UNICODE_FULLWIDTH_COMMA,
620 UNICODE_HORIZONTAL_ELLIPSIS:
621 begin
622 p := length(ABefore)+1;
623 while p > 1 do
624 begin
625 charLen := 1;
626 dec(p);
627 while (p > 0) and (ABefore[p] in [#$80..#$BF]) do
628 begin
629 dec(p); //do not split UTF8 char
630 inc(charLen);
631 end;
632 if charLen <= 4 then
633 u := UTF8CodepointToUnicode(@ABefore[p],charLen)
634 else
635 u := ord('A');
636 case GetUnicodeBidiClass(u) of
637 ubcNonSpacingMark: ; // include NSM
638 ubcOtherNeutrals, ubcWhiteSpace, ubcCommonSeparator, ubcEuropeanNumberSeparator:
639 begin
640 p := 1;
641 break;
642 end
643 else
644 break;
645 end;
646 end;
647 end;
648 end;
649 end;
650
651 if p > 1 then //can put the word after
652 begin
653 AAfter := copy(ABefore,p,length(ABefore)-p+1)+AAfter;
654 ABefore := copy(ABefore,1,p-1);
655 end else
656 begin //cannot put the word after, so before
657
658 end;
659 end;
660 while (ABefore <> '') and (ABefore[length(ABefore)] in spacingChars) do delete(ABefore,length(ABefore),1);
661 while (AAfter <> '') and (AAfter[1] in spacingChars) do delete(AAfter,1,1);
662end;
663
664
665function StrToResampleFilter(str: string): TResampleFilter;
666var f: TResampleFilter;
667begin
668 result := rfLinear;
669 str := LowerCase(str);
670 for f := low(TResampleFilter) to high(TResampleFilter) do
671 if CompareText(str,ResampleFilterStr[f])=0 then
672 begin
673 result := f;
674 exit;
675 end;
676end;
677
678{ TBGRACustomFontRenderer }
679
680function TBGRACustomFontRenderer.TextSizeAngle(sUTF8: string;
681 orientationTenthDegCCW: integer): TSize;
682begin
683 result := TextSize(sUTF8); //ignore orientation by default
684end;
685
686procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
687 y: single; sUTF8: string; c: TBGRAPixel; align: TAlignment;
688 ARightToLeft: boolean);
689begin
690 //if RightToLeft is not handled
691 TextOut(ADest,x,y,sUTF8,c,align);
692end;
693
694procedure TBGRACustomFontRenderer.TextOut(ADest: TBGRACustomBitmap; x,
695 y: single; sUTF8: string; texture: IBGRAScanner; align: TAlignment;
696 ARightToLeft: boolean);
697begin
698 //if RightToLeft is not handled
699 TextOut(ADest,x,y,sUTF8,texture,align);
700end;
701
702procedure TBGRACustomFontRenderer.CopyTextPathTo(ADest: IBGRAPath; x, y: single; s: string; align: TAlignment);
703begin {optional implementation} end;
704
705function TBGRACustomFontRenderer.HandlesTextPath: boolean;
706begin
707 result := false;
708end;
709
710
711function CheckPutImageBounds(x, y, tx, ty: integer; out minxb, minyb, maxxb,
712 maxyb, ignoreleft: integer; const cliprect: TRect): boolean;
713var x2,y2: integer;
714begin
715 if (x >= cliprect.Right) or (y >= cliprect.Bottom) or (x <= cliprect.Left-tx) or
716 (y <= cliprect.Top-ty) or (ty <= 0) or (tx <= 0) then
717 begin
718 result := false;
719 exit;
720 end;
721
722 x2 := x + tx - 1;
723 y2 := y + ty - 1;
724
725 if y < cliprect.Top then
726 minyb := cliprect.Top
727 else
728 minyb := y;
729 if y2 >= cliprect.Bottom then
730 maxyb := cliprect.Bottom - 1
731 else
732 maxyb := y2;
733
734 if x < cliprect.Left then
735 begin
736 ignoreleft := cliprect.Left-x;
737 minxb := cliprect.Left;
738 end
739 else
740 begin
741 ignoreleft := 0;
742 minxb := x;
743 end;
744 if x2 >= cliprect.Right then
745 maxxb := cliprect.Right - 1
746 else
747 maxxb := x2;
748
749 result := true;
750end;
751
752{************************** Cyclic functions *******************}
753
754// Get the cyclic value in the range [0..cycle-1]
755function PositiveMod(value, cycle: Int32or64): Int32or64; inline;
756begin
757 result := value mod cycle;
758 if result < 0 then //modulo can be negative
759 Inc(result, cycle);
760end;
761
762{ Table of precalc values. Note : the value is stored for
763 the first half of the cycle, and values are stored 'minus 1'
764 in order to stay in the range 0..65535 }
765var
766 sinTab65536: packed array of word;
767 byteSqrtTab: packed array of word;
768
769function Sin65536(value: word): Int32or64;
770var b: integer;
771begin
772 //allocate array
773 if sinTab65536 = nil then
774 setlength(sinTab65536,32768);
775
776 if value >= 32768 then //function is upside down after half-period
777 begin
778 b := value xor 32768;
779 if sinTab65536[b] = 0 then //precalc
780 sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1;
781 result := not sinTab65536[b];
782 end else
783 begin
784 b := value;
785 if sinTab65536[b] = 0 then //precalc
786 sinTab65536[b] := round((sin(b*2*Pi/65536)+1)*65536/2)-1;
787 {$hints off}
788 result := sinTab65536[b]+1;
789 {$hints on}
790 end;
791end;
792
793function Cos65536(value: word): Int32or64;
794begin
795 {$PUSH}{$R-}
796 result := Sin65536(value+16384); //cosine is translated
797 {$POP}
798end;
799
800procedure PrecalcSin65536;
801var
802 i: Integer;
803begin
804 for i := 0 to 32767 do Sin65536(i);
805end;
806
807procedure PrecalcByteSqrt;
808var i: integer;
809begin
810 if byteSqrtTab = nil then
811 begin
812 setlength(byteSqrtTab,256);
813 for i := 0 to 255 do
814 byteSqrtTab[i] := round(sqrt(i/255)*255);
815 end;
816end;
817
818function ByteSqrt(value: byte): byte; inline;
819begin
820 if byteSqrtTab = nil then PrecalcByteSqrt;
821 result := ByteSqrtTab[value];
822end;
823
824function DetectFileFormat(AFilenameUTF8: string): TBGRAImageFormat;
825var stream: TFileStreamUTF8;
826begin
827 try
828 stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite);
829 except
830 result := ifUnknown;
831 exit;
832 end;
833 try
834 result := DetectFileFormat(stream, ExtractFileExt(AFilenameUTF8));
835 finally
836 stream.Free;
837 end;
838end;
839
840function DetectFileFormat(AStream: TStream; ASuggestedExtensionUTF8: string
841 ): TBGRAImageFormat;
842var
843 scores: array[TBGRAImageFormat] of integer;
844 imageFormat,bestImageFormat: TBGRAImageFormat;
845 bestScore: integer;
846
847 procedure DetectFromStream;
848 var
849 {%H-}magic: packed array[0..7] of byte;
850 {%H-}dwords: packed array[0..9] of DWORD;
851 magicAsText: string;
852
853 streamStartPos, maxFileSize: Int64;
854 expectedFileSize: DWord;
855
856 procedure DetectTarga;
857 var
858 paletteCount: integer;
859 {%H-}targaPixelFormat: packed record pixelDepth: byte; imgDescriptor: byte; end;
860 begin
861 if (magic[1] in[$00,$01]) and (magic[2] in[0,1,2,3,9,10,11]) and (maxFileSize >= 18) then
862 begin
863 paletteCount:= magic[5] + magic[6] shl 8;
864 if ((paletteCount = 0) and (magic[7] = 0)) or
865 (magic[7] in [16,24,32]) then //check palette bit count
866 begin
867 AStream.Position:= streamStartPos+16;
868 if AStream.Read({%H-}targaPixelFormat,2) = 2 then
869 begin
870 if (targaPixelFormat.pixelDepth in [8,16,24,32]) and
871 (targaPixelFormat.imgDescriptor and 15 < targaPixelFormat.pixelDepth) then
872 inc(scores[ifTarga],2);
873 end;
874 end;
875 end;
876 end;
877
878 procedure DetectLazPaint;
879 var
880 w,h: dword;
881 i: integer;
882 begin
883 if (copy(magicAsText,1,8) = 'LazPaint') then //with header
884 begin
885 AStream.Position:= streamStartPos+8;
886 if AStream.Read(dwords,10*4) = 10*4 then
887 begin
888 for i := 0 to 6 do dwords[i] := LEtoN(dwords[i]);
889 if (dwords[0] = 0) and (dwords[1] <= maxFileSize) and (dwords[5] <= maxFileSize) and
890 (dwords[9] <= maxFileSize) and
891 (dwords[6] = 0) then inc(scores[ifLazPaint],2);
892 end;
893 end else //without header
894 if ((magic[0] <> 0) or (magic[1] <> 0)) and (magic[2] = 0) and (magic[3] = 0) and
895 ((magic[4] <> 0) or (magic[5] <> 0)) and (magic[6] = 0) and (magic[7] = 0) then
896 begin
897 w := magic[0] + (magic[1] shl 8);
898 h := magic[4] + (magic[5] shl 8);
899 AStream.Position:= streamStartPos+8;
900 if AStream.Read(dwords,4) = 4 then
901 begin
902 dwords[0] := LEtoN(dwords[0]);
903 if (dwords[0] > 0) and (dwords[0] < 65536) then
904 begin
905 if 12+dwords[0] < expectedFileSize then
906 begin
907 AStream.Position:= streamStartPos+12+dwords[0];
908 if AStream.Read(dwords,6*4) = 6*4 then
909 begin
910 for i := 0 to 5 do dwords[i] := LEtoN(dwords[i]);
911 if (dwords[0] <= w) and (dwords[1] <= h) and
912 (dwords[2] <= w) and (dwords[3] <= h) and
913 (dwords[2] >= dwords[0]) and (dwords[3] >= dwords[1]) and
914 ((dwords[4] = 0) or (dwords[4] = 1)) and
915 (dwords[5] > 0) then inc(scores[ifLazPaint],1);
916 end;
917 end;
918 end;
919 end;
920 end;
921 end;
922
923 begin
924 fillchar({%H-}magic, sizeof(magic), 0);
925 fillchar({%H-}dwords, sizeof(dwords), 0);
926
927 streamStartPos:= AStream.Position;
928 maxFileSize:= AStream.Size - streamStartPos;
929 if maxFileSize < 8 then exit;
930 if AStream.Read(magic,sizeof(magic)) <> sizeof(magic) then
931 begin
932 fillchar(scores,sizeof(scores),0);
933 exit;
934 end;
935 setlength(magicAsText,sizeof(magic));
936 move(magic[0],magicAsText[1],sizeof(magic));
937
938 if (magic[0] = $ff) and (magic[1] = $d8) then
939 begin
940 inc(scores[ifJpeg]);
941 if (magic[2] = $ff) and (magic[3] >= $c0) then inc(scores[ifJpeg]);
942 end;
943
944 if (magic[0] = $89) and (magic[1] = $50) and (magic[2] = $4e) and
945 (magic[3] = $47) and (magic[4] = $0d) and (magic[5] = $0a) and
946 (magic[6] = $1a) and (magic[7] = $0a) then inc(scores[ifPng],2);
947
948 if (copy(magicAsText,1,6)='GIF87a') or (copy(magicAsText,1,6)='GIF89a') then inc(scores[ifGif],2);
949
950 if (magic[0] = $0a) and (magic[1] in [0,2,3,4,5]) and (magic[2] in[0,1]) and (magic[3] in[1,2,4,8]) then
951 inc(scores[ifPcx],2);
952
953 if (copy(magicAsText,1,2)='BM') then
954 begin
955 inc(scores[ifBmp]);
956 expectedFileSize:= magic[2] + (magic[3] shl 8) + (magic[4] shl 16) + (magic[5] shl 24);
957 if expectedFileSize = maxFileSize then inc(scores[ifBmp]);
958 end else
959 if (copy(magicAsText,1,2)='RL') then
960 begin
961 inc(scores[ifBmpMioMap]);
962 if (magic[2] in[0,1]) and (magic[3] = 0) then inc(scores[ifBmpMioMap]);
963 end;
964
965 if (magic[0] = $00) and (magic[1] = $00) and (magic[3] = $00) and
966 (magic[4] + (magic[5] shl 8) > 0) then
967 begin
968 if magic[2] = $01 then
969 inc(scores[ifIco])
970 else if magic[2] = $02 then
971 inc(scores[ifCur]);
972 end;
973
974 if (copy(magicAsText,1,4) = 'PDN3') then
975 begin
976 expectedFileSize:= 6 + (magic[4] + (magic[5] shl 8) + (magic[6] shl 16)) + 2;
977 if expectedFileSize <= maxFileSize then
978 begin
979 inc(scores[ifPaintDotNet]);
980 if magic[7] = $3c then inc(scores[ifPaintDotNet]);
981 end;
982 end;
983
984 if (copy(magicAsText,1,4) = 'oXo ') then
985 begin
986 inc(scores[ifPhoxo],1);
987 if (magic[4] = 1) and (magic[5] = 0) and (magic[6] = 0) and (magic[7] = 0) then
988 inc(scores[ifPhoxo],1);
989 end;
990
991 DetectLazPaint;
992
993 if (magic[0] = $50) and (magic[1] = $4b) and (magic[2] = $03) and (magic[3] = $04) then
994 begin
995 if DefaultBGRAImageReader[ifOpenRaster] = nil then inc(scores[ifOpenRaster]) else
996 with CreateBGRAImageReader(ifOpenRaster) do
997 try
998 AStream.Position := streamStartPos;
999 if CheckContents(AStream) then inc(scores[ifOpenRaster],2);
1000 finally
1001 Free;
1002 end;
1003 end;
1004
1005 if (copy(magicAsText,1,4) = '8BPS') and (magic[4] = $00) and (magic[5] = $01) then inc(scores[ifPsd],2);
1006
1007 DetectTarga;
1008
1009 if (copy(magicAsText,1,2)='II') and (magic[2] = 42) and (magic[3]=0) then inc(scores[ifTiff]) else
1010 if (copy(magicAsText,1,2)='MM') and (magic[2] = 0) and (magic[3]=42) then inc(scores[ifTiff]);
1011
1012 if (copy(magicAsText,1,8) = '/* XPM *') or (copy(magicAsText,1,6) = '! XPM2') then inc(scores[ifXPixMap]);
1013
1014 if (copy(magicAsText,1,6) = '<?xml ') then inc(scores[ifSvg]);
1015
1016 AStream.Position := streamStartPos;
1017 end;
1018
1019var
1020 extFormat: TBGRAImageFormat;
1021
1022begin
1023 result := ifUnknown;
1024 for imageFormat:= low(TBGRAImageFormat) to high(TBGRAImageFormat) do
1025 scores[imageFormat] := 0;
1026
1027 ASuggestedExtensionUTF8:= UTF8LowerCase(ASuggestedExtensionUTF8);
1028 if (ASuggestedExtensionUTF8 <> '') and (ASuggestedExtensionUTF8[1] <> '.') then //first UTF8 char is in first pos
1029 ASuggestedExtensionUTF8 := '.'+ASuggestedExtensionUTF8;
1030
1031 extFormat:= SuggestImageFormat(ASuggestedExtensionUTF8);
1032 if extFormat <> ifUnknown then inc(scores[extFormat]);
1033
1034 If AStream <> nil then DetectFromStream;
1035
1036 bestScore := 0;
1037 bestImageFormat:= ifUnknown;
1038 for imageFormat:=low(TBGRAImageFormat) to high(TBGRAImageFormat) do
1039 if scores[imageFormat] > bestScore then
1040 begin
1041 bestScore:= scores[imageFormat];
1042 bestImageFormat:= imageFormat;
1043 end;
1044 result := bestImageFormat;
1045end;
1046
1047function SuggestImageFormat(AFilenameOrExtensionUTF8: string): TBGRAImageFormat;
1048var ext: string;
1049 posDot: integer;
1050begin
1051 result := ifUnknown;
1052
1053 ext := ExtractFileName(AFilenameOrExtensionUTF8);
1054 posDot := LastDelimiter('.', ext);
1055 if posDot <> 0 then ext := copy(ext,posDot,length(ext)-posDot+1)
1056 else ext := '.'+ext;
1057 ext := UTF8LowerCase(ext);
1058
1059 if (ext = '.jpg') or (ext = '.jpeg') then result := ifJpeg else
1060 if (ext = '.png') then result := ifPng else
1061 if (ext = '.gif') then result := ifGif else
1062 if (ext = '.pcx') then result := ifPcx else
1063 if (ext = '.bmp') then result := ifBmp else
1064 if (ext = '.ico') then result := ifIco else
1065 if (ext = '.cur') then result := ifCur else
1066 if (ext = '.pdn') then result := ifPaintDotNet else
1067 if (ext = '.lzp') then result := ifLazPaint else
1068 if (ext = '.ora') then result := ifOpenRaster else
1069 if (ext = '.psd') then result := ifPsd else
1070 if (ext = '.tga') then result := ifTarga else
1071 if (ext = '.tif') or (ext = '.tiff') then result := ifTiff else
1072 if (ext = '.xwd') then result := ifXwd else
1073 if (ext = '.xpm') then result := ifXPixMap else
1074 if (ext = '.oxo') then result := ifPhoxo else
1075 if (ext = '.svg') then result := ifSvg;
1076end;
1077
1078function SuggestImageExtension(AFormat: TBGRAImageFormat): string;
1079begin
1080 case AFormat of
1081 ifJpeg: result := 'jpg';
1082 ifPng: result := 'png';
1083 ifGif: result := 'gif';
1084 ifBmp: result := 'bmp';
1085 ifBmpMioMap: result := 'bmp';
1086 ifIco: result := 'ico';
1087 ifCur: result := 'ico';
1088 ifPcx: result := 'pcx';
1089 ifPaintDotNet: result := 'pdn';
1090 ifLazPaint: result := 'lzp';
1091 ifOpenRaster: result := 'ora';
1092 ifPhoxo: result := 'oXo';
1093 ifPsd: result := 'psd';
1094 ifTarga: result := 'tga';
1095 ifTiff: result := 'tif';
1096 ifXwd: result := 'xwd';
1097 ifXPixMap: result := 'xpm';
1098 ifSvg: result := 'svg';
1099 else result := '?';
1100 end;
1101end;
1102
1103function CreateBGRAImageReader(AFormat: TBGRAImageFormat): TFPCustomImageReader;
1104begin
1105 if DefaultBGRAImageReader[AFormat] = nil then
1106 begin
1107 case AFormat of
1108 ifUnknown: raise exception.Create('The image format is unknown.');
1109 ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to read this image.');
1110 ifPaintDotNet: raise exception.Create('You need to call BGRAPaintNet.RegisterPaintNetFormat to read this image.');
1111 ifSvg: raise exception.Create('You need to call BGRA.RegisterSvgFormat to read this image.');
1112 else
1113 raise exception.Create('The image reader is not registered for this image format.');
1114 end;
1115 end;
1116 result := DefaultBGRAImageReader[AFormat].Create;
1117end;
1118
1119function CreateBGRAImageWriter(AFormat: TBGRAImageFormat; AHasTransparentPixels: boolean): TFPCustomImageWriter;
1120begin
1121 if DefaultBGRAImageWriter[AFormat] = nil then
1122 begin
1123 case AFormat of
1124 ifUnknown: raise exception.Create('The image format is unknown');
1125 ifOpenRaster: raise exception.Create('You need to call BGRAOpenRaster.RegisterOpenRasterFormat to write with this image format.');
1126 ifPhoxo: raise exception.Create('You need to call BGRAPhoxo.RegisterPhoxoFormat to write with this image format.');
1127 else
1128 raise exception.Create('The image writer is not registered for this image format.');
1129 end;
1130 end;
1131
1132 if AFormat = ifPng then
1133 begin
1134 result := TBGRAWriterPNG.Create;
1135 TBGRAWriterPNG(result).UseAlpha := AHasTransparentPixels;
1136 end else
1137 if AFormat = ifBmp then
1138 begin
1139 result := TFPWriterBMP.Create;
1140 if AHasTransparentPixels then
1141 TFPWriterBMP(result).BitsPerPixel := 32 else
1142 TFPWriterBMP(result).BitsPerPixel := 24;
1143 end else
1144 if AFormat = ifXPixMap then
1145 begin
1146 result := TFPWriterXPM.Create;
1147 TFPWriterXPM(result).ColorCharSize := 2;
1148 end else
1149 result := DefaultBGRAImageWriter[AFormat].Create;
1150end;
1151
1152operator =(const AGuid1, AGuid2: TGuid): boolean;
1153begin
1154 result := CompareMem(@AGuid1, @AGuid2, sizeof(TGuid));
1155end;
1156
1157type
1158 TResourceType = record
1159 ext: string;
1160 code: pchar;
1161 end;
1162
1163const
1164 ResourceTypes: array[1..7] of TResourceType =
1165 ((ext: 'CUR'; code: RT_GROUP_CURSOR),
1166 (ext: 'BMP'; code: RT_BITMAP),
1167 (ext: 'ICO'; code: RT_GROUP_ICON),
1168 (ext: 'DAT'; code: RT_RCDATA),
1169 (ext: 'DATA'; code: RT_RCDATA),
1170 (ext: 'HTM'; code: RT_HTML),
1171 (ext: 'HTML'; code: RT_HTML));
1172
1173{ TBGRAResourceManager }
1174
1175function TBGRAResourceManager.GetWinResourceType(AExtension: string): pchar;
1176var
1177 i: Integer;
1178begin
1179 if (AExtension <> '') and (AExtension[1]='.') then delete(AExtension,1,1);
1180 for i := low(ResourceTypes) to high(ResourceTypes) do
1181 if AExtension = ResourceTypes[i].ext then
1182 exit(ResourceTypes[i].code);
1183
1184 exit(RT_RCDATA);
1185end;
1186
1187function TBGRAResourceManager.GetResourceStream(AFilename: string): TStream;
1188var
1189 name,ext: RawByteString;
1190 rt: PChar;
1191begin
1192 ext := UpperCase(ExtractFileExt(AFilename));
1193 name := ChangeFileExt(AFilename,'');
1194 rt := GetWinResourceType(ext);
1195
1196 if (rt = RT_GROUP_CURSOR) or (rt = RT_GROUP_ICON) then
1197 raise exception.Create('Not implemented');
1198
1199 result := TResourceStream.Create(HINSTANCE, name, rt);
1200end;
1201
1202function TBGRAResourceManager.IsWinResource(AFilename: string): boolean;
1203var
1204 name,ext: RawByteString;
1205 rt: PChar;
1206begin
1207 ext := UpperCase(ExtractFileExt(AFilename));
1208 name := ChangeFileExt(AFilename,'');
1209 rt := GetWinResourceType(ext);
1210 result := FindResource(HINSTANCE, pchar(name), rt)<>0;
1211end;
1212
1213{$IFDEF BGRABITMAP_USE_LCL}
1214type
1215
1216 { TLCLResourceManager }
1217
1218 TLCLResourceManager = class(TBGRAResourceManager)
1219 protected
1220 function FindLazarusResource(AFilename: string): TLResource;
1221 public
1222 function GetResourceStream(AFilename: string): TStream; override;
1223 function IsWinResource(AFilename: string): boolean; override;
1224 end;
1225
1226function TLCLResourceManager.FindLazarusResource(AFilename: string): TLResource;
1227var
1228 name,ext: RawByteString;
1229begin
1230 ext := UpperCase(ExtractFileExt(AFilename));
1231 if (ext<>'') and (ext[1]='.') then Delete(ext,1,1);
1232 name := ChangeFileExt(AFilename,'');
1233 if ext<>'' then
1234 result := LazarusResources.Find(name,ext)
1235 else
1236 result := LazarusResources.Find(name);
1237end;
1238
1239function TLCLResourceManager.GetResourceStream(AFilename: string): TStream;
1240var
1241 res: TLResource;
1242begin
1243 res := FindLazarusResource(AFilename);
1244 if Assigned(res) then
1245 result := TLazarusResourceStream.CreateFromHandle(res)
1246 else
1247 result := inherited GetResourceStream(AFilename);
1248end;
1249
1250function TLCLResourceManager.IsWinResource(AFilename: string): boolean;
1251begin
1252 if FindLazarusResource(AFilename)<>nil then
1253 result := false
1254 else
1255 Result:=inherited IsWinResource(AFilename);
1256end;
1257
1258{$ENDIF}
1259
1260initialization
1261
1262 {$DEFINE INCLUDE_INIT}
1263 {$I bgrapixel.inc}
1264
1265 {$DEFINE INCLUDE_INIT}
1266 {$I csscolorconst.inc}
1267
1268 DefaultBGRAImageWriter[ifJpeg] := TFPWriterJPEG;
1269 DefaultBGRAImageWriter[ifPng] := TBGRAWriterPNG;
1270 DefaultBGRAImageWriter[ifBmp] := TFPWriterBMP;
1271 DefaultBGRAImageWriter[ifPcx] := TFPWriterPCX;
1272 DefaultBGRAImageWriter[ifTarga] := TFPWriterTarga;
1273 DefaultBGRAImageWriter[ifXPixMap] := TFPWriterXPM;
1274 DefaultBGRAImageWriter[ifTiff] := TFPWriterTiff;
1275 //writing XWD not implemented
1276
1277 DefaultBGRAImageReader[ifXwd] := TFPReaderXWD;
1278 //the other readers are registered by their unit
1279
1280 {$IFDEF BGRABITMAP_USE_LCL}
1281 BGRAResource := TLCLResourceManager.Create;
1282 {$ELSE}
1283 BGRAResource := TBGRAResourceManager.Create;
1284 {$ENDIF}
1285
1286finalization
1287
1288 {$DEFINE INCLUDE_FINAL}
1289 {$I csscolorconst.inc}
1290
1291 {$DEFINE INCLUDE_FINAL}
1292 {$I bgrapixel.inc}
1293
1294 BGRAResource.Free;
1295end.
Note: See TracBrowser for help on using the repository browser.