source: trunk/Packages/bgrabitmap/bgraopenraster.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 26.7 KB
Line 
1unit BGRAOpenRaster;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, BGRALayers, zipper, DOM, BGRABitmap, FPImage;
9
10const
11 OpenRasterMimeType = 'image/openraster'; //do not change, it's part of the file format
12
13type
14
15 { TBGRAOpenRasterDocument }
16
17 TBGRAOpenRasterDocument = class(TBGRALayeredBitmap)
18 private
19 FFiles: array of record
20 Filename: string;
21 Stream: TMemoryStream;
22 end;
23 FStackXML: TXMLDocument;
24 FZipInputStream: TStream;
25 procedure SetMimeType(AValue: string);
26 protected
27 Procedure ZipOnCreateStream(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry);
28 Procedure ZipOnDoneStream(Sender : TObject; var AStream : TStream; AItem : TFullZipFileEntry);
29 Procedure ZipOnOpenInputStream(Sender : TObject; var AStream : TStream);
30 Procedure ZipOnCloseInputStream(Sender : TObject; var AStream : TStream);
31 procedure ClearFiles;
32 function GetMemoryStream(AFilename: string): TMemoryStream;
33 procedure SetMemoryStream(AFilename: string; AStream: TMemoryStream);
34 function AddLayerFromMemoryStream(ALayerFilename: string): integer;
35 function CopyLayerToMemoryStream(ALayerIndex: integer; ALayerFilename: string): boolean;
36 function CopyBitmapToMemoryStream(ABitmap: TBGRABitmap; AFilename: string): boolean;
37 procedure SetMemoryStreamAsString(AFilename: string; AContent: string);
38 function GetMemoryStreamAsString(AFilename: string): string;
39 procedure UnzipFromStream(AStream: TStream; AFileList: TStrings = nil);
40 procedure UnzipFromFile(AFilenameUTF8: string);
41 procedure ZipToFile(AFilenameUTF8: string);
42 procedure ZipToStream(AStream: TStream);
43 procedure CopyThumbnailToMemoryStream(AMaxWidth, AMaxHeight: integer);
44 procedure AnalyzeZip; virtual;
45 procedure PrepareZipToSave; virtual;
46 function GetMimeType: string; override;
47
48 public
49 constructor Create; overload; override;
50 constructor Create(AWidth, AHeight: integer); overload; override;
51 procedure Clear; override;
52 function CheckMimeType(AStream: TStream): boolean;
53 procedure LoadFlatImageFromStream(AStream: TStream;
54 out ANbLayers: integer;
55 out ABitmap: TBGRABitmap);
56 procedure LoadFromStream(AStream: TStream); override;
57 procedure LoadFromFile(const filenameUTF8: string); override;
58 procedure SaveToFile(const filenameUTF8: string); override;
59 procedure SaveToStream(AStream: TStream); override;
60 property MimeType : string read GetMimeType write SetMimeType;
61 property StackXML : TXMLDocument read FStackXML;
62 end;
63
64 { TFPReaderOpenRaster }
65
66 TFPReaderOpenRaster = class(TFPCustomImageReader)
67 private
68 FWidth,FHeight,FNbLayers: integer;
69 protected
70 function InternalCheck(Stream: TStream): boolean; override;
71 procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
72 public
73 property Width: integer read FWidth;
74 property Height: integer read FHeight;
75 property NbLayers: integer read FNbLayers;
76 end;
77
78 { TFPWriterOpenRaster }
79
80 TFPWriterOpenRaster = class(TFPCustomImageWriter)
81 protected
82 procedure InternalWrite (Str:TStream; Img:TFPCustomImage); override;
83 end;
84
85procedure RegisterOpenRasterFormat;
86
87implementation
88
89uses XMLRead, XMLWrite, FPReadPNG, BGRABitmapTypes, zstream, BGRAUTF8,
90 UnzipperExt;
91
92const
93 MergedImageFilename = 'mergedimage.png';
94 LayerStackFilename = 'stack.xml';
95
96function IsZipStream(stream: TStream): boolean;
97var
98 header: packed array[0..1] of char;
99 SavePos: int64;
100begin
101 Result := False;
102 try
103 if stream.Position + 2 < Stream.Size then
104 begin
105 header := #0#0;
106 SavePos := stream.Position;
107 stream.Read(header, 2);
108 stream.Position := SavePos;
109 if (header[0] = 'P') and (header[1] = 'K') then
110 Result := True;
111 end;
112 except
113 on ex: Exception do ;
114 end;
115end;
116
117{ TFPWriterOpenRaster }
118
119procedure TFPWriterOpenRaster.InternalWrite(Str: TStream; Img: TFPCustomImage);
120var doc: TBGRAOpenRasterDocument;
121 tempBmp: TBGRABitmap;
122 x,y: integer;
123
124begin
125 doc := TBGRAOpenRasterDocument.Create;
126 if Img is TBGRABitmap then doc.AddLayer(Img as TBGRABitmap) else
127 begin
128 tempBmp := TBGRABitmap.Create(img.Width,img.Height);
129 for y := 0 to Img.Height-1 do
130 for x := 0 to img.Width-1 do
131 tempBmp.SetPixel(x,y, FPColorToBGRA(img.Colors[x,y]));
132 doc.AddOwnedLayer(tempBmp);
133 end;
134 doc.SaveToStream(Str);
135 doc.Free;
136end;
137
138{ TFPReaderOpenRaster }
139
140function TFPReaderOpenRaster.InternalCheck(Stream: TStream): boolean;
141var magic: packed array[0..3] of byte;
142 OldPos,BytesRead: Int64;
143 doc : TBGRAOpenRasterDocument;
144begin
145 Result:=false;
146 if Stream=nil then exit;
147 oldPos := stream.Position;
148 {$PUSH}{$HINTS OFF}
149 BytesRead := Stream.Read({%H-}magic,sizeof(magic));
150 {$POP}
151 stream.Position:= OldPos;
152 if BytesRead<>sizeof(magic) then exit;
153 if (magic[0] = $50) and (magic[1] = $4b) and (magic[2] = $03) and (magic[3] = $04) then
154 begin
155 doc := TBGRAOpenRasterDocument.Create;
156 result := doc.CheckMimeType(Stream);
157 doc.Free;
158 end;
159end;
160
161procedure TFPReaderOpenRaster.InternalRead(Stream: TStream; Img: TFPCustomImage);
162var
163 layeredImage: TBGRAOpenRasterDocument;
164 flat: TBGRABitmap;
165 x,y: integer;
166begin
167 FWidth := 0;
168 FHeight:= 0;
169 FNbLayers:= 0;
170 layeredImage := TBGRAOpenRasterDocument.Create;
171 try
172 layeredImage.LoadFlatImageFromStream(Stream, FNbLayers, flat);
173 if Assigned(flat) then
174 begin
175 FWidth := flat.Width;
176 FHeight := flat.Height;
177 end else
178 begin
179 layeredImage.LoadFromStream(Stream);
180 flat := layeredImage.ComputeFlatImage;
181 FWidth:= layeredImage.Width;
182 FHeight:= layeredImage.Height;
183 FNbLayers:= layeredImage.NbLayers;
184 end;
185 try
186 if Img is TBGRACustomBitmap then
187 TBGRACustomBitmap(img).Assign(flat)
188 else
189 begin
190 Img.SetSize(flat.Width,flat.Height);
191 for y := 0 to flat.Height-1 do
192 for x := 0 to flat.Width-1 do
193 Img.Colors[x,y] := BGRAToFPColor(flat.GetPixel(x,y));
194 end;
195 finally
196 flat.free;
197 end;
198 FreeAndNil(layeredImage);
199 except
200 on ex: Exception do
201 begin
202 layeredImage.Free;
203 raise Exception.Create('Error while loading OpenRaster file. ' + ex.Message);
204 end;
205 end;
206end;
207
208{ TBGRAOpenRasterDocument }
209
210procedure TBGRAOpenRasterDocument.AnalyzeZip;
211var StackStream: TMemoryStream;
212 imageNode, stackNode, layerNode, attr, srcAttr: TDOMNode;
213 i,j,w,h,idx: integer;
214 x,y: integer;
215 float: double;
216 errPos: integer;
217 opstr : string;
218 gammastr: string;
219begin
220 inherited Clear;
221
222 if MimeType <> OpenRasterMimeType then
223 raise Exception.Create('Invalid mime type');
224
225 StackStream := GetMemoryStream(LayerStackFilename);
226 if StackStream = nil then
227 raise Exception.Create('Layer stack not found');
228
229 ReadXMLFile(FStackXML, StackStream);
230
231 imageNode := StackXML.FindNode('image');
232 if imagenode = nil then
233 raise Exception.Create('Image node not found');
234
235 w := 0;
236 h := 0;
237 LinearBlend := true;
238
239 if Assigned(imageNode.Attributes) then
240 for i:=0 to imageNode.Attributes.Length-1 do
241 begin
242 attr := imagenode.Attributes[i];
243 if lowercase(attr.NodeName) = 'w' then
244 w := strToInt(string(attr.NodeValue)) else
245 if lowercase(attr.NodeName) = 'h' then
246 h := strToInt(string(attr.NodeValue)) else
247 if lowercase(attr.NodeName) = 'gamma-correction' then
248 linearBlend := (attr.NodeValue = 'no') or (attr.NodeValue = '0');
249 end;
250
251 SetSize(w,h);
252
253 stackNode := imageNode.FindNode('stack');
254 if stackNode = nil then
255 raise Exception.Create('Stack node not found');
256
257 for i := stackNode.ChildNodes.Length-1 downto 0 do
258 begin
259 OnLayeredBitmapLoadProgress((stackNode.ChildNodes.Length-i)*100 div stackNode.ChildNodes.Length);
260 layerNode:= stackNode.ChildNodes[i];
261 if (layerNode.NodeName = 'layer') and Assigned(layerNode.Attributes) then
262 begin
263 srcAttr := layerNode.Attributes.GetNamedItem('src');
264 idx := AddLayerFromMemoryStream(UTF8Encode(srcAttr.NodeValue));
265 if idx <> -1 then
266 begin
267 x := 0;
268 y := 0;
269 gammastr := '';
270 for j := 0 to layerNode.Attributes.Length-1 do
271 begin
272 attr := layerNode.Attributes[j];
273 if lowercase(attr.NodeName) = 'opacity' then
274 begin
275 val(attr.NodeValue, float, errPos);
276 if errPos = 0 then
277 begin
278 if float < 0 then float := 0;
279 if float > 1 then float := 1;
280 LayerOpacity[idx] := round(float*255);
281 end;
282 end else
283 if lowercase(attr.NodeName) = 'gamma-correction' then
284 gammastr := string(attr.NodeValue) else
285 if lowercase(attr.NodeName) = 'visibility' then
286 LayerVisible[idx] := (attr.NodeValue = 'visible') or (attr.NodeValue = 'yes') or (attr.NodeValue = '1') else
287 if (lowercase(attr.NodeName) = 'x') or (lowercase(attr.NodeName) = 'y') then
288 begin
289 val(attr.NodeValue, float, errPos);
290 if errPos = 0 then
291 begin
292 if float < -(MaxInt shr 1) then float := -(MaxInt shr 1);
293 if float > (MaxInt shr 1) then float := (MaxInt shr 1);
294 if (lowercase(attr.NodeName) = 'x') then x := round(float);
295 if (lowercase(attr.NodeName) = 'y') then y := round(float);
296 end;
297 end else
298 if lowercase(attr.NodeName) = 'name' then
299 LayerName[idx] := UTF8Encode(attr.NodeValue) else
300 if lowercase(attr.NodeName) = 'composite-op' then
301 begin
302 opstr := StringReplace(lowercase(string(attr.NodeValue)),'_','-',[rfReplaceAll]);
303 if (pos(':',opstr) = 0) and (opstr <> 'xor') then opstr := 'svg:'+opstr;
304 //parse composite op
305 if (opstr = 'svg:src-over') or (opstr = 'krita:dissolve') then
306 BlendOperation[idx] := boTransparent else
307 if opstr = 'svg:lighten' then
308 BlendOperation[idx] := boLighten else
309 if opstr = 'svg:screen' then
310 BlendOperation[idx] := boScreen else
311 if opstr = 'svg:color-dodge' then
312 BlendOperation[idx] := boColorDodge else
313 if (opstr = 'svg:color-burn') or (opstr = 'krita:gamma_dark'){approx} then
314 BlendOperation[idx] := boColorBurn else
315 if opstr = 'svg:darken' then
316 BlendOperation[idx] := boDarken else
317 if (opstr = 'svg:plus') or (opstr = 'svg:add') or (opstr = 'krita:linear_dodge') then
318 BlendOperation[idx] := boLinearAdd else
319 if (opstr = 'svg:multiply') or (opstr = 'krita:bumpmap') then
320 BlendOperation[idx] := boMultiply else
321 if opstr = 'svg:overlay' then
322 BlendOperation[idx] := boOverlay else
323 if opstr = 'svg:soft-light' then
324 BlendOperation[idx] := boSvgSoftLight else
325 if opstr = 'svg:hard-light' then
326 BlendOperation[idx] := boHardLight else
327 if opstr = 'svg:difference' then
328 BlendOperation[idx] := boLinearDifference else
329 if (opstr = 'krita:inverse-subtract') or (opstr = 'krita:linear-burn') then
330 BlendOperation[idx] := boLinearSubtractInverse else
331 if opstr = 'krita:subtract' then
332 BlendOperation[idx] := boLinearSubtract else
333 if (opstr = 'svg:difference') or
334 (opstr = 'krita:equivalence') then
335 BlendOperation[idx] := boLinearDifference else
336 if (opstr = 'svg:exclusion') or
337 (opstr = 'krita:exclusion') then
338 BlendOperation[idx] := boLinearExclusion else
339 if opstr = 'krita:divide' then
340 BlendOperation[idx] := boDivide else
341 if opstr = 'bgra:soft-light' then
342 BlendOperation[idx] := boSoftLight else
343 if opstr = 'bgra:nice-glow' then
344 BlendOperation[idx] := boNiceGlow else
345 if opstr = 'bgra:glow' then
346 BlendOperation[idx] := boGlow else
347 if opstr = 'bgra:reflect' then
348 BlendOperation[idx] := boReflect else
349 if opstr = 'bgra:negation' then
350 BlendOperation[idx] := boLinearNegation else
351 if (opstr = 'bgra:xor') or (opstr = 'xor') then
352 BlendOperation[idx] := boXor else
353 begin
354 //messagedlg('Unknown blend operation : ' + attr.NodeValue,mtInformation,[mbOk],0);
355 BlendOperation[idx] := boTransparent;
356 end;
357 end;
358 end;
359 LayerOffset[idx] := point(x,y);
360 if (gammastr = 'yes') or (gammastr = 'on') then
361 begin
362 case BlendOperation[idx] of
363 boLinearAdd: BlendOperation[idx] := boAdditive;
364 boOverlay: BlendOperation[idx] := boDarkOverlay;
365 boLinearDifference: BlendOperation[idx] := boDifference;
366 boLinearExclusion: BlendOperation[idx] := boExclusion;
367 boLinearSubtract: BlendOperation[idx] := boSubtract;
368 boLinearSubtractInverse: BlendOperation[idx] := boSubtractInverse;
369 boLinearNegation: BlendOperation[idx] := boNegation;
370 end;
371 end else
372 if (gammastr = 'no') or (gammastr = 'off') then
373 if BlendOperation[idx] = boTransparent then
374 BlendOperation[idx] := boLinearBlend; //explicit linear blending
375 end;
376 end;
377 end;
378
379end;
380
381procedure TBGRAOpenRasterDocument.PrepareZipToSave;
382var i: integer;
383 imageNode,stackNode,layerNode: TDOMElement;
384 layerFilename,strval: string;
385 stackStream: TMemoryStream;
386begin
387 ClearFiles;
388 MimeType := OpenRasterMimeType;
389 FStackXML := TXMLDocument.Create;
390 imageNode := TDOMElement(StackXML.CreateElement('image'));
391 StackXML.AppendChild(imageNode);
392 imageNode.SetAttribute('w',widestring(inttostr(Width)));
393 imageNode.SetAttribute('h',widestring(inttostr(Height)));
394 if LinearBlend then
395 imageNode.SetAttribute('gamma-correction','no')
396 else
397 imageNode.SetAttribute('gamma-correction','yes');
398
399 stackNode := TDOMElement(StackXML.CreateElement('stack'));
400 imageNode.AppendChild(stackNode);
401 SetMemoryStreamAsString('stack.xml',''); //to put it before image data
402
403 CopyThumbnailToMemoryStream(256,256);
404
405 for i := NbLayers-1 downto 0 do
406 begin
407 layerFilename := 'data/layer'+inttostr(i)+'.png';
408 if CopyLayerToMemoryStream(i, layerFilename) then
409 begin
410 layerNode := StackXML.CreateElement('layer');
411 stackNode.AppendChild(layerNode);
412 layerNode.SetAttribute('name', UTF8Decode(LayerName[i]));
413 str(LayerOpacity[i]/255:0:3,strval);
414 layerNode.SetAttribute('opacity',widestring(strval));
415 layerNode.SetAttribute('src',widestring(layerFilename));
416 if LayerVisible[i] then
417 layerNode.SetAttribute('visibility','visible')
418 else
419 layerNode.SetAttribute('visibility','hidden');
420 layerNode.SetAttribute('x',widestring(inttostr(LayerOffset[i].x)));
421 layerNode.SetAttribute('y',widestring(inttostr(LayerOffset[i].y)));
422 strval := '';
423 case BlendOperation[i] of
424 boLighten: strval := 'svg:lighten';
425 boScreen: strval := 'svg:screen';
426 boAdditive, boLinearAdd: strval := 'svg:add';
427 boColorDodge: strval := 'svg:color-dodge';
428 boColorBurn : strval := 'svg:color-burn';
429 boDarken: strval := 'svg:darken';
430 boMultiply: strval := 'svg:multiply';
431 boOverlay, boDarkOverlay: strval := 'svg:overlay';
432 boSoftLight: strval := 'bgra:soft-light';
433 boHardLight: strval := 'svg:hard-light';
434 boDifference,boLinearDifference: strval := 'svg:difference';
435 boLinearSubtractInverse, boSubtractInverse: strval := 'krita:inverse_subtract';
436 boLinearSubtract, boSubtract: strval := 'krita:subtract';
437 boExclusion, boLinearExclusion: strval := 'svg:exclusion';
438 boDivide: strval := 'krita:divide';
439 boNiceGlow: strval := 'bgra:nice-glow';
440 boGlow: strval := 'bgra:glow';
441 boReflect: strval := 'bgra:reflect';
442 boLinearNegation,boNegation: strval := 'bgra:negation';
443 boXor: strval := 'bgra:xor';
444 boSvgSoftLight: strval := 'svg:soft-light';
445 else strval := 'svg:src-over';
446 end;
447 layerNode.SetAttribute('composite-op',widestring(strval));
448 if BlendOperation[i] <> boTransparent then //in 'transparent' case, linear blending depends on general setting
449 begin
450 if BlendOperation[i] in[boAdditive,boDarkOverlay,boDifference,boSubtractInverse,
451 boSubtract,boExclusion,boNegation] then
452 strval := 'yes' else strval := 'no';
453 layerNode.SetAttribute('gamma-correction',widestring(strval));
454 end;
455 end;
456 end;
457 StackStream := TMemoryStream.Create;
458 WriteXMLFile(StackXML, StackStream);
459 SetMemoryStream('stack.xml',StackStream);
460end;
461
462procedure TBGRAOpenRasterDocument.LoadFromFile(const filenameUTF8: string);
463var AStream: TFileStreamUTF8;
464begin
465 AStream := TFileStreamUTF8.Create(filenameUTF8,fmOpenRead or fmShareDenyWrite);
466 try
467 LoadFromStream(AStream);
468 finally
469 AStream.Free;
470 end;
471end;
472
473procedure TBGRAOpenRasterDocument.SaveToFile(const filenameUTF8: string);
474begin
475 PrepareZipToSave;
476 ZipToFile(filenameUTF8);
477 ClearFiles;
478end;
479
480procedure TBGRAOpenRasterDocument.SaveToStream(AStream: TStream);
481begin
482 PrepareZipToSave;
483 ZipToStream(AStream);
484 ClearFiles;
485end;
486
487function TBGRAOpenRasterDocument.GetMimeType: string;
488begin
489 if length(FFiles)=0 then
490 result := OpenRasterMimeType
491 else
492 result := GetMemoryStreamAsString('mimetype');
493end;
494
495constructor TBGRAOpenRasterDocument.Create;
496begin
497 inherited Create;
498 RegisterOpenRasterFormat;
499end;
500
501constructor TBGRAOpenRasterDocument.Create(AWidth, AHeight: integer);
502begin
503 inherited Create(AWidth, AHeight);
504 RegisterOpenRasterFormat;
505end;
506
507function TBGRAOpenRasterDocument.AddLayerFromMemoryStream(ALayerFilename: string): integer;
508var stream: TMemoryStream;
509 bmp: TBGRABitmap;
510 png: TFPReaderPNG;
511begin
512 stream := GetMemoryStream(ALayerFilename);
513 if stream = nil then raise Exception.Create('Layer not found');
514
515 png := TFPReaderPNG.Create;
516 bmp := TBGRABitmap.Create;
517 try
518 bmp.LoadFromStream(stream,png);
519 except
520 on ex: exception do
521 begin
522 png.Free;
523 bmp.Free;
524 raise exception.Create('Layer format error');
525 end;
526 end;
527 png.Free;
528
529 result := AddOwnedLayer(bmp);
530 LayerName[result] := ExtractFileName(ALayerFilename);
531end;
532
533function TBGRAOpenRasterDocument.CopyLayerToMemoryStream(ALayerIndex: integer;
534 ALayerFilename: string): boolean;
535var
536 bmp: TBGRABitmap;
537 mustFreeBmp: boolean;
538 p: PBGRAPixel;
539 n: integer;
540begin
541 result := false;
542 bmp := LayerBitmap[ALayerIndex];
543 if bmp <> nil then mustFreeBmp := false
544 else
545 begin
546 bmp := GetLayerBitmapCopy(ALayerIndex);
547 if bmp = nil then exit;
548 mustFreeBmp:= true;
549 end;
550 if bmp.HasTransparentPixels then
551 begin
552 //avoid png bug with black color
553 if not mustFreeBmp then
554 begin
555 bmp := bmp.Duplicate as TBGRABitmap;
556 mustFreeBmp := true;
557 end;
558 p := bmp.data;
559 for n := bmp.NbPixels-1 downto 0 do
560 begin
561 if (p^.alpha <> 0) and (p^.red = 0) and (p^.green = 0) and (p^.blue = 0) then
562 p^.blue := 1;
563 inc(p);
564 end;
565 end;
566
567 result := CopyBitmapToMemoryStream(bmp,ALayerFilename);
568 if mustFreeBmp then bmp.Free;
569end;
570
571function TBGRAOpenRasterDocument.CopyBitmapToMemoryStream(ABitmap: TBGRABitmap;
572 AFilename: string): boolean;
573var
574 memStream: TMemoryStream;
575begin
576 result := false;
577 memstream := TMemoryStream.Create;
578 try
579 ABitmap.SaveToStreamAsPng(memStream);
580 SetMemoryStream(AFilename,memstream);
581 result := true;
582 except
583 on ex: Exception do
584 begin
585 memStream.Free;
586 end;
587 end;
588end;
589
590procedure TBGRAOpenRasterDocument.SetMemoryStreamAsString(AFilename: string;
591 AContent: string);
592var strstream: TStringStream;
593 memstream: TMemoryStream;
594begin
595 strstream:= TStringStream.Create(AContent);
596 memstream := TMemoryStream.Create;
597 strstream.Position := 0;
598 memstream.CopyFrom(strstream, strstream.Size);
599 strstream.Free;
600 SetMemoryStream(AFilename, memstream);
601end;
602
603function TBGRAOpenRasterDocument.GetMemoryStreamAsString(AFilename: string): string;
604var stream: TMemoryStream;
605 str: TStringStream;
606begin
607 stream := GetMemoryStream(AFilename);
608 str := TStringStream.Create('');
609 str.CopyFrom(stream,stream.Size);
610 result := str.DataString;
611 str.Free;
612end;
613
614procedure TBGRAOpenRasterDocument.UnzipFromStream(AStream: TStream;
615 AFileList: TStrings = nil);
616var unzip: TUnZipper;
617begin
618 ClearFiles;
619 unzip := TUnZipper.Create;
620 try
621 unzip.OnCreateStream := @ZipOnCreateStream;
622 unzip.OnDoneStream := @ZipOnDoneStream;
623 unzip.OnOpenInputStream := @ZipOnOpenInputStream;
624 unzip.OnCloseInputStream := @ZipOnCloseInputStream;
625 FZipInputStream := AStream;
626 if Assigned(AFileList) then
627 begin
628 if AFileList.Count > 0 then
629 unzip.UnZipFiles(AFileList);
630 end else
631 unzip.UnZipAllFiles;
632 finally
633 FZipInputStream := nil;
634 unzip.Free;
635 end;
636end;
637
638procedure TBGRAOpenRasterDocument.UnzipFromFile(AFilenameUTF8: string);
639var unzip: TUnZipper;
640begin
641 ClearFiles;
642 unzip := TUnZipper.Create;
643 try
644 unzip.FileName := Utf8ToAnsi(AFilenameUTF8);
645 unzip.OnCreateStream := @ZipOnCreateStream;
646 unzip.OnDoneStream := @ZipOnDoneStream;
647 unzip.UnZipAllFiles;
648 finally
649 unzip.Free;
650 end;
651end;
652
653procedure TBGRAOpenRasterDocument.ZipToFile(AFilenameUTF8: string);
654var
655 stream: TFileStreamUTF8;
656begin
657 stream := TFileStreamUTF8.Create(AFilenameUTF8, fmCreate);
658 try
659 ZipToStream(stream);
660 finally
661 stream.Free;
662 end;
663end;
664
665procedure TBGRAOpenRasterDocument.ZipToStream(AStream: TStream);
666var zip: TZipper;
667 i: integer;
668begin
669 zip := TZipper.Create;
670 try
671 for i := 0 to high(FFiles) do
672 begin
673 FFiles[i].Stream.Position:= 0;
674 zip.Entries.AddFileEntry(FFiles[i].Stream,FFiles[i].Filename).CompressionLevel := clnone;
675 end;
676 zip.SaveToStream(AStream);
677 finally
678 zip.Free;
679 end;
680end;
681
682procedure TBGRAOpenRasterDocument.CopyThumbnailToMemoryStream(AMaxWidth,AMaxHeight: integer);
683var thumbnail: TBGRABitmap;
684 w,h: integer;
685begin
686 if (Width = 0) or (Height = 0) then exit;
687 thumbnail := ComputeFlatImage;
688 CopyBitmapToMemoryStream(thumbnail,MergedImageFilename);
689 if (thumbnail.Width > AMaxWidth) or
690 (thumbnail.Height > AMaxHeight) then
691 begin
692 if thumbnail.Width > AMaxWidth then
693 begin
694 w := AMaxWidth;
695 h := round(thumbnail.Height* (w/thumbnail.Width));
696 end else
697 begin
698 w := thumbnail.Width;
699 h := thumbnail.Height;
700 end;
701 if h > AMaxHeight then
702 begin
703 h := AMaxHeight;
704 w := round(thumbnail.Width* (h/thumbnail.Height));
705 end;
706 BGRAReplace(thumbnail, thumbnail.Resample(w,h));
707 end;
708 CopyBitmapToMemoryStream(thumbnail,'Thumbnails\thumbnail.png');
709 thumbnail.Free;
710end;
711
712procedure TBGRAOpenRasterDocument.Clear;
713begin
714 ClearFiles;
715 inherited Clear;
716end;
717
718function TBGRAOpenRasterDocument.CheckMimeType(AStream: TStream): boolean;
719var unzip: TUnzipperStreamUtf8;
720 mimeTypeFound: string;
721 oldPos: int64;
722begin
723 result := false;
724 unzip := TUnzipperStreamUtf8.Create;
725 oldPos := AStream.Position;
726 try
727 unzip.InputStream := AStream;
728 mimeTypeFound := unzip.UnzipFileToString('mimetype');
729 if mimeTypeFound = OpenRasterMimeType then result := true;
730 except
731 end;
732 unzip.Free;
733 astream.Position:= OldPos;
734end;
735
736procedure TBGRAOpenRasterDocument.LoadFlatImageFromStream(AStream: TStream; out
737 ANbLayers: integer; out ABitmap: TBGRABitmap);
738var fileList: TStringList;
739 imgStream, stackStream: TMemoryStream;
740 imageNode, stackNode: TDOMNode;
741 i: integer;
742begin
743 fileList := TStringList.Create;
744 fileList.Add(MergedImageFilename);
745 fileList.Add(LayerStackFilename);
746 imgStream := nil;
747 try
748 UnzipFromStream(AStream, fileList);
749 imgStream := GetMemoryStream(MergedImageFilename);
750 if imgStream = nil then
751 ABitmap := nil
752 else
753 ABitmap := TBGRABitmap.Create(imgStream);
754 ANbLayers := 1;
755
756 stackStream := GetMemoryStream(LayerStackFilename);
757 ReadXMLFile(FStackXML, StackStream);
758 imageNode := StackXML.FindNode('image');
759 if Assigned(imagenode) then
760 begin
761 stackNode := imageNode.FindNode('stack');
762 if Assigned(stackNode) then
763 begin
764 ANbLayers:= 0;
765 for i := stackNode.ChildNodes.Length-1 downto 0 do
766 begin
767 if stackNode.ChildNodes[i].NodeName = 'layer' then
768 inc(ANbLayers);
769 end;
770 end;
771 end;
772
773 finally
774 fileList.Free;
775 ClearFiles;
776 end;
777end;
778
779procedure TBGRAOpenRasterDocument.LoadFromStream(AStream: TStream);
780begin
781 OnLayeredBitmapLoadFromStreamStart;
782 try
783 UnzipFromStream(AStream);
784 AnalyzeZip;
785 finally
786 OnLayeredBitmapLoaded;
787 ClearFiles;
788 end;
789end;
790
791procedure TBGRAOpenRasterDocument.SetMimeType(AValue: string);
792begin
793 SetMemoryStreamAsString('mimetype',AValue);
794end;
795
796procedure TBGRAOpenRasterDocument.ZipOnCreateStream(Sender: TObject; var AStream: TStream;
797 AItem: TFullZipFileEntry);
798var MemStream: TMemoryStream;
799begin
800 MemStream := TMemoryStream.Create;
801 SetMemoryStream(AItem.ArchiveFileName, MemStream);
802 AStream := MemStream;
803end;
804
805{$hints off}
806procedure TBGRAOpenRasterDocument.ZipOnDoneStream(Sender: TObject; var AStream: TStream;
807 AItem: TFullZipFileEntry);
808begin
809 //do nothing, files stay in memory
810end;
811{$hints on}
812
813procedure TBGRAOpenRasterDocument.ZipOnOpenInputStream(Sender: TObject;
814 var AStream: TStream);
815begin
816 AStream := FZipInputStream;
817end;
818
819procedure TBGRAOpenRasterDocument.ZipOnCloseInputStream(Sender: TObject;
820 var AStream: TStream);
821begin
822 AStream := nil; //avoid freeing
823end;
824
825procedure TBGRAOpenRasterDocument.ClearFiles;
826var i: integer;
827begin
828 for i := 0 to high(FFiles) do
829 ffiles[i].Stream.Free;
830 FFiles := nil;
831 FreeAndNil(FStackXML);
832end;
833
834function TBGRAOpenRasterDocument.GetMemoryStream(AFilename: string): TMemoryStream;
835var i: integer;
836begin
837 for i := 0 to high(FFiles) do
838 if ffiles[i].Filename = AFilename then
839 begin
840 result := FFiles[i].Stream;
841 result.Position:= 0;
842 exit;
843 end;
844 result := nil;
845end;
846
847procedure TBGRAOpenRasterDocument.SetMemoryStream(AFilename: string;
848 AStream: TMemoryStream);
849var i: integer;
850begin
851 for i := 0 to high(FFiles) do
852 if ffiles[i].Filename = AFilename then
853 begin
854 FreeAndNil(FFiles[i].Stream);
855 FFiles[i].Stream := AStream;
856 exit;
857 end;
858 setlength(FFiles, length(FFiles)+1);
859 FFiles[high(FFiles)].Filename := AFilename;
860 FFiles[high(FFiles)].Stream := AStream;
861end;
862
863var AlreadyRegistered: boolean;
864
865procedure RegisterOpenRasterFormat;
866begin
867 if AlreadyRegistered then exit;
868 ImageHandlers.RegisterImageReader ('OpenRaster', 'ora', TFPReaderOpenRaster);
869 RegisterLayeredBitmapReader('ora', TBGRAOpenRasterDocument);
870 RegisterLayeredBitmapWriter('ora', TBGRAOpenRasterDocument);
871 //TPicture.RegisterFileFormat('ora', 'OpenRaster', TBGRAOpenRasterDocument);
872 DefaultBGRAImageReader[ifOpenRaster] := TFPReaderOpenRaster;
873 DefaultBGRAImageWriter[ifOpenRaster] := TFPWriterOpenRaster;
874 AlreadyRegistered:= True;
875end;
876
877end.
878
Note: See TracBrowser for help on using the repository browser.