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

* Make compression struct accessible to descendants. Fixes issue #40327

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-06-19 14:26:57 +02:00
parent fa735ba7b2
commit ab3916b0f8
2 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -65,6 +65,7 @@ type
procedure InternalRead(Str: TStream; Img: TFPCustomImage); override; procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
function InternalCheck(Str: TStream): boolean; override; function InternalCheck(Str: TStream): boolean; override;
class function InternalSize(Str:TStream): TPoint; override; class function InternalSize(Str:TStream): TPoint; override;
property CompressInfo : jpeg_decompress_struct Read Finfo Write FInfo;
public public
constructor Create; override; constructor Create; override;
destructor Destroy; override; destructor Destroy; override;

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

@ -38,7 +38,9 @@ type
FQuality: TFPJPEGCompressionQuality; FQuality: TFPJPEGCompressionQuality;
FProgressMgr: TFPJPEGProgressManager; FProgressMgr: TFPJPEGProgressManager;
protected protected
procedure InitWriting; virtual;
procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override; procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
property CompressInfo : jpeg_compress_struct Read FInfo Write FInfo;
public public
constructor Create; override; constructor Create; override;
destructor Destroy; override; destructor Destroy; override;
@ -95,23 +97,24 @@ end;
{ TFPWriterJPEG } { TFPWriterJPEG }
procedure TFPWriterJPEG.InitWriting;
begin
FError := jpeg_std_error;
FInfo := Default(jpeg_compress_struct);
jpeg_create_compress(@FInfo);
FInfo.err := jerror.jpeg_std_error(FError);
FInfo.progress := @FProgressMgr.pub;
FProgressMgr.pub.progress_monitor := @ProgressCallback;
FProgressMgr.instance := Self;
end;
procedure TFPWriterJPEG.InternalWrite(Str: TStream; Img: TFPCustomImage); procedure TFPWriterJPEG.InternalWrite(Str: TStream; Img: TFPCustomImage);
var var
MemStream: TMemoryStream; MemStream: TMemoryStream;
Continue: Boolean; Continue: Boolean;
procedure InitWriting;
begin
FillChar(FInfo, sizeof(FInfo), 0);
FError := jpeg_std_error;
FInfo.err := jerror.jpeg_std_error(FError);
jpeg_create_compress(@FInfo);
FProgressMgr.pub.progress_monitor := @ProgressCallback;
FProgressMgr.instance := Self;
FInfo.progress := @FProgressMgr.pub;
end;
procedure SetDestination; procedure SetDestination;
begin begin
if Str is TMemoryStream then if Str is TMemoryStream then