lcl: add TPicture.LoadFromStream, TPicture.SaveToStream based on image header sign (issue #0010006)

git-svn-id: trunk@24945 -

lcl/graphics.pp

@@ -804,6 +804,7 @@ type
     procedure GetSupportedSourceMimeTypes(List: TStrings); virtual;
     function GetResourceType: TResourceType; virtual;
     class function GetFileExtensions: string; virtual;
+    class function IsStreamFormatSupported(Stream: TStream): Boolean; virtual;
   public
     property Empty: Boolean read GetEmpty;
     property Height: Integer read GetHeight write SetHeight;
@@ -901,18 +902,25 @@ type
     procedure Progress(Sender: TObject; Stage: TProgressStage;
                        PercentDone: Byte; RedrawNow: Boolean; const R: TRect;
                        const Msg: string; var DoContinue: boolean); virtual;
+    procedure LoadFromStreamWithClass(Stream: TStream; AClass: TGraphicClass);
   public
     constructor Create;
     destructor Destroy; override;
-    procedure LoadFromFile(const Filename: string);
-    procedure SaveToFile(const Filename: string; const FileExt: string = '');
-    procedure SaveToStreamWithFileExt(Stream: TStream; const FileExt: string);
-    procedure LoadFromStreamWithFileExt(Stream: TStream; const FileExt: string);
-    procedure LoadFromLazarusResource(const AName: string);
+
+    procedure Clear; virtual;
+    // load methods
     procedure LoadFromClipboardFormat(FormatID: TClipboardFormat);
-    procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType;
-      FormatID: TClipboardFormat);
+    procedure LoadFromClipboardFormatID(ClipboardType: TClipboardType; FormatID: TClipboardFormat);
+    procedure LoadFromFile(const Filename: string);
+    procedure LoadFromLazarusResource(const AName: string);
+    procedure LoadFromStream(Stream: TStream);
+    procedure LoadFromStreamWithFileExt(Stream: TStream; const FileExt: string);
+    // save methods
     procedure SaveToClipboardFormat(FormatID: TClipboardFormat);
+    procedure SaveToFile(const Filename: string; const FileExt: string = '');
+    procedure SaveToStream(Stream: TStream);
+    procedure SaveToStreamWithFileExt(Stream: TStream; const FileExt: string);
+
     class function SupportsClipboardFormat(FormatID: TClipboardFormat): Boolean;
     procedure Assign(Source: TPersistent); override;
     class procedure RegisterFileFormat(const AnExtension, ADescription: string;
@@ -920,7 +928,6 @@ type
     class procedure RegisterClipboardFormat(FormatID: TClipboardFormat;
       AGraphicClass: TGraphicClass);
     class procedure UnregisterGraphicClass(AClass: TGraphicClass);
-    procedure Clear; virtual;
     function FindGraphicClassWithFileExt(const Ext: string;
       ExceptionOnNotFound: boolean = true): TGraphicClass;
   public
@@ -1412,6 +1419,7 @@ type
     procedure WriteStream(AStream: TMemoryStream); override;
   public
     class function GetFileExtensions: string; override;
+    class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
     class function IsFileExtensionSupported(const FileExtension: string): boolean;
     function LazarusResourceTypeValid(const ResourceType: string): boolean; override;
   end;
@@ -1470,6 +1478,7 @@ type
     procedure InitializeWriter(AImage: TLazIntfImage; AWriter: TFPCustomImageWriter); override;
     class function GetSharedImageClass: TSharedRasterImageClass; override;
   public
+    class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
     class function GetFileExtensions: string; override;
   end;
 
@@ -1487,6 +1496,7 @@ type
     class function GetWriterClass: TFPCustomImageWriterClass; override;
     class function GetSharedImageClass: TSharedRasterImageClass; override;
   public
+    class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
     class function GetFileExtensions: string; override;
   end;
 
@@ -1742,6 +1752,7 @@ type
     class function GetSharedImageClass: TSharedRasterImageClass; override;
   public
     constructor Create; override;
+    class function IsStreamFormatSupported(Stream: TStream): Boolean; override;
     class function GetFileExtensions: string; override;
   public
     property CompressionQuality: TJPEGQualityRange read FQuality write FQuality;

lcl/include/fpimagebitmap.inc

@@ -25,6 +25,21 @@ begin
   Result:='';
 end;
 
+class function TFPImageBitmap.IsStreamFormatSupported(Stream: TStream): Boolean;
+var
+  Pos: Int64;
+  Reader: TFPCustomImageReader;
+begin
+  Pos := Stream.Position;
+  Reader := GetReaderClass.Create;
+  try
+    Result := Reader.CheckContents(Stream);
+  finally
+    Reader.Free;
+    Stream.Position := Pos;
+  end;
+end;
+
 procedure TFPImageBitmap.FinalizeReader(AReader: TFPCustomImageReader);
 begin
 end;

lcl/include/graphic.inc

@@ -234,6 +234,11 @@ begin
   Result:='';
 end;
 
+class function TGraphic.IsStreamFormatSupported(Stream: TStream): Boolean;
+begin
+  Result := False;
+end;
+
 procedure TGraphic.LoadFromFile(const Filename: string);
 var
   Stream: TStream;

lcl/include/jpegimage.inc

@@ -29,6 +29,20 @@ begin
   FQuality := 75;
 end;
 
+class function TJPEGImage.IsStreamFormatSupported(Stream: TStream): Boolean;
+var
+  Pos: Int64;
+  SOI: Word;
+begin
+  Pos := Stream.Position;
+  try
+    Stream.Read(SOI, SizeOf(SOI));
+    Result := SOI = $FFD8;
+  finally
+    Stream.Position := Pos;
+  end;
+end;
+
 procedure TJPEGImage.FinalizeReader(AReader: TFPCustomImageReader);
 begin
   FProgressiveEncoding := TFPReaderJPEG(AReader).ProgressiveEncoding;

lcl/include/picture.inc

@@ -38,6 +38,7 @@ type
     function GetFormatFilter(Index: integer): String;
     function FindExt(const Ext: string): TGraphicClass;
     function FindClassName(const AClassname: string): TGraphicClass;
+    function FindByStreamFormat(Stream: TStream): TGraphicClass;
     procedure Remove(AClass: TGraphicClass);
     procedure BuildFilterStrings(GraphicClass: TGraphicClass;
                                  var Descriptions, Filters: string);
@@ -136,8 +137,7 @@ begin
   Result := nil;
 end;
 
-function TPicFileFormatsList.FindClassName(
-  const AClassName: string): TGraphicClass;
+function TPicFileFormatsList.FindClassName(const AClassName: string): TGraphicClass;
 var
   I: Integer;
 begin
@@ -150,6 +150,19 @@ begin
   Result := nil;
 end;
 
+function TPicFileFormatsList.FindByStreamFormat(Stream: TStream): TGraphicClass;
+var
+  I: Integer;
+begin
+  for I := Count - 1 downto 0 do
+  begin
+    Result := GetFormats(I)^.GraphicClass;
+    if Result.IsStreamFormatSupported(Stream) then
+      Exit;
+  end;
+  Result := nil;
+end;
+
 procedure TPicFileFormatsList.Remove(AClass: TGraphicClass);
 // remove all file formats which inherits from AClass
 var
@@ -514,6 +527,16 @@ begin
   end;
 end;
 
+procedure TPicture.LoadFromStream(Stream: TStream);
+var
+  GraphicClass: TGraphicClass;
+begin
+  GraphicClass := GetPicFileFormats.FindByStreamFormat(Stream);
+  if GraphicClass = nil then
+    raise EInvalidGraphic.Create(rsUnknownPictureFormat);
+  LoadFromStreamWithClass(Stream, GraphicClass);
+end;
+
 procedure TPicture.SaveToFile(const Filename: string; const FileExt: string = '');
 var
   Ext: string;
@@ -534,6 +557,12 @@ begin
   end;
 end;
 
+procedure TPicture.SaveToStream(Stream: TStream);
+begin
+  if Assigned(Graphic) then
+    Graphic.SaveToStream(Stream);
+end;
+
 procedure TPicture.SaveToStreamWithFileExt(Stream: TStream; const FileExt: string);
 var
   GraphicClass: TGraphicClass;
@@ -577,29 +606,8 @@ end;
 
 procedure TPicture.LoadFromStreamWithFileExt(Stream: TStream;
   const FileExt: string);
-var
-  GraphicClass: TGraphicClass;
-  NewGraphic: TGraphic;
-  ok: Boolean;
 begin
-  GraphicClass := FindGraphicClassWithFileExt(FileExt);
-
-  NewGraphic := GraphicClass.Create;
-  ok:=false;
-  try
-    NewGraphic.OnProgress := @Progress;
-    //DebugLn(['TPicture.LoadFromStreamWithFileExt ',Stream.Position,' ',Stream.Size,' ',DbgSName(Stream)]);
-    NewGraphic.LoadFromStream(Stream);
-    ok:=true;
-  finally
-    // this try..finally construction will in case of an exception
-    // not alter the error backtrace output
-    if not ok then NewGraphic.Free;
-  end;
-  FGraphic.Free;
-  FGraphic := NewGraphic;
-  FGraphic.OnChange := @Changed;
-  Changed(Self);
+  LoadFromStreamWithClass(Stream, FindGraphicClassWithFileExt(FileExt));
 end;
 
 procedure TPicture.LoadFromClipboardFormat(FormatID: TClipboardFormat);
@@ -709,6 +717,28 @@ begin
     FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg, DoContinue);
 end;
 
+procedure TPicture.LoadFromStreamWithClass(Stream: TStream; AClass: TGraphicClass);
+var
+  NewGraphic: TGraphic;
+  ok: Boolean;
+begin
+  NewGraphic := AClass.Create;
+  ok:=false;
+  try
+    NewGraphic.OnProgress := @Progress;
+    NewGraphic.LoadFromStream(Stream);
+    ok:=true;
+  finally
+    // this try..finally construction will in case of an exception
+    // not alter the error backtrace output
+    if not ok then NewGraphic.Free;
+  end;
+  FGraphic.Free;
+  FGraphic := NewGraphic;
+  FGraphic.OnChange := @Changed;
+  Changed(Self);
+end;
+
 procedure TPicture.ReadData(Stream: TStream);
 var
   GraphicClassName: Shortstring;

lcl/include/png.inc

@@ -35,6 +35,27 @@ begin
   Result := TSharedPortableNetworkGraphic;
 end;
 
+class function TPortableNetworkGraphic.IsStreamFormatSupported(Stream: TStream): Boolean;
+const
+  Signature: array[0..7] of Byte = ($89, $50, $4E, $47, $0D, $0A, $1A, $0A);
+var
+  Pos: Int64;
+  SigCheck: array[0..7] of byte;
+  r: integer;
+begin
+  Pos := Stream.Position;
+  try
+    Stream.Read(SigCheck, SizeOf(SigCheck));
+    Result := False;
+    for r := 0 to 7 do
+      if (SigCheck[r] <> Signature[r]) then
+        Exit;
+    Result := True;
+  finally
+    Stream.Position := Pos;
+  end;
+end;
+
 class function TPortableNetworkGraphic.GetWriterClass: TFPCustomImageWriterClass;
 begin
   Result := TLazWriterPNG;

lcl/include/pnm.inc

@@ -35,6 +35,24 @@ begin
   Result := TSharedPortableAnyMapGraphic;
 end;
 
+class function TPortableAnyMapGraphic.IsStreamFormatSupported(Stream: TStream): Boolean;
+var
+  Pos: Int64;
+  C: Char;
+begin
+  Pos := Stream.Position;
+  try
+    Stream.ReadBuffer(C, 1);
+    Result := (C = 'P');
+    if not Result then
+      Exit;
+    Stream.ReadBuffer(C, 1);
+    Result := (Ord(C)-Ord('0')) in [1..6];
+  finally
+    Stream.Position := Pos;
+  end;
+end;
+
 class function TPortableAnyMapGraphic.GetWriterClass: TFPCustomImageWriterClass;
 begin
   Result := TFPWriterPNM;

lcl/lclstrconsts.pas

@@ -194,6 +194,7 @@ resourceString
   rsErrorCreatingDeviceContext = 'Error creating device context for %s.%s';
   rsIndexOutOfBounds = '%s Index %d out of bounds 0 .. %d';
   rsUnknownPictureExtension = 'Unknown picture extension';
+  rsUnknownPictureFormat = 'Unknown picture format';
   rsBitmaps = 'Bitmaps';
   rsPixmap = 'Pixmap';
   rsPortableNetworkGraphic = 'Portable Network Graphic';