1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAOpenRaster;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 uses
9   BGRAClasses, SysUtils, BGRALayers, zipper, DOM, BGRABitmap, BGRALayerOriginal,
10   BGRASVGShapes, FPImage, BGRASVG;
11 
12 const
13   OpenRasterMimeType = 'image/openraster'; //do not change, it's part of the file format
14   OpenRasterSVGDefaultDPI = 90;
15 
16 type
17 
18   { TBGRAOpenRasterDocument }
19 
20   TBGRAOpenRasterDocument = class(TBGRALayeredBitmap)
21   private
22     FFiles: array of record
23       Filename: string;
24       Stream: TMemoryStream;
25     end;
26     FStackXML: TXMLDocument;
27     FZipInputStream: TStream;
28     procedure SetMimeType(AValue: string);
29   protected
30     Procedure ZipOnCreateStream(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry);
31     Procedure ZipOnDoneStream(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry);
32     Procedure ZipOnOpenInputStream(Sender : TObject; var AStream : TStream);
33     Procedure ZipOnCloseInputStream(Sender : TObject; var AStream : TStream);
34     procedure ClearFiles;
35     function GetMemoryStream(AFilename: string): TMemoryStream;
36     procedure SetMemoryStream(AFilename: string; AStream: TMemoryStream);
37     function AddLayerFromMemoryStream(ALayerFilename: string): integer;
38     function CopyRasterLayerToMemoryStream(ALayerIndex: integer; ALayerFilename: string): boolean;
39     procedure CopySVGToMemoryStream(ASVG: TBGRASVG; ASVGMatrix: TAffineMatrix; AOutFilename: string; out AOffset: TPoint);
40     function CopyBitmapToMemoryStream(ABitmap: TBGRABitmap; AFilename: string): boolean;
41     procedure SetMemoryStreamAsString(AFilename: string; AContent: string);
42     function GetMemoryStreamAsString(AFilename: string): string;
43     procedure UnzipFromStream(AStream: TStream; AFileList: TStrings = nil);
44     procedure UnzipFromFile(AFilenameUTF8: string);
45     procedure ZipToFile(AFilenameUTF8: string);
46     procedure ZipToStream(AStream: TStream);
47     procedure CopyThumbnailToMemoryStream(AMaxWidth, AMaxHeight: integer);
48     procedure AnalyzeZip; virtual;
49     procedure PrepareZipToSave; virtual;
50     function GetMimeType: string; override;
51     procedure InternalLoadFromStream(AStream: TStream);
52     procedure InternalSaveToStream(AStream: TStream);
53 
54   public
55     constructor Create; overload; override;
56     constructor Create(AWidth, AHeight: integer); overload; override;
57     procedure Clear; override;
58     function CheckMimeType(AStream: TStream): boolean;
59     procedure LoadFlatImageFromStream(AStream: TStream;
60               out ANbLayers: integer;
61               out ABitmap: TBGRABitmap);
62     procedure LoadFromStream(AStream: TStream); override;
63     procedure LoadFromFile(const filenameUTF8: string); override;
64     procedure SaveToStream(AStream: TStream); override;
65     procedure SaveToFile(const filenameUTF8: string); override;
66     property MimeType : string read GetMimeType write SetMimeType;
67     property StackXML : TXMLDocument read FStackXML;
68   end;
69 
70   { TFPReaderOpenRaster }
71 
72   TFPReaderOpenRaster = class(TFPCustomImageReader)
73     private
74       FWidth,FHeight,FNbLayers: integer;
75     protected
76       function InternalCheck(Stream: TStream): boolean; override;
77       procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
78     public
79       property Width: integer read FWidth;
80       property Height: integer read FHeight;
81       property NbLayers: integer read FNbLayers;
82   end;
83 
84   { TFPWriterOpenRaster }
85 
86   TFPWriterOpenRaster = class(TFPCustomImageWriter)
87     protected
88       procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
89   end;
90 
91 procedure RegisterOpenRasterFormat;
92 
93 implementation
94 
95 uses XMLRead, XMLWrite, BGRABitmapTypes, zstream, BGRAUTF8,
96   UnzipperExt, BGRASVGOriginal, BGRATransform, BGRASVGType, math;
97 
98 const
99   MergedImageFilename = 'mergedimage.png';
100   LayerStackFilename = 'stack.xml';
101 
102 function IsZipStream(stream: TStream): boolean;
103 var
104   header:  packed array[0..1] of char;
105   SavePos: int64;
106 begin
107   Result := False;
108   try
109     if stream.Position + 2 < Stream.Size then
110     begin
111       header  := #0#0;
112       SavePos := stream.Position;
113       stream.Read(header, 2);
114       stream.Position := SavePos;
115       if (header[0] = 'P') and (header[1] = 'K') then
116         Result := True;
117     end;
118   except
119     on ex: Exception do ;
120   end;
121 end;
122 
123 { TFPWriterOpenRaster }
124 
125 procedure TFPWriterOpenRaster.InternalWrite(Str: TStream; Img: TFPCustomImage);
126 var doc: TBGRAOpenRasterDocument;
127   tempBmp: TBGRABitmap;
128   x,y: integer;
129 
130 begin
131   doc := TBGRAOpenRasterDocument.Create;
132   if Img is TBGRABitmap then doc.AddLayer(Img as TBGRABitmap) else
133   begin
134     tempBmp := TBGRABitmap.Create(img.Width,img.Height);
135     for y := 0 to Img.Height-1 do
136       for x := 0 to img.Width-1 do
137         tempBmp.SetPixel(x,y, FPColorToBGRA(img.Colors[x,y]));
138     doc.AddOwnedLayer(tempBmp);
139   end;
140   doc.SaveToStream(Str);
141   doc.Free;
142 end;
143 
144 { TFPReaderOpenRaster }
145 
InternalChecknull146 function TFPReaderOpenRaster.InternalCheck(Stream: TStream): boolean;
147 var magic: packed array[0..3] of byte;
148   OldPos,BytesRead: Int64;
149   doc : TBGRAOpenRasterDocument;
150 begin
151   Result:=false;
152   if Stream=nil then exit;
153   oldPos := stream.Position;
154   {$PUSH}{$HINTS OFF}
155   BytesRead := Stream.Read({%H-}magic,sizeof(magic));
156   {$POP}
157   stream.Position:= OldPos;
158   if BytesRead<>sizeof(magic) then exit;
159   if (magic[0] = $50) and (magic[1] = $4b) and (magic[2] = $03) and (magic[3] = $04) then
160   begin
161     doc := TBGRAOpenRasterDocument.Create;
162     result := doc.CheckMimeType(Stream);
163     doc.Free;
164   end;
165 end;
166 
167 procedure TFPReaderOpenRaster.InternalRead(Stream: TStream; Img: TFPCustomImage);
168 var
169   layeredImage: TBGRAOpenRasterDocument;
170   flat: TBGRABitmap;
171   x,y: integer;
172 begin
173   FWidth := 0;
174   FHeight:= 0;
175   FNbLayers:= 0;
176   layeredImage := TBGRAOpenRasterDocument.Create;
177   try
178     layeredImage.LoadFlatImageFromStream(Stream, FNbLayers, flat);
179     if Assigned(flat) then
180     begin
181       FWidth := flat.Width;
182       FHeight := flat.Height;
183     end else
184     begin
185       layeredImage.LoadFromStream(Stream);
186       flat := layeredImage.ComputeFlatImage;
187       FWidth:= layeredImage.Width;
188       FHeight:= layeredImage.Height;
189       FNbLayers:= layeredImage.NbLayers;
190     end;
191     try
192       if Img is TBGRACustomBitmap then
193         TBGRACustomBitmap(img).Assign(flat)
194       else
195       begin
196         Img.SetSize(flat.Width,flat.Height);
197         for y := 0 to flat.Height-1 do
198           for x := 0 to flat.Width-1 do
199             Img.Colors[x,y] := BGRAToFPColor(flat.GetPixel(x,y));
200       end;
201     finally
202       flat.free;
203     end;
204     FreeAndNil(layeredImage);
205   except
206     on ex: Exception do
207     begin
208       layeredImage.Free;
209       raise Exception.Create('Error while loading OpenRaster file. ' + ex.Message);
210     end;
211   end;
212 end;
213 
214 { TBGRAOpenRasterDocument }
215 
216 procedure TBGRAOpenRasterDocument.AnalyzeZip;
217 
218   function CountLayersRec(stackNode: TDOMNode): integer;
219   var i: integer;
220     layerNode: TDOMNode;
221   begin
222     result := 0;
223     for i := stackNode.ChildNodes.Length-1 downto 0 do
224     begin
225       layerNode:= stackNode.ChildNodes[i];
226       if (layerNode.NodeName = 'layer') and Assigned(layerNode.Attributes) then
227         inc(result) else
228       if (layerNode.NodeName = 'stack') then
229         inc(result, CountLayersRec(layerNode));
230     end;
231   end;
232 
233 var
234   totalLayerCount, doneLayerCount: integer;
235 
236   procedure AddLayersRec(stackNode: TDOMNode);
237   var i,j : integer;
238     layerNode, attr: TDOMNode;
239     idx,x,y: integer;
240     float: double;
241     errPos: integer;
242     opstr : string;
243     gammastr: string;
244   begin
245     for i := stackNode.ChildNodes.Length-1 downto 0 do
246     begin
247       OnLayeredBitmapLoadProgress(doneLayerCount*100 div totalLayerCount);
248       layerNode:= stackNode.ChildNodes[i];
249       if layerNode.NodeName = 'stack' then
250         AddLayersRec(layerNode) else
251       if (layerNode.NodeName = 'layer') and Assigned(layerNode.Attributes) then
252       begin
253         attr := layerNode.Attributes.GetNamedItem('src');
254         idx := AddLayerFromMemoryStream(UTF8Encode(attr.NodeValue));
255         if idx <> -1 then
256         begin
257           x := 0;
258           y := 0;
259           gammastr := '';
260           for j := 0 to layerNode.Attributes.Length-1 do
261           begin
262             attr := layerNode.Attributes[j];
263             if lowercase(attr.NodeName) = 'opacity' then
264             begin
265               val(attr.NodeValue, float, errPos);
266               if errPos = 0 then
267               begin
268                 if float < 0 then float := 0;
269                 if float > 1 then float := 1;
270                 LayerOpacity[idx] := round(float*255);
271               end;
272             end else
273             if lowercase(attr.NodeName) = 'gamma-correction' then
274               gammastr := string(attr.NodeValue) else
275             if lowercase(attr.NodeName) = 'visibility' then
276               LayerVisible[idx] := (attr.NodeValue = 'visible') or (attr.NodeValue = 'yes') or (attr.NodeValue = '1') else
277             if (lowercase(attr.NodeName) = 'x') or (lowercase(attr.NodeName) = 'y') then
278             begin
279               val(attr.NodeValue, float, errPos);
280               if errPos = 0 then
281               begin
282                 if float < -(MaxInt shr 1) then float := -(MaxInt shr 1);
283                 if float > (MaxInt shr 1) then float := (MaxInt shr 1);
284                 if (lowercase(attr.NodeName) = 'x') then x := round(float);
285                 if (lowercase(attr.NodeName) = 'y') then y := round(float);
286               end;
287             end else
288             if lowercase(attr.NodeName) = 'name' then
289               LayerName[idx] := UTF8Encode(attr.NodeValue) else
290             if lowercase(attr.NodeName) = 'composite-op' then
291             begin
292               opstr := StringReplace(lowercase(string(attr.NodeValue)),'_','-',[rfReplaceAll]);
293               if (pos(':',opstr) = 0) and (opstr <> 'xor') then opstr := 'svg:'+opstr;
294               //parse composite op
295               if (opstr = 'svg:src-over') or (opstr = 'krita:dissolve') then
296                 BlendOperation[idx] := boTransparent else
297               if opstr = 'svg:lighten' then
298                 BlendOperation[idx] := boLighten else
299               if opstr = 'svg:screen' then
300                 BlendOperation[idx] := boScreen else
301               if opstr = 'svg:color-dodge' then
302                 BlendOperation[idx] := boColorDodge else
303               if (opstr = 'svg:color-burn') or (opstr = 'krita:gamma_dark'){approx} then
304                 BlendOperation[idx] := boColorBurn else
305               if opstr = 'svg:darken' then
306                 BlendOperation[idx] := boDarken else
307               if (opstr = 'svg:plus') or (opstr = 'svg:add') or (opstr = 'krita:linear_dodge') then
308                 BlendOperation[idx] := boLinearAdd else
309               if (opstr = 'svg:multiply') or (opstr = 'krita:bumpmap') then
310                 BlendOperation[idx] := boMultiply else
311               if opstr = 'svg:overlay' then
312                 BlendOperation[idx] := boOverlay else
313               if opstr = 'svg:soft-light' then
314                 BlendOperation[idx] := boSvgSoftLight else
315               if opstr = 'svg:hard-light' then
316                 BlendOperation[idx] := boHardLight else
317               if opstr = 'svg:difference' then
318                 BlendOperation[idx] := boLinearDifference else
319               if (opstr = 'krita:inverse-subtract') or (opstr = 'krita:linear-burn') then
320                 BlendOperation[idx] := boLinearSubtractInverse else
321               if opstr = 'krita:subtract' then
322                 BlendOperation[idx] := boLinearSubtract else
323               if (opstr = 'svg:difference') or
324                 (opstr = 'krita:equivalence') then
325                 BlendOperation[idx] := boLinearDifference else
326               if (opstr = 'svg:exclusion') or
327                 (opstr = 'krita:exclusion') then
328                 BlendOperation[idx] := boLinearExclusion else
329               if opstr = 'krita:divide' then
330                 BlendOperation[idx] := boDivide else
331               if opstr = 'bgra:soft-light' then
332                 BlendOperation[idx] := boSoftLight else
333               if opstr = 'bgra:nice-glow' then
334                 BlendOperation[idx] := boNiceGlow else
335               if opstr = 'bgra:glow' then
336                 BlendOperation[idx] := boGlow else
337               if opstr = 'bgra:reflect' then
338                 BlendOperation[idx] := boReflect else
339               if opstr = 'bgra:negation' then
340                 BlendOperation[idx] := boLinearNegation else
341               if (opstr = 'bgra:xor') or (opstr = 'xor') then
342                 BlendOperation[idx] := boXor else
343               if opstr = 'bgra:mask' then
344                 BlendOperation[idx] := boMask else
345               if opstr = 'bgra:linear-multiply-saturation' then
346                 BlendOperation[idx] := boLinearMultiplySaturation else
347               if opstr = 'svg:hue' then
348                 BlendOperation[idx] := boCorrectedHue else
349               if opstr = 'svg:color' then
350                 BlendOperation[idx] := boCorrectedColor else
351               if opstr = 'svg:luminosity' then
352                 BlendOperation[idx] := boCorrectedLightness else
353               if opstr = 'svg:saturation' then
354                 BlendOperation[idx] := boCorrectedSaturation else
355               if opstr = 'krita:hue-hsl' then
356                 BlendOperation[idx] := boLinearHue else
357               if opstr = 'krita:color-hsl' then
358                 BlendOperation[idx] := boLinearColor else
359               if opstr = 'krita:lightness' then
360                 BlendOperation[idx] := boLinearLightness else
361               if opstr = 'krita:saturation-hsl' then
362                 BlendOperation[idx] := boLinearSaturation else
363               begin
364                 //messagedlg('Unknown blend operation : ' + attr.NodeValue,mtInformation,[mbOk],0);
365                 BlendOperation[idx] := boTransparent;
366               end;
367             end;
368           end;
369           if LayerOriginalGuid[idx] <> GUID_NULL then
370           begin
371             LayerOriginalMatrix[idx] := AffineMatrixTranslation(x,y)*LayerOriginalMatrix[idx];
372             RenderLayerFromOriginal(idx);
373           end else LayerOffset[idx] := point(x,y);
374           if (gammastr = 'yes') or (gammastr = 'on') then
375           begin
376             case BlendOperation[idx] of
377               boLinearAdd: BlendOperation[idx] := boAdditive;
378               boOverlay: BlendOperation[idx] := boDarkOverlay;
379               boLinearDifference: BlendOperation[idx] := boDifference;
380               boLinearExclusion: BlendOperation[idx] := boExclusion;
381               boLinearSubtract: BlendOperation[idx] := boSubtract;
382               boLinearSubtractInverse: BlendOperation[idx] := boSubtractInverse;
383               boLinearNegation: BlendOperation[idx] := boNegation;
384             end;
385           end else
386           if (gammastr = 'no') or (gammastr = 'off') then
387             if BlendOperation[idx] = boTransparent then
388               BlendOperation[idx] := boLinearBlend; //explicit linear blending
389         end;
390         inc(doneLayerCount);
391       end;
392     end;
393   end;
394 
395 var StackStream: TMemoryStream;
396   imageNode, stackNode, attr: TDOMNode;
397   i,w,h: integer;
398 
399 begin
400   inherited Clear;
401 
402   if MimeType <> OpenRasterMimeType then
403     raise Exception.Create('Invalid mime type');
404 
405   StackStream := GetMemoryStream(LayerStackFilename);
406   if StackStream = nil then
407     raise Exception.Create('Layer stack not found');
408 
409   ReadXMLFile(FStackXML, StackStream);
410 
411   imageNode := StackXML.FindNode('image');
412   if imagenode = nil then
413     raise Exception.Create('Image node not found');
414 
415   w := 0;
416   h := 0;
417   LinearBlend := true;
418 
419   if Assigned(imageNode.Attributes) then
420     for i:=0 to imageNode.Attributes.Length-1 do
421     begin
422       attr := imagenode.Attributes[i];
423       if lowercase(attr.NodeName) = 'w' then
424         w := strToInt(string(attr.NodeValue)) else
425       if lowercase(attr.NodeName) = 'h' then
426         h := strToInt(string(attr.NodeValue)) else
427       if lowercase(attr.NodeName) = 'gamma-correction' then
428         linearBlend := (attr.NodeValue = 'no') or (attr.NodeValue = '0');
429     end;
430 
431   SetSize(w,h);
432 
433   stackNode := imageNode.FindNode('stack');
434   if stackNode = nil then
435     raise Exception.Create('Stack node not found');
436 
437   totalLayerCount := CountLayersRec(stackNode);
438   doneLayerCount := 0;
439   AddLayersRec(stackNode);
440 end;
441 
442 procedure TBGRAOpenRasterDocument.PrepareZipToSave;
443 
444 var i: integer;
445     imageNode,stackNode,layerNode: TDOMElement;
446     layerFilename,strval: string;
447     stackStream: TMemoryStream;
448     ofs, wantedOfs: TPoint;
449     fileAdded: Boolean;
450     svg: TBGRASVG;
451     m: TAffineMatrix;
452 begin
453   ClearFiles;
454   MimeType := OpenRasterMimeType;
455   FStackXML := TXMLDocument.Create;
456   imageNode := TDOMElement(StackXML.CreateElement('image'));
457   StackXML.AppendChild(imageNode);
458   imageNode.SetAttribute('w',widestring(inttostr(Width)));
459   imageNode.SetAttribute('h',widestring(inttostr(Height)));
460   if LinearBlend then
461     imageNode.SetAttribute('gamma-correction','no')
462   else
463     imageNode.SetAttribute('gamma-correction','yes');
464 
465   stackNode := TDOMElement(StackXML.CreateElement('stack'));
466   imageNode.AppendChild(stackNode);
467   SetMemoryStreamAsString('stack.xml',''); //to put it before image data
468 
469   CopyThumbnailToMemoryStream(256,256);
470 
471   for i := NbLayers-1 downto 0 do
472   begin
473     OnLayeredBitmapSaveProgress(round((NbLayers-1-i) * 100 / NbLayers));
474     if (LayerOriginalGuid[i] <> GUID_NULL) and LayerOriginalKnown[i] and
475        LayerOriginalClass[i].CanConvertToSVG then
476     begin
477       layerFilename := 'data/layer'+inttostr(i)+'.svg';
478       if LayerOriginal[i].IsInfiniteSurface then
479       begin
480         svg := LayerOriginal[i].ConvertToSVG(LayerOriginalMatrix[i], wantedOfs) as TBGRASVG;
481         m := AffineMatrixTranslation(wantedOfs.X, wantedOfs.Y);
482         svg.WidthAsPixel := self.Width;
483         svg.HeightAsPixel := self.Height;
484       end else
485       begin
486         svg := LayerOriginal[i].ConvertToSVG(AffineMatrixIdentity, wantedOfs) as TBGRASVG;
487         m := LayerOriginalMatrix[i]
488           * AffineMatrixTranslation(wantedOfs.X, wantedOfs.Y);
489       end;
490       try
491         CopySVGToMemoryStream(svg, m, layerFilename, ofs);
492         fileAdded := true;
493       finally
494         svg.Free;
495       end;
496     end else
497     begin
498       layerFilename := 'data/layer'+inttostr(i)+'.png';
499       ofs := LayerOffset[i];
500       fileAdded := CopyRasterLayerToMemoryStream(i, layerFilename);
501     end;
502 
503     if fileAdded then
504     begin
505       layerNode := StackXML.CreateElement('layer');
506       stackNode.AppendChild(layerNode);
507       layerNode.SetAttribute('name', UTF8Decode(LayerName[i]));
508       str(LayerOpacity[i]/255:0:3,strval);
509       layerNode.SetAttribute('opacity',widestring(strval));
510       layerNode.SetAttribute('src',widestring(layerFilename));
511       if LayerVisible[i] then
512         layerNode.SetAttribute('visibility','visible')
513       else
514         layerNode.SetAttribute('visibility','hidden');
515       layerNode.SetAttribute('x',widestring(inttostr(ofs.x)));
516       layerNode.SetAttribute('y',widestring(inttostr(ofs.y)));
517       strval := '';
518       case BlendOperation[i] of
519         boLighten: strval := 'svg:lighten';
520         boScreen: strval := 'svg:screen';
521         boAdditive, boLinearAdd: strval := 'svg:add';
522         boColorDodge: strval := 'svg:color-dodge';
523         boColorBurn : strval := 'svg:color-burn';
524         boDarken: strval := 'svg:darken';
525         boMultiply: strval := 'svg:multiply';
526         boOverlay, boDarkOverlay: strval := 'svg:overlay';
527         boSoftLight: strval := 'bgra:soft-light';
528         boHardLight: strval := 'svg:hard-light';
529         boDifference,boLinearDifference: strval := 'svg:difference';
530         boLinearSubtractInverse, boSubtractInverse: strval := 'krita:inverse_subtract';
531         boLinearSubtract, boSubtract: strval := 'krita:subtract';
532         boExclusion, boLinearExclusion: strval := 'svg:exclusion';
533         boDivide: strval := 'krita:divide';
534         boNiceGlow: strval := 'bgra:nice-glow';
535         boGlow: strval := 'bgra:glow';
536         boReflect: strval := 'bgra:reflect';
537         boLinearNegation,boNegation: strval := 'bgra:negation';
538         boXor: strval := 'bgra:xor';
539         boSvgSoftLight: strval := 'svg:soft-light';
540         boMask: strval := 'bgra:mask';
541         boLinearMultiplySaturation: strval := 'bgra:linear-multiply-saturation';
542         boCorrectedHue: strval := 'svg:hue';
543         boCorrectedColor: strval := 'svg:color';
544         boCorrectedLightness: strval := 'svg:luminosity';
545         boCorrectedSaturation: strval := 'svg:saturation';
546         boLinearHue: strval := 'krita:hue_hsl';
547         boLinearColor: strval := 'krita:color_hsl';
548         boLinearLightness: strval := 'krita:lightness';
549         boLinearSaturation: strval := 'krita:saturation_hsl';
550         else strval := 'svg:src-over';
551       end;
552       layerNode.SetAttribute('composite-op',widestring(strval));
553       if BlendOperation[i] <> boTransparent then //in 'transparent' case, linear blending depends on general setting
554       begin
555         if BlendOperation[i] in[boAdditive,boDarkOverlay,boDifference,boSubtractInverse,
556              boSubtract,boExclusion,boNegation] then
557           strval := 'yes' else strval := 'no';
558         layerNode.SetAttribute('gamma-correction',widestring(strval));
559       end;
560     end;
561   end;
562   OnLayeredBitmapSaveProgress(100);
563   StackStream := TMemoryStream.Create;
564   WriteXMLFile(StackXML, StackStream);
565   SetMemoryStream('stack.xml',StackStream);
566 end;
567 
568 procedure TBGRAOpenRasterDocument.LoadFromFile(const filenameUTF8: string);
569 var AStream: TFileStreamUTF8;
570 begin
571   AStream := TFileStreamUTF8.Create(filenameUTF8,fmOpenRead or fmShareDenyWrite);
572   OnLayeredBitmapLoadStart(filenameUTF8);
573   try
574     InternalLoadFromStream(AStream);
575   finally
576     OnLayeredBitmapLoaded;
577     AStream.Free;
578   end;
579 end;
580 
581 procedure TBGRAOpenRasterDocument.SaveToStream(AStream: TStream);
582 begin
583   OnLayeredBitmapSaveToStreamStart;
584   try
585     InternalSaveToStream(AStream);
586   finally
587     OnLayeredBitmapSaved;
588   end;
589 end;
590 
591 procedure TBGRAOpenRasterDocument.SaveToFile(const filenameUTF8: string);
592 begin
593   OnLayeredBitmapSaveStart(filenameUTF8);
594   try
595     PrepareZipToSave;
596     ZipToFile(filenameUTF8);
597   finally
598     OnLayeredBitmapSaved;
599     ClearFiles;
600   end;
601 end;
602 
603 procedure TBGRAOpenRasterDocument.InternalSaveToStream(AStream: TStream);
604 begin
605   try
606     PrepareZipToSave;
607     ZipToStream(AStream);
608   finally
609     ClearFiles;
610   end;
611 end;
612 
GetMimeTypenull613 function TBGRAOpenRasterDocument.GetMimeType: string;
614 begin
615   if length(FFiles)=0 then
616     result := OpenRasterMimeType
617    else
618     result := GetMemoryStreamAsString('mimetype');
619 end;
620 
621 procedure TBGRAOpenRasterDocument.InternalLoadFromStream(AStream: TStream);
622 begin
623   try
624     UnzipFromStream(AStream);
625     AnalyzeZip;
626   finally
627     ClearFiles;
628   end;
629 end;
630 
631 constructor TBGRAOpenRasterDocument.Create;
632 begin
633   inherited Create;
634   RegisterOpenRasterFormat;
635 end;
636 
637 constructor TBGRAOpenRasterDocument.Create(AWidth, AHeight: integer);
638 begin
639   inherited Create(AWidth, AHeight);
640   RegisterOpenRasterFormat;
641 end;
642 
AddLayerFromMemoryStreamnull643 function TBGRAOpenRasterDocument.AddLayerFromMemoryStream(ALayerFilename: string): integer;
644 var stream: TMemoryStream;
645   bmp: TBGRABitmap;
646   orig: TBGRALayerSVGOriginal;
647   svg: TBGRASVG;
648   g: TSVGGroup;
649   i, svgElemCount: Integer;
650   origViewBox: TSVGViewBox;
651   elemToMove: TList;
652   m: TAffineMatrix;
653 begin
654   stream := GetMemoryStream(ALayerFilename);
655   if stream = nil then raise Exception.Create('Layer not found');
656 
657   if SuggestImageFormat(ALayerFilename) = ifSvg then
658   begin
659     svg := TBGRASVG.Create;
660     svg.DefaultDpi:= OpenRasterSVGDefaultDPI;
661     try
662       svg.LoadFromStream(stream);
663     except
664       on ex:exception do
665       begin
666         svg.Free;
667         raise exception.Create('SVG layer format error');
668       end;
669     end;
670     g := nil;
671     svgElemCount := 0;
672     for i := 0 to svg.Content.ElementCount-1 do
673       if svg.Content.IsSVGElement[i] then
674       begin
675         inc(svgElemCount);
676         if svg.Content.ElementObject[i] is TSVGGroup then
677           g := TSVGGroup(svg.Content.ElementObject[i]);
678       end;
679 
680     if (svgElemCount = 1) and Assigned(g) and
681        g.DOMElement.hasAttribute('bgra:originalViewBox') then
682     begin
683       svg.ContainerWidthAsPixel:= Width;
684       svg.ContainerHeightAsPixel:= Height;
685       origViewBox := TSVGViewBox.Parse(g.DOMElement.GetAttribute('bgra:originalViewBox'));
686       m := svg.GetStretchPresentationMatrix(cuPixel) * g.matrix[cuPixel] *
687         AffineMatrixTranslation(origViewBox.min.x, origViewBox.min.y);
688       g.DOMElement.RemoveAttribute('bgra:originalViewBox');
689       for i := svg.Content.ElementCount-1 downto 0 do
690         if svg.Content.ElementObject[i] <> g then
691           svg.Content.RemoveElement(svg.Content.ElementObject[i]);
692       elemToMove := TList.Create;
693       for i := 0 to g.Content.ElementCount-1 do
694         elemToMove.Add(g.Content.ElementObject[i]);
695       for i := 0 to elemToMove.Count-1 do
696         svg.Content.BringElement(TObject(elemToMove[i]), g.Content);
697       elemToMove.Free;
698       svg.Content.RemoveElement(g);
699       svg.ViewBox := origViewBox;
700       svg.WidthAsPixel:= origViewBox.size.x;
701       svg.HeightAsPixel:= origViewBox.size.y;
702     end else
703       m := AffineMatrixIdentity;
704     orig := TBGRALayerSVGOriginal.Create;
705     orig.SetSVG(svg, Width, Height);
706     result := AddLayerFromOwnedOriginal(orig);
707     LayerOriginalMatrix[result] := m;
708   end else
709   begin
710     bmp := TBGRABitmap.Create;
711     try
712       bmp.LoadFromStream(stream);
713     except
714       on ex: exception do
715       begin
716         bmp.Free;
717         raise exception.Create('Raster layer format error');
718       end;
719     end;
720     result := AddOwnedLayer(bmp);
721   end;
722   LayerName[result] := ExtractFileName(ALayerFilename);
723 end;
724 
CopyRasterLayerToMemoryStreamnull725 function TBGRAOpenRasterDocument.CopyRasterLayerToMemoryStream(ALayerIndex: integer;
726   ALayerFilename: string): boolean;
727 var
728   bmp: TBGRABitmap;
729   mustFreeBmp: boolean;
730 begin
731   result := false;
732   bmp := LayerBitmap[ALayerIndex];
733   if bmp <> nil then mustFreeBmp := false
734   else
735   begin
736     bmp := GetLayerBitmapCopy(ALayerIndex);
737     if bmp = nil then exit;
738     mustFreeBmp:= true;
739   end;
740 
741   result := CopyBitmapToMemoryStream(bmp,ALayerFilename);
742   if mustFreeBmp then bmp.Free;
743 end;
744 
745 procedure TBGRAOpenRasterDocument.CopySVGToMemoryStream(
746   ASVG: TBGRASVG; ASVGMatrix: TAffineMatrix; AOutFilename: string; out AOffset: TPoint);
747 
748   function IsIntegerTranslation(m: TAffineMatrix; out ofs: TPoint): boolean;
749   begin
750     ofs := Point(round(m[1,3]), round(m[2,3]));
751     result := IsAffineMatrixTranslation(m) and
752              (abs(round(m[1,3]) - ofs.x) < 1e-4) and
753              (abs(round(m[2,3]) - ofs.y) < 1e-4);
754   end;
755 
756   procedure StoreSVG(ASVG: TBGRASVG);
757   var
758     memStream: TMemoryStream;
759     w, h: Single;
760   begin
761     memStream := TMemoryStream.Create;
762     try
763       w := ASVG.WidthAsPixel;
764       h := ASVG.HeightAsPixel;
765       //ensure we are not using units affected by DPI
766       ASVG.ConvertToUnit(cuCustom);
767       ASVG.WidthAsPixel := w;
768       ASVG.HeightAsPixel := h;
769       ASVG.SaveToStream(memStream);
770       SetMemoryStream(AOutFilename,memstream);
771     except
772       on ex: Exception do
773       begin
774         memStream.Free;
775         raise exception.Create(ex.Message);
776       end;
777     end;
778   end;
779 
780   procedure StoreTransformedSVG(out AOffset: TPoint);
781   var
782     box, transfBox: TAffineBox;
783     newSvg: TBGRASVG;
784     newBounds: TRectF;
785     rootElems: TList;
786     i: Integer;
787     g: TSVGGroup;
788     newViewBox, origViewBox: TSVGViewBox;
789     presentMatrix: TAffineMatrix;
790   begin
791     newSvg := ASVG.Duplicate;
792     presentMatrix := ASVGMatrix * newSvg.GetStretchPresentationMatrix(cuPixel);
793     rootElems := TList.Create;
794     try
795       origViewBox := newSvg.ViewBox;
796       with origViewBox do
797         box := TAffineBox.AffineBox(RectWithSizeF(min.x, min.y, size.x, size.y));
798       transfBox := presentMatrix * box;
799       newBounds := RectF(transfBox.RectBounds);
800       AOffset := Point(round(newBounds.Left), round(newBounds.Top));
801       newBounds.Offset(-AOffset.X, -AOffset.Y);
802       presentMatrix := AffineMatrixTranslation(-AOffset.X, -AOffset.Y) * presentMatrix;
803       for i := 0 to newSvg.Content.ElementCount-1 do
804         rootElems.Add(newSvg.Content.ElementObject[i]);
805       g := newSvg.Content.AppendGroup;
806       for i := 0 to rootElems.Count-1 do
807         g.Content.BringElement(TObject(rootElems[i]), newSvg.Content);
808       g.matrix[cuPixel] := presentMatrix;
809       g.DOMElement.SetAttribute('xmlns:bgra', 'https://wiki.freepascal.org/LazPaint_SVG_format');
810       g.DOMElement.SetAttribute('bgra:originalViewBox', origViewBox.ToString);
811       newSvg.WidthAsPixel:= newBounds.Width;
812       newSvg.HeightAsPixel:= newBounds.Height;
813       newViewBox.min := newBounds.TopLeft;
814       newViewBox.size := PointF(newBounds.Width, newBounds.Height);
815       newSvg.ViewBox := newViewBox;
816       StoreSVG(newSvg);
817     finally
818       rootElems.Free;
819       newSvg.Free;
820     end;
821   end;
822 
823 begin
824   if IsIntegerTranslation(ASVGMatrix, AOffset) then
825     StoreSVG(ASVG)
826     else StoreTransformedSVG(AOffset);
827 end;
828 
CopyBitmapToMemoryStreamnull829 function TBGRAOpenRasterDocument.CopyBitmapToMemoryStream(ABitmap: TBGRABitmap;
830   AFilename: string): boolean;
831 var
832   memStream: TMemoryStream;
833 begin
834   result := false;
835   memstream := TMemoryStream.Create;
836   try
837     ABitmap.SaveToStreamAsPng(memStream);
838     SetMemoryStream(AFilename,memstream);
839     result := true;
840   except
841     on ex: Exception do
842     begin
843       memStream.Free;
844     end;
845   end;
846 end;
847 
848 procedure TBGRAOpenRasterDocument.SetMemoryStreamAsString(AFilename: string;
849   AContent: string);
850 var strstream: TStringStream;
851   memstream: TMemoryStream;
852 begin
853   strstream:= TStringStream.Create(AContent);
854   memstream := TMemoryStream.Create;
855   strstream.Position := 0;
856   memstream.CopyFrom(strstream, strstream.Size);
857   strstream.Free;
858   SetMemoryStream(AFilename, memstream);
859 end;
860 
GetMemoryStreamAsStringnull861 function TBGRAOpenRasterDocument.GetMemoryStreamAsString(AFilename: string): string;
862 var stream: TMemoryStream;
863   str: TStringStream;
864 begin
865   stream := GetMemoryStream(AFilename);
866   str := TStringStream.Create('');
867   str.CopyFrom(stream,stream.Size);
868   result := str.DataString;
869   str.Free;
870 end;
871 
872 procedure TBGRAOpenRasterDocument.UnzipFromStream(AStream: TStream;
873           AFileList: TStrings = nil);
874 var unzip: TUnZipper;
875 begin
876   ClearFiles;
877   unzip := TUnZipper.Create;
878   try
879     unzip.OnCreateStream := @ZipOnCreateStream;
880     unzip.OnDoneStream := @ZipOnDoneStream;
881     unzip.OnOpenInputStream := @ZipOnOpenInputStream;
882     unzip.OnCloseInputStream := @ZipOnCloseInputStream;
883     FZipInputStream := AStream;
884     if Assigned(AFileList) then
885     begin
886       if AFileList.Count > 0 then
887         unzip.UnZipFiles(AFileList);
888     end else
889       unzip.UnZipAllFiles;
890   finally
891     FZipInputStream := nil;
892     unzip.Free;
893   end;
894 end;
895 
896 procedure TBGRAOpenRasterDocument.UnzipFromFile(AFilenameUTF8: string);
897 var unzip: TUnZipper;
898 begin
899   ClearFiles;
900   unzip := TUnZipper.Create;
901   try
902     unzip.FileName := Utf8ToAnsi(AFilenameUTF8);
903     unzip.OnCreateStream := @ZipOnCreateStream;
904     unzip.OnDoneStream := @ZipOnDoneStream;
905     unzip.UnZipAllFiles;
906   finally
907     unzip.Free;
908   end;
909 end;
910 
911 procedure TBGRAOpenRasterDocument.ZipToFile(AFilenameUTF8: string);
912 var
913   stream: TFileStreamUTF8;
914 begin
915   stream := TFileStreamUTF8.Create(AFilenameUTF8, fmCreate);
916   try
917     ZipToStream(stream);
918   finally
919     stream.Free;
920   end;
921 end;
922 
923 procedure TBGRAOpenRasterDocument.ZipToStream(AStream: TStream);
924 var zip: TZipper;
925   i: integer;
926   tempFile: String;
927 begin
928   zip := TZipper.Create;
929   tempFile := ChangeFileExt(GetTempFileName, '');
930   if ExtractFileExt(tempFile) = '.tmp' then
931     tempFile := ChangeFileExt(tempFile, '');
932   zip.FileName:= tempFile;
933   try
934     for i := 0 to high(FFiles) do
935     begin
936       FFiles[i].Stream.Position:= 0;
937       zip.Entries.AddFileEntry(FFiles[i].Stream,FFiles[i].Filename).CompressionLevel := clnone;
938     end;
939     zip.SaveToStream(AStream);
940   finally
941     zip.Free;
942   end;
943 end;
944 
945 procedure TBGRAOpenRasterDocument.CopyThumbnailToMemoryStream(AMaxWidth,AMaxHeight: integer);
946 var thumbnail: TBGRABitmap;
947   w,h: integer;
948 begin
949   if (Width = 0) or (Height = 0) then exit;
950   thumbnail := ComputeFlatImage;
951   CopyBitmapToMemoryStream(thumbnail,MergedImageFilename);
952   if (thumbnail.Width > AMaxWidth) or
953    (thumbnail.Height > AMaxHeight) then
954   begin
955     if thumbnail.Width > AMaxWidth then
956     begin
957       w := AMaxWidth;
958       h := round(thumbnail.Height* (w/thumbnail.Width));
959     end else
960     begin
961       w := thumbnail.Width;
962       h := thumbnail.Height;
963     end;
964     if h > AMaxHeight then
965     begin
966       h := AMaxHeight;
967       w := round(thumbnail.Width* (h/thumbnail.Height));
968     end;
969     BGRAReplace(thumbnail, thumbnail.Resample(w,h));
970   end;
971   CopyBitmapToMemoryStream(thumbnail,'Thumbnails/thumbnail.png');
972   thumbnail.Free;
973 end;
974 
975 procedure TBGRAOpenRasterDocument.Clear;
976 begin
977   ClearFiles;
978   inherited Clear;
979 end;
980 
CheckMimeTypenull981 function TBGRAOpenRasterDocument.CheckMimeType(AStream: TStream): boolean;
982 var unzip: TUnzipperStreamUtf8;
983   mimeTypeFound: string;
984   oldPos: int64;
985 begin
986   result := false;
987   unzip := TUnzipperStreamUtf8.Create;
988   oldPos := AStream.Position;
989   try
990     unzip.InputStream := AStream;
991     mimeTypeFound := unzip.UnzipFileToString('mimetype');
992     if mimeTypeFound = OpenRasterMimeType then result := true;
993   except
994   end;
995   unzip.Free;
996   astream.Position:= OldPos;
997 end;
998 
999 procedure TBGRAOpenRasterDocument.LoadFlatImageFromStream(AStream: TStream; out
1000   ANbLayers: integer; out ABitmap: TBGRABitmap);
1001 var fileList: TStringList;
1002   imgStream, stackStream: TMemoryStream;
1003   imageNode, stackNode: TDOMNode;
1004   i: integer;
1005 begin
1006   fileList := TStringList.Create;
1007   fileList.Add(MergedImageFilename);
1008   fileList.Add(LayerStackFilename);
1009   imgStream := nil;
1010   try
1011     UnzipFromStream(AStream, fileList);
1012     imgStream := GetMemoryStream(MergedImageFilename);
1013     if imgStream = nil then
1014       ABitmap := nil
1015     else
1016       ABitmap := TBGRABitmap.Create(imgStream);
1017     ANbLayers := 1;
1018 
1019     stackStream := GetMemoryStream(LayerStackFilename);
1020     ReadXMLFile(FStackXML, StackStream);
1021     imageNode := StackXML.FindNode('image');
1022     if Assigned(imagenode) then
1023     begin
1024       stackNode := imageNode.FindNode('stack');
1025       if Assigned(stackNode) then
1026       begin
1027         ANbLayers:= 0;
1028         for i := stackNode.ChildNodes.Length-1 downto 0 do
1029         begin
1030           if stackNode.ChildNodes[i].NodeName = 'layer' then
1031             inc(ANbLayers);
1032         end;
1033       end;
1034     end;
1035 
1036   finally
1037     fileList.Free;
1038     ClearFiles;
1039   end;
1040 end;
1041 
1042 procedure TBGRAOpenRasterDocument.LoadFromStream(AStream: TStream);
1043 begin
1044   OnLayeredBitmapLoadFromStreamStart;
1045   try
1046     InternalLoadFromStream(AStream);
1047   finally
1048     OnLayeredBitmapLoaded;
1049   end;
1050 end;
1051 
1052 procedure TBGRAOpenRasterDocument.SetMimeType(AValue: string);
1053 begin
1054   SetMemoryStreamAsString('mimetype',AValue);
1055 end;
1056 
1057 procedure TBGRAOpenRasterDocument.ZipOnCreateStream(Sender: TObject; var AStream: TStream;
1058   AItem: TFullZipFileEntry);
1059 var MemStream: TMemoryStream;
1060 begin
1061   MemStream := TMemoryStream.Create;
1062   SetMemoryStream(AItem.ArchiveFileName, MemStream);
1063   AStream := MemStream;
1064 end;
1065 
1066 {$hints off}
1067 procedure TBGRAOpenRasterDocument.ZipOnDoneStream(Sender: TObject; var AStream: TStream;
1068   AItem: TFullZipFileEntry);
1069 begin
1070   //do nothing, files stay in memory
1071 end;
1072 {$hints on}
1073 
1074 procedure TBGRAOpenRasterDocument.ZipOnOpenInputStream(Sender: TObject;
1075   var AStream: TStream);
1076 begin
1077   AStream := FZipInputStream;
1078 end;
1079 
1080 procedure TBGRAOpenRasterDocument.ZipOnCloseInputStream(Sender: TObject;
1081   var AStream: TStream);
1082 begin
1083   AStream := nil; //avoid freeing
1084 end;
1085 
1086 procedure TBGRAOpenRasterDocument.ClearFiles;
1087 var i: integer;
1088 begin
1089   for i := 0 to high(FFiles) do
1090     ffiles[i].Stream.Free;
1091   FFiles := nil;
1092   FreeAndNil(FStackXML);
1093 end;
1094 
GetMemoryStreamnull1095 function TBGRAOpenRasterDocument.GetMemoryStream(AFilename: string): TMemoryStream;
1096 var i: integer;
1097 begin
1098   for i := 0 to high(FFiles) do
1099     if ffiles[i].Filename = AFilename then
1100     begin
1101       result := FFiles[i].Stream;
1102       result.Position:= 0;
1103       exit;
1104     end;
1105   result := nil;
1106 end;
1107 
1108 procedure TBGRAOpenRasterDocument.SetMemoryStream(AFilename: string;
1109   AStream: TMemoryStream);
1110 var i: integer;
1111 begin
1112   for i := 0 to high(FFiles) do
1113     if ffiles[i].Filename = AFilename then
1114     begin
1115       FreeAndNil(FFiles[i].Stream);
1116       FFiles[i].Stream := AStream;
1117       exit;
1118     end;
1119   setlength(FFiles, length(FFiles)+1);
1120   FFiles[high(FFiles)].Filename := AFilename;
1121   FFiles[high(FFiles)].Stream := AStream;
1122 end;
1123 
1124 var AlreadyRegistered: boolean;
1125 
1126 procedure RegisterOpenRasterFormat;
1127 begin
1128   if AlreadyRegistered then exit;
1129   ImageHandlers.RegisterImageReader ('OpenRaster', 'ora', TFPReaderOpenRaster);
1130   RegisterLayeredBitmapReader('ora', TBGRAOpenRasterDocument);
1131   RegisterLayeredBitmapWriter('ora', TBGRAOpenRasterDocument);
1132   //TPicture.RegisterFileFormat('ora', 'OpenRaster', TBGRAOpenRasterDocument);
1133   DefaultBGRAImageReader[ifOpenRaster] := TFPReaderOpenRaster;
1134   DefaultBGRAImageWriter[ifOpenRaster] := TFPWriterOpenRaster;
1135   AlreadyRegistered:= True;
1136 end;
1137 
1138 end.
1139 
1140