diff --git a/packages/fcl-image/src/fpreadjpeg.pas b/packages/fcl-image/src/fpreadjpeg.pas index ee25ab398b..1a13cce492 100644 --- a/packages/fcl-image/src/fpreadjpeg.pas +++ b/packages/fcl-image/src/fpreadjpeg.pas @@ -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; diff --git a/packages/fcl-image/src/fpreadpsd.pas b/packages/fcl-image/src/fpreadpsd.pas index 9f4f1b8713..13827a0726 100644 --- a/packages/fcl-image/src/fpreadpsd.pas +++ b/packages/fcl-image/src/fpreadpsd.pas @@ -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); diff --git a/packages/fcl-image/src/fpwritejpeg.pas b/packages/fcl-image/src/fpwritejpeg.pas index b082245da5..1665d15635 100644 --- a/packages/fcl-image/src/fpwritejpeg.pas +++ b/packages/fcl-image/src/fpwritejpeg.pas @@ -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);