/pliant/graphic/filter/io.pli
 
 1  abstract 
 2    [Reading and writing a Pliant image from or to a file.] 
 3   
 4  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 5  # 
 6  # This program is free software; you can redistribute it and/or 
 7  # modify it under the terms of the GNU General Public License version 2 
 8  # as published by the Free Software Foundation. 
 9  # 
 10  # This program is distributed in the hope that it will be useful, 
 11  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 12  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 13  # GNU General Public License for more details. 
 14  # 
 15  # You should have received a copy of the GNU General Public License 
 16  # version 2 along with this program; if not, write to the Free Software 
 17  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 18   
 19   
 20  module "/pliant/language/compiler.pli" 
 21  module "/pliant/language/stream.pli" 
 22  module "/pliant/admin/file.pli" 
 23  module "prototype.pli" 
 24  module "all.pli" 
 25  module "/pliant/graphic/image/prototype.pli" 
 26  module "/pliant/language/context.pli" 
 27  module "/pliant/graphic/misc/mtbuffer.pli" 
 28  module "/pliant/storage/database.pli" 
 29   
 30  constant trace false 
 31   
 32  function image_query filename options h -> status 
 33    arg Str filename options ; arg_w ImagePrototype h ; arg ExtendedStatus status 
 34    var Link:ImageReadFilter :> image_read_filter (options option "filter" Str filename) 
 35    if not exists:f 
 36      return (failure "There is no filter for "+filename+" image") 
 37    status := query filename options h 
 38   
 39   
 40  method p load stream options -> status 
 41    oarg_rw ImagePrototype p ; arg_rw Stream stream ; arg Str options ; arg ExtendedStatus status 
 42    var Link:ImageReadFilter :> image_read_filter (options option "filter" Str stream:name) 
 43    if not exists:f 
 44      return (failure "There is no filter for "+stream:name+" image") 
 45    part open "load image "+(entry_type addressof:f):name+" open" 
 46      status := open stream options (var ImagePrototype h) 
 47    if status=failure 
 48      return 
 49    if (setup options)=failure 
 50      return failure:"Cannot setup image" 
 51    options := options 
 52    var Address buffer := null 
 53    part read_lines "load image "+(entry_type addressof:f):name+" "+stream:name 
 54      for (var Int y) p:size_y-1 
 55        part line "line "+string:y+"/"+(string p:size_y) 
 56          if stream=failure 
 57            status := failure "Image input stream is broken" 
 58            leave read_lines 
 59          if trace and 100*y\p:size_y<>100*(y-1)\p:size_y 
 60            console stream:name " " (string 100*y\p:size_y) "%  [cr]" 
 61          var Address adr := write_map p:size_x p:size_x (var Int count) 
 62          if adr<>null 
 63            if (readline adr)=failure 
 64              status := failure "Failed to read mapped line "+(string y+1)+"/"+(string p:size_y) 
 65              write_unmap count adr 
 66              leave read_lines 
 67            write_unmap count adr 
 68          else 
 69            if buffer=null 
 70              buffer := memory_allocate p:line_size addressof:p 
 71            if (readline buffer)=failure 
 72              status := failure "Failed to read line "+(string y+1)+"/"+(string p:size_y) 
 73              leave read_lines 
 74            write p:size_x buffer 
 75    if buffer<>null 
 76      memory_free buffer 
 77    part close "load image "+(entry_type addressof:f):name+" close" 
 78      if f:close=failure 
 79        if status=success 
 80          status := failure "Failed to close the image input file" 
 81    if trace 
 82      console (repeat stream:name:len+7 " ""[cr]" 
 83   
 84  method p load filename options -> status 
 85    oarg_rw ImagePrototype p ; arg Str filename options ; arg ExtendedStatus status 
 86    var Link:Stream :> new Stream 
 87    if (open filename options in+safe+anyeol+bigcache+image_read_flags:(options option "filter" Str filename))=failure 
 88      return (failure "Failed to open "+filename) 
 89    status := load options 
 90    if s=failure 
 91      status := failure filename+" is corrupted" 
 92   
 93   
 94  method p save stream options -> status 
 95    oarg_rw ImagePrototype p ; arg_rw Stream stream ; arg Str options ; arg ExtendedStatus status 
 96    var Link:ImageWriteFilter :> image_write_filter (options option "filter" Str stream:name) 
 97    if not exists:f 
 98      return (failure "There is no filter for "+stream:name+" image") 
 99    var ImagePrototype := image_prototype p:x0 p:y0 p:x1 p:y1 p:size_x p:size_y p:gamut 
 100    options := options 
 101    part open "save image "+(entry_type addressof:f):name+" open" 
 102      status := open stream options h 
 103    if status=failure 
 104      return 
 105    var Int burst := options option "burst" Int (shunt (options option "burst") processor_count undefined) 
 106    var Str cflag := options option "continue_flag" Str 
 107    if burst<>undefined and burst>1 
 108      (var MtBuffer buffers) size := line_size 
 109      part burst_write_lines "burst "+string:burst+" save image "+(entry_type addressof:f):name+" "+stream:name 
 110        parallel threads burst 
 111          for (var Int y) p:size_y-1 
 112            if cflag:len>and (cflag pmap Bool)<>true 
 113              status := failure "Interrupted" 
 114            if status=success 
 115              if trace and 100*y\p:size_y<>100*(y-1)\p:size_y 
 116                console stream:name " " (string 100*y\p:size_y) "%  [cr]" 
 117              var Address buffer 
 118              task 
 119                share buffers 
 120                buffer := buffers allocate 
 121                part read_line "burst read line "+string:y+"/"+(string p:size_y) 
 122                  read p:size_x buffer 
 123              post 
 124                part write_line "burst write line "+string:y+"/"+(string p:size_y) 
 125                  if (writeline buffer)=failure 
 126                    status := failure "Failed to write line "+(string y+1)+"/"+(string p:size_y) 
 127                buffers free buffer                
 128                if stream=failure 
 129                  status := failure "Image output stream is broken" 
 130    else 
 131      var Address buffer := null 
 132      part write_lines "save image "+(entry_type addressof:f):name+" "+stream:name 
 133        for (var Int y) p:size_y-1 
 134          if cflag:len>and (cflag pmap Bool)<>true 
 135            status := failure "Interrupted" 
 136          if status=failure 
 137            leave write_lines 
 138          part line "line "+string:y+"/"+(string p:size_y) 
 139            if trace and 100*y\p:size_y<>100*(y-1)\p:size_y 
 140              console stream:name " " (string 100*y\p:size_y) "%  [cr]" 
 141            var Address adr := read_map p:size_x p:size_x (var Int count) 
 142            if adr<>null 
 143              if (writeline adr)=failure 
 144                status := failure "Failed to write mapped line "+(string y+1)+"/"+(string p:size_y) 
 145              read_unmap count adr 
 146            else 
 147              if buffer=null 
 148                buffer := memory_allocate p:line_size addressof:p 
 149              read p:size_x buffer 
 150              if (writeline buffer)=failure 
 151                status := failure "Failed to write line "+(string y+1)+"/"+(string p:size_y) 
 152            if stream=failure 
 153              status := failure "Image output stream is broken" 
 154      if buffer<>null 
 155        memory_free buffer 
 156    part close "save image "+(entry_type addressof:f):name+" close" 
 157      var ExtendedStatus cs := close 
 158    if cs=failure and status=success 
 159      status := cs 
 160    if trace 
 161      console (repeat stream:name:len+7 " ""[cr]" 
 162   
 163  method p save filename options -> status 
 164    oarg_rw ImagePrototype p ; arg Str filename options ; arg ExtendedStatus status 
 165    var CBool tmp := not (options option "notmp") 
 166    var Link:Stream :> new Stream 
 167    if (open filename+(shunt tmp ".tmp" ""options out+safe+bigcache+image_write_flags:(options option "filter" Str filename))=failure 
 168      return (failure "Failed to open "+filename) 
 169    status := save options+" filter "+string:filename 
 170    if status=success and s:close=failure 
 171      status := failure "Failed to write "+filename 
 172    if tmp 
 173      if status=success 
 174        file_delete filename 
 175        file_move filename+".tmp" filename 
 176      else 
 177        file_delete filename+".tmp" 
 178   
 179   
 180  export image_query '. load' '. save' 
 181