Patch title: Release 85 bulk changes
Abstract:
File: /pliant/graphic/filter/io.pli
Key:
    Removed line
    Added line
abstract
  [Reading and writing a Pliant image from or to a file.]

# 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/stream.pli"
module "/pliant/admin/file.pli"
module "prototype.pli"
module "all.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/language/context.pli"
module "/pliant/graphic/misc/mtbuffer.pli"

constant trace false

function image_query filename options h -> status
  arg Str filename options ; arg_w ImagePrototype h ; arg ExtendedStatus status
  var Link:ImageReadFilter f :> image_read_filter (shunt (options option "filter") (options option "filter" Str) filename)
  if not exists:f
    return (failure "There is no filter for "+filename+" image")
  status := f query filename options h


method p load stream options -> status
  oarg_rw ImagePrototype p ; arg_rw Stream stream ; arg Str options ; arg ExtendedStatus status
  var Link:ImageReadFilter f :> image_read_filter (shunt (options option "filter") (options option "filter" Str) stream:name)
  if not exists:f
    return (failure "There is no filter for "+stream:name+" image")
  status := f open stream options (var ImagePrototype h)
  if status=failure
    return
  if (p setup h options)=failure
    return failure:"Cannot setup image"
  p options := h options
  var Address buffer := null
  part read_lines "load image "+(entry_type addressof:f):name+" "+stream:name
    for (var Int y) 0 p:size_y-1
      part line "line "+string:y+"/"+(string p:size_y)
        if stream=failure
          status := failure "Image input stream is broken"
          leave read_lines
        if trace and 100*y\p:size_y<>100*(y-1)\p:size_y
          console stream:name " " (string 100*y\p:size_y) "%  [cr]"
        var Address adr := p write_map 0 y p:size_x p:size_x (var Int count)
        if adr<>null
          if (f readline adr)=failure
            status := failure "Failed to read mapped line "+(string y+1)+"/"+(string p:size_y)
            p write_unmap 0 y count adr
            leave read_lines
          p write_unmap 0 y count adr
        else
          if buffer=null
            buffer := memory_allocate p:line_size addressof:p
          if (f readline buffer)=failure
            status := failure "Failed to read line "+(string y+1)+"/"+(string p:size_y)
            leave read_lines
          p write 0 y p:size_x buffer
  if buffer<>null
    memory_free buffer
  if f:close=failure
    if status=success
      status := failure "Failed to close the image input file"
  if trace
    console (repeat stream:name:len+7 " ") "[cr]"

method p load filename options -> status
  oarg_rw ImagePrototype p ; arg Str filename options ; arg ExtendedStatus status
  var Link:Stream s :> new Stream
  if (s open filename options in+safe)=failure
    return (failure "Failed to open "+filename)
  status := p load s options
  if s=failure
    status := failure filename+" is corrupted"


method p save stream options -> status
  oarg_rw ImagePrototype p ; arg_rw Stream stream ; arg Str options ; arg ExtendedStatus status
  var Link:ImageWriteFilter f :> image_write_filter (shunt (options option "filter") (options option "filter" Str) stream:name)
  if not exists:f
    return (failure "There is no filter for "+stream:name+" image")
  var ImagePrototype h := image_prototype p:x0 p:y0 p:x1 p:y1 p:size_x p:size_y p:gamut
  h options := p options
  status := f open stream options h
  if status=failure
    return
  var Int burst := options option "burst" Int
  if burst=undefined and (options option "burst") and processor_count>1
    burst := processor_count
  if burst=defined and burst>1
    (var MtBuffer buffers) size := p line_size
    part burst_write_lines "burst "+string:burst+" save image "+(entry_type addressof:f):name+" "+stream:name
      parallel threads burst
        for (var Int y) 0 p:size_y-1
          if status=success
            if trace and 100*y\p:size_y<>100*(y-1)\p:size_y
              console stream:name " " (string 100*y\p:size_y) "%  [cr]"
            var Address buffer
            task
              share p f buffers
              buffer := buffers allocate
              part read_line "burst read line "+string:y+"/"+(string p:size_y)
                p read 0 y p:size_x buffer
            post
              part write_line "burst write line "+string:y+"/"+(string p:size_y)
                if (f writeline buffer)=failure
                  status := failure "Failed to write line "+(string y+1)+"/"+(string p:size_y)
              buffers free buffer               
              if stream=failure
                status := failure "Image output stream is broken"
  else
    var Address buffer := null
    part write_lines "save image "+(entry_type addressof:f):name+" "+stream:name
      for (var Int y) 0 p:size_y-1
        if status=failure
          leave write_lines
        part line "line "+string:y+"/"+(string p:size_y)
          if trace and 100*y\p:size_y<>100*(y-1)\p:size_y
            console stream:name " " (string 100*y\p:size_y) "%  [cr]"
          var Address adr := p read_map 0 y p:size_x p:size_x (var Int count)
          if adr<>null
            if (f writeline adr)=failure
              status := failure "Failed to write mapped line "+(string y+1)+"/"+(string p:size_y)
            p read_unmap 0 y count adr
          else
            if buffer=null
              buffer := memory_allocate p:line_size addressof:p
            p read 0 y p:size_x buffer
            if (f writeline buffer)=failure
              status := failure "Failed to write line "+(string y+1)+"/"+(string p:size_y)
          if stream=failure
            status := failure "Image output stream is broken"
    if buffer<>null
      memory_free buffer
  if f:close=failure
    if status=success
      status := failure "Failed to close the image output file"
  if trace
    console (repeat stream:name:len+7 " ") "[cr]"

method p save filename options -> status
  oarg_rw ImagePrototype p ; arg Str filename options ; arg ExtendedStatus status
  var CBool tmp := not (options option "notmp")
  var Link:Stream s :> new Stream
  if (s open filename+(shunt tmp ".tmp" "") options out+safe)=failure
    return (failure "Failed to open "+filename)
  status := p save s options+" filter "+string:filename
  if status=success and s:close=failure
    status := failure "Failed to write "+filename
  if tmp
    if status=success
      file_delete filename
      file_move filename+".tmp" filename
    else
      file_delete filename+".tmp"


export image_query '. load' '. save'