Patch title: Release 92 bulk changes
Abstract:
File: /graphic/filter/jpeg.pli
Key:
    Removed line
    Added line
abstract
  [The well known JPEG file format interface.] ; eol
  [We link to JPEG standard library rather than porting it to Pliant because ]
  [JPEG encoding is far from beeing trivial.]

# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.


module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "prototype.pli"
module "/pliant/graphic/color/gamut.pli"

constant read_resolution true
constant write_resolution true


#-------------------------------------------------------------------------


if os_api<>"win32"
  constant jpeglib "libjpeg.so"
else
  constant jpeglib pliant_root_path+"binary\libjpeg.dll"

type jpeg_error_mgr
  field Address error_exit
  field Address emit_message
  field (Array Byte 132-8) unused1

type my_destination_mgr
  field Address next_output_byte
  field Int free_in_buffer
  field Address init_destination
  field Address empty_output_buffer
  field Address term_destination
  field Pointer:Stream stream

type jpeg_compress_struct
  field Pointer:jpeg_error_mgr err
  field (Array Byte 20) unused1
  field Pointer:my_destination_mgr dest
  field Int image_width
  field Int image_height
  field Int input_components
  field Int in_color_space
  field (Array Byte 372-44) unused2


type my_source_mgr
  field Address next_input_byte
  field Int bytes_in_buffer
  field Address init_source
  field Address fill_input_buffer
  field Address skip_input_data
  field Address resync_to_restart
  field Address term_source
  field Pointer:Stream stream

type jpeg_decompress_struct
  field Pointer:jpeg_error_mgr err
  field (Array Byte 20) unused1
  field Pointer:my_source_mgr src
  field Int image_width
  field Int image_height
  field Int num_components
  field Int jpeg_color_space
  field (Array Byte 464-44) unused2


constant JCS_GRAYSCALE 1
constant JCS_RGB 2
constant JPEG_LIB_VERSION 62
constant OUTPUT_BUF_SIZE 4096
constant JPEG_COM 0FEh

function jpeg_std_error jerr -> same
  arg_rw jpeg_error_mgr jerr ; arg_RW jpeg_error_mgr same
  external jpeglib "jpeg_std_error"
  
function jpeg_CreateCompress cinfo version size
  arg_rw jpeg_compress_struct cinfo ; arg Int version size
  external jpeglib "jpeg_CreateCompress"

function jpeg_create_compress cinfo
  arg_rw jpeg_compress_struct cinfo
  jpeg_CreateCompress cinfo JPEG_LIB_VERSION jpeg_compress_struct:size
  
function jpeg_set_defaults cinfo
  arg_rw jpeg_compress_struct cinfo
  external jpeglib "jpeg_set_defaults"

function jpeg_set_quality cinfo quality force_baseline
  arg_rw jpeg_compress_struct cinfo ; arg Int quality ; arg CBool force_baseline
  external jpeglib "jpeg_set_quality"

function jpeg_start_compress cinfo wat
  arg_rw jpeg_compress_struct cinfo ; arg CBool wat
  external jpeglib "jpeg_start_compress"

function jpeg_write_scanlines cinfo ptrs maxi -> count
  arg_rw jpeg_compress_struct cinfo ; arg Pointer:Address ptrs ; arg Int maxi count
  external jpeglib "jpeg_write_scanlines"

function jpeg_finish_compress cinfo
  arg_rw jpeg_compress_struct cinfo
  external jpeglib "jpeg_finish_compress"

function jpeg_abort_compress cinfo
  arg_rw jpeg_compress_struct cinfo
  external jpeglib "jpeg_abort_compress"

function jpeg_destroy_compress cinfo
  arg_rw jpeg_compress_struct cinfo
  external jpeglib "jpeg_destroy_compress"

function jpeg_write_marker cinfo marker adr len
  arg_rw jpeg_compress_struct cinfo ; arg Int marker ; arg Address adr ; arg Int len
  external jpeglib "jpeg_write_marker"



function jpeg_CreateDecompress cinfo version size
  arg_rw jpeg_decompress_struct cinfo ; arg Int version size
  external jpeglib "jpeg_CreateDecompress"

function jpeg_create_decompress cinfo
  arg_rw jpeg_decompress_struct cinfo
  jpeg_CreateDecompress cinfo JPEG_LIB_VERSION jpeg_decompress_struct:size
  
function jpeg_read_header cinfo require_image -> status
  arg_rw jpeg_decompress_struct cinfo ; arg CBool require_image ; arg Int status
  external jpeglib "jpeg_read_header"

function jpeg_start_decompress cinfo
  arg_rw jpeg_decompress_struct cinfo
  external jpeglib "jpeg_start_decompress"

function jpeg_read_scanlines cinfo ptrs maxi -> count
  arg_rw jpeg_decompress_struct cinfo ; arg Pointer:Address ptrs ; arg Int maxi count
  external jpeglib "jpeg_read_scanlines"

function jpeg_finish_decompress cinfo
  arg_rw jpeg_decompress_struct cinfo
  external jpeglib "jpeg_finish_decompress"

function jpeg_abort_decompress cinfo
  arg_rw jpeg_decompress_struct cinfo
  external jpeglib "jpeg_abort_decompress"

function jpeg_destroy_decompress cinfo
  arg_rw jpeg_decompress_struct cinfo
  external jpeglib "jpeg_destroy_decompress"

function jpeg_set_marker_processor cinfo marker_code routine
  arg_rw jpeg_decompress_struct cinfo ; arg Int marker_code ; arg Address routine
  external jpeglib "jpeg_set_marker_processor"


#-------------------------------------------------------------------------


function init_source cinfo
  arg_rw jpeg_decompress_struct cinfo
  external_calling_convention
  var Pointer:my_source_mgr src :> cinfo src
  var Pointer:Stream stream :> src stream
  src bytes_in_buffer := 0

function fill_input_buffer cinfo -> ok
  arg_rw jpeg_decompress_struct cinfo ; arg CBool ok
  external_calling_convention
  var Pointer:my_source_mgr src :> cinfo src
  var Pointer:Stream stream :> src stream
  stream read_available src:next_input_byte src:bytes_in_buffer
  ok := stream=success and src:bytes_in_buffer<>0

function skip_input_data cinfo num_bytes
  arg_rw jpeg_decompress_struct cinfo ; arg Int num_bytes
  external_calling_convention
  var Pointer:my_source_mgr src :> cinfo src
  var Pointer:Stream stream :> src stream
  var Int remain := num_bytes
  var Int step := min src:bytes_in_buffer num_bytes
  src next_input_byte := src:next_input_byte translate Byte step
  src bytes_in_buffer -= step
  remain -= step
  while remain<>0 and not stream:atend
    stream read_available (var Address adr) (var Int step) remain
    remain -= step
  
function resync_to_restart cinfo desired -> ok
  arg_rw jpeg_decompress_struct cinfo ; arg Int desired ; arg CBool ok
  external_calling_convention
  console "oops: undefined function resync_to_restart called by jpeg library interface"
  ok := false

function term_source cinfo
  arg_rw jpeg_decompress_struct cinfo
  external_calling_convention 
  

type ImageReadFilterJpeg
  field jpeg_decompress_struct cinfo
  field my_source_mgr src
  field jpeg_error_mgr jerr
  field Int remain
 
ImageReadFilter maybe ImageReadFilterJpeg


function jpeg_getc cinfo -> byte
  arg_rw jpeg_decompress_struct cinfo ; arg uInt byte
  var Pointer:my_source_mgr src :> cinfo src
  if src:bytes_in_buffer=0
    fill_input_buffer cinfo
  byte := src:next_input_byte map uInt8
  src next_input_byte := src:next_input_byte translate Byte 1
  src bytes_in_buffer -= 1

function process_comment cinfo -> ok
  arg_rw jpeg_decompress_struct cinfo ; arg CBool ok
  external_calling_convention
  var Int len := jpeg_getc:cinfo*256+jpeg_getc:cinfo-2
  var Str comment := repeat len " "
  for (var Int i) 0 len-1
    comment i := character jpeg_getc:cinfo
  console "jpeg comment: " comment eol
  ok := true

function error_exit cinfo
  arg Address cinfo
  external_calling_convention

function emit_message cinfo msg_level
  arg Address cinfo ; arg Int msg_level
  external_calling_convention

method f open stream options h -> status
  arg_rw ImageReadFilterJpeg f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status
  f:src stream :> stream
  f:cinfo err :> jpeg_std_error f:jerr
  f:jerr error_exit := (the_function error_exit Address):executable
  f:jerr emit_message := (the_function emit_message Address Int):executable
  jpeg_create_decompress f:cinfo
  f:cinfo src :> f src
  f:src init_source := (the_function init_source jpeg_decompress_struct) executable
  f:src fill_input_buffer := (the_function fill_input_buffer jpeg_decompress_struct -> CBool) executable
  f:src skip_input_data := (the_function skip_input_data jpeg_decompress_struct Int) executable
  f:src resync_to_restart := (the_function resync_to_restart jpeg_decompress_struct Int -> CBool) executable
  f:src term_source := (the_function term_source jpeg_decompress_struct) executable
  if (jpeg_read_header f:cinfo true)<>1
    jpeg_destroy_decompress f:cinfo
    return failure
  if false # f:cinfo:jpeg_color_space<>JCS_RGB and f:cinfo:jpeg_color_space<>JCS_GRAYSCALE
    jpeg_destroy_decompress f:cinfo
    return (failure "unsupported JPEG color space "+(string f:cinfo:jpeg_color_space))
  var Int size_x := f:cinfo image_width
  var Int size_y := f:cinfo image_height
  if not ((options (options option_position "resolution" 0) options:len) parse word:"resolution" (var Float dpi_x) (var Float dpi_y) any)
    dpi_x := options option "resolution" Float 72 ; dpi_y := dpi_x
  if read_resolution
    var Int density_unit := ((addressof f:cinfo) translate Byte 286) map uInt8
    if density_unit=1
      dpi_x := ((addressof f:cinfo) translate Byte 288) map uInt16
      dpi_y := ((addressof f:cinfo) translate Byte 290) map uInt16
  h := image_prototype 0 0 size_x/dpi_x*25.4 size_y/dpi_y*25.4 size_x size_y color_gamut:(shunt f:cinfo:jpeg_color_space=JCS_GRAYSCALE "grey" "rgb")
  jpeg_set_marker_processor f:cinfo JPEG_COM (the_function process_comment jpeg_decompress_struct -> CBool):executable
  jpeg_start_decompress f:cinfo
  f remain := size_y  
  status := success

method f readline adr -> status
  arg_rw ImageReadFilterJpeg f ; arg Address adr ; arg Status status
  var Pointer:Address ptrs :> adr
  status := shunt (jpeg_read_scanlines f:cinfo ptrs 1)=1 success failure
  if status=success
    f remain -= 1

method f close -> status
  arg_rw ImageReadFilterJpeg f ; arg ExtendedStatus status
  if f:remain=0
    jpeg_finish_decompress f:cinfo
  jpeg_destroy_decompress f:cinfo
  status := shunt f:src:stream=success success failure


#-------------------------------------------------------------------------


function init_destination cinfo
  arg_rw jpeg_compress_struct cinfo
  external_calling_convention
  var Pointer:my_destination_mgr dest :> cinfo dest
  var Pointer:Stream stream :> dest stream
  dest next_output_byte := stream stream_write_cur
  dest free_in_buffer := (cast stream:stream_write_stop Int).-.(cast stream:stream_write_cur Int)

function empty_output_buffer cinfo -> ok
  arg_rw jpeg_compress_struct cinfo ; arg CBool ok
  external_calling_convention
  var Pointer:my_destination_mgr dest :> cinfo dest
  var Pointer:Stream stream :> dest stream
  stream stream_write_cur := stream stream_write_stop
  stream flush anytime
  dest next_output_byte := stream stream_write_cur
  dest free_in_buffer := (cast stream:stream_write_stop Int).-.(cast stream:stream_write_cur Int)
  ok := stream=success

function term_destination cinfo
  arg_rw jpeg_compress_struct cinfo
  external_calling_convention 
  var Pointer:my_destination_mgr dest :> cinfo dest
  var Pointer:Stream stream :> dest stream
  stream stream_write_cur := stream:stream_write_stop translate Byte -(dest free_in_buffer)
  stream flush anytime
  

type ImageWriteFilterJpeg
  field jpeg_compress_struct cinfo
  field my_destination_mgr dest
  field jpeg_error_mgr jerr
  field Int remain

ImageWriteFilter maybe ImageWriteFilterJpeg

method f open stream options h -> status
  arg_rw ImageWriteFilterJpeg f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status
  if h:gamut:name<>"rgb"
    return failure:"Only RGB images are currently supported by JPEG output filter"
  f:dest stream :> stream
  f:cinfo err :> jpeg_std_error f:jerr
  jpeg_create_compress f:cinfo
  f:cinfo dest :> f dest
  f:dest init_destination := (the_function init_destination jpeg_compress_struct) executable
  f:dest empty_output_buffer := (the_function empty_output_buffer jpeg_compress_struct -> CBool) executable
  f:dest term_destination := (the_function term_destination jpeg_compress_struct) executable
  f:cinfo image_width := h size_x
  f:cinfo image_height := h size_y
  f:cinfo input_components := 3
  f:cinfo in_color_space := JCS_RGB
  if write_resolution
    ((addressof f:cinfo) translate Byte 210) map uInt8 := 1 # density_unit
    ((addressof f:cinfo) translate Byte 212) map uInt16 := cast h:size_x/(abs h:x1-h:x0)*25.4 Int # X_density
    ((addressof f:cinfo) translate Byte 214) map uInt16 := cast h:size_y/(abs h:y1-h:y0)*25.4 Int # Y_density
  jpeg_set_defaults f:cinfo
  var Float quality := options option "quality" Float
  if quality=defined
    jpeg_set_quality f:cinfo (cast quality*100 Int) false
  jpeg_start_compress f:cinfo true
  var Str comment := options option "comment" Str
  if comment<>""
    jpeg_write_marker f:cinfo JPEG_COM comment:characters comment:len
  f remain := h size_y
  status := success
  
method f writeline adr -> status
  arg_rw ImageWriteFilterJpeg f ; arg Address adr ; arg Status status
  var Pointer:Address ptrs :> adr
  status := shunt (jpeg_write_scanlines f:cinfo ptrs 1)=1 success failure
  if status=success
    f remain -= 1

method f close -> status
  arg_rw ImageWriteFilterJpeg f ; arg ExtendedStatus status
  if f:remain=0
    jpeg_finish_compress f:cinfo
  jpeg_destroy_compress f:cinfo
  status := shunt f:dest:stream=success success failure


image_record_filters ".jpg" ImageReadFilterJpeg ImageWriteFilterJpeg
image_record_filters ".jpeg" ImageReadFilterJpeg ImageWriteFilterJpeg
image_record_filters ".jpg" ImageReadFilterJpeg false ImageWriteFilterJpeg false
image_record_filters ".jpeg" ImageReadFilterJpeg false ImageWriteFilterJpeg false