/pliant/graphic/filter/jpeg.pli
 
 1  abstract 
 2    [The well known JPEG file format interface.] ; eol 
 3    [We link to JPEG standard library rather than porting it to Pliant because ] 
 4    [JPEG encoding is far from beeing trivial.] 
 5   
 6  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 7  # 
 8  # This program is free software; you can redistribute it and/or 
 9  # modify it under the terms of the GNU General Public License version 2 
 10  # as published by the Free Software Foundation. 
 11  # 
 12  # This program is distributed in the hope that it will be useful, 
 13  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 14  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 15  # GNU General Public License for more details. 
 16  # 
 17  # You should have received a copy of the GNU General Public License 
 18  # version 2 along with this program; if not, write to the Free Software 
 19  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 20   
 21   
 22  module "/pliant/language/compiler.pli" 
 23  module "/pliant/language/context.pli" 
 24  module "/pliant/language/stream.pli" 
 25  module "prototype.pli" 
 26  module "/pliant/graphic/color/gamut.pli" 
 27   
 28  constant read_resolution true 
 29  constant write_resolution true 
 30   
 31   
 32 
 
 33   
 34   
 35  if os_api<>"win32" 
 36    constant jpeglib "libjpeg.so" 
 37  else 
 38    constant jpeglib pliant_root_path+"binary\libjpeg.dll" 
 39   
 40  type jpeg_error_mgr 
 41    field Address error_exit 
 42    field Address emit_message 
 43    field (Array Byte 132-8) unused1 
 44   
 45  type my_destination_mgr 
 46    field Address next_output_byte 
 47    field Int free_in_buffer 
 48    field Address init_destination 
 49    field Address empty_output_buffer 
 50    field Address term_destination 
 51    field Pointer:Stream stream 
 52   
 53  type jpeg_compress_struct 
 54    field Pointer:jpeg_error_mgr err 
 55    field (Array Byte 20) unused1 
 56    field Pointer:my_destination_mgr dest 
 57    field Int image_width 
 58    field Int image_height 
 59    field Int input_components 
 60    field Int in_color_space 
 61    field (Array Byte 372-44) unused2 
 62   
 63   
 64  type my_source_mgr 
 65    field Address next_input_byte 
 66    field Int bytes_in_buffer 
 67    field Address init_source 
 68    field Address fill_input_buffer 
 69    field Address skip_input_data 
 70    field Address resync_to_restart 
 71    field Address term_source 
 72    field Pointer:Stream stream 
 73   
 74  type jpeg_decompress_struct 
 75    field Pointer:jpeg_error_mgr err 
 76    field (Array Byte 20) unused1 
 77    field Pointer:my_source_mgr src 
 78    field Int image_width 
 79    field Int image_height 
 80    field Int num_components 
 81    field Int jpeg_color_space 
 82    field (Array Byte 464-44) unused2 
 83   
 84   
 85  constant JCS_GRAYSCALE 1 
 86  constant JCS_RGB 2 
 87  constant JPEG_LIB_VERSION 62 
 88  constant OUTPUT_BUF_SIZE 4096 
 89  constant JPEG_COM 0FEh 
 90   
 91  function jpeg_std_error jerr -> same 
 92    arg_rw jpeg_error_mgr jerr ; arg_RW jpeg_error_mgr same 
 93    external jpeglib "jpeg_std_error" 
 94     
 95  function jpeg_CreateCompress cinfo version size 
 96    arg_rw jpeg_compress_struct cinfo ; arg Int version size 
 97    external jpeglib "jpeg_CreateCompress" 
 98   
 99  function jpeg_create_compress cinfo 
 100    arg_rw jpeg_compress_struct cinfo 
 101    jpeg_CreateCompress cinfo JPEG_LIB_VERSION jpeg_compress_struct:size 
 102     
 103  function jpeg_set_defaults cinfo 
 104    arg_rw jpeg_compress_struct cinfo 
 105    external jpeglib "jpeg_set_defaults" 
 106   
 107  function jpeg_set_quality cinfo quality force_baseline 
 108    arg_rw jpeg_compress_struct cinfo ; arg Int quality ; arg CBool force_baseline 
 109    external jpeglib "jpeg_set_quality" 
 110   
 111  function jpeg_start_compress cinfo wat 
 112    arg_rw jpeg_compress_struct cinfo ; arg CBool wat 
 113    external jpeglib "jpeg_start_compress" 
 114   
 115  function jpeg_write_scanlines cinfo ptrs maxi -> count 
 116    arg_rw jpeg_compress_struct cinfo ; arg Pointer:Address ptrs ; arg Int maxi count 
 117    external jpeglib "jpeg_write_scanlines" 
 118   
 119  function jpeg_finish_compress cinfo 
 120    arg_rw jpeg_compress_struct cinfo 
 121    external jpeglib "jpeg_finish_compress" 
 122   
 123  function jpeg_abort_compress cinfo 
 124    arg_rw jpeg_compress_struct cinfo 
 125    external jpeglib "jpeg_abort_compress" 
 126   
 127  function jpeg_destroy_compress cinfo 
 128    arg_rw jpeg_compress_struct cinfo 
 129    external jpeglib "jpeg_destroy_compress" 
 130   
 131  function jpeg_write_marker cinfo marker adr len 
 132    arg_rw jpeg_compress_struct cinfo ; arg Int marker ; arg Address adr ; arg Int len 
 133    external jpeglib "jpeg_write_marker" 
 134   
 135   
 136   
 137  function jpeg_CreateDecompress cinfo version size 
 138    arg_rw jpeg_decompress_struct cinfo ; arg Int version size 
 139    external jpeglib "jpeg_CreateDecompress" 
 140   
 141  function jpeg_create_decompress cinfo 
 142    arg_rw jpeg_decompress_struct cinfo 
 143    jpeg_CreateDecompress cinfo JPEG_LIB_VERSION jpeg_decompress_struct:size 
 144     
 145  function jpeg_read_header cinfo require_image -> status 
 146    arg_rw jpeg_decompress_struct cinfo ; arg CBool require_image ; arg Int status 
 147    external jpeglib "jpeg_read_header" 
 148   
 149  function jpeg_start_decompress cinfo 
 150    arg_rw jpeg_decompress_struct cinfo 
 151    external jpeglib "jpeg_start_decompress" 
 152   
 153  function jpeg_read_scanlines cinfo ptrs maxi -> count 
 154    arg_rw jpeg_decompress_struct cinfo ; arg Pointer:Address ptrs ; arg Int maxi count 
 155    external jpeglib "jpeg_read_scanlines" 
 156   
 157  function jpeg_finish_decompress cinfo 
 158    arg_rw jpeg_decompress_struct cinfo 
 159    external jpeglib "jpeg_finish_decompress" 
 160   
 161  function jpeg_abort_decompress cinfo 
 162    arg_rw jpeg_decompress_struct cinfo 
 163    external jpeglib "jpeg_abort_decompress" 
 164   
 165  function jpeg_destroy_decompress cinfo 
 166    arg_rw jpeg_decompress_struct cinfo 
 167    external jpeglib "jpeg_destroy_decompress" 
 168   
 169  function jpeg_set_marker_processor cinfo marker_code routine 
 170    arg_rw jpeg_decompress_struct cinfo ; arg Int marker_code ; arg Address routine 
 171    external jpeglib "jpeg_set_marker_processor" 
 172   
 173   
 174 
 
 175   
 176   
 177  function init_source cinfo 
 178    arg_rw jpeg_decompress_struct cinfo 
 179    external_calling_convention 
 180    var Pointer:my_source_mgr src :> cinfo src 
 181    var Pointer:Stream stream :> src stream 
 182    src bytes_in_buffer := 0 
 183   
 184  function fill_input_buffer cinfo -> ok 
 185    arg_rw jpeg_decompress_struct cinfo ; arg CBool ok 
 186    external_calling_convention 
 187    var Pointer:my_source_mgr src :> cinfo src 
 188    var Pointer:Stream stream :> src stream 
 189    stream read_available src:next_input_byte src:bytes_in_buffer 
 190    ok := stream=success and src:bytes_in_buffer<>0 
 191   
 192  function skip_input_data cinfo num_bytes 
 193    arg_rw jpeg_decompress_struct cinfo ; arg Int num_bytes 
 194    external_calling_convention 
 195    var Pointer:my_source_mgr src :> cinfo src 
 196    var Pointer:Stream stream :> src stream 
 197    var Int remain := num_bytes 
 198    var Int step := min src:bytes_in_buffer num_bytes 
 199    src next_input_byte := src:next_input_byte translate Byte step 
 200    src bytes_in_buffer -= step 
 201    remain -= step 
 202    while remain<>and not stream:atend 
 203      stream read_available (var Address adr) (var Int step) remain 
 204      remain -= step 
 205     
 206  function resync_to_restart cinfo desired -> ok 
 207    arg_rw jpeg_decompress_struct cinfo ; arg Int desired ; arg CBool ok 
 208    external_calling_convention 
 209    console "oops: undefined function resync_to_restart called by jpeg library interface" 
 210    ok := false 
 211   
 212  function term_source cinfo 
 213    arg_rw jpeg_decompress_struct cinfo 
 214    external_calling_convention  
 215     
 216   
 217  type ImageReadFilterJpeg 
 218    field jpeg_decompress_struct cinfo 
 219    field my_source_mgr src 
 220    field jpeg_error_mgr jerr 
 221    field Int remain 
 222    
 223  ImageReadFilter maybe ImageReadFilterJpeg 
 224   
 225   
 226  function jpeg_getc cinfo -> byte 
 227    arg_rw jpeg_decompress_struct cinfo ; arg uInt byte 
 228    var Pointer:my_source_mgr src :> cinfo src 
 229    if src:bytes_in_buffer=0 
 230      fill_input_buffer cinfo 
 231    byte := src:next_input_byte map uInt8 
 232    src next_input_byte := src:next_input_byte translate Byte 1 
 233    src bytes_in_buffer -= 1 
 234   
 235  function process_comment cinfo -> ok 
 236    arg_rw jpeg_decompress_struct cinfo ; arg CBool ok 
 237    external_calling_convention 
 238    var Int len := jpeg_getc:cinfo*256+jpeg_getc:cinfo-2 
 239    var Str comment := repeat len " " 
 240    for (var Int i) len-1 
 241      comment := character jpeg_getc:cinfo 
 242    console "jpeg comment: " comment eol 
 243    ok := true 
 244   
 245  function error_exit cinfo 
 246    arg Address cinfo 
 247    external_calling_convention 
 248   
 249  function emit_message cinfo msg_level 
 250    arg Address cinfo ; arg Int msg_level 
 251    external_calling_convention 
 252   
 253  method f open stream options h -> status 
 254    arg_rw ImageReadFilterJpeg f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status 
 255    f:src stream :> stream 
 256    f:cinfo err :> jpeg_std_error f:jerr 
 257    f:jerr error_exit := (the_function error_exit Address):executable 
 258    f:jerr emit_message := (the_function emit_message Address Int):executable 
 259    jpeg_create_decompress f:cinfo 
 260    f:cinfo src :> src 
 261    f:src init_source := (the_function init_source jpeg_decompress_struct) executable 
 262    f:src fill_input_buffer := (the_function fill_input_buffer jpeg_decompress_struct -> CBool) executable 
 263    f:src skip_input_data := (the_function skip_input_data jpeg_decompress_struct Int) executable 
 264    f:src resync_to_restart := (the_function resync_to_restart jpeg_decompress_struct Int -> CBool) executable 
 265    f:src term_source := (the_function term_source jpeg_decompress_struct) executable 
 266    if (jpeg_read_header f:cinfo true)<>1 
 267      jpeg_destroy_decompress f:cinfo 
 268      return failure 
 269    if false # f:cinfo:jpeg_color_space<>JCS_RGB and f:cinfo:jpeg_color_space<>JCS_GRAYSCALE 
 270      jpeg_destroy_decompress f:cinfo 
 271      return (failure "unsupported JPEG color space "+(string f:cinfo:jpeg_color_space)) 
 272    var Int size_x := f:cinfo image_width 
 273    var Int size_y := f:cinfo image_height 
 274    if not ((options (options option_position "resolution" 0) options:len) parse word:"resolution" (var Float dpi_x) (var Float dpi_y) any) 
 275      dpi_x := options option "resolution" Float 72 ; dpi_y := dpi_x 
 276    if read_resolution 
 277      var Int density_unit := ((addressof f:cinfo) translate Byte 286) map uInt8 
 278      if density_unit=1 
 279        dpi_x := ((addressof f:cinfo) translate Byte 288) map uInt16 
 280        dpi_y := ((addressof f:cinfo) translate Byte 290) map uInt16 
 281    := 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") 
 282    jpeg_set_marker_processor f:cinfo JPEG_COM (the_function process_comment jpeg_decompress_struct -> CBool):executable 
 283    jpeg_start_decompress f:cinfo 
 284    remain := size_y   
 285    status := success 
 286   
 287  method f readline adr -> status 
 288    arg_rw ImageReadFilterJpeg f ; arg Address adr ; arg Status status 
 289    var Pointer:Address ptrs :> adr 
 290    status := shunt (jpeg_read_scanlines f:cinfo ptrs 1)=1 success failure 
 291    if status=success 
 292      remain -= 1 
 293   
 294  method f close -> status 
 295    arg_rw ImageReadFilterJpeg f ; arg ExtendedStatus status 
 296    if f:remain=0 
 297      jpeg_finish_decompress f:cinfo 
 298    jpeg_destroy_decompress f:cinfo 
 299    status := shunt f:src:stream=success success failure 
 300   
 301   
 302 
 
 303   
 304   
 305  function init_destination cinfo 
 306    arg_rw jpeg_compress_struct cinfo 
 307    external_calling_convention 
 308    var Pointer:my_destination_mgr dest :> cinfo dest 
 309    var Pointer:Stream stream :> dest stream 
 310    dest next_output_byte := stream stream_write_cur 
 311    dest free_in_buffer := (cast stream:stream_write_stop Int).-.(cast stream:stream_write_cur Int) 
 312   
 313  function empty_output_buffer cinfo -> ok 
 314    arg_rw jpeg_compress_struct cinfo ; arg CBool ok 
 315    external_calling_convention 
 316    var Pointer:my_destination_mgr dest :> cinfo dest 
 317    var Pointer:Stream stream :> dest stream 
 318    stream stream_write_cur := stream stream_write_stop 
 319    stream flush anytime 
 320    dest next_output_byte := stream stream_write_cur 
 321    dest free_in_buffer := (cast stream:stream_write_stop Int).-.(cast stream:stream_write_cur Int) 
 322    ok := stream=success 
 323   
 324  function term_destination cinfo 
 325    arg_rw jpeg_compress_struct cinfo 
 326    external_calling_convention  
 327    var Pointer:my_destination_mgr dest :> cinfo dest 
 328    var Pointer:Stream stream :> dest stream 
 329    stream stream_write_cur := stream:stream_write_stop translate Byte -(dest free_in_buffer) 
 330    stream flush anytime 
 331     
 332   
 333  type ImageWriteFilterJpeg 
 334    field jpeg_compress_struct cinfo 
 335    field my_destination_mgr dest 
 336    field jpeg_error_mgr jerr 
 337    field Int remain 
 338   
 339  ImageWriteFilter maybe ImageWriteFilterJpeg 
 340   
 341  method f open stream options h -> status 
 342    arg_rw ImageWriteFilterJpeg f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status 
 343    if h:gamut:name<>"rgb" 
 344      return failure:"Only RGB images are currently supported by JPEG output filter" 
 345    f:dest stream :> stream 
 346    f:cinfo err :> jpeg_std_error f:jerr 
 347    jpeg_create_compress f:cinfo 
 348    f:cinfo dest :> dest 
 349    f:dest init_destination := (the_function init_destination jpeg_compress_struct) executable 
 350    f:dest empty_output_buffer := (the_function empty_output_buffer jpeg_compress_struct -> CBool) executable 
 351    f:dest term_destination := (the_function term_destination jpeg_compress_struct) executable 
 352    f:cinfo image_width := size_x 
 353    f:cinfo image_height := size_y 
 354    f:cinfo input_components := 3 
 355    f:cinfo in_color_space := JCS_RGB 
 356    if write_resolution 
 357      ((addressof f:cinfo) translate Byte 210) map uInt8 := # density_unit 
 358      ((addressof f:cinfo) translate Byte 212) map uInt16 := cast h:size_x/(abs h:x1-h:x0)*25.4 Int # X_density 
 359      ((addressof f:cinfo) translate Byte 214) map uInt16 := cast h:size_y/(abs h:y1-h:y0)*25.4 Int # Y_density 
 360    jpeg_set_defaults f:cinfo 
 361    var Float quality := options option "quality" Float 
 362    if quality=defined 
 363      jpeg_set_quality f:cinfo (cast quality*100 Int) false 
 364    jpeg_start_compress f:cinfo true 
 365    var Str comment := options option "comment" Str 
 366    if comment<>"" 
 367      jpeg_write_marker f:cinfo JPEG_COM comment:characters comment:len 
 368    remain := size_y 
 369    status := success 
 370     
 371  method f writeline adr -> status 
 372    arg_rw ImageWriteFilterJpeg f ; arg Address adr ; arg Status status 
 373    var Pointer:Address ptrs :> adr 
 374    status := shunt (jpeg_write_scanlines f:cinfo ptrs 1)=1 success failure 
 375    if status=success 
 376      remain -= 1 
 377   
 378  method f close -> status 
 379    arg_rw ImageWriteFilterJpeg f ; arg ExtendedStatus status 
 380    if f:remain=0 
 381      jpeg_finish_compress f:cinfo 
 382    jpeg_destroy_compress f:cinfo 
 383    status := shunt f:dest:stream=success success failure 
 384   
 385   
 386  image_record_filters ".jpg" ImageReadFilterJpeg false ImageWriteFilterJpeg false 
 387  image_record_filters ".jpeg" ImageReadFilterJpeg false ImageWriteFilterJpeg false 
 388