Patch title: Release 94 bulk changes
Abstract:
File: /pliant/protocol/lpr/spool.pli
Key:
    Removed line
    Added line
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/unsafe.pli"
module "/pliant/language/schedule/daemon.pli"
module "/pliant/language/schedule/resourcesem.pli"
module "/pliant/language/context.pli"
module "/pliant/fullpliant/this_computer.pli"
module "/pliant/admin/file.pli"
submodule "database.pli"

module "/pliant/language/stream/pipe.pli"
module "/pliant/language/stream/flow.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/image/resampling.pli"
module "/pliant/graphic/image/antialiasing.pli"
module "/pliant/graphic/image/convert.pli"
module "/pliant/graphic/image/sharpening.pli"
module "/pliant/graphic/image/lazy.pli"
module "/pliant/graphic/filter/io.pli"
module "device.pli"
module "embedded.pli"
module "/pliant/admin/execute.pli"

constant print_postscript os_api="linux"
constant print_pdf os_api="linux"
constant print_png true
constant print_jpeg true
constant print_packed true
constant print_html false
constant embedded file_os_name:"embedded:/"<>file_os_name:"file:/" and (file_query "file:/bin/gs" standard)=undefined
constant fullpliant this_computer:env:"pliant":"system":"distribution"="fullpliant"
constant uid_gid 7
constant purge_errors_after 86400 # seconds

constant first_line_limit 1024
constant strict_order true

if print_html
  module "/pliant/graphic/browser/common.pli"
  module "/pliant/graphic/browser/parser.pli"
  module "/pliant/graphic/image/packed.pli"


gvar ResourceSem lpr_rip_slot
lpr_rip_slot configure processor_count
gvar Sem lpr_queue_sem

function lpr_filename job extension -> name
  arg Data:LprJob job ; arg Str extension name
  name := "data:/pliant/spool/"+job:queue+"/"+keyof:job+"."+extension

function lpr_error job message
  arg_rw Data:LprJob job ; arg Str message
  if job:error=""
    job error := message

function lpr_open queue options stream -> job
  arg Str queue ; arg Str options ; arg_rw Stream stream ; arg Data:LprJob job
  if strict_order
    lpr_queue_sem rd_request
  var Str id := generate_id
  lpr_database:data:job create id
  job :> lpr_database:data:job id
  job queue := queue
  if queue=""
    each q this_computer:env:"printer"
      if q:"default"="true"
        job queue := keyof q
  job s_startup := datetime
  job s_status := "R"
  var Data:LprQueue printer :> job printer
  if printer:driver<>"" and not (options option "raw")
    stream open (lpr_filename job "lpr") out+mkdir+safe
  else
    job format := "prn"
    job r_status := "T"
    stream open (lpr_filename job "prn") out+mkdir+safe
  if stream=failure
    lpr_error job "Failed to open the job file"
  if strict_order
    lpr_queue_sem rd_release
  
function lpr_close job stream -> status
  arg_rw Data:LprJob job ; arg_rw Stream stream ; arg ExtendedStatus status
  status := stream close
  if status=failure
    lpr_error job "Failed to store the job file"
  job s_status := "T"

function lpr_cancel job stream
  arg_rw Data:LprJob job ; arg_rw Stream stream
  stream close
  if job:p_status="R"
    job p_status := "T"
  else
    file_delete (lpr_filename job "lpr")
    file_delete (lpr_filename job job:format)
    file_delete (lpr_filename job "prn")
    if job:error="" or (job:e_timestamp<>undefined and datetime:seconds-job:e_timestamp:seconds>purge_errors_after)
      lpr_database:data:job delete keyof:job


function lpr_compute_format job
  arg_rw Data:LprJob job
  var Str header := "" ; var Str line := ""
  if ((var Stream s) open (lpr_filename job "lpr") in+safe)=success
    s read_available (var Address adr) (var Int size)
    header set adr size false
  line := header
  line := line 0 (line search "[cr]" line:len)
  line := line 0 (line search "[lf]" line:len)
  var Str c_header := "" ; var Str c_line := ""
  if (header 0 2)=character:1Fh+character:8Bh # GZIP
    if ((var Stream gz) open "gzip:"+(lpr_filename job "lpr") in+safe)=success
      gz read_available (var Address adr) (var Int size)
      c_header set adr size false
  c_line := c_header
  c_line := c_line 0 (c_line search "[cr]" c_line:len)
  c_line := c_line 0 (c_line search "[lf]" c_line:len)
  var Str format
  if print_postscript and (line eparse "%!PS" any)
    format := "ps"
  eif print_pdf and (line eparse "%PDF" any)
    format := "pdf"
  eif print_png and line=character:89h+"PNG"
    format := "png"
  eif print_jpeg and (header 0 2)=character:0FFh+character:0D8h
    format := "jpeg"
  eif print_packed and (header 0 2)=character:1Fh+character:8Bh and c_line="pliant image packed"
    format := "packed"
  eif print_html and (line 0 1)="<"
    format := "html"
  else
    format := "prn"
  var Data:LprQueue printer :> job printer
  if printer:driver=""
    format := "prn"
  plugin format
  file_move (lpr_filename job "lpr") (lpr_filename job format)
  if format="prn"
    job r_status := "T"
  job format := format


function lpr_print image options job prn -> status
  oarg_rw ImagePrototype image ; arg Str options ; arg_rw Data:LprJob job ; arg_rw Stream prn ; arg ExtendedStatus status
  var Data:LprQueue printer :> job printer
  var Link:ImagePrototype img :> image
  var Str pgamut := shunt printer:gamut<>"" printer:gamut "rgb" 
  if pgamut<>image:gamut:name
    var Link:ImageConvert conv :> new ImageConvert
    status := conv bind img color_gamut:pgamut (shunt image:gamut:name="rgb" "grid_steps "+(string printer:grid_steps) "")
    if status=failure
      return
    img :> conv
  var Int divisor_x := cast image:size_x/(abs image:x1-image:x0)*25.4/printer:resolution_x Int
  var Int divisor_y := cast image:size_y/(abs image:y1-image:y0)*25.4/printer:resolution_y Int
  if divisor_x>1 or divisor_y>1
    var Link:ImageAntiAliasing aa :> new ImageAntiAliasing
    status := aa bind img divisor_x divisor_y
    if status=failure
      return
    img :> aa
  if printer:sharpening=defined
    var Link:ImageSharpening sharpen :> new ImageSharpening
    status := sharpen bind img printer:sharpening
    if status=failure
      return
    img :> sharpen
  var Str opt := "filter "+(string "."+printer:driver)+" model "+(string printer:model)+" notmp "+options+" "+printer:options+" timeout "+(string printer:timeout)
  if ((options (options option_position "offset" 0) options:len) parse word:"offset" (var Float offset_x) (var Float offset_y) any)
    if not ((printer:options (printer:options option_position "offset" 0) printer:options:len) parse word:"offset" (var Float base_x) (var Float base_y) any)
      base_x := 0 ; base_y := 0
    opt := "offset "+(string base_x+offset_x)+" "+(string base_y+offset_y)+" "+opt
  status := img save prn opt

if print_postscript or print_pdf

  method p index_x x -> i
    arg ImagePrototype p ; arg Float x ; arg Int i
    i := cast (x-p:x0)/(p:x1-p:x0)*p:size_x Int
  
  method p index_y y -> i
    arg ImagePrototype p ; arg Float y ; arg Int i
    i := cast (y-p:y0)/(p:y1-p:y0)*p:size_y Int

  method p mm_x i -> x
    arg ImagePrototype p ; arg Int i ; arg Float x
    x := p:x0+(p:x1-p:x0)*i/p:size_x

  method p mm_y i -> y
    arg ImagePrototype p ; arg Int i ; arg Float y
    y := p:y0+(p:y1-p:y0)*i/p:size_y

  method stream atend_workaround -> c
    arg_rw Stream stream ; arg CBool c
    while not stream:atend and (stream:stream_read_cur map Char)="%"
      stream readline
    c := stream atend

  function lpr_print_postscript file job prn -> status
    arg Str file ; arg_rw Data:LprJob job ; arg_rw Stream prn ; arg ExtendedStatus status
    var Data:LprQueue printer :> job printer
    part rip
      stream_pipe (var Str in_pipe) (var Str out_pipe)
      var Str gs_resolution := (string printer:resolution_x*printer:antialiasing_x)+"x"+(string printer:resolution_y*printer:antialiasing_y)
      if (printer:options option "papersize")
        gs_resolution += " -sPAPERSIZE="+(printer:options option "papersize" Str)
      thread
        if not fullpliant
          var Str cmd := "gs -sDEVICE=ppmraw -r"+gs_resolution+" -sOutputFile=- -q -dNOPAUSE -dSAFER "+file_os_name:file+" -c quit"
          if (execute cmd output out_pipe)<>0
            console cmd eol
        eif embedded
          var Str temp := replace file_temporary "file:/" "embedded:/"
          if (file_clone file temp)=failure
            file_copy file temp
          var Str cmd := "gs -sDEVICE=ppmraw -r"+gs_resolution+" -sOutputFile=- -q -dNOPAUSE -dSAFER "+file_os_name:(replace temp "embedded:/" "file:/")+" -c quit"
          if (execute cmd root "embedded:/" path "embedded:/" output out_pipe)<>0
            console cmd eol
          file_delete temp
        else
          var Str jail := "file:/tmp/"+generate_id+"/"
          file_copy file jail+"print.ps"
          file_tree_create jail+"bin/" ; file_clone "file:/bin/gs" jail+"bin/gs"
          file_tree_create jail+"lib/"
          var Array:FileInfo libs := file_list "file:/lib/" standard+relative
          for (var Int i) 0 libs:size-1
            file_clone "file:/lib/"+libs:i:name jail+"lib/"+libs:i:name
          file_tree_create jail+"tmp/" ; file_rights jail+"tmp/" uid_gid uid_gid 0 0
          file_tree_rights jail undefined undefined 4 0 5 0
          var Str cmd := "/bin/gs -sDEVICE=ppmraw -r"+gs_resolution+" -sOutputFile=- -q -dNOPAUSE -dSAFER /print.ps -c quit"
          if (execute cmd root jail path jail user uid_gid group uid_gid output out_pipe)<>0
            console cmd eol
          file_tree_delete jail
      var Link:Stream s :> new Stream
      s open in_pipe in+safe+bigcache ; var Int page := 0
      while not s:atend_workaround
        page += 1 ; job r_comment := "page "+string:page
        var Link:ImageLazy lazy :> new ImageLazy
        status := lazy bind s "filter [dq].ppm[dq] resolution "+(string printer:resolution_x*printer:antialiasing_x)+" "+(string printer:resolution_y*printer:antialiasing_y)+(shunt (printer:options option "burst") " backward "+(string 16*(max printer:antialiasing_x printer:antialiasing_y)) "")
        if lazy=failure
          leave rip
        var Link:ImageResampling rs
        if printer:margin_left<>0 or printer:margin_top<>0 or printer:margin_right<>0 or printer:margin_bottom<>0
          var Int ix0 := max (lazy index_x printer:margin_left) 0
          var Int iy0 := max (lazy index_y printer:margin_top) 0
          var Int ix1 := max (min (lazy index_x printer:size_x-printer:margin_right) lazy:size_x) ix0+1
          var Int iy1 := max (min (lazy index_y printer:size_y-printer:margin_bottom) lazy:size_y) iy0+1
          var Link:ImageResampling rs :> new ImageResampling
          status := rs bind lazy (lazy mm_x ix0) (lazy mm_y iy0) (lazy mm_x ix1) (lazy mm_y iy1) ix1-ix0 iy1-iy0
          if status=failure
            leave rip
        else
          rs :> addressof:lazy map ImageResampling
        status := lpr_print rs "" job prn
        if status=failure
          leave rip
        lazy read 0 lazy:size_y-1 1 addressof:(var ColorBuffer drop_pixel)
      status := success

  function lpr_print_ghostscript file job prn -> status
    arg Str file ; arg_rw Data:LprJob job ; arg_rw Stream prn ; arg ExtendedStatus status
    var Data:LprQueue printer :> job printer
    part rip
      stream_pipe (var Str in_pipe) (var Str out_pipe)
      var Str gs_resolution := (string printer:resolution_x*printer:antialiasing_x)+"x"+(string printer:resolution_y*printer:antialiasing_y)
      if (printer:options option "papersize")
        gs_resolution += " -sPAPERSIZE="+(printer:options option "papersize" Str)
      var Str gs_options := printer:options option "ghostscript_options" Str
      if gs_options<>""
        gs_resolution += " "+gs_options
      thread
        if not fullpliant
          var Str cmd := "gs -sDEVICE="+printer:model+" -r"+gs_resolution+" -sOutputFile=- -q -dNOPAUSE -dSAFER "+file_os_name:file+" -c quit"
          if (execute cmd output out_pipe)<>0
            console cmd eol
        eif embedded
          var Str temp := replace file_temporary "file:/" "embedded:/"
          if (file_clone file temp)=failure
            file_copy file temp
          var Str cmd := "gs -sDEVICE="+printer:model+" -r"+gs_resolution+" -sOutputFile=- -q -dNOPAUSE -dSAFER "+file_os_name:(replace temp "embedded:/" "file:/")+" -c quit"
          if (execute cmd root "embedded:/" path "embedded:/" output out_pipe)<>0
            console cmd eol
          file_delete temp
        else
          var Str jail := "file:/tmp/"+generate_id+"/"
          file_copy file jail+"print.ps"
          file_tree_create jail+"bin/" ; file_clone "file:/bin/gs" jail+"bin/gs"
          file_tree_create jail+"lib/"
          var Array:FileInfo libs := file_list "file:/lib/" standard+relative
          for (var Int i) 0 libs:size-1
            file_clone "file:/lib/"+libs:i:name jail+"lib/"+libs:i:name
          file_tree_create jail+"tmp/" ; file_rights jail+"tmp/" uid_gid uid_gid 0 0
          file_tree_rights jail undefined undefined 4 0 5 0
          var Str cmd := "/bin/gs -sDEVICE="+printer:model+" -r"+gs_resolution+" -sOutputFile=- -q -dNOPAUSE -dSAFER /print.ps -c quit"
          if (execute cmd root jail path jail user uid_gid group uid_gid output out_pipe)<>0
            console cmd eol
          file_tree_delete jail
      var Link:Stream s :> new Stream
      s open in_pipe in+safe+bigcache
      while not s:atend
        raw_copy s prn 1 2^24
      status := success

if print_png or print_jpeg or print_packed
  function lpr_print_image file job prn -> status
    arg Str file ; arg_rw Data:LprJob job ; arg_rw Stream prn ; arg ExtendedStatus status
    var Data:LprQueue printer :> job printer
    var Link:Stream input :> new Stream
    input open file in+safe
    while not input:atend
      var Link:ImageLazy image :> new ImageLazy
      status := image bind input "filter [dq]."+job:format+"[dq] resolution "+(string printer:resolution_x*printer:antialiasing_x)+" "+(string printer:resolution_y*printer:antialiasing_y)
      if status=failure
        return
      var Link:ImageResampling rs :> new ImageResampling
      var ImagePrototype proto := image_prototype image:x0 image:y0 image:x1 image:y1 printer:resolution_x*printer:antialiasing_x printer:resolution_y*printer:antialiasing_y printer:antialiasing_x printer:antialiasing_y image_adjust_reduce image:gamut
      status := rs bind image proto:x0 proto:y0 proto:x1 proto:y1 proto:size_x proto:size_y
      if status=failure
        return
      status := lpr_print rs "" job prn
      if status=failure
        return
      rs :> null map ImageResampling
      image :> null map ImageLazy # force image lazy to close in order to consume crc bytes
    status := success

if print_html
  function lpr_print_html file job prn -> status
    arg Str file ; arg_rw Data:LprJob job ; arg_rw Stream prn ; arg ExtendedStatus status
    var Data:LprQueue printer :> job printer
    var Str url := file
    var Str form := ""
    var Str options := ""
    var Link:D2Box drawing :> html_parse url form options
    var ImagePrototype page := image_prototype 0 0 printer:size_x-printer:margin_left-printer:margin_right printer:size_y-printer:margin_top-printer:margin_bottom printer:resolution_x*printer:antialiasing_x printer:resolution_y*printer:antialiasing_y printer:antialiasing_x printer:antialiasing_y image_adjust_reduce color_gamut:"rgb"
    (var D2Context context) bind page
    drawing position context
    var Link:ImagePacked image :> new ImagePacked
    image setup page ""
    (var D2Context context) bind image
    image fill image:x0 image:y0 image:x1 image:y1 (addressof -1)
    drawing draw image context
    status := lpr_print image "" job prn



function lpr_init
  each job lpr_database:data:job
    if job:s_status<>"T"
      lpr_error job "Server was restarted while the job was beeing spooled"
      job s_status := "T"
      job r_status := "T"
      job p_status := "T"
    if job:r_status="R" # we don't try to set it back to waiting in order to avoid potencial infinite loop crash
      lpr_error job "Server was restarted while the job was beeing ripped"
      job r_status := "T"
    if job:p_status="R"
      lpr_error job "Server was restarted while the job was beeing printed"
      job p_status := "T"
  each printer this_computer:env:"printer"
    var Str queue := keyof printer
    var Array:FileInfo files := file_list "data:/pliant/spool/"+queue+"/" standard
    for (var Int i) 0 files:size-1
      var Str id := files:i stripped_name
      if not (exists lpr_database:data:job:id) or lpr_database:data:job:id:error<>""
        file_delete files:i:name


function lpr_spool
  daemon "print spooler daemon"
    while not daemon_emergency
      lpr_embedded_migrate "embedded:/"
      lpr_queue_sem request
      each job lpr_database:data:job filter job:error<>""
        if job:e_timestamp=undefined
          job e_timestamp := datetime
        eif datetime:seconds-job:e_timestamp:seconds>purge_errors_after
          lpr_cancel job (var Stream no_data)
      each job lpr_database:data:job filter job:s_status<>"W" and job:error=""
        var Str id := keyof job
        var Data:LprQueue queue :> job printer
        if queue:once or job:s_status="T"
          if job:format=""
            if job:s_status="T" or (file_query (lpr_filename job "lpr") standard):size>=first_line_limit
              part computer_format "Compute print job '"+id+"' format"
                lpr_compute_format job
                plugin study
          eif job:r_status="W" and ( job:s_status="T" or (queue:once and job:s_status="R" and (job:format="png" or job:format="jpeg" or job:format="packed") and (file_query (lpr_filename job job:format) standard)=defined) )
            if (lpr_rip_slot nowait_request 1)
              job r_startup := datetime
              job r_status := "R"
              thread
                var Data:LprJob j :> lpr_database:data:job id
                var Data:LprQueue q :> j printer
                part rip "Rip '"+j:format+"' job '"+id+"' for queue '"+keyof:q+"'"
                  var Str file := lpr_filename j j:format
                  var Link:Stream prn :> new Stream
                  prn open (lpr_filename j "prn") out+safe
                  if prn=failure
                    lpr_error j "Failed to open the printer native format spooler temporary file"
                  var ExtendedStatus rs
                  if (print_postscript and j:format="ps") or (print_pdf and j:format="pdf")
                    rs := lpr_print_postscript file j prn
                    rs := shunt q:driver="ghostscript" (lpr_print_ghostscript file j prn) (lpr_print_postscript file j prn)
                  eif (print_png and j:format="png") or (print_jpeg and j:format="jpeg") or (print_packed and j:format="packed")
                    var Str file_head file_tail
                    if job:s_status="R"
                      file_head := "[dq]flow:" ; file_tail := "[dq] flag_path [dq]"+(pathof job:s_status)+"[dq] flag_value [dq]R[dq]"
                    rs := lpr_print_image file_head+file+file_tail j prn
                  eif print_html and j:format="html"
                    rs := lpr_print_html file j prn
                  else
                    rs := failure "unsupported '"+j:format+"' job format"
                    plugin rip
                  if rs=failure
                    lpr_error j "Ripping error: "+rs:message
                  if prn:close=failure
                    lpr_error j "Failed to store the printer native format spooler temporary file"
                  j r_status := "T" ; j r_comment := ""
                  plugin rip
                  lpr_rip_slot release 1
          eif job:p_status="W" and ( job:r_status="T" or (queue:once and job:r_status="R" and (file_query (lpr_filename job "prn") standard)=defined) ) and queue:status<>"S"
            # if job:s_status="T" and job:r_status="T" or (file_query (lpr_filename job "prn") standard):size>=(queue:options option "print_start_minimum" Intn 0)
            var CBool lock := queue:printer<>""
            if not lock or (lpr_printer_sem nowait_request queue:printer)
              job p_startup := datetime
              job p_status := "R"
              thread
                var Data:LprJob j :> lpr_database:data:job id
                var Data:LprQueue q :> j printer
                part rip "Print job '"+id+"' on '"+keyof:q+"'"
                  (var Stream src) open (lpr_filename j "prn") in+safe+bigcache ; var Intn offset := 0
                  var Str target := lpr_device_search q:device
                  if target:len>0 and (target target:len-1)="/"
                    target += shunt j:file<>"" j:file keyof:j+"."+(shunt q:driver<>"" q:driver "prn")
                  (var Stream dest) open (string target)+" timeout "+(string q:timeout)+" "+q:options+(shunt j:label<>"" " title "+(string j:label) "") out+safe
                  part copy
                    src read_available (var Address adr) (var Int size)
                    if size=0 and src=success and (j:s_status="R" or j:r_status="R")
                      j p_comment := string:offset+" stalled"
                      sleep 1
                      restart copy
                    if size>0
                      if j:p_status<>"R"
                        leave copy
                      dest raw_write adr size
                      if dest=success
                        offset += size ; j p_comment := string offset
                        restart copy
                      else
                        lpr_error j (shunt offset=0 "Printer did not start" "Printer crashed")
                  src close
                  dest close
                  j p_status := "T" ; j p_comment := ""
                  plugin print
                  lpr_cancel j dest
                  if strict_order
                    lpr_queue_sem rd_request ; lpr_queue_sem rd_release
                  if lock
                    lpr_printer_sem release q:printer
      lpr_queue_sem release
      daemon_sleep (min (max lpr_database:data:job:size 1) 5)


function lpr_stop queue
  arg Str queue
  this_computer "printer" queue "status" := "S"

function lpr_restart queue
  arg Str queue
  this_computer "printer" queue "status" := "R"

export lpr_filename lpr_open lpr_close lpr_error lpr_cancel lpr_print
export lpr_init lpr_spool lpr_stop lpr_restart lpr_rip_slot