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