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

fcl-image JPEG reader/writer, PSD reader

Browse Source 
fcl-image JPEG reader - procedure inside InternalRead moved to protected virtual methods
fcl-image JPEG writer - procedure inside InternalWrite moved to protected virtual methods
fcl-image PSD reader - code fixes for reading palettes, added Read of Image Resources Section
This commit is contained in:
Massimo Magnano 2023-07-07 12:01:55 +02:00
parent 486f3a0c7f
commit fc714078a9
3 changed files with 600 additions and 434 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

508
packages/fcl-image/src/fpreadjpeg.pas
View File

@ -16,6 +16,9 @@
ToDo:
- palette
2023-07 - Massimo Magnano
- procedure inside InternalRead moved to protected methods (virtual)
}
unit FPReadJPEG;
@ -45,9 +48,15 @@ type
TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth);
TJPEGReadPerformance = (jpBestQuality, jpBestSpeed);
TExifOrientation = ( // all angles are clockwise
eoUnknown, eoNormal, eoMirrorHor, eoRotate180, eoMirrorVert,
eoMirrorHorRot270, eoRotate90, eoMirrorHorRot90, eoRotate270
);
TFPReaderJPEG = class(TFPCustomImageReader)
private
FSmoothing: boolean;
FSmoothing,
Continue: boolean;
FMinHeight:integer;
FMinWidth:integer;
FWidth: Integer;
@ -59,13 +68,18 @@ type
FInfo: jpeg_decompress_struct;
FScale: TJPEGScale;
FPerformance: TJPEGReadPerformance;
FOrientation: TExifOrientation;
procedure SetPerformance(const AValue: TJPEGReadPerformance);
procedure SetSmoothing(const AValue: boolean);
protected
procedure ReadHeader(Str: TStream; Img: TFPCustomImage); virtual;
procedure ReadPixels(Str: TStream; Img: TFPCustomImage); virtual;
procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
function InternalCheck(Str: TStream): boolean; override;
class function InternalSize(Str:TStream): TPoint; override;
property CompressInfo : jpeg_decompress_struct Read Finfo Write FInfo;
property Orientation: TExifOrientation Read FOrientation Write FOrientation;
public
constructor Create; override;
destructor Destroy; override;
@ -80,12 +94,6 @@ type
implementation
type
TExifOrientation = ( // all angles are clockwise
eoUnknown, eoNormal, eoMirrorHor, eoRotate180, eoMirrorVert,
eoMirrorHorRot270, eoRotate90, eoMirrorHorRot90, eoRotate270
);
procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
StartSize: integer);
var
@ -170,14 +178,99 @@ begin
FPerformance:=AValue;
end;
procedure TFPReaderJPEG.InternalRead(Str: TStream; Img: TFPCustomImage);
procedure TFPReaderJPEG.ReadHeader(Str: TStream; Img: TFPCustomImage);
var
MemStream: TMemoryStream;
Orientation: TExifOrientation;
S: TSize;
function TranslateSize(const Sz: TSize): TSize;
begin
case FOrientation of
eoUnknown, eoNormal, eoMirrorHor, eoMirrorVert, eoRotate180: Result := Sz;
eoMirrorHorRot270, eoRotate90, eoMirrorHorRot90, eoRotate270:
begin
Result.Width := Sz.Height;
Result.Height := Sz.Width;
end;
end;
end;
begin
jpeg_read_header(@FInfo, TRUE);
if FInfo.saw_EXIF_marker and (FInfo.orientation >= Ord(Low(TExifOrientation))) and (FInfo.orientation <= Ord(High(TExifOrientation))) then
FOrientation := TExifOrientation(FInfo.orientation)
else
FOrientation := Low(TExifOrientation);
S := TranslateSize(TSize.Create(FInfo.image_width, FInfo.image_height));
FWidth := S.Width;
FHeight := S.Height;
FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE;
FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo);
end;
procedure TFPReaderJPEG.ReadPixels(Str: TStream; Img: TFPCustomImage);
var
SampArray: JSAMPARRAY;
SampRow: JSAMPROW;
Color: TFPColor;
LinesRead: Cardinal;
x: Integer;
y: Integer;
c: word;
Status,Scan: integer;
ReturnValue,RestartLoop: Boolean;
procedure InitReadingPixels;
var d1,d2:integer;
function DToScale(inp:integer):TJPEGScale;
begin
if inp>7 then Result:=jsEighth else
if inp>3 then Result:=jsQuarter else
if inp>1 then Result:=jsHalf else
Result:=jsFullSize;
end;
begin
FInfo.scale_num := 1;
if (FMinWidth>0) and (FMinHeight>0) then
if (FInfo.image_width>FMinWidth) or (FInfo.image_height>FMinHeight) then
begin
d1:=Round((FInfo.image_width / FMinWidth)-0.5);
d2:=Round((FInfo.image_height / FMinHeight)-0.5);
if d1>d2 then fScale:=DToScale(d2) else fScale:=DtoScale(d1);
end;
FInfo.scale_denom :=1 shl Byte(FScale); //1
FInfo.do_block_smoothing := FSmoothing;
if FGrayscale then FInfo.out_color_space := JCS_GRAYSCALE;
if (FInfo.out_color_space = JCS_GRAYSCALE) then
begin
FInfo.quantize_colors := True;
FInfo.desired_number_of_colors := 256;
end;
if FPerformance = jpBestSpeed then
begin
FInfo.dct_method := JDCT_IFAST;
FInfo.two_pass_quantize := False;
FInfo.dither_mode := JDITHER_ORDERED;
// FInfo.do_fancy_upsampling := False; can create an AV inside jpeglib
end;
if FProgressiveEncoding then
begin
FInfo.enable_2pass_quant := FInfo.two_pass_quantize;
FInfo.buffered_image := True;
end;
end;
function TranslatePixel(const Px: TPoint): TPoint;
begin
case Orientation of
case FOrientation of
eoUnknown, eoNormal: Result := Px;
eoMirrorHor:
begin
@ -217,87 +310,13 @@ var
end;
end;
function TranslateSize(const Sz: TSize): TSize;
begin
case Orientation of
eoUnknown, eoNormal, eoMirrorHor, eoMirrorVert, eoRotate180: Result := Sz;
eoMirrorHorRot270, eoRotate90, eoMirrorHorRot90, eoRotate270:
begin
Result.Width := Sz.Height;
Result.Height := Sz.Width;
end;
end;
end;
procedure SetSource;
begin
MemStream.Position:=0;
jpeg_stdio_src(@FInfo, @MemStream);
end;
procedure ReadHeader;
procedure SetPixel(x, y: integer; const C: TFPColor);
var
S: TSize;
P: TPoint;
begin
jpeg_read_header(@FInfo, TRUE);
if FInfo.saw_EXIF_marker and (FInfo.orientation >= Ord(Low(TExifOrientation))) and (FInfo.orientation <= Ord(High(TExifOrientation))) then
Orientation := TExifOrientation(FInfo.orientation)
else
Orientation := Low(TExifOrientation);
S := TranslateSize(TSize.Create(FInfo.image_width, FInfo.image_height));
FWidth := S.Width;
FHeight := S.Height;
FGrayscale := FInfo.jpeg_color_space = JCS_GRAYSCALE;
FProgressiveEncoding := jpeg_has_multiple_scans(@FInfo);
end;
procedure InitReadingPixels;
var d1,d2:integer;
function DToScale(inp:integer):TJPEGScale;
begin
if inp>7 then Result:=jsEighth else
if inp>3 then Result:=jsQuarter else
if inp>1 then Result:=jsHalf else
Result:=jsFullSize;
end;
begin
FInfo.scale_num := 1;
if (FMinWidth>0) and (FMinHeight>0) then
if (FInfo.image_width>FMinWidth) or (FInfo.image_height>FMinHeight) then
begin
d1:=Round((FInfo.image_width / FMinWidth)-0.5);
d2:=Round((FInfo.image_height / FMinHeight)-0.5);
if d1>d2 then fScale:=DToScale(d2) else fScale:=DtoScale(d1);
end;
FInfo.scale_denom :=1 shl Byte(FScale); //1
FInfo.do_block_smoothing := FSmoothing;
if FGrayscale then FInfo.out_color_space := JCS_GRAYSCALE;
if (FInfo.out_color_space = JCS_GRAYSCALE) then
begin
FInfo.quantize_colors := True;
FInfo.desired_number_of_colors := 256;
end;
if FPerformance = jpBestSpeed then
begin
FInfo.dct_method := JDCT_IFAST;
FInfo.two_pass_quantize := False;
FInfo.dither_mode := JDITHER_ORDERED;
// FInfo.do_fancy_upsampling := False; can create an AV inside jpeglib
end;
if FProgressiveEncoding then
begin
FInfo.enable_2pass_quant := FInfo.two_pass_quantize;
FInfo.buffered_image := True;
end;
P := TPoint.Create(x,y);
P := TranslatePixel(P);
Img.Colors[P.x, P.y] := C;
end;
function CorrectCMYK(const C: TFPColor): TFPColor;
@ -314,6 +333,7 @@ var
Result.blue:=(C.blue-MinColor) shl 8;
Result.alpha:=alphaOpaque;
end;
function CorrectYCCK(const C: TFPColor): TFPColor;
var
MinColor: word;
@ -327,175 +347,163 @@ var
Result.blue:=(C.blue-MinColor) shl 8;
Result.alpha:=alphaOpaque;
end;
procedure ReadPixels;
procedure SetPixel(x, y: integer; const C: TFPColor);
var
P: TPoint;
begin
P := TPoint.Create(x,y);
P := TranslatePixel(P);
Img.Colors[P.x, P.y] := C;
end;
procedure OutputScanLines();
var
Continue: Boolean;
SampArray: JSAMPARRAY;
SampRow: JSAMPROW;
Color: TFPColor;
LinesRead: Cardinal;
x: Integer;
y: Integer;
c: word;
Status,Scan: integer;
ReturnValue,RestartLoop: Boolean;
procedure OutputScanLines();
var
x: integer;
begin
Color.Alpha:=alphaOpaque;
y:=0;
while (FInfo.output_scanline < FInfo.output_height) do begin
// read one line per call
LinesRead := jpeg_read_scanlines(@FInfo, SampArray, 1);
if LinesRead<1 then begin
ReturnValue:=false;
break;
end;
if (FInfo.jpeg_color_space = JCS_CMYK) then
for x:=0 to FInfo.output_width-1 do begin
Color.Red:=SampRow^[x*4+0];
Color.Green:=SampRow^[x*4+1];
Color.Blue:=SampRow^[x*4+2];
Color.alpha:=SampRow^[x*4+3];
SetPixel(x, y, CorrectCMYK(Color));
end
else
if (FInfo.jpeg_color_space = JCS_YCCK) then
for x:=0 to FInfo.output_width-1 do begin
Color.Red:=SampRow^[x*4+0];
Color.Green:=SampRow^[x*4+1];
Color.Blue:=SampRow^[x*4+2];
Color.alpha:=SampRow^[x*4+3];
SetPixel(x, y, CorrectYCCK(Color));
end
else
if fgrayscale then begin
for x:=0 to FInfo.output_width-1 do begin
c:= SampRow^[x] shl 8;
Color.Red:=c;
Color.Green:=c;
Color.Blue:=c;
SetPixel(x, y, Color);
end;
end
else begin
for x:=0 to FInfo.output_width-1 do begin
Color.Red:=SampRow^[x*3+0] shl 8;
Color.Green:=SampRow^[x*3+1] shl 8;
Color.Blue:=SampRow^[x*3+2] shl 8;
SetPixel(x, y, Color);
end;
end;
inc(y);
end;
end;
x: integer;
begin
InitReadingPixels;
Color.Alpha:=alphaOpaque;
y:=0;
while (FInfo.output_scanline < FInfo.output_height) do begin
// read one line per call
LinesRead := jpeg_read_scanlines(@FInfo, SampArray, 1);
if LinesRead<1 then begin
ReturnValue:=false;
break;
end;
if (FInfo.jpeg_color_space = JCS_CMYK) then
for x:=0 to FInfo.output_width-1 do begin
Color.Red:=SampRow^[x*4+0];
Color.Green:=SampRow^[x*4+1];
Color.Blue:=SampRow^[x*4+2];
Color.alpha:=SampRow^[x*4+3];
SetPixel(x, y, CorrectCMYK(Color));
end
else
if (FInfo.jpeg_color_space = JCS_YCCK) then
for x:=0 to FInfo.output_width-1 do begin
Color.Red:=SampRow^[x*4+0];
Color.Green:=SampRow^[x*4+1];
Color.Blue:=SampRow^[x*4+2];
Color.alpha:=SampRow^[x*4+3];
SetPixel(x, y, CorrectYCCK(Color));
end
else
if fgrayscale then begin
for x:=0 to FInfo.output_width-1 do begin
c:= SampRow^[x] shl 8;
Color.Red:=c;
Color.Green:=c;
Color.Blue:=c;
SetPixel(x, y, Color);
end;
end
else begin
for x:=0 to FInfo.output_width-1 do begin
Color.Red:=SampRow^[x*3+0] shl 8;
Color.Green:=SampRow^[x*3+1] shl 8;
Color.Blue:=SampRow^[x*3+2] shl 8;
SetPixel(x, y, Color);
end;
end;
inc(y);
end;
end;
begin
InitReadingPixels;
Continue:=true;
Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
if not Continue then exit;
Continue:=true;
Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
if not Continue then exit;
jpeg_start_decompress(@FInfo);
jpeg_start_decompress(@FInfo);
Img.SetSize(FWidth,FHeight);
Img.SetSize(FWidth,FHeight);
GetMem(SampArray,SizeOf(JSAMPROW));
GetMem(SampRow,FInfo.output_width*FInfo.output_components);
SampArray^[0]:=SampRow;
try
case FProgressiveEncoding of
false:
begin
GetMem(SampArray,SizeOf(JSAMPROW));
GetMem(SampRow,FInfo.output_width*FInfo.output_components);
SampArray^[0]:=SampRow;
try
case FProgressiveEncoding of
false:
begin
ReturnValue:=true;
OutputScanLines();
if FInfo.buffered_image then jpeg_finish_output(@FInfo);
end;
true:
begin
while true do begin
(* The RestartLoop variable drops a placeholder for suspension
mode, or partial jpeg decode, return and continue. In case
of support this suspension, the RestartLoop:=True should be
changed by an Exit and in the routine enter detects that it
is being called from a suspended state to not
reinitialize some buffer *)
RestartLoop:=false;
repeat
status := jpeg_consume_input(@FInfo);
until (status=JPEG_SUSPENDED) or (status=JPEG_REACHED_EOI);
ReturnValue:=true;
OutputScanLines();
if FInfo.buffered_image then jpeg_finish_output(@FInfo);
end;
true:
begin
while true do begin
(* The RestartLoop variable drops a placeholder for suspension
mode, or partial jpeg decode, return and continue. In case
of support this suspension, the RestartLoop:=True should be
changed by an Exit and in the routine enter detects that it
is being called from a suspended state to not
reinitialize some buffer *)
RestartLoop:=false;
repeat
status := jpeg_consume_input(@FInfo);
until (status=JPEG_SUSPENDED) or (status=JPEG_REACHED_EOI);
ReturnValue:=true;
if FInfo.output_scanline = 0 then begin
Scan := FInfo.input_scan_number;
(* if we haven't displayed anything yet (output_scan_number==0)
and we have enough data for a complete scan, force output
of the last full scan *)
if (FInfo.output_scan_number = 0) and (Scan > 1) and
(status <> JPEG_REACHED_EOI) then Dec(Scan);
if FInfo.output_scanline = 0 then begin
Scan := FInfo.input_scan_number;
(* if we haven't displayed anything yet (output_scan_number==0)
and we have enough data for a complete scan, force output
of the last full scan *)
if (FInfo.output_scan_number = 0) and (Scan > 1) and
(status <> JPEG_REACHED_EOI) then Dec(Scan);
if not jpeg_start_output(@FInfo, Scan) then begin
RestartLoop:=true; (* I/O suspension *)
if not jpeg_start_output(@FInfo, Scan) then begin
RestartLoop:=true; (* I/O suspension *)
end;
end;
if not RestartLoop then begin
if (FInfo.output_scanline = $ffffff) then
FInfo.output_scanline := 0;
OutputScanLines();
if ReturnValue=false then begin
if (FInfo.output_scanline = 0) then begin
(* didn't manage to read any lines - flag so we don't call
jpeg_start_output() multiple times for the same scan *)
FInfo.output_scanline := $ffffff;
end;
RestartLoop:=true; (* I/O suspension *)
end;
if not RestartLoop then begin
if (FInfo.output_scanline = $ffffff) then
FInfo.output_scanline := 0;
OutputScanLines();
if ReturnValue=false then begin
if (FInfo.output_scanline = 0) then begin
(* didn't manage to read any lines - flag so we don't call
jpeg_start_output() multiple times for the same scan *)
FInfo.output_scanline := $ffffff;
if (FInfo.output_scanline = FInfo.output_height) then begin
if not jpeg_finish_output(@FInfo) then begin
RestartLoop:=true; (* I/O suspension *)
end;
RestartLoop:=true; (* I/O suspension *)
end;
if not RestartLoop then begin
if (FInfo.output_scanline = FInfo.output_height) then begin
if not jpeg_finish_output(@FInfo) then begin
RestartLoop:=true; (* I/O suspension *)
end;
if not RestartLoop then begin
if (jpeg_input_complete(@FInfo) and
(FInfo.input_scan_number = FInfo.output_scan_number)) then
break;
if not RestartLoop then begin
if (jpeg_input_complete(@FInfo) and
(FInfo.input_scan_number = FInfo.output_scan_number)) then
break;
FInfo.output_scanline := 0;
end;
FInfo.output_scanline := 0;
end;
end;
end;
if RestartLoop then begin
(* Suspension mode, but as not supported by this implementation
it will simple break the loop to avoid endless looping. *)
break;
end;
end;
if RestartLoop then begin
(* Suspension mode, but as not supported by this implementation
it will simple break the loop to avoid endless looping. *)
break;
end;
end;
end;
finally
FreeMem(SampRow);
FreeMem(SampArray);
end;
end;
jpeg_finish_decompress(@FInfo);
Progress(psEnding, 100, false, Rect(0,0,0,0), '', Continue);
finally
FreeMem(SampRow);
FreeMem(SampArray);
end;
jpeg_finish_decompress(@FInfo);
Progress(psEnding, 100, false, Rect(0,0,0,0), '', Continue);
end;
procedure TFPReaderJPEG.InternalRead(Str: TStream; Img: TFPCustomImage);
var
MemStream: TMemoryStream;
begin
FWidth:=0;
FHeight:=0;
@ -517,9 +525,12 @@ begin
FProgressMgr.pub.progress_monitor := @ProgressCallback;
FProgressMgr.instance := Self;
FInfo.progress := @FProgressMgr.pub;
SetSource;
ReadHeader;
ReadPixels;
MemStream.Position:=0;
jpeg_stdio_src(@FInfo, @MemStream);
ReadHeader(MemStream, Img);
ReadPixels(MemStream, Img);
finally
jpeg_Destroy_Decompress(@FInfo);
end;
@ -535,18 +546,6 @@ var
JInfo: jpeg_decompress_struct;
JError: jpeg_error_mgr;
procedure SetSource;
begin
jpeg_stdio_src(@JInfo, @Str);
end;
procedure ReadHeader;
begin
jpeg_read_header(@JInfo, TRUE);
Result.X := JInfo.image_width;
Result.Y := JInfo.image_height;
end;
begin
FillChar(JInfo,SizeOf(JInfo),0);
if Str.Position < Str.Size then begin
@ -554,8 +553,11 @@ begin
JInfo.err := @JError;
jpeg_CreateDecompress(@JInfo, JPEG_LIB_VERSION, SizeOf(JInfo));
try
SetSource;
ReadHeader;
jpeg_stdio_src(@JInfo, @Str);
jpeg_read_header(@JInfo, TRUE);
Result.X := JInfo.image_width;
Result.Y := JInfo.image_height;
finally
jpeg_Destroy_Decompress(@JInfo);
end;

378
packages/fcl-image/src/fpreadpsd.pas
View File

@ -14,6 +14,11 @@
**********************************************************************
ToDo: read further images
2023-07 - Massimo Magnano
- code fixes for reading palettes
- added Read of Image Resources Section
}
unit FPReadPSD;
@ -24,6 +29,133 @@ interface
uses
Classes, SysUtils, FPimage;
const
{ Image color modes }
PSD_BITMAP = 0; { Bitmap image }
PSD_GRAYSCALE = 1; { Greyscale image }
PSD_INDEXED = 2; { Indexed image }
PSD_RGB = 3; { RGB image }
PSD_CMYK = 4; { CMYK }
PSD_MULTICHANNEL = 7; { Multichannel image }
PSD_DUOTONE = 8; { Duotone image }
PSD_LAB = 9; { L*a*b image }
{ Image color spaces }
PSD_CS_RGB = 0; { RGB }
PSD_CS_HSB = 1; { Hue, Saturation, Brightness }
PSD_CS_CMYK = 2; { CMYK }
PSD_CS_PANTONE = 3; { Pantone matching system (Lab) }
PSD_CS_FOCOLTONE = 4; { Focoltone color system (CMYK) }
PSD_CS_TRUMATCH = 5; { Trumatch color (CMYK) }
PSD_CS_TOYO = 6; { Toyo 88 colorfinder 1050 (Lab) }
PSD_CS_LAB = 7; { L*a*b }
PSD_CS_GRAYSCALE = 8; { Grey scale }
PSD_CS_HKS = 10; { HKS colors (CMYK) }
PSD_CS_DIC = 11; { DIC color guide (Lab) }
PSD_CS_ANPA = 3000; { Anpa color (Lab) }
{ Image Resource IDs }
PSD_ResourceSectionSignature ='8BIM';
PSD_PS2_IMAGE_INFO = $03e8; { Obsolete - ps 2.0 image info }
PSD_MAC_PRINT_INFO = $03e9; { Optional - Mac print manager print info record }
PSD_PS2_COLOR_TAB = $03eb; { Obsolete - ps 2.0 indexed color table }
PSD_RESN_INFO = $03ed; { ResolutionInfo structure }
PSD_ALPHA_NAMES = $03ee; { Alpha channel names }
PSD_DISPLAY_INFO = $03ef; { Superceded by PSD_DISPLAY_INFO_NEW for ps CS3 and higher - DisplayInfo structure }
PSD_CAPTION = $03f0; { Optional - Caption string }
PSD_BORDER_INFO = $03f1; { Border info }
PSD_BACKGROUND_COL = $03f2; { Background color }
PSD_PRINT_FLAGS = $03f3; { Print flags }
PSD_GREY_HALFTONE = $03f4; { Greyscale and multichannel halftoning info }
PSD_COLOR_HALFTONE = $03f5; { Color halftoning info }
PSD_DUOTONE_HALFTONE = $03f6; { Duotone halftoning info }
PSD_GREY_XFER = $03f7; { Greyscale and multichannel transfer functions }
PSD_COLOR_XFER = $03f8; { Color transfer functions }
PSD_DUOTONE_XFER = $03f9; { Duotone transfer functions }
PSD_DUOTONE_INFO = $03fa; { Duotone image information }
PSD_EFFECTIVE_BW = $03fb; { Effective black & white values for dot range }
PSD_OBSOLETE_01 = $03fc; { Obsolete }
PSD_EPS_OPT = $03fd; { EPS options }
PSD_QUICK_MASK = $03fe; { Quick mask info }
PSD_OBSOLETE_02 = $03ff; { Obsolete }
PSD_LAYER_STATE = $0400; { Layer state info }
PSD_WORKING_PATH = $0401; { Working path (not saved) }
PSD_LAYER_GROUP = $0402; { Layers group info }
PSD_OBSOLETE_03 = $0403; { Obsolete }
PSD_IPTC_NAA_DATA = $0404; { IPTC-NAA record (IMV4.pdf) }
PSD_IMAGE_MODE_RAW = $0405; { Image mode for raw format files }
PSD_JPEG_QUAL = $0406; { JPEG quality }
PSD_GRID_GUIDE = $0408; { Grid & guide info }
PSD_THUMB_RES = $0409; { Thumbnail resource }
PSD_COPYRIGHT_FLG = $040a; { Copyright flag }
PSD_URL = $040b; { URL string }
PSD_THUMB_RES2 = $040c; { Thumbnail resource }
PSD_GLOBAL_ANGLE = $040d; { Superceded by PSD_NEW_COLOR_SAMPLER for ps CS3 and higher - Global angle }
PSD_COLOR_SAMPLER = $040e; { Superceded by PSD_NEW_COLOR_SAMPLER for ps CS3 and higher - Color samplers resource }
PSD_ICC_PROFILE = $040f; { ICC Profile }
PSD_WATERMARK = $0410; { Watermark }
PSD_ICC_UNTAGGED = $0411; { Do not use ICC profile flag }
PSD_EFFECTS_VISIBLE = $0412; { Show / hide all effects layers }
PSD_SPOT_HALFTONE = $0413; { Spot halftone }
PSD_DOC_IDS = $0414; { Document specific IDs }
PSD_ALPHA_NAMES_UNI = $0415; { Unicode alpha names }
PSD_IDX_COL_TAB_CNT = $0416; { Indexed color table count }
PSD_IDX_TRANSPARENT = $0417; { Index of transparent color (if any) }
PSD_GLOBAL_ALT = $0419; { Global altitude }
PSD_SLICES = $041a; { Slices }
PSD_WORKFLOW_URL_UNI = $041b; { Workflow URL - Unicode string }
PSD_JUMP_TO_XPEP = $041c; { Jump to XPEP (?) }
PSD_ALPHA_ID = $041d; { Alpha IDs }
PSD_URL_LIST_UNI = $041e; { URL list - unicode }
PSD_VERSION_INFO = $0421; { Version info }
PSD_EXIF_DATA = $0422; { Exif data block 1 }
PSD_EXIF_DATA_3 = $0423; { Exif data block 3 (?) }
PSD_XMP_DATA = $0424; { XMP data block }
PSD_CAPTION_DIGEST = $0425; { Caption digest }
PSD_PRINT_SCALE = $0426; { Print scale }
PSD_PIXEL_AR = $0428; { Pixel aspect ratio }
PSD_LAYER_COMPS = $0429; { Layer comps }
PSD_ALT_DUOTONE_COLOR = $042A;{ Alternative Duotone colors }
PSD_ALT_SPOT_COLOR = $042B; { Alternative Spot colors }
PSD_LAYER_SELECT_ID = $042D; { Layer selection ID }
PSD_HDR_TONING_INFO = $042E; { HDR toning information }
PSD_PRINT_INFO_SCALE = $042F; { Print scale }
PSD_LAYER_GROUP_E_ID = $0430; { Layer group(s) enabled ID }
PSD_COLOR_SAMPLER_NEW = $0431;{ Color sampler resource for ps CS3 and higher PSD files }
PSD_MEASURE_SCALE = $0432; { Measurement scale }
PSD_TIMELINE_INFO = $0433; { Timeline information }
PSD_SHEET_DISCLOSE = $0434; { Sheet discloser }
PSD_DISPLAY_INFO_NEW = $0435; { DisplayInfo structure for ps CS3 and higher PSD files }
PSD_ONION_SKINS = $0436; { Onion skins }
PSD_COUNT_INFO = $0438; { Count information }
PSD_PRINT_INFO = $043A; { Print information added in ps CS5 }
PSD_PRINT_STYLE = $043B; { Print style }
PSD_MAC_NSPRINTINFO = $043C; { Mac NSPrintInfo }
PSD_WIN_DEVMODE = $043D; { Windows DEVMODE }
PSD_AUTO_SAVE_PATH = $043E; { Auto save file path }
PSD_AUTO_SAVE_FORMAT = $043F; { Auto save format }
PSD_PATH_INFO_FIRST = $07d0; { First path info block }
PSD_PATH_INFO_LAST = $0bb6; { Last path info block }
PSD_CLIPPING_PATH = $0bb7; { Name of clipping path }
PSD_PLUGIN_R_FIRST = $0FA0; { First plugin resource }
PSD_PLUGIN_R_LAST = $1387; { Last plugin resource }
PSD_IMAGEREADY_VARS = $1B58; { Imageready variables }
PSD_IMAGEREADY_DATA = $1B59; { Imageready data sets }
PSD_LIGHTROOM_WORK = $1F40; { Lightroom workflow }
PSD_PRINT_FLAGS_2 = $2710; { Print flags }
{ Display resolution units }
PSD_RES_INCH = 1; { Pixels / inch }
PSD_RES_CM = 2; { Pixels / cm }
{ Width and height units }
PSD_UNIT_INCH = 1; { inches }
PSD_UNIT_CM = 2; { cm }
PSD_UNIT_POINT = 3; { points (72 points = 1 inch) }
PSD_UNIT_PICA = 4; { pica ( 6 pica = 1 inch) }
PSD_UNIT_COLUMN = 5;{ columns ( column defined in ps prefs, default = 2.5 inches) }
type
TRGB = packed record
Red, Green, Blue : Byte;
@ -33,7 +165,7 @@ type
L, a, b: byte;
end;
{ File Header Section }
TPSDHeader = packed record
Signature : array[0..3] of Char; // File IDs '8BPS'
Version : word; // Version number, always 1
@ -42,70 +174,31 @@ type
Rows : Cardinal; // Height of image in pixels (1-30000)
Columns : Cardinal; // Width of image in pixels (1-30000)
Depth : Word; // Number of bits per channel (1, 8, and 16)
Mode: Word; // Color mode
Mode: Word; // Color mode (see previous Image color modes consts)
end;
{
Mode Description
0 Bitmap (monochrome)
1 Gray-scale
2 Indexed color (palette color)
3 RGB color
4 CMYK color
7 Multichannel color
8 Duotone (halftone)
9 Lab color
}
TColorModeDataBlock = packed record
{ Image Resource Blocks }
TPSDResourceBlock = packed record
Types : array[0..3] of Char; // Always "8BIM"
ID:word; // (See table below)
Name:byte; // Even-length Pascal-format string, 2 bytes or longer
Size : Cardinal; // Length of resource data following, in bytes
Data:byte; // Resource data, padded to even length
ID:word; // see previous Image Resource IDs consts
NameLen:Byte; // Pascal-format string, 2 bytes or longer
Name:Char;
end;
{
ID Data Format Description
03e8 WORD[5] Channels, rows, columns, depth, and mode
03e9 Optional Macintosh print manager information
03eb Indexed color table
03ed (See below) Resolution information
"TResolutionInfo"
03ee BYTE[] Alpha channel names (Pascal-format strings)
03ef (See below) Display information for each channel
"TDisplayInfo"
03f0 BYTE[] Optional Pascal-format caption string
03f1 LONG, WORD Fixed-point border width, border units (see below)
03f2 Background color
03f3 BYTE[8] Print flags (see below)
03f4 Gray-scale and halftoning information
03f5 Color halftoning information
03f6 Duotone halftoning information
03f7 Gray-scale and multichannel transfer function
03f8 Color transfer functions
03f9 Duotone transfer functions
03fa Duotone image information
03fb BYTE[2] Effective black and white value for dot range
03fc
03fd EPS options
03fe WORD, BYTE Quick Mask channel ID, flag for mask initially empty
03ff
0400 WORD Index of target layer (0=bottom)
0401 Working path
0402 WORD[] Layers group info, group ID for dragging groups
0403
0404 IPTC-NAA record
0405 Image mode for raw-format files
0406 JPEG quality (Adobe internal)
07d0
0bb6 Saved path information
0bb7 Clipping pathname
2710 (See below) Print flags information
}
PPSDResourceBlock =^TPSDResourceBlock;
TPSDResourceBlockData = packed record
Size:LongWord;
Data:Byte;
end;
PPSDResourceBlockData =^TPSDResourceBlockData;
//MaxM: Resolution always recorded in a fixed point implied decimal int32
// with 16 bits before point and 16 after (cast as DWord and divide resolution by 2^16
TResolutionInfo = record
hRes:Cardinal; // Fixed-point number: pixels per inch
hRes:Cardinal; // Fixed-point number: pixels per inch (see note before)
hResUnit:word; // 1=pixels per inch, 2=pixels per centimeter
WidthUnit:word; // 1=in, 2=cm, 3=pt, 4=picas, 5=columns
vRes:Cardinal; // Fixed-point number: pixels per inch
vRes:Cardinal; // Fixed-point number: pixels per inch (see note before)
vResUnit:word; // 1=pixels per inch, 2=pixels per centimeter
HeightUnit:word; // 1=in, 2=cm, 3=pt, 4=picas, 5=columns
end;
@ -131,7 +224,6 @@ type
FOnCreateImage: TPSDCreateCompatibleImgEvent;
protected
FHeader : TPSDHeader;
FColorDataBlock: TColorModeDataBlock;
FBytesPerPixel : Byte;
FScanLine : PByte;
FLineSize : PtrInt;
@ -146,6 +238,8 @@ type
procedure CreateBWPalette;
function ReadPalette(Stream: TStream): boolean;
procedure AnalyzeHeader;
procedure ReadResourceBlockData(Img: TFPCustomImage; blockID:Word;
blockName:ShortString; Size:LongWord; Data:Pointer); virtual;
procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
function ReadScanLine(Stream: TStream): boolean; virtual;
procedure WriteScanLine(Img: TFPCustomImage); virtual;
@ -233,37 +327,57 @@ end;
function TFPReaderPSD.ReadPalette(Stream: TStream): boolean;
Var
I : Integer;
c : TFPColor;
OldPos: Integer;
BufSize:Longint;
PalBuf: array[0..767] of Byte;
ContProgress: Boolean;
procedure ReadPaletteFromStream;
var
i : Integer;
c : TFPColor;
{%H-}PalBuf: array[0..767] of Byte;
ContProgress: Boolean;
begin
Stream.Read({%H-}PalBuf, BufSize);
ContProgress:=true;
Progress(FPimage.psRunning, 0, False, Rect(0,0,0,0), '', ContProgress);
if not ContProgress then exit;
for i:=0 to BufSize div 3 do
begin
with c do
begin
Red:=PalBuf[I] shl 8;
Green:=PalBuf[I+(BufSize div 3)] shl 8;
Blue:=PalBuf[I+(BufSize div 3)* 2] shl 8;
Alpha:=alphaOpaque;
end;
FPalette.Add(c);
end;
end;
begin
Result:=false;
ThePalette.count := 0;
OldPos := Stream.Position;
Result:=False;
BufSize:=0;
Stream.Read(BufSize, SizeOf(BufSize));
BufSize:=BEtoN(BufSize);
Stream.Read(PalBuf, BufSize);
ContProgress:=true;
Progress(FPimage.psRunning, trunc(100.0 * (Stream.position / Stream.size)),
False, Rect(0,0,0,0), '', ContProgress);
if not ContProgress then exit;
For I:=0 To BufSize div 3 Do
Begin
With c do
begin
Red:=PalBuf[I] shl 8;
Green:=PalBuf[I+(BufSize div 3)] shl 8;
Blue:=PalBuf[I+(BufSize div 3)* 2] shl 8;
Alpha:=alphaOpaque;
end;
ThePalette.Add(C);
End;
Stream.Position := OldPos;
Result:=true;
Case FHeader.Mode of
PSD_BITMAP :begin // Bitmap (monochrome)
FPalette := TFPPalette.Create(0);
CreateBWPalette;
end;
PSD_GRAYSCALE,
PSD_DUOTONE:begin // Gray-scale or Duotone image
FPalette := TFPPalette.Create(0);
CreateGrayPalette;
end;
PSD_INDEXED:begin // Indexed color (palette color)
FPalette := TFPPalette.Create(0);
if (BufSize=0) then exit;
ReadPaletteFromStream;
end;
end;
Result:=True;
end;
procedure TFPReaderPSD.AnalyzeHeader;
@ -288,12 +402,76 @@ begin
end;
end;
procedure TFPReaderPSD.ReadResourceBlockData(Img: TFPCustomImage; blockID: Word;
blockName: ShortString; Size: LongWord; Data: Pointer);
begin
end;
procedure TFPReaderPSD.InternalRead(Stream: TStream; Img: TFPCustomImage);
var
H: Integer;
BufSize:Cardinal;
Encoding:word;
ContProgress: Boolean;
procedure ReadResourceBlocks;
var
TotalBlockSize,
pPosition:LongWord;
blockData,
curBlock :PPSDResourceBlock;
curBlockData :PPSDResourceBlockData;
signature:String[4];
blockName:ShortString;
blockID:Word;
dataSize:LongWord;
begin
//MaxM: Do NOT Remove the Casts after BEToN
Stream.Read(TotalBlockSize, 4);
TotalBlockSize :=BEtoN(DWord(TotalBlockSize));
GetMem(blockData, TotalBlockSize);
try
Stream.Read(blockData^, TotalBlockSize);
pPosition :=0;
curBlock :=blockData;
repeat
signature :=curBlock^.Types;
if (signature=PSD_ResourceSectionSignature) then
begin
blockID :=BEtoN(Word(curBlock^.ID));
blockName :=curBlock^.Name;
setLength(blockName, curBlock^.NameLen);
curBlockData :=PPSDResourceBlockData(curBlock);
Inc(Pointer(curBlockData), sizeof(TPSDResourceBlock));
if (curBlock^.NameLen>0) then //MaxM: Maybe tested, in all my tests is always 0
begin
Inc(Pointer(curBlockData), curBlock^.NameLen);
if not(Odd(curBlock^.NameLen))
then Inc(Pointer(curBlockData), 1);
end;
dataSize :=BEtoN(DWord(curBlockData^.Size));
Inc(Pointer(curBlockData), 4);
ReadResourceBlockData(Img, blockID, blockName, dataSize, curBlockData);
Inc(Pointer(curBlockData), dataSize);
end
else Inc(Pointer(curBlockData), 1); //skip padding or something went wrong, search for next '8BIM'
curBlock :=PPSDResourceBlock(curBlockData);
pPosition :=Pointer(curBlockData)-Pointer(blockData);
until (pPosition >= TotalBlockSize);
finally
FreeMem(blockData, TotalBlockSize);
end;
end;
begin
FScanLine:=nil;
FPalette:=nil;
@ -307,35 +485,17 @@ begin
Progress(FPimage.psRunning, trunc(100.0 * (Stream.position / Stream.size)), False, Rect(0,0,0,0), '', ContProgress);
if not ContProgress then exit;
AnalyzeHeader;
Case FHeader.Mode of
0:begin // Bitmap (monochrome)
FPalette := TFPPalette.Create(0);
CreateBWPalette;
end;
1, 8:begin // Gray-scale
FPalette := TFPPalette.Create(0);
CreateGrayPalette;
end;
2:begin // Indexed color (palette color)
FPalette := TFPPalette.Create(0);
if not ReadPalette(stream) then exit;
end;
end;
// color palette
ReadPalette(Stream);
if Assigned(OnCreateImage) then
OnCreateImage(Self,Img);
Img.SetSize(FWidth,FHeight);
// color palette
BufSize:=0;
Stream.Read(BufSize, SizeOf(BufSize));
BufSize:=BEtoN(BufSize);
Stream.Seek(BufSize, soCurrent);
// color data block
Stream.Read(BufSize, SizeOf(BufSize));
BufSize:=BEtoN(BufSize);
Stream.Read(FColorDataBlock, SizeOf(FColorDataBlock));
Stream.Seek(BufSize-SizeOf(FColorDataBlock), soCurrent);
// Image Resources Section
ReadResourceBlocks;
// mask
Stream.Read(BufSize, SizeOf(BufSize));
BufSize:=BEtoN(BufSize);

148
packages/fcl-image/src/fpwritejpeg.pas
View File

@ -13,6 +13,10 @@
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
2023-07 - Massimo Magnano
- procedure inside InternalWrite moved to protected methods (virtual)
}
unit FPWriteJPEG;
@ -31,14 +35,16 @@ type
TFPWriterJPEG = class(TFPCustomImageWriter)
private
FGrayscale: boolean;
FGrayscale, Continue: Boolean;
FInfo: jpeg_compress_struct;
FError: jpeg_error_mgr;
FProgressiveEncoding: boolean;
FQuality: TFPJPEGCompressionQuality;
FProgressMgr: TFPJPEGProgressManager;
protected
procedure InitWriting; virtual;
procedure InitWriting(Str: TStream; Img: TFPCustomImage); virtual;
procedure WriteHeader(Str: TStream; Img: TFPCustomImage); virtual;
procedure WritePixels(Str: TStream; Img: TFPCustomImage); virtual;
procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
property CompressInfo : jpeg_compress_struct Read FInfo Write FInfo;
public
@ -98,7 +104,7 @@ end;
{ TFPWriterJPEG }
procedure TFPWriterJPEG.InitWriting;
procedure TFPWriterJPEG.InitWriting(Str: TStream; Img: TFPCustomImage);
begin
FError := jpeg_std_error;
FInfo := Default(jpeg_compress_struct);
@ -107,13 +113,76 @@ begin
FInfo.progress := @FProgressMgr.pub;
FProgressMgr.pub.progress_monitor := @ProgressCallback;
FProgressMgr.instance := Self;
end;
procedure TFPWriterJPEG.WriteHeader(Str: TStream; Img: TFPCustomImage);
begin
FInfo.image_width := Img.Width;
FInfo.image_height := Img.Height;
if FGrayscale then
begin
FInfo.input_components := 1;
FInfo.in_color_space := JCS_GRAYSCALE;
end
else
begin
FInfo.input_components := 3; // RGB has 3 components
FInfo.in_color_space := JCS_RGB;
end;
jpeg_set_defaults(@FInfo);
jpeg_set_quality(@FInfo, FQuality, True);
if ProgressiveEncoding then
jpeg_simple_progression(@FInfo);
end;
procedure TFPWriterJPEG.WritePixels(Str: TStream; Img: TFPCustomImage);
var
LinesWritten: Cardinal;
SampArray: JSAMPARRAY;
SampRow: JSAMPROW;
Color: TFPColor;
x: Integer;
y: Integer;
begin
Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
if not Continue then exit;
jpeg_start_compress(@FInfo, True);
// write one line per call
GetMem(SampArray,SizeOf(JSAMPROW));
GetMem(SampRow,FInfo.image_width*FInfo.input_components);
SampArray^[0]:=SampRow;
try
y:=0;
while (FInfo.next_scanline < FInfo.image_height) do begin
if FGrayscale then
for x:=0 to FInfo.image_width-1 do
SampRow^[x]:=CalculateGray(Img.Colors[x,y]) shr 8
else
for x:=0 to FInfo.image_width-1 do begin
Color:=Img.Colors[x,y];
SampRow^[x*3+0]:=Color.Red shr 8;
SampRow^[x*3+1]:=Color.Green shr 8;
SampRow^[x*3+2]:=Color.Blue shr 8;
end;
LinesWritten := jpeg_write_scanlines(@FInfo, SampArray, 1);
if LinesWritten<1 then break;
inc(y);
end;
finally
FreeMem(SampRow);
FreeMem(SampArray);
end;
jpeg_finish_compress(@FInfo);
Progress(psEnding, 100, False, Rect(0,0,0,0), '', Continue);
end;
procedure TFPWriterJPEG.InternalWrite(Str: TStream; Img: TFPCustomImage);
var
MemStream: TMemoryStream;
Continue: Boolean;
procedure SetDestination;
begin
@ -124,71 +193,6 @@ var
jpeg_stdio_dest(@FInfo, @MemStream);
end;
procedure WriteHeader;
begin
FInfo.image_width := Img.Width;
FInfo.image_height := Img.Height;
if FGrayscale then
begin
FInfo.input_components := 1;
FInfo.in_color_space := JCS_GRAYSCALE;
end
else
begin
FInfo.input_components := 3; // RGB has 3 components
FInfo.in_color_space := JCS_RGB;
end;
jpeg_set_defaults(@FInfo);
jpeg_set_quality(@FInfo, FQuality, True);
if ProgressiveEncoding then
jpeg_simple_progression(@FInfo);
end;
procedure WritePixels;
var
LinesWritten: Cardinal;
SampArray: JSAMPARRAY;
SampRow: JSAMPROW;
Color: TFPColor;
x: Integer;
y: Integer;
begin
Progress(psStarting, 0, False, Rect(0,0,0,0), '', Continue);
if not Continue then exit;
jpeg_start_compress(@FInfo, True);
// write one line per call
GetMem(SampArray,SizeOf(JSAMPROW));
GetMem(SampRow,FInfo.image_width*FInfo.input_components);
SampArray^[0]:=SampRow;
try
y:=0;
while (FInfo.next_scanline < FInfo.image_height) do begin
if FGrayscale then
for x:=0 to FInfo.image_width-1 do
SampRow^[x]:=CalculateGray(Img.Colors[x,y]) shr 8
else
for x:=0 to FInfo.image_width-1 do begin
Color:=Img.Colors[x,y];
SampRow^[x*3+0]:=Color.Red shr 8;
SampRow^[x*3+1]:=Color.Green shr 8;
SampRow^[x*3+2]:=Color.Blue shr 8;
end;
LinesWritten := jpeg_write_scanlines(@FInfo, SampArray, 1);
if LinesWritten<1 then break;
inc(y);
end;
finally
FreeMem(SampRow);
FreeMem(SampArray);
end;
jpeg_finish_compress(@FInfo);
Progress(psEnding, 100, False, Rect(0,0,0,0), '', Continue);
end;
procedure EndWriting;
begin
jpeg_destroy_compress(@FInfo);
@ -198,10 +202,10 @@ begin
Continue := true;
MemStream:=nil;
try
InitWriting;
InitWriting(Str, Img);
SetDestination;
WriteHeader;
WritePixels;
WriteHeader(MemStream, Img);
WritePixels(MemStream, Img);
if MemStream<>Str then begin
MemStream.Position:=0;
Str.CopyFrom(MemStream,MemStream.Size);