Unit jcmarker;

{ This file contains routines to write JPEG datastream markers. }

{ Original: jcmarker.c; Copyright (C) 1991-1998, Thomas G. Lane. }

interface

{$I jconfig.inc}

uses
  jinclude, jmorecfg, jerror,
  jdeferr, jpeglib, jutils;


const
                { JPEG marker codes }
  M_SOF0  = $c0;
  M_SOF1  = $c1;
  M_SOF2  = $c2;
  M_SOF3  = $c3;

  M_SOF5  = $c5;
  M_SOF6  = $c6;
  M_SOF7  = $c7;

  M_JPG   = $c8;
  M_SOF9  = $c9;
  M_SOF10 = $ca;
  M_SOF11 = $cb;
  
  M_SOF13 = $cd;
  M_SOF14 = $ce;
  M_SOF15 = $cf;
  
  M_DHT   = $c4;
  
  M_DAC   = $cc;
  
  M_RST0  = $d0;
  M_RST1  = $d1;
  M_RST2  = $d2;
  M_RST3  = $d3;
  M_RST4  = $d4;
  M_RST5  = $d5;
  M_RST6  = $d6;
  M_RST7  = $d7;
  
  M_SOI   = $d8;
  M_EOI   = $d9;
  M_SOS   = $da;
  M_DQT   = $db;
  M_DNL   = $dc;
  M_DRI   = $dd;
  M_DHP   = $de;
  M_EXP   = $df;
  
  M_APP0  = $e0;
  M_APP1  = $e1;
  M_APP2  = $e2;
  M_APP3  = $e3;
  M_APP4  = $e4;
  M_APP5  = $e5;
  M_APP6  = $e6;
  M_APP7  = $e7;
  M_APP8  = $e8;
  M_APP9  = $e9;
  M_APP10 = $ea;
  M_APP11 = $eb;
  M_APP12 = $ec;
  M_APP13 = $ed;
  M_APP14 = $ee;
  M_APP15 = $ef;

  M_JPG0  = $f0;
  M_JPG13 = $fd;
  M_COM   = $fe;

  M_TEM   = $01;

  M_ERROR = $100;

type
  JPEG_MARKER = Word;

{ Private state }

type
  my_marker_ptr = ^my_marker_writer;
  my_marker_writer = record
    pub : jpeg_marker_writer; { public fields }

    last_restart_interval : uint; { last DRI value emitted; 0 after SOI }
  end;




{GLOBAL}
procedure jinit_marker_writer (cinfo : j_compress_ptr);

implementation

{ Basic output routines.

  Note that we do not support suspension while writing a marker.
  Therefore, an application using suspension must ensure that there is
  enough buffer space for the initial markers (typ. 600-700 bytes) before
  calling jpeg_start_compress, and enough space to write the trailing EOI
  (a few bytes) before calling jpeg_finish_compress.  Multipass compression
  modes are not supported at all with suspension, so those two are the only
  points where markers will be written. }


{LOCAL}
procedure emit_byte (cinfo : j_compress_ptr; val : int);
{ Emit a byte }
var
  dest : jpeg_destination_mgr_ptr;
begin
  dest := cinfo^.dest;

  dest^.next_output_byte^ := JOCTET(val);
  Inc(dest^.next_output_byte);

  Dec(dest^.free_in_buffer);
  if (dest^.free_in_buffer = 0) then
  begin
    if not dest^.empty_output_buffer(cinfo) then
      ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
  end;
end;


{LOCAL}
procedure emit_marker(cinfo : j_compress_ptr; mark : JPEG_MARKER);
{ Emit a marker code }
begin
  emit_byte(cinfo, $FF);
  emit_byte(cinfo, int(mark));
end;


{LOCAL}
procedure emit_2bytes (cinfo : j_compress_ptr; value : int);
{ Emit a 2-byte integer; these are always MSB first in JPEG files }
begin
  emit_byte(cinfo, (value shr 8) and $FF);
  emit_byte(cinfo, value and $FF);
end;


{ Routines to write specific marker types. }

{LOCAL}
function emit_dqt (cinfo : j_compress_ptr; index : int) : int;
{ Emit a DQT marker }
{ Returns the precision used (0 = 8bits, 1 = 16bits) for baseline checking }
var
  qtbl : JQUANT_TBL_PTR;
  prec : int;
  i : int;
var
  qval : uint;
begin
  qtbl := cinfo^.quant_tbl_ptrs[index];
  if (qtbl = NIL) then
    ERREXIT1(j_common_ptr(cinfo), JERR_NO_QUANT_TABLE, index);

  prec := 0;
  for i := 0 to Pred(DCTSIZE2) do
  begin
    if (qtbl^.quantval[i] > 255) then
      prec := 1;
  end;

  if not qtbl^.sent_table then
  begin
    emit_marker(cinfo, M_DQT);

    if (prec <> 0) then
      emit_2bytes(cinfo, DCTSIZE2*2 + 1 + 2)
    else
      emit_2bytes(cinfo, DCTSIZE2 + 1 + 2);

    emit_byte(cinfo, index + (prec shl 4));

    for i := 0 to Pred(DCTSIZE2) do
    begin
      { The table entries must be emitted in zigzag order. }
      qval := qtbl^.quantval[jpeg_natural_order[i]];
      if (prec <> 0) then
	emit_byte(cinfo, int(qval shr 8));
      emit_byte(cinfo, int(qval and $FF));
    end;

    qtbl^.sent_table := TRUE;
  end;

  emit_dqt := prec;
end;


{LOCAL}
procedure emit_dht (cinfo : j_compress_ptr; index : int; is_ac : boolean);
{ Emit a DHT marker }
var
  htbl : JHUFF_TBL_PTR;
  length, i : int;
begin
  if (is_ac) then
  begin
    htbl := cinfo^.ac_huff_tbl_ptrs[index];
    index := index + $10;                { output index has AC bit set }
  end
  else
  begin
    htbl := cinfo^.dc_huff_tbl_ptrs[index];
  end;

  if (htbl = NIL) then
    ERREXIT1(j_common_ptr(cinfo), JERR_NO_HUFF_TABLE, index);

  if not htbl^.sent_table then
  begin
    emit_marker(cinfo, M_DHT);

    length := 0;
    for i := 1 to 16 do
      length := length + htbl^.bits[i];

    emit_2bytes(cinfo, length + 2 + 1 + 16);
    emit_byte(cinfo, index);

    for i := 1 to 16 do
      emit_byte(cinfo, htbl^.bits[i]);

    for i := 0 to Pred(length) do
      emit_byte(cinfo, htbl^.huffval[i]);

    htbl^.sent_table := TRUE;
  end;
end;


{LOCAL}
procedure emit_dac (cinfo : j_compress_ptr);
{ Emit a DAC marker }
{ Since the useful info is so small, we want to emit all the tables in }
{ one DAC marker.  Therefore this routine does its own scan of the table. }
{$ifdef C_ARITH_CODING_SUPPORTED}
var
  dc_in_use : array[0..NUM_ARITH_TBLS] of byte;
  ac_in_use : array[0..NUM_ARITH_TBLS] of byte;
  length, i : int;
  compptr : jpeg_component_info_ptr;
begin
  for i := 0 to pred(NUM_ARITH_TBLS) do
  begin
    dc_in_use[i] := 0;
    ac_in_use[i] := 0;
  end;

  for i := 0 to pred(cinfo^.comps_in_scan) do
  begin
    compptr := cinfo^.cur_comp_info[i];
    dc_in_use[compptr^.dc_tbl_no] := 1;
    ac_in_use[compptr^.ac_tbl_no] := 1;
  end;

  length := 0;
  for i := 0 to pred(NUM_ARITH_TBLS) do
    Inc(length, dc_in_use[i] + ac_in_use[i]);

  emit_marker(cinfo, M_DAC);

  emit_2bytes(cinfo, length*2 + 2);

  for i := 0 to pred(NUM_ARITH_TBLS) do
  begin
    if (dc_in_use[i] <> 0) then
    begin
      emit_byte(cinfo, i);
      emit_byte(cinfo, cinfo^.arith_dc_L[i] + (cinfo^.arith_dc_U[i] shl 4));
    end;
    if (ac_in_use[i] <> 0) then
    begin
      emit_byte(cinfo, i + $10);
      emit_byte(cinfo, cinfo^.arith_ac_K[i]);
    end;
  end;
end;
{$else}
begin
end;
{$endif}  {C_ARITH_CODING_SUPPORTED}


{LOCAL}
procedure emit_dri (cinfo : j_compress_ptr);
{ Emit a DRI marker }
begin
  emit_marker(cinfo, M_DRI);

  emit_2bytes(cinfo, 4);	{ fixed length }

  emit_2bytes(cinfo, int(cinfo^.restart_interval));
end;


{LOCAL}
procedure emit_sof (cinfo : j_compress_ptr; code : JPEG_MARKER);
{ Emit a SOF marker }
var
  ci : int;
  compptr : jpeg_component_info_ptr;
begin
  emit_marker(cinfo, code);

  emit_2bytes(cinfo, 3 * cinfo^.num_components + 2 + 5 + 1); { length }

  { Make sure image isn't bigger than SOF field can handle }
  if (long(cinfo^.image_height) > long(65535)) or
     (long(cinfo^.image_width) > long(65535)) then
    ERREXIT1(j_common_ptr(cinfo), JERR_IMAGE_TOO_BIG, uInt(65535));

  emit_byte(cinfo, cinfo^.data_precision);
  emit_2bytes(cinfo, int(cinfo^.image_height));
  emit_2bytes(cinfo, int(cinfo^.image_width));

  emit_byte(cinfo, cinfo^.num_components);

  compptr := jpeg_component_info_ptr(cinfo^.comp_info);
  for ci := 0  to Pred(cinfo^.num_components) do
  begin
    emit_byte(cinfo, compptr^.component_id);
    emit_byte(cinfo, (compptr^.h_samp_factor shl 4) + compptr^.v_samp_factor);
    emit_byte(cinfo, compptr^.quant_tbl_no);
    Inc(compptr);
  end;
end;


{LOCAL}
procedure emit_sos (cinfo : j_compress_ptr);
{ Emit a SOS marker }
var
  i, td, ta : int;
  compptr : jpeg_component_info_ptr;
begin
  emit_marker(cinfo, M_SOS);

  emit_2bytes(cinfo, 2 * cinfo^.comps_in_scan + 2 + 1 + 3); { length }

  emit_byte(cinfo, cinfo^.comps_in_scan);

  for i := 0 to Pred(cinfo^.comps_in_scan) do
  begin
    compptr := cinfo^.cur_comp_info[i];
    emit_byte(cinfo, compptr^.component_id);
    td := compptr^.dc_tbl_no;
    ta := compptr^.ac_tbl_no;