* SETQ
* SET.QUEUE verb
* Copyright (c) 2006 Ladybridge Systems, All Rights Reserved
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
* 
* 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
* along with this program; if not, write to the Free Software Foundation,
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
* 
* Ladybridge Systems can be contacted via the www.openqm.com web site.
* 
* START-HISTORY:
* 12 Oct 06  2.4-15 New module.
* 16 Sep 04  2.0-1 OpenQM launch. Earlier history details suppressed.
* END-HISTORY
*
* START-DESCRIPTION:
*
*   SET.QUEUE queue, width, depth, top.margin, bottom.margin, mode, options...
*   SET.QUEUE DISPLAY
*
* END-DESCRIPTION
*
* START-CODE

$internal
program SETQ
$catalog $SETQ

$include int$keys.h
$include parser.h
$include keys.h
$include err.h
$include pcl.h
$include forms.h

common /pcldata/ pcldata

$define MAX.MARGIN 50
$define MAX.LEFT.MARGIN 50    ;* Known in pio.c
$define TEMPLATE.PRINT.UNIT -3

   is.windows = system(91)
   lptr = -1
   first = @true

   open '$FORMS' to frm.f else
      stop sysmsg(1436, '$FORMS')  ;* Cannot open %1: %M
   end

   * Set defaults

   queue = 0
   width = config('LPTRWIDE')
   depth = config('LPTRHIGH')
   top.margin = 0
   bottom.margin = 0
   mode = 1
   options = ''


   if not(pcldata) then
      open 'SYSCOM' to syscom.f then
         read pcldata from syscom.f, '$PCLDATA' else null
         close syscom.f
      end
   end

   @system.return.code = -1                 ;* Preset for argument errors

   call !parser(parser$reset, 0, @sentence, 0)
   call !parser(parser$get.token, token.type, token, keyword) ;* Verb

   call !parser(parser$get.token, token.type, token, keyword) ;* Queue
   begin case
      case keyword = KW$DISPLAY
         * The only other keyword allowed with DISPLAY is LPTR

         call !parser(parser$get.token, token.type, token, keyword)
         if token.type # PARSER$END then
            if keyword # KW$LPTR then stop sysmsg(2018, token) ;* Unexpected token (xx)
            lptr = 0
            call !parser(parser$get.token, token.type, token, keyword)
            if token.type # PARSER$END then
               if not(token matches '1N0N') or (token < 0) or (token > LPTR$HIGH.PRINT.UNIT) then
                  stop sysmsg(2053) ;* Invalid print unit number
               end
               lptr = token + 0
            end
         end

         if lptr = 0 then printer on
         gosub show.all.queues
         if lptr = 0 then printer off
         @system.return.code = 0
         return

      case token matches '1-3N'
         queue = token + 0
         call !parser(parser$get.token, token.type, token, keyword)
   end case

   if token.type = PARSER$END then   ;* Report queue configuration
      gosub report.queue(queue)
   end else                          ;* Set queue configuration

      * ---------- Width ----------

      if token.type = PARSER$COMMA then
         call !parser(parser$get.token, token.type, token, keyword)
         if token matches '1N0N' then
            if (token < 1) or (token > MAX.WIDTH) then
               stop sysmsg(7100) ;* Width parameter is out of range
            end
            width = token + 0
            call !parser(parser$get.token, token.type, token, keyword)
         end
      end

      * ---------- Depth ----------

      if token.type = PARSER$COMMA then
         call !parser(parser$get.token, token.type, token, keyword)
         if token matches '1N0N' then
            if token > MAX.DEPTH then
               stop sysmsg(7101) ;* Depth parameter is out of range
            end
            depth = token + 0
            call !parser(parser$get.token, token.type, token, keyword)
         end
      end

      * ---------- Top Margin ----------

      if token.type = PARSER$COMMA then
         call !parser(parser$get.token, token.type, token, keyword)
         if token matches '1N0N' then
            if (token < 0) or (token > MAX.MARGIN) then
               stop sysmsg(7102) ;* Top margin parameter is out of range
            end
            top.margin = token + 0
            call !parser(parser$get.token, token.type, token, keyword)
         end
      end

      * ---------- Bottom Margin ----------

      if token.type = PARSER$COMMA then
         call !parser(parser$get.token, token.type, token, keyword)
         if token matches '1N0N' then
            if (token < 0) or (token > MAX.MARGIN) then
               stop sysmsg(7103) ;* Bottom margin parameter is out of range
            end
            bottom.margin = token + 0
            call !parser(parser$get.token, token.type, token, keyword)
         end
      end

      * ---------- Mode ----------

      if token.type = PARSER$COMMA then
         call !parser(parser$get.token, token.type, token, keyword)
         if token matches '1N0N' then
            if listindex('0,1,3,4,5,6', ',', token) = 0 then
               stop sysmsg(7104) ;* Mode parameter is out of range
            end
            mode = token + 0
            call !parser(parser$get.token, token.type, token, keyword)
         end
      end

      * ---------- Options ----------

      loop
      while token.type = PARSER$COMMA
         call !parser(parser$get.token, token.type, token, keyword)
reparse:
      until token.type = PARSER$END
         begin case
            case keyword = 0
               null

            case keyword = KW$AS
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end

               begin case
                  case keyword = KW$PATHNAME
                     call !parser(parser$get.token, token.type, name, keyword)
                     if token.type = parser$end then
                        stop sysmsg(7106) ;* Pathname required
                     end

                     if not(ospath(name, OS$PATHNAME)) then
                        stop sysmsg(7107) ;* Invalid pathname
                     end

                     options<-1> = 'AS PATHNAME "' : name : '"'

                  case keyword = KW$NEXT
                     call !parser(parser$get.token, token.type, name, keyword)
                     if token.type = parser$comma or token.type = parser$end then
                        * No name, use default
                        options<-1> = 'AS NEXT'
                        goto reparse
                     end
                     options<-1> = 'AS NEXT "' : name : '"'

                  case 1
                     options<-1> = 'AS NEXT "' : name : '"'
               end case

            case keyword = KW$AT
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7123, token) ;* Printer name required
               end
               options<-1> = 'AT "' : name : '"'

            case keyword = KW$BANNER
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'BANNER "' : name : '"'
               
            case keyword = KW$CPI
               call !parser(parser$get.token, token.type, cpi, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end

               if not(cpi matches '1-2N1-2N.1-2N') then
                  stop sysmsg(7155) ;* Invalid character pitch value
               end
               options<-1> = 'CPI ' : cpi

            case keyword = KW$DUPLEX
               call !parser(parser$look.ahead, token.type, token, keyword)
               if keyword = KW$SHORT then
                  call !parser(parser$get.token, token.type, token, keyword)
                  options<-1> = 'DUPLEX SHORT'
               end else
                  options<-1> = 'DUPLEX'
               end

            case keyword = KW$COPIES
               call !parser(parser$get.token, token.type, copies, keyword)
               if token.type = PARSER$END or not(copies matches '1N0N') or copies < 1 then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'COPIES ' : copies

            case keyword = KW$FORM
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'FORM ' : name

            case keyword = KW$GDI and is.windows
               options<-1> = 'GDI'

            case keyword = KW$KEEP.OPEN
               options<-1> = 'KEEP.OPEN'

            case keyword = KW$LANDSCAPE
               options<-1> = 'LANDSCAPE'

            case keyword = KW$LEFT.MARGIN
               call !parser(parser$get.token, token.type, lmgn, keyword)
               if token.type = PARSER$END or not(lmgn matches '1N0N') then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               if lmgn > MAX.LEFT.MARGIN then
                  stop sysmsg(7108) ;* Left margin parameter is out of range
               end
               options<-1> = 'LEFT.MARGIN ' : lmgn

            case keyword = KW$LPI
               call !parser(parser$get.token, token.type, lpi, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end

               locate lpi in pcldata<PCL.VALID.LPI,1> setting pos else
                  stop sysmsg(7157) ;* Invalid line spacing (lines per inch) value
               end
               options<-1> = 'LPI ' : lpi

            case keyword = KW$NEWLINE
               call !parser(parser$get.token, token.type, token, keyword)
               token = upcase(token)
               if listindex('CR,LF,CRLF', ',', token) then
                  options<-1> = 'NEWLINE ' : token
               end else
                  stop sysmsg(6843) ;* Newline mode required
               end

            case keyword = KW$NFMT
               options<-1> = 'NFMT'

            case keyword = KW$NODEFAULT
               options<-1> = 'NODEFAULT'

            case keyword = KW$OPTIONS
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'OPTIONS "' : name : '"'

            case keyword = KW$OVERLAY
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'OVERLAY "' : upcase(name) : '"'

            case keyword = KW$PAPER.SIZE
               call !parser(parser$get.token, token.type, s, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end

               s = upcase(s)
               locate s in pcldata<PCL.PAPER.NAME,1> setting pos else
                  stop sysmsg(7156) ;* Unrecognised paper size
               end
               options<-1> = 'PAPER.SIZE ' : s

            case keyword = KW$PCL
               options<-1> = 'PCL'

            case keyword = KW$POSTSCRIPT
               options<-1> = 'POSTSCRIPT'

            case keyword = KW$PORTRAIT and is.windows
               options<-1> = 'PORTRAIT'

            case keyword = KW$PREFIX
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'PREFIX "' : upcase(name) : '"'

            case keyword = KW$RAW and is.windows
               options<-1> = 'RAW'

            case keyword = KW$SPOOLER
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'SPOOLER "' : upcase(name) : '"'

            case keyword = KW$STYLE
               call !parser(parser$get.token, token.type, name, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end
               options<-1> = 'STYLE "' : upcase(name) : '"'

            case keyword = KW$SYMBOL.SET
               call !parser(parser$get.token, token.type, s, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end

               s = upcase(s)
               locate s in pcldata<PCL.SYMBOL.SET,1> setting pos else
                  stop sysmsg(7158)  ;* Unrecognised symbol set name
               end
               options<-1> = 'SYMBOL.SET ' : s

            case keyword = KW$WEIGHT
               call !parser(parser$get.token, token.type, s, keyword)
               if token.type = PARSER$END or token.type = PARSER$COMMA then
                  stop sysmsg(7105, token) ;* Invalid or missing qualifier in xx
               end

               s = upcase(s)
               locate s in pcldata<PCL.WEIGHT,1> setting pos else
                  stop sysmsg(7159)  ;* Unrecognised font weight name
               end
               options<-1> = 'WEIGHT ' : s

            case 1
               stop sysmsg(2018, token) ;* Unexpected token (xx)
         end case

         call !parser(parser$get.token, token.type, token, keyword)
      repeat

      if token.type # PARSER$END then
         stop sysmsg(2018, token) ;* Unexpected token (xx)
      end

      @system.return.code = 0

      * Save queue data

      frm.rec = ''
      frm.rec<FRM.WIDTH> = width
      frm.rec<FRM.DEPTH> = depth
      frm.rec<FRM.TMGN> = top.margin
      frm.rec<FRM.BMGN> = bottom.margin
      frm.rec<FRM.MODE> = mode
      frm.rec<FRM.OPTIONS> = lower(options)
      recordlocku frm.f, queue
      write frm.rec to frm.f, queue
   end

   return

* ======================================================================

show.all.queues:
   select frm.f
   readlist queues then
      call !sort(queues, queues, 'AR')
      loop
         gosub report.queue(remove(queues, more))
      while more
      repeat
   end else
      display sysmsg(7163)  ;* No queues defined
   end
   return

* ======================================================================
*           1         2         3         4         5         6         7
* 0123456789012345678901234567890123456789012345678901234567890123456789012345678
* Queue Width Depth Tmgn Bmgn Mode Options
*  1234   132    66    3    3    1 AT LASER
$define OPT.COL 33

local subroutine report.queue(qno)
   if first then
      print on lptr 'Queue Width Depth Tmgn Bmgn Mode Options'
      first = @false
   end

   print on lptr fmt(qno, '5R') :  ' ' :
   read frm.rec from frm.f, qno then
      print on lptr fmt(frm.rec<FRM.WIDTH>, '5R') :  ' ' :
      print on lptr fmt(frm.rec<FRM.DEPTH>, '5R') :  ' ' :
      print on lptr fmt(frm.rec<FRM.TMGN>, '4R') :  ' ' :
      print on lptr fmt(frm.rec<FRM.BMGN>, '4R') :  ' ' :
      print on lptr fmt(frm.rec<FRM.MODE>, '4R') :  ' ' :

      args = raise(frm.rec<FRM.OPTIONS>)
      opt.width = @crtwide - OPT.COL - 1   ;* Available width
      w = opt.width
      loop
      while args # ''
         s = args<1>

         * Remove redundant quotes
         if count(s, '"') = 2 then
            if index(field(s, '"', 2), ' ', 1) = 0 then
               s = convert('"', '', s)
            end
         end

         if len(s) > opt.width then        ;* Item cannot fit a single line
            if w # opt.width then       ;* Line is not blank
               print on lptr
               w = opt.width
               print on lptr space(OPT.COL) :
            end
            print on lptr s[1,opt.width]
            print on lptr space(OPT.COL) :
            args = args[opt.width + 1, 99999]
         end else
            if len(s) > w then
               print on lptr
               w = opt.width
               print on lptr space(OPT.COL) :
            end

            print on lptr s :
            w -= len(s)
            del args<1>
            if args # '' then
               print on lptr ',' :
               w -= 1
               if w then
                  print on lptr ' ' :
                  w -= 1
               end
            end
         end
      repeat

      print on lptr
   end else
      print 'Undefined'
   end

   return
end

* Avoid compiler warnings
   pos = pos
end

* END-CODE
