LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   History :  
6
       23/08/10 - Yar - Replaced OpenGL1x to OpenGLTokens
7
       29/06/10 - Yar - Improved FPC compatibility
8
       29/04/10 - Yar - Bugfixed loading of fliped image (thanks mif)
9
       27/02/10 - Yar - Creation
10
   
11
}
12
unit GLFileJPEG;
13

14
interface
15

16
{$I GLScene.inc}
17

18
uses
19
  Classes, SysUtils,
20
  GLCrossPlatform, OpenGLTokens, GLContext, GLGraphics, GLTextureFormat,
21
  GLApplicationFileIO, GLSLog;
22

23
type
24

25
  TGLJPEGImage = class(TGLBaseImage)
26
  private
27
    FAbortLoading: boolean;
28
    FDivScale: longword;
29
    FDither: boolean;
30
    FSmoothing: boolean;
31
    FProgressiveEncoding: boolean;
32
    procedure SetSmoothing(const AValue: boolean);
33
  public
34
    constructor Create; override;
35
    class function Capabilities: TGLDataFileCapabilities; override;
36

37
    procedure LoadFromFile(const filename: string); override;
38
    procedure SaveToFile(const filename: string); override;
39
    procedure LoadFromStream(stream: TStream); override;
40
    procedure SaveToStream(stream: TStream); override;
41

42
    { Assigns from any Texture.}
43
    procedure AssignFromTexture(textureContext: TGLContext;
44
      const textureHandle: TGLuint;
45
      textureTarget: TGLTextureTarget;
46
      const CurrentFormat: boolean;
47
      const intFormat: TGLInternalFormat); reintroduce;
48

49
    property DivScale: longword read FDivScale write FDivScale;
50
    property Dither: boolean read FDither write FDither;
51
    property Smoothing: boolean read FSmoothing write SetSmoothing;
52
    property ProgressiveEncoding: boolean read FProgressiveEncoding;
53
  end;
54

55
implementation
56

57
uses
58
  FPReadJPEG,
59
  fpimage,
60
  jmorecfg,
61
  jpeglib,
62
  jerror,
63
  jdeferr,
64
  jdmarker,
65
  jdmaster,
66
  jdapimin,
67
  jdapistd,
68
  jcparam,
69
  jcapimin,
70
  jcapistd,
71
  jcomapi,
72
  jdatasrc,
73
  jmemmgr,
74

75
  GLVectorGeometry;
76

77

78
// ------------------
79
// ------------------ TGLJPEGImage ------------------
80
// ------------------
81

82
constructor TGLJPEGImage.Create;
83
begin
84
  inherited;
85
  FAbortLoading := False;
86
  FDivScale := 1;
87
  FDither := False;
88
end;
89

90
 
91

92

93
procedure TGLJPEGImage.LoadFromFile(const filename: string);
94
var
95
  fs: TStream;
96
begin
97
  if FileStreamExists(fileName) then
98
  begin
99
    fs := CreateFileStream(fileName, fmOpenRead);
100
    try
101
      LoadFromStream(fs);
102
    finally
103
      fs.Free;
104
      ResourceName := filename;
105
    end;
106
  end
107
  else
108
    raise EInvalidRasterFile.CreateFmt('File %s not found', [filename]);
109
end;
110

111
// SaveToFile
112

113

114
procedure TGLJPEGImage.SaveToFile(const filename: string);
115
var
116
  fs: TStream;
117
begin
118
  fs := CreateFileStream(fileName, fmOpenWrite or fmCreate);
119
  try
120
    SaveToStream(fs);
121
  finally
122
    fs.Free;
123
  end;
124
  ResourceName := filename;
125
end;
126

127
// LoadFromStream
128

129

130
procedure JPEGError(CurInfo: j_common_ptr);
131
begin
132
  if CurInfo = nil then
133
    exit;
134
  raise Exception.CreateFmt('JPEG error', [CurInfo^.err^.msg_code]);
135
end;
136

137
procedure EmitMessage(CurInfo: j_common_ptr; msg_level: integer);
138
begin
139
  if CurInfo = nil then
140
    exit;
141
  if msg_level = 0 then
142
  ;
143
end;
144

145
procedure OutputMessage(CurInfo: j_common_ptr);
146
begin
147
  if CurInfo = nil then
148
    exit;
149
end;
150

151
procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
152
begin
153
  if CurInfo = nil then
154
    exit;
155
  GLSLogger.LogInfo(buffer);
156
end;
157

158
procedure ResetErrorMgr(CurInfo: j_common_ptr);
159
begin
160
  if CurInfo = nil then
161
    exit;
162
  CurInfo^.err^.num_warnings := 0;
163
  CurInfo^.err^.msg_code := 0;
164
end;
165

166
procedure ProgressCallback(CurInfo: j_common_ptr);
167
begin
168
  if CurInfo = nil then
169
    exit;
170
  // ToDo
171
end;
172

173
var
174
  jpeg_std_error: jpeg_error_mgr;
175

176
procedure TGLJPEGImage.LoadFromStream(stream: TStream);
177
var
178
  MemStream: TMemoryStream;
179
  vInfo: jpeg_decompress_struct;
180
  vError: jpeg_error_mgr;
181
  jc: TFPJPEGProgressManager;
182

183
  procedure SetSource;
184
  begin
185
    MemStream.Position := 0;
186
    jpeg_stdio_src(@vInfo, @MemStream);
187
  end;
188

189
  procedure ReadHeader;
190
  begin
191
    UnMipmap;
192
    jpeg_read_header(@vInfo, True);
193
    FLOD[0].Width := vInfo.image_width;
194
    FLOD[0].Height := vInfo.image_height;
195
    FLOD[0].Depth := 0;
196
    if vInfo.jpeg_color_space = JCS_CMYK then
197
    begin
198
      FColorFormat := GL_RGBA;
199
      FInternalFormat := tfRGBA8;
200
      FElementSize := 4;
201
    end
202
    else
203
    if vInfo.out_color_space = JCS_GRAYSCALE then
204
    begin
205
      FColorFormat := GL_LUMINANCE;
206
      FInternalFormat := tfLUMINANCE8;
207
      FElementSize := 1;
208
    end
209
    else
210
    begin
211
      FColorFormat := GL_RGB;
212
      FInternalFormat := tfRGB8;
213
      FElementSize := 3;
214
    end;
215
    FDataType := GL_UNSIGNED_BYTE;
216
    FCubeMap := False;
217
    FTextureArray := False;
218
    ReallocMem(FData, DataSize);
219
    FProgressiveEncoding := jpeg_has_multiple_scans(@vInfo);
220
  end;
221

222
  procedure InitReadingPixels;
223
  begin
224
    vInfo.scale_num := 1;
225
    vInfo.scale_denom := 1;
226
    vInfo.do_block_smoothing := FSmoothing;
227

228
    if vInfo.out_color_space = JCS_GRAYSCALE then
229
    begin
230
      vInfo.quantize_colors := True;
231
      vInfo.desired_number_of_colors := 236;
232
    end;
233

234
    if FProgressiveEncoding then
235
    begin
236
      vInfo.enable_2pass_quant := vInfo.two_pass_quantize;
237
      vInfo.buffered_image := True;
238
    end;
239
  end;
240

241
  function CorrectCMYK(const C: TFPColor): TFPColor;
242
  var
243
    MinColor: word;
244
  begin
245
    if C.red < C.green then
246
      MinColor := C.red
247
    else
248
      MinColor := C.green;
249
    if C.blue < MinColor then
250
      MinColor := C.blue;
251
    if MinColor + C.alpha > $FF then
252
      MinColor := $FF - C.alpha;
253
    Result.red := (C.red - MinColor) shl 8;
254
    Result.green := (C.green - MinColor) shl 8;
255
    Result.blue := (C.blue - MinColor) shl 8;
256
    Result.alpha := alphaOpaque;
257
  end;
258

259
  procedure ReadPixels;
260
  var
261
    SampArray: JSAMPARRAY;
262
    SampRow: JSAMPROW;
263
    Color: TFPColor;
264
    LinesRead: Cardinal;
265
    y: Integer;
266
    Status, Scan: integer;
267
    ReturnValue, RestartLoop: boolean;
268

269
    procedure OutputScanLines();
270
    var
271
      x: integer;
272
      pPixel: PByte;
273
    begin
274
      Color.Alpha := alphaOpaque;
275
      y := FLOD[0].Height - 1;
276
      while (vInfo.output_scanline < vInfo.output_height) do
277
      begin
278
        // read one line per call
279
        LinesRead := jpeg_read_scanlines(@vInfo, SampArray, 1);
280
        if LinesRead < 1 then
281
        begin
282
          ReturnValue := False;
283
          break;
284
        end;
285
        pPixel := @PByteArray(FData)[y*FLOD[0].Width*FElementSize];
286

287
        if vInfo.jpeg_color_space = JCS_CMYK then
288
        begin
289
          for x := 0 to vInfo.output_width - 1 do
290
          begin
291
            Color.Red := SampRow^[x * 4 + 0];
292
            Color.Green := SampRow^[x * 4 + 1];
293
            Color.Blue := SampRow^[x * 4 + 2];
294
            Color.alpha := SampRow^[x * 4 + 3];
295
            Color := CorrectCMYK(Color);
296
            pPixel^:= Color.red; Inc(pPixel);
297
            pPixel^:= Color.green; Inc(pPixel);
298
            pPixel^:= Color.blue; Inc(pPixel);
299
            pPixel^:= Color.alpha; Inc(pPixel);
300
          end;
301
        end
302
        else // RGB or LUMINANCE
303
          Move(SampRow^[0], pPixel^, FElementSize * vInfo.output_width);
304

305
        Dec(y);
306
      end;
307
    end;
308

309
  begin
310
    InitReadingPixels;
311

312
    jpeg_start_decompress(@vInfo);
313

314
    GetMem(SampArray, SizeOf(JSAMPROW));
315
    GetMem(SampRow, vInfo.output_width * vInfo.output_components);
316
    SampArray^[0] := SampRow;
317
    try
318
      case FProgressiveEncoding of
319
        False:
320
          begin
321
            ReturnValue:=true;
322
            OutputScanLines();
323
            if vInfo.buffered_image then jpeg_finish_output(@vInfo);
324
          end;
325
        True:
326
          begin
327
            while true do
328
            begin
329
              (* The RestartLoop variable drops a placeholder for suspension
330
                 mode, or partial jpeg decode, return and continue. In case
331
                 of support this suspension, the RestartLoop:=True should be
332
                 changed by an Exit and in the routine enter detects that it
333
                 is being called from a suspended state to not
334
                 reinitialize some buffer *)
335
              RestartLoop:=false;
336
              repeat
337
                status := jpeg_consume_input(@vInfo);
338
              until (status=JPEG_SUSPENDED) or (status=JPEG_REACHED_EOI);
339
              ReturnValue:=true;
340
              if vInfo.output_scanline = 0 then
341
              begin
342
                Scan := vInfo.input_scan_number;
343
                (* if we haven't displayed anything yet (output_scan_number==0)
344
                  and we have enough data for a complete scan, force output
345
                  of the last full scan *)
346
                if (vInfo.output_scan_number = 0) and (Scan > 1) and
347
                  (status <> JPEG_REACHED_EOI) then Dec(Scan);
348

349
                if not jpeg_start_output(@vInfo, Scan) then
350
                begin
351
                  RestartLoop:=true; (* I/O suspension *)
352
                end;
353
              end;
354

355
              if not RestartLoop then
356
              begin
357
                if (vInfo.output_scanline = $ffffff) then
358
                  vInfo.output_scanline := 0;
359

360
                OutputScanLines();
361

362
                if ReturnValue=false then begin
363
                  if (vInfo.output_scanline = 0) then
364
                  begin
365
                     (* didn't manage to read any lines - flag so we don't call
366
                        jpeg_start_output() multiple times for the same scan *)
367
                     vInfo.output_scanline := $ffffff;
368
                  end;
369
                  RestartLoop:=true; (* I/O suspension *)
370
                end;
371

372
                if not RestartLoop then
373
                begin
374
                  if (vInfo.output_scanline = vInfo.output_height) then
375
                  begin
376
                    if not jpeg_finish_output(@vInfo) then
377
                    begin
378
                      RestartLoop:=true; (* I/O suspension *)
379
                    end;
380

381
                    if not RestartLoop then
382
                    begin
383
                      if (jpeg_input_complete(@vInfo) and
384
                         (vInfo.input_scan_number = vInfo.output_scan_number)) then
385
                        break;
386

387
                      vInfo.output_scanline := 0;
388
                    end;
389
                  end;
390
                end;
391
              end;
392
              if RestartLoop then
393
                break;
394
            end;
395
          end;
396
      end;
397
    finally
398
      FreeMem(SampRow);
399
      FreeMem(SampArray);
400
    end;
401

402
    jpeg_finish_decompress(@vInfo);
403
  end;
404

405
begin
406
  MemStream := nil;
407
  FillChar(vInfo, SizeOf(vInfo), $00);
408
  try
409

410
    if stream is TMemoryStream then
411
      MemStream := TMemoryStream(stream)
412
    else
413
    begin
414
      MemStream := TMemoryStream.Create;
415
      MemStream.CopyFrom(stream, stream.Size - stream.Position);
416
      MemStream.Position := 0;
417
    end;
418

419
    if MemStream.Size > 0 then
420
    begin
421
      vError := jpeg_std_error;
422
      vInfo.err := @vError;
423
      jpeg_CreateDecompress(@vInfo, JPEG_LIB_VERSION, SizeOf(vInfo));
424
      try
425
        jc.pub.progress_monitor := @ProgressCallback;
426
        jc.instance := Self;
427
        vInfo.progress := @jc.pub;
428
        SetSource;
429
        ReadHeader;
430
        ReadPixels;
431
      finally
432
        jpeg_Destroy_Decompress(@vInfo);
433
      end;
434
    end;
435
  finally
436
    if Assigned(MemStream) and (MemStream <> stream) then
437
      MemStream.Free;
438
  end;
439
end;
440

441

442

443
procedure TGLJPEGImage.SaveToStream(stream: TStream);
444
begin
445

446
end;
447

448
// AssignFromTexture
449

450

451
procedure TGLJPEGImage.AssignFromTexture(textureContext: TGLContext;
452
  const textureHandle: TGLuint; textureTarget: TGLTextureTarget;
453
  const CurrentFormat: boolean; const intFormat: TGLInternalFormat);
454
begin
455

456
end;
457

458
procedure TGLJPEGImage.SetSmoothing(const AValue: boolean);
459
begin
460
  if FSmoothing <> AValue then
461
    FSmoothing := AValue;
462
end;
463

464
// Capabilities
465

466

467
class function TGLJPEGImage.Capabilities: TGLDataFileCapabilities;
468
begin
469
  Result := [dfcRead {, dfcWrite}];
470
end;
471

472
initialization
473

474

475
  with jpeg_std_error do
476
  begin
477
    error_exit := @JPEGError;
478
    emit_message := @EmitMessage;
479
    output_message := @OutputMessage;
480
    format_message := @FormatMessage;
481
    reset_error_mgr := @ResetErrorMgr;
482
  end;
483

484

485
  { Register this Fileformat-Handler with GLScene }
486
  RegisterRasterFormat('jpg', 'Joint Photographic Experts Group Image',
487
    TGLJPEGImage);
488
  RegisterRasterFormat('jpeg', 'Joint Photographic Experts Group Image',
489
    TGLJPEGImage);
490
  RegisterRasterFormat('jpe', 'Joint Photographic Experts Group Image',
491
    TGLJPEGImage);
492
end.
493

494