Learn from sources
       star star Member BOATSCH2 in CGIDEV2 / QRPGLESRC

       *********************************************************************
       *  RPG ILE MODULE CGIDEV2/BOATSCH2
       *
       *  After compiling this RPG MODULE,
       *  create the related program with the following command:
       *
       * CRTPGM CGIDEV2/BOATSCH2 MODULE(CGIDEV2/BOATSCH2) ACTGRP(BOATSCH2)
       *
       *********************************************************************
       * MAIN PROGRAM FLOW
       *
       * 1 - Receives input from BOATSCH1 output html
       *     (see member BOATSCH1 in source file CGIDEV2/BOATHTML)
       *     telling which boats should be displayed
       *     from file CGIDEV2/BOATSALE1 (boats for sale)
       * 2 - Loads the html output skeleton from
       *     member BOATSCH2 in source file CGIDEV2/BOATHTML
       * 3 - If the first time through,
       *     overrides and opens file BOATSALE1
       * 4 - Writes html output section /$top
       * 5 - Retrieves the occurrencies of "serno" in the input string.
       *     For each entry (boat serial number) in this array:
       *     - gets related boat data from BOATSALE1 record
       *     - sets variables (boat gif, boat length, make, etc)
       *       and writes html output section /$found
       *     - retrieves and writes out boat dependent html
       *       This is rather tricky.
       *       Boat dependent html text (boat features, interior jpg's, etc)
       *       cannot be in the skeleton html text. Instead, the skeleton
       *       contains a section, named /$text, with a single variable,
       *       named /%text%/.
       *       On the other side, in library CGIDEV2 there is a source
       *       physical file (named BOATTXTS), with an html text member
       *       for each boat serial number.
       *       The following is done:
       *        -assign and open the appropriate member
       *         of file CGIDEV2/BOATTXTS
       *        -read each record, set variable /%text%/ to contain
       *         the corresponding html text line, write section /$text.
       * 6 - When no more occurrencies of "serno" in the input string,
       *     writes html output section /$htmlend (end html),
       *     and returns.
       *********************************************************************
       /copy CGIDEV2/qrpglesrc,hspecs
       /copy CGIDEV2/qrpglesrc,hspecsbnd
       * Boats for sale data base file (LF on BOATSALE by boat serial number)
      FBOATSALE1 if   e           k disk    USROPN
      F                                     extfile('CGIDEV2/BOATSALE1')
       * Boat dependent HTML text
      FBOATTXTS  if   e             disk    USROPN
      F                                     RENAME(BOATTXTS:TXTREC)
      F                                     extfile('CGIDEV2/BOATTXTS')
      F                                     extmbr(TxtMbr)
       * HTTP links
      FBOATLINKS if   e           k disk    USROPN
      F                                     extfile('CGIDEV2/BOATLINKS')
       *--------------------------------------------------------------------
       * Prototype definitions and standard system API error structure
       /copy CGIDEV2/qrpglesrc,prototypeb
       /copy CGIDEV2/qrpglesrc,usec
       * Variables common to CGI programs
       /copy CGIDEV2/qrpglesrc,variables3
       *--------------------------------------------------------------------
       * VARIABLES SPECIFIC TO THIS PROGRAM
       *--------------------------------------------------------------------
       * Variables received from the input string
      D lng             s              2
      D BckGnd          s             10
      D quit            s              4
       * Variables used to load the external html source member
      D Lib             s             10
      D Fn              s             10
      D Mbr             s             10
       * Boats serial numbers received in the input string
      D ItemCount       s             10i 0
      D SernoC          s              7a
      D i               s             10i 0
       * Member name for file BOATTXTS
      D                 DS
      DTxtMbr                   1     10
      DTxtMbr1                  1      3
      DTxtMbr2                  4     10
       * Command to be executed
      D Command         s            256a
       * Switches
      D GetLinkSW       s              1a
      D BoatSaleSW      s              1a
      D SomeBoatSW      s              1a
       * For Monthly Estimator Url substitution
      D EstKwd          s             13a   INZ('/%ESTIMATOR%/')
      D EstKwdLen       s             10i 0 INZ(%size(EstKwd))
      D SrcArr1         s              1a   dim(80)
      D SrcArr2         s              1a   dim(80)
       *
      D bnbrC           s              7a
      D Align           s              5a
      D r               s             10i 0
       * Fields required by CHKNBR subprocedure
      D ChkNbrDs        ds
      D   anyerrs                       n
      D   invalidchrs                   n
      D   multdecpts                    n
      D   multsigns                     n
      D   nonbrs                        n
      D   toobig                        n
      D   lessthan0                     n
      D maxdigits       s             10i 0
      D badNumSW        s               n
       *--------------------------------------------------------------------
       * Prolog common to CGI programs
       * -Receive input from the remote browser
       *--------------------------------------------------------------------
       /copy CGIDEV2/qrpglesrc,prolog3
       *=====================================================================
       * MAIN PROCESSING LINE
       *=====================================================================
 xxxxx * Get program start time for calculating execution time
 xxxxxC                   time                    timedata1
       * Parse input string
      C                   exsr      Parse
       * Set output skeleton html member name
      C                   exsr      SetSkl
       * Read skeleton output html into core
      C                   callp     gethtml(fn:lib:mbr:'/$')
       * Retrieve environment variables
      C                   exsr      RtvEnvVar
       * Get http links
      C                   exsr      GetLinks
       * Assign data base file BOATSALE1, the open it
      C     BoatSaleSW    ifeq      *blank
      C                   eval      BoatSaleSW = 'x'
      C                   open      BOATSALE1                            50
      C                   endif
       * Issue html section /$top
      C                   exsr      SetTop
      C                   callp     wrtsection('top')
       *------------------
       * Retrieve number of boats to be shown
      C                   eval      ItemCount = ZhbGetVarCnt('serno')
       * Show the requested boats
      C                   eval      i =1
      C     i             DOUGT     ItemCount
      C                   eval      SernoC = ZhbGetVar('serno':i)
      C                   move      SernoC        bnbr
      C                   exsr      ChkSerNoc                                    check numeric input
      C                   if        badNumSw=*on                                 invalid numric input
      C                   eval      i+=1
      C                   iter                                                   ignore this input
      C                   endif
      C                   eval      bnbr=c2n2(SernoC)
      C     bnbr          chain     BOATRC                             60
      C     *in60         ifeq      '0'
      C                   exsr      SetFound
      C                   callp     wrtsection('found')
      C                   exsr      MoreText
      C                   else
      C                   callp     wrtsection('notfound')
      C                   endif
      C                   eval      i+=1
      C                   ENDDO
       * If no boats selected
      C     ItemCount     ifeq      0
      C                   callp     wrtsection('noselect')
      C                   endif
       * Send output buffer and quit
      C                   exsr      Exit
       *=====================================================================
       * Send output buffer and quit
       *=====================================================================
      C     Exit          begsr
       * Compute and display run time
      C                   time                    timedata2
      C     timedata2     subdur    timedata1     ms:*ms
      C                   eval      sec = ms / 1000000
      C                   callp     updhtmlvar('runtime':
      C                             %trim(%editw(sec:'     0 .   ')))
      C                   callp     wrtsection('endhtml')
       * Do not delete the call to wrtsection with section name *fini.  It is needed
       * to ensure that all output html that has been buffered gets output.
      C                   callp     wrtsection('*fini')
       *
      C     quit          ifne      *blank
      C                   close     BOATSALE1
      C                   eval      *inlr = *on
      C                   endif
       *
      C                   return
      C                   endsr
       *=====================================================================
       * Parse input string
       *=====================================================================
      C     Parse         begsr
      C                   eval      lng     = zhbgetvar('lng')
      C                   eval      BckGnd  = zhbgetvar('bckgnd')
      C                   eval      quit    = zhbgetvar('quit')
       * Convert to uppercase
      C                   eval      lng = uppify(lng)
      C                   eval      BckGnd = uppify(BckGnd)
      C                   endsr
       *=====================================================================
       *  Additional boat dependent html text
       *  output html sections /$textxx
       *=====================================================================
      C     MoreText      begsr
       * Assign and open database file BOATTXTS
      C                   eval      TxtMbr1 = 'MBR'
      C                   move      bnbr          TxtMbr2
      C                   open      BOATTXTS
       *
      C                   do        *hival
      C                   read      txtrec                                 40
      C     *in40         ifeq      '1'
      C                   leave
      C                   endif
      C                   exsr      SetText
      C                   callp     wrtsection('text')
      C                   enddo
       *
      C                   close     BOATTXTS
      C                   callp     wrtsection('eotext')
      C                   endsr
       *---------------------------------------------------------------------
       *  Get http links
       *---------------------------------------------------------------------
      C     GetLinks      begsr
      C     GetLinkSW     IFEQ      *blank
       * Assign and open database file BOATLINKS to CGIDEV2/BOATLINKS
      C                   eval      GetLinkSW = 'x'
      C                   open      BOATLINKS
       *  Get Monthly Estimator http link into field "estimadr"
      C     *like         define    lnkadr        estimadr
      C                   eval      lnkkey = 'ESTIMATOR'
      C     lnkkey        chain     lnkrec                             60
      C     *in60         ifeq      '0'
      C                   eval      estimadr = lnkadr
      C                   endif
       * Close file (will not be needed the next time through)
      C                   close     BOATLINKS
      C                   ENDIF
      C                   endsr
       *=====================================================================
       * Set html output variables for section /$top
       *=====================================================================
      C     SetTop        begsr
       * Repeat national language for the next invocation
      C                   callp     updhtmlvar('LNG':lng:
      C                             InitHTMLVars)
       * Repeat background color for the next invocation
      C                   callp     updhtmlvar('BCKGND':bckgnd)
       * Color for text, background, links, visited links, active links
      C                   exsr      SetColor
       * Protocol
      C                   callp     updHtmlVar('PROTOCOL':S_Protocol)
      C                   endsr
       *=====================================================================
       * Set html output variables for section /$found (display a boat)
       *=====================================================================
      C     SetFound      begsr
       * Boat serial number (numeric, converted to char
      C                   movel(p)  bnbr          bnbrC
      C                   callp     updHtmlVar('BNBR':bnbrC   )
       * Boat type
      C                   callp     updHtmlVar('BTYPE':btype)
       * Boat maker
      C                   callp     updHtmlVar('BMAKER':bmaker)
       * Boat name
      C                   callp     updHtmlVar('BNAME':bname)
       * Boat length (numeric, edited)
      C                   callp     updhtmlvar('BLEN':
      C                             %trim(%editc(blen:'J')))
       * Boat year built (numeric, edited)
      C                   callp     updhtmlvar('BYEAR':
      C                             %trim(%editc(byear:'4')))
       * Boat price (numeric, edited)
      C     bprice        ifeq      0
      C                   callp     updhtmlvar('BPRICE':'to be defined ')
      C                   else
      C                   callp     updhtmlvar('BPRICE':
      C                             %trim(%editw(bprice:'  ,   ,   , 0 $')))
      C                   endif
       * Boat city where located
      C                   callp     updhtmlvar('BCITY':bcity)
       * Boat state where located
      C                   callp     updhtmlvar('BSTATE':bstate)
       * Boat country where located
      C                   callp     updhtmlvar('BCTRY':bctry)
       * Boat gif name
      C     bgif          ifeq      *blanks
      C                   move      bnbr          bgif
      C                   endif
      C                   callp     updhtmlvar('BGIF':bgif)
      c* Gif alignment
      C     balign        ifeq      *blank
      C                   eval      balign ='L'
      C                   endif
      C     balign        ifeq      'R'
      C                   eval      align = 'right'
      C                   else
      C                   eval      align = 'left'
      C                   endif
      C                   callp     updhtmlvar('BALIGN':align)
      c* Gif horizontal spacing
      C     bhspac        ifeq      0
      C                   eval      bhspac =8
      C                   endif
      C                   callp     updhtmlvar('BHSPAC':
      C                             %trim(%editc(bhspac:'1')))
      c* Gif vertical spacing
      C     bvspac        ifeq      0
      C                   eval      bvspac=5
      C                   endif
      C                   callp     updhtmlvar('BVSPAC':
      C                             %trim(%editc(bvspac:'1')))
       *
      C                   endsr
       *=====================================================================
       *  Set output variables for section /$text
       *=====================================================================
      C     SetText       begsr
       * Substitute /%ESTIMATOR%/ with corresponding URL in "srcdta"
      C                   exsr      EstURL
       * Additional boat dependent html text line
      C                   callp     updhtmlvar('TEXT':srcdta)
       *
      C                   endsr
       *=====================================================================
       * Substitute /%ESTIMATOR%/ with corresponding URL in "srcdta"
       *=====================================================================
      C     EstURL        begsr
      C     *like         define    srcdta        srcdta1
       * If /%ESTIMATOR%/ not in "srcdta", exit routine
      C     EstKwd        scan      srcdta        r
      C     r             cabeq     0             EstURLX
  *    *
       *  "estimadrL" = length of URL "estimadr"
      C     ' '           checkr    estimadr      estimadrL         3 0
       *  "len1"      = length of text preeceding /%ESTIMATOR%/
      C                   z-add     r             len1              3 0
      C                   eval      len1 = len1 - 1
       *  "start2     = start of text following /%ESTIMATOR%/
      C                   z-add     r             start2            3 0
      C                   eval      start2 = start2 + EstKwdLen
       *  "len2"      = fittable length of text following /%ESTIMATOR%/
      C                   z-add     80            len2              3 0
      C                   eval      len2 = len2 - len1 - estimadrL
       *  perform substitution
      C                   eval      srcdta1 = %subst(srcdta:1:len1)
      C                   eval      srcdta1 = %trimr(srcdta1) + estimadr
      C                   eval      srcdta1 = %trimr(srcdta1) +
      C                                       %subst(srcdta:start2:len2)
      C                   eval      srcdta = srcdta1
       *
      C     EstURLX       tag
      C                   endsr
       *=====================================================================
       * Color for text, background, links, visited links, active links
       *=====================================================================
      C     SetColor      begsr
      C                   eval      BckGnd = uppify(BckGnd)
      C                   callp     updhtmlvar('TXTCOLOR':'black')
      C                   callp     updhtmlvar('BOLD':' ')
       * BGCOLOR white, LINK blue, VLINK red, ALINK green
      C     bckgnd        ifeq      'WHITE'
      C     bckgnd        oreq      *blank
      C                   callp     updhtmlvar('BGCOLOR':'FFFFFF')
      C                   callp     updhtmlvar('LINK':'0000FF')
      C                   callp     updhtmlvar('VLINK':'FF0000')
      C                   callp     updhtmlvar('ALINK':'00FF00')
      C                   endif
       * BGCOLOR gray, LINK blue, VLINK red, ALINK green
      C     bckgnd        ifeq      'GRAY'
      C                   callp     updhtmlvar('BGCOLOR':'CCCCCC')
      C                   callp     updhtmlvar('LINK':'0000FF')
      C                   callp     updhtmlvar('VLINK':'FF0000')
      C                   callp     updhtmlvar('ALINK':'00FF00')
      C                   endif
       * BGCOLOR light blue, LINK blue, VLINK red, ALINK green
      C     bckgnd        ifeq      'LBLUE'
      C                   callp     updhtmlvar('BGCOLOR':'5BE6F3')
      C                   callp     updhtmlvar('LINK':'0000FF')
      C                   callp     updhtmlvar('VLINK':'FF0000')
      C                   callp     updhtmlvar('ALINK':'00FF00')
      C                   endif
       * BGCOLOR black, LINK green, VLINK red, ALINK white
      C     bckgnd        ifeq      'BLACK'
      C                   callp     updhtmlvar('TXTCOLOR':'white')
      C                   callp     updhtmlvar('BGCOLOR':'000000')
      C                   callp     updhtmlvar('LINK':'00FF00')
      C                   callp     updhtmlvar('VLINK':'FF0000')
      C                   callp     updhtmlvar('ALINK':'FFFFFF')
      C                   callp     updhtmlvar('BOLD':'«b»')
      C                   endif
      C                   endsr
       *=====================================================================
       * Set html output skeleton member before its read into memory
       *=====================================================================
      C     SetSkl        begsr
      C                   eval      lng = uppify(lng)
      C                   eval      Lib = 'CGIDEV2'
      C                   eval      Fn  = 'DEMOHTML' + lng
      C                   eval      Mbr = 'BOATSCH2'
      C                   endsr
       *=====================================================================
       *  Retrieve environment variables
       *=====================================================================
      C     RtvEnvVar     begsr
       * Use getenvp to get this server's protocol
      C                   eval      S_Protocol =getenv('SERVER_PROTOCOL':
      C                             qusec)
       *
      C                   endsr
       *=====================================================================
       * Check numeric input field "sernoc"
       *=====================================================================
      C     ChkSernoC     begsr
      C                   eval      badNumSW=*off
       * Check numeric input through subprocedure ChkNbr
      C                   eval      maxdigits=%size(sernoC)
      C                   eval      ChkNbrDs=chkNbr(sernoC:maxdigits)
      C                   if        anyerrs=*on
      C                   eval      badNumSw=*on
      C                   endif
       *
      C                   endsr
0.048 sec.s