/*
   Author - Mark Short, 1991
            Design stuff Aug. 26.
   WindIO   EXEC -
   Persistent Input/Output Window
   Actions:
      CREATE - allocate the window and vscreen, return id (w00000-w99999)
               or return code if failure
      SHOW   - Paint screen refresh and return
      READ   - Paint screen and accept keyboard input,
               Return Key pressed, cursor position and data values
      DELETE - release the window and vscreen, return rc

    Note: Maximum rows = terminal size
          Maximum cols = terminal size-1 (need attribute byte)

 */

 parse arg args
 parse value strip(args) with 1 dlm 2 function (dlm) args
 parse upper var function function
      /* Find out what they want to do and Do it */
 retcd = -2

 Select
    When function = 'CREATE' then retcd = Create()
    When function = 'READ'   then retcd = Show(1)
    When function = 'SHOW'   then retcd = Show(0)
    when function = 'DELETE' then retcd = Delete()
    otherwise say '<'function'> is an invalid WINDIO function'
    end
return retcd

/*
  Create the window and Vscreen and return its name
  StartRow - Upper left hand Corner Default Position row
  StartCol - Upper left hand Corner Default Position column
  #Rows    - Number of rows not including the top and bottom line
             max is max rows - 2
  #Cols    - Number of cols not including the left and right side and
             attrib byte you lose, max is maxwidth - 4
 */
Create:
 parse var args StartRow (dlm) StartCol (dlm) #Rows (dlm) #Cols .

     /* what size of terminal do I really have here */
 parse value diag('8C') with 1 Flags 2 . 3 MaxCols 5 MaxRows 7 .
 MaxRows = c2d(MaxRows)
 MaxCols = c2d(MaxCols) - 1  /* allow for the attribute byte on left */

     /*
        Set window boundries up, use defaults or min/max when needed
        bump #Rows up 2 if they give one, account for top/bot filler
        Account for 5 columns you lose to attribute bytes
      */

 if #Rows = '' ] ^datatype(#Rows,'W') then #Rows = MaxRows%2
 else #Rows = min(max(#Rows+2,3),MaxRows-2)
 if #Cols = '' ] ^datatype(#Cols,'W') then #Cols = MaxCols%2
 else #Cols = min(max(#Cols,8),MaxCols-5)

    /*
       Try to get cursor position from xedit - returns -3 if not XEDIT
      We want the upper left corner of window on or near cursor if caller
      does not request a position
    */

 address command 'SET CMSTYPE HT'
 address command 'QUERY WINDOW XEDIT'
 if rc = 0 then nop  /* in xedit, window will "pop up" on top, no clear*/
 else    address command 'VMFCLEAR'  /* not in xedit - clear or get MORE...*/
 address command 'SET CMSTYPE RT'
 address command 'QUERY CURSOR (LIFO'
 pull . cursor.1 cursor.2 .

/*
   Validate upper left hand corner of window, use it, correct it or use
  default for XEDIT cursor, or use row 1 column 1
 */

 if StartRow = '' ] ^datatype(StartRow,'W') then
    if cursor.1 + #rows >= MaxRows then StartRow = max(1,MaxRows - #rows)
    else StartRow = max(cursor.1+1,1)
 else
    if StartRow + #rows >= MaxRows then StartRow = max(1,MaxRows - #rows)
    else StartRow = max(1,StartRow)

 if StartCol = '' ] ^datatype(StartCol,'W') then
    if cursor.2 + #cols + 5 > MaxCols then
       StartCol = max(1,MaxCols - #cols - 5)
    else StartCol = max(cursor.2 + 1,1)
 else
    if StartCol + #Cols + 5 > MaxCols then
       StartCol = max(1,MaxCols - #cols - 5)
    else StartCol = max(1,StartCol)

   /* actual window creation */

 address command
 Win# = NextWin('W')
'VSCREEN DEFINE' Win# #Rows #Cols+5 '0 0'
'WINDOW DEFINE'  Win# #Rows #Cols+6 StartRow StartCol '(NOB FIXED'
'WINDOW SHOW    'Win# 'ON' Win# '1 1'
 retcd = rc
 if rc = 0 then retcd = Win#
 return retcd

/*
   Parse out the text and data field parameters, where the cursor goes,
  what color, etc....
   Get the information back when they hit a transaction key, and return
  it to the caller

   You can set:
    TopLine - text on top line of window
    BotLine - text on bottom line of window
    WinColor - color of window border (default is system default)
               or :'s if on a 3278-2
    FieldRow - which row the cursor will be on
    FieldNum - which field in FieldRow the cursor will be on
    FieldOff - the offset into the FieldNum of the cursor
    InLines  - The Text and data fields to display, each row is seperated
               by '15'x.
    Fields   - list of text and data fields to display on each row
               seperated by '05'x
    Text     - Definition:
               Commas represent '01'x in TEXT and DATA strings, this
               allows commas in text and prefill fields

               TEXT,textstring,textcolor,attributes
                   where:
                     Textstring - the text to display, usually associated
                                  with DATA field, can just be comment.
                     Textcolor  - what color to display this textstring
                     attributes - such as REVVIDEO, BLINK, UNDERLINE

               DATA,prefill,length
                   where:
                     Prefill    - the text to prewrite in typeable data
                                  field.
                     Length     - maximum data field size in characters
                     Datacolor  - what color to display this textstring
                     attributes - such as REVVIDEO, BLINK, UNDERLINE
 */
Show:
 arg ReadIt
 parse var args Win# (dlm) TopLine (dlm) BotLine,
           (dlm) WinColor (dlm) FieldRow (dlm) FieldNum (dlm) FieldOff,
           (dlm) InLines

     /* get the window size */
 address command 'QUERY VSCREEN' win# '(LIFO'
 if rc = 0 then pull . . #Rows #Cols .
 else exit 'BadWindowId'

 address command 'VSCREEN CLEAR' win#  /* tabla rasa */

      /*
         User specifies row number, this will add one to it to ignore
         the border as a row for the programs sake
       */
 if datatype(FieldRow,'W') then FieldRow = FieldRow + 1
 else FieldRow = 2  /* default if invalid or empty */
    /* validate FieldNum and FieldOff */
 if datatype(FieldNum,'W') then nop
 else do
    FieldNum = 1
    say FieldNum 'is invalid value for field number'
    end
 if datatype(FieldOff,'W') then nop
 else do
    FieldOff = 1
    say FieldOff 'is invalid value for field offset'
    end

 WinColor = VerifyColor(WinColor)

   /*
         Set a fill character for border to blank if they have color
        a : otherwise so you can see border on mono terminal
    */

     /*
        What kind of terminal do I really have here?
        If it is not color then set fill character (fc) to ':' so
        it will display a ':' as border instead of reverse video
      */
 parse value diag('8C') with 1 Flags 2 .
 if c2d(Flags) = 0 then fc =  ':'
 else fc = ' '

   /* this bunch of writes draws the border of the window */

 address command

'VSCREEN WRITE' Win# '1 1' #Cols,
    '(' WinColor ' PRO REV FIELD 'fc]]left(TopLine,#Cols-2,fc)
     /* write out the left and write borders */
 do BorderRow = 2 to #Rows-1
   'VSCREEN WRITE' Win# BorderRow '1  2  (' WinColor ' PRO REV FIELD 'fc
   'VSCREEN WRITE' Win# BorderRow #Cols-1 '2  (' WinColor ' PRO REV FIELD 'fc
    end
'VSCREEN WRITE' Win# #Rows '1' #Cols,
    '(' WinColor ' PRO REV FIELD 'fc]]left(BotLine,#Cols-2,fc)

 /*
    Break the InLines down x'15' delimits, store in line. array
  */

 do i = 2 until InLines = ''
    parse var InLines line.i '15'x InLines
    end
 #lines = i

 /*
    Tear apart the lines, build information needed to display the
    TEXT and DATA fields, also info needed to return these fields and
    cursor position
  */
 dflist. = 0     /* initialize to 0 in case they are on a line without */
                 /* any data fields */
 do rr = 2 to #Rows - 1
    datafield# = 0
    colpos = 3
    dflist.rr = ''
    do field# = 1 until Line.rr = ''
         /* probably should do more work here, breakem down build
            return info, etc */

       parse var Line.rr FieldType '01'x Field '05'x Line.rr
       parse upper value strip(FieldType) with FieldType
       Select
          when abbrev('TEXT',FieldType,1) then do
             parse var Field Txt '01'x TxtColor '01'x Attrib
             GoodAttribs = ''
             TxtColor = VerifyColor(TxtColor)
             Do a = 1 to words(Attrib)
                GoodAttribs = GoodAttribs VerifyExtAttrib(word(attrib,a))
                end
                /* if null Txt then skip it, can't determine length */
             if Txt == '' then nop
             else do
                TxtLen = length(Txt)
                address command 'VSCREEN WRITE' Win# rr ColPos TxtLen+1,
                             '(' TxtColor GoodAttribs 'PROTECT FIELD' Txt
                ColPos = ColPos + TxtLen + 1
                end
             end
          when abbrev('DATA',FieldType,1) then do
             datafield# = datafield# + 1
                /* initial is 0 to help on returning cursor code */
             dflist.rr = dflist.rr colpos
             parse var Field Datafill '01'x DataLen '01'x,
                             DataColor '01'x Attrib
             GoodAttribs = ''
             DataColor = VerifyColor(DataColor)
             Color.rr.colpos = DataColor
             Do a = 1 to words(Attrib)
                GoodAttribs = GoodAttribs VerifyExtAttrib(word(attrib,a))
                end
             Attrib.rr.colpos = GoodAttribs
             datalen.rr.datafield# = DataLen
             if datafill = '' then datafill = ' '
             prefill.rr.colpos = datafill
             address command 'VSCREEN WRITE' Win# rr ColPos Datalen+1,
                           '('DataColor GoodAttribs 'FIELD' Datafill
             ColPos = ColPos + DataLen + 1
             end
          otherwise nop /* one long protected line */
          end
       end

            /* fill in the rest of the line with protection */

    Select
       when #Cols-ColPos =  2 then do
          say 'Warning:'
          say 'You cannot have 1 blank at end of row 'rr-1,
              ', change +/-1'
          end
       when #Cols-ColPos <  2 then nop /* worked out perfect no fill */

       otherwise /* pad it out to end of row */
          address command 'VSCREEN WRITE' Win# rr ColPos #Cols-ColPos-1,
                          '(PROT FIELD  '
       end
    end
       /* make sure they specified a valid column position */

 cpos = word(DFList.FieldRow,FieldNum)
 if datatype(cpos,'W') = 0 then do
    cpos = 3
    FieldOff = 0
    end
 else do
    if datatype(datalen.FieldRow.FieldNum,'W') then
       if datalen.FieldRow.FieldNum < FieldOff then FieldOff =,
          datalen.FieldRow.FieldNum
    end
 address command 'VSCREEN CURSOR' Win# FieldRow CPos+FieldOff
 If ReadIt then retstuff = ReadWindow()
 else do
    address command 'VSCREEN WAITT' Win#
    address command 'PSCREEN REFRESH'
    retstuff = RC
    end
return retstuff

ReadWindow:
 address command 'VSCREEN WAITREAD' Win#

    /* WaitRead.1 has keypressed */
 parse var WaitRead.1 KeyHit KeyValue .
 select
    when KeyHit = 'CLEAR' then KeyValue = 100
    when KeyHit = 'ENTER' then KeyValue = 0
    when KeyHit = 'PAKEY' then KeyValue = 100 + KeyValue
    otherwise nop  /* already ok for PFKEY */
    end

    /* tell them what field # and offset into field was picked */
    /* WaitRead.2 has field and cursor position */
 parse var WaitRead.2 . CursRow CursCol .
    /* Default is offset from left start */

 CursRow = Max(CursRow,1)  /* in case they were */
 CursCol = Max(CursCol,1)  /* not in the window */
 ReturnCurs = CursRow-1 1 CursCol - 2
 do i = 1 to words(DFList.CursRow)
    if CursCol <  word(DFList.CursRow,i) then leave
    if CursCol >= word(DFList.CursRow,i) then
       ReturnCurs = CursRow-1 i CursCol-word(DFList.CursRow,i)
    end

    /* get value for input fields */

 do i = 3 to WaitRead.0
    parse var WaitRead.i . Row Col Data
    prefill.row.col = data
    end

/* what to send back ??? */
 ReturnFields = ''
 do row = 2 to #rows-1
    do col = 1 to words(dflist.row)
       Offset = word(dflist.row,col)
       ReturnFields = ReturnFields]]'15'x]]Prefill.Row.Offset

           /* rewrite the datafield to screen */
       address command 'VSCREEN WRITE' Win# row OffSet Datalen.Row.Col+1,
                     '('Color.row.offset Attrib.row.offset 'FIELD',
                        Prefill.row.Offset
       end
    end
    /* refresh the window */
 address command 'VSCREEN WAITT' Win#
 return KeyValue]]'15'x]]ReturnCurs]]ReturnFields

/*
  Delete the Window and VScreen given its id
 */
Delete:
 parse upper var args WinName
      /* clean up window */
 address command 'VSCREEN DELETE' WinName
 address command 'WINDOW DELETE' WinName
 return rc

/*
   Verify the extended attribute if it is not valid return NONE
  which is always valid
 */
VerifyExtAttrib: procedure
arg ExtAttrib .
 if abbrev('BLINK',ExtAttrib,3)     ] abbrev('REVVIDEO',ExtAttrib,3) ],
    abbrev('UNDERLINE',ExtAttrib,1) ] abbrev('NONE',ExtAttrib,3) ],
    abbrev('NULLS',ExtAttrib,3) ] abbrev('BLANKS',ExtAttrib,5) ],
    abbrev('INVISIBLE',ExtAttrib,1) then nop
 else ExtAttrib = 'NONE'
return ExtAttrib

/*
   Verify the color attribute if it is not valid return DEFAULT
  which is always valid
 */
VerifyColor: procedure
arg Color .
 if abbrev('BLUE',Color,1)      ] abbrev('RED',Color,1) ],
    abbrev('PINK',Color,1)      ] abbrev('GREEN',Color,1) ],
    abbrev('YELLOW', Color,1)   ] abbrev('WHITE',Color,1) ],
    abbrev('TURQUOISE',Color,1) ] abbrev('DEFAULT',Color,1) then nop
 else Color = 'NONE'
return Color

NextWin: procedure

   address command 'EXEC SETSAVE'
   address command 'SET CMSTYPE HT'
   i = 0
   Do until qrc = 28
      address command 'QUERY WINDOW W'right(i,5,'0')
      qrc = rc
      if qrc = 0 then i = i + 1
      end
   address command 'EXEC SETREST'
return 'W'right(i,5,'0')