Learn from sources
       Member STATE in CGIDEV2 / QRPGLESRC

       **************************************************************************
       * This material is provided by IBM for illustrative purposes             *
       * only and has not been thoroughly tested under all conditions.          *
       * IBM, therefore, cannot guarantee or imply reliability,                 *
       * serviceability, or function of this material.  IBM provides            *
       * no program services for this material.  All material contained         *
       * herein is provided to you "AS IS" without any warranties of            *
       * any kind.  THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS          *
       * FOR A PARTICULAR PURPOSE AND NON-INFRINGMENT ARE EXPRESSLY             *
       * DISCLAIMED.  SOME JURISDICTIONS DO NOT ALLOW THE EXCLUSION             *
       * OF IMPLIED WARRANTIES, SO THE ABOVE EXCLUSIONS MAY NOT APPLY           *
       * TO YOU.  IN NO EVENT WILL IBM BE LIABLE TO ANY PARTY FOR ANY           *
       * DIRECT, INDIRECT, SPECIAL OR OTHER CONSEQUENTIAL DAMAGES FOR           *
       * ANY USE OF THIS MATERIAL, INCLUDING, WITHOUT LIMITATION, ANY           *
       * LOST PROFITS, BUSINESS INTERRUPTION, LOSS OF PROGRAMS OR OTHER         *
       * DATA ON YOUR INFORMATION HANDLING SYSTEM OR OTHERWISE, EVEN            *
       * IF WE ARE EXPRESSLY ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.        *
       *                                                                        *
       * (C) Copyright IBM Corp. 1997, 2005                                     *
       * All rights reserved.                                                   *
       * US Government Users Restricted Rights -                                *
       * Use, duplication, or disclosure restricted                             *
       * by GSA ADP Schedule Contract with IBM Corp.                            *
       *                                                                        *
       * Licensed Materials - Property of IBM                                   *
       **************************************************************************
       /copy qrpglesrc,hspecs
       /copy qrpglesrc,hspecsbnd
 
       * Prototype definitions and standard system API error structure
       /copy qrpglesrc,prototypeb
       /copy qrpglesrc,usec
 
       * For program status data structure and program status subroutine
      D psds           sds                                                       Pgm status DS
      D   psdsdata                   429                                         The data
      D   PgmName                     10    overlay(psdsdata:1)
      D pssrswitch      s               n   inz(*off)                            switch for pssr
      D wrotetop        s               n   inz(*off)                            Whthr top sec wrtn
 
       * Message ID for CrtUsrSpc
      D MsgId           s              7
 
       * Externally described HTML fields
       /if defined(rothman)
      D ExtHtmlFiles    c                   '/home/rothman/cgidev2/-
      D                                     cgidevexthtml/state.html'
       /elseif not defined(rothman)
      D ExtHtmlFiles    c                   '/cgidevexthtml/state.html'
       /endif
      D ExtHtmlIndsDS   ds
      D ExtHtmlInds                     n   dim(6)
      D ExtHtmlErrMsg   s           1000    varying
 
       * State related variables
      D State           ds                  based(StateP)
      D  Count                        10i 0
      D  Entries                   32767    varying
 
       * Miscellaneous variables
      D NewLine         c                   x'15'
      D NbrVars         s             10i 0
      D SavedQueryString...
      D                 s          32767    varying
      D i               s             10i 0
      D rc              s             10i 0
 
       * User space variables
      D UsrSpcName      s             10
      D UsrSpcLib       c                   'CGIDEV2USP'
 
 xxxxx * Program timing variable
 xxxxxD sec             s             15p 6
 
       * Input variables
      D AnEntry         s             40    varying
      D WkEntry         s          32767    varying
 
       ****************************************************************************
       * Mainline
       ****************************************************************************
       * Initialization
      C                   exsr      Initialize
       * Get externally described HTML
      C                   exsr      GetExtHtml
       * Get user's input, create or retrieve user space pointer.
      C                   exsr      UsrSpc
       * Process inputs
      C                   select
       *  If no inputs, this is the first time.  Output initial screen.
      C                   when      nbrvars = 0
      C                   callp     updhtmlvar('count':%editc(count:'3'))
      C                   callp     updhtmlvar('Entries':'')
      C                   exsr      WriteTop
      C                   callp     wrtSection('body1 List body2')
      C                   exsr      FinishUp
       *  Request to quit
      C                   when      ZhbGetVarUpper('Quit') = 'QUIT'
      C                   eval      rc = DoCmd('DLTUSRSPC ' + usrspclib + '/' +
      C                             usrspcname)
      C                   eval      StateP = *null
      C                   eval      rc = AddMsg('User space ' + usrspcname +
      C                             ' has been deleted.')
      C                   exsr      WriteTop
      C                   callp     WrtSection('body3 startover')
      C                   exsr      FinishUp
       *  Request to add an entry
      C                   other
      C                   eval      rc = AddMsg('Using user space ' +
      C                             UsrSpcName + '.')
       *
      C                   eval      AnEntry = ZhbGetVar('AnEntry')
      C                   if        AnEntry = ''
      C                   eval      rc = AddMsg('You entered a blank entry,  -
      C                             which was ignored.')
      C                   else
      C                   eval      Count = Count + 1
       * The encode and EcodeBlanks subprocedures are used to encode
       * any occurrences of ", &, <, >, or blank in the input.
      C                   eval      WkEntry = Encode2(AnEntry:rc)
      C                   eval      WkEntry = EncodeBlanks(WkEntry)
      C                   eval      Entries = Entries + WkEntry + '
'   C endif   C exsr WriteTop   C callp WrtSection('body1')   C if count > 0   C callp UpdHtmlVar('count':%editc(count:'Z'))   C callp updHtmlVar('Entries':Entries)   C callp WrtSection('list')   C endif   C callp WrtSection('body2')   C exsr FinishUp   C endsl   C return   ****************************************************************************   C FinishUp begsr   ****************************************************************************  xxxxx * Get and write run time  xxxxxC eval sec = TimerElapsed()  xxxxxC callp wrtdebug(PgmName +  xxxxxC ': Execution time (seconds) ' +  xxxxxC %trim(%editc(sec:'N')):*on)  xxxxxC callp updhtmlvar('runtime':%editc(sec:'N'))  xxxxxC callp wrtsection('runtime')   * End of html   C callp WrtSection('endhtml *fini')   C endsr     ****************************************************************************   C GetExtHtml begsr   ****************************************************************************   * Clear output buffer   C callp ClrHtmlBuffer     * Get external HTML. If it fails, send message to the browser, then return.   * Note that the starting and ending delimiters are being specified to   * override of the default of a starting delimiter of /$ and no ending   * delimiter.   *   * The delimiters ' allow section records to look like   * HTML comments. This prevents PC based HTML validity checkers   * from treating them as errors.   *   C eval ExtHtmlIndsDS = GetHtmlIFSMult(   C ExtHtmlFiles:   C '')   C if ExtHtmlInds(1) = *off   C eval ExtHtmlErrMsg = 'Content-type: text/html' +   C newline + newline + ' -   C State Demonstration -   C

-   C State Demonstration -   C

Error(s) ocurred. Programmer has -   C been notified. Please try again later. -   C

'   C callp WrtNoSection(%addr(ExtHtmlErrMsg)+2:   C %len(ExtHtmlErrMsg))   C callp WrtSection('*fini')   C return   C endif   C endsr   ****************************************************************************   C UsrSpc begsr   ****************************************************************************   * Get browser input   C eval NbrVars = ZhbGetInput(SavedQueryString:qusec)   * Abort if any errors.   C if qusbavl > 0   C exsr *pssr   C endif   * Get and process user space name. If not found, create it.   C eval UsrSpcName = ZhbGetVar('UsrSpcName')   C if UsrSpcName = ''   C eval UsrSpcName= CrtUsrSpc(   C UsrSpcLib : StateP : MsgID)   C if UsrSpcName = ''   C exsr *pssr   C eval count = 0   C eval entries = ''   C else   C eval rc = AddMsg('User space ' +   C UsrSpcName + ' has been created')   C endif   C else   C eval StateP = RtvUsrSpcPtr(UsrSpcName:   C UsrSpcLib)   C if StateP = *null   C eval rc = AddMsg('You apparently quit and then -   C used the back button or reload button, -   C neither of which is allowed. Please -   C start over.')   C exsr WriteTop   C callp WrtSection('startover endhtml *fini')   C return   C endif   C endif   * Update user space variable   C callp UpdHtmlVar('UsrSpcName':UsrSpcName)   C endsr  xxxxx   ****************************************************************************   C WriteTop begsr   ****************************************************************************   C callp wrtsection('top')   C eval wrotetop = *on   C if GetMsgCnt > 0   C callp WrtMsgs   C endif   C endsr   ****************************************************************************   C Initialize begsr   ****************************************************************************  xxxxx * Start program timer  xxxxxC callp TimerStart()   * Clear messages   C callp ClrMsgs   * Create the user space library if it doesn't exist.   C eval rc = DoCmd('CHKOBJ ' + UsrSpcLib +   C ' *LIB')   C if rc <> 0   C eval rc = DoCmd('CRTLIB ' + UsrSpcLib)   C eval rc = addMsg('Library ' + UsrSpcLib +   C ' has been created.')   C endif   * Set off wrotetop   C eval wrotetop = *off   * Write qualified job name to debugging file   C callp WrtJobDbg(*On)   C endsr   ****************************************************************************   * Program status subroutine   ****************************************************************************   C *pssr begsr   * If have already been in pssr, get out to avoid looping   C if pssrswitch=*on   C eval *inlr = *on   C return   C endif   * Set on switch to indicate we've been here   C eval pssrswitch=*on   * Write HTML sections (top if not already done, pssr, endhtml and *fini)   C if wrotetop=*off   C callp wrtsection('top')   C endif   C callp wrtsection('pssr endhtml *fini')   * Send psds data to cgidebug physical file   C callp wrtpsds(psds)   C eval *inlr = *on   C return   C endsr
0.034 sec.s