**************************************************************************
* 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 *
**************************************************************************
* To work properly, this program must be created with a named activation
* group
/copy qrpglesrc,hspecs
/copy qrpglesrc,hspecsbnd
xxxxxFhoursop if e k disk usropn Hours of operation
xxxxxF infsr(*pssr) If error, use *pssr
* Prototype defintions
/copy qrpglesrc,prototypeb
* Our version of standard system API error structure
/copy qrpglesrc,usec
* Number of variables
D nbrVars s 10i 0
* For program status data structure and program status subroutine
D psds ds Pgm status DS
D psdsdata 429 The data
D pssrswitch n inz(*off) switch for pssr
D wrotetop s n inz(*off) Whthr top sec wrtn
* Constant for updHTMLvar subprocedure
D init c '0'
*HTML input variables
xxxxxD ds
xxxxxD dayin 1 varying
xxxxxD dayinnbr 1s 0 overlay(dayin:3)
xxxxxD reqcnt s 10i 0
* Saved query string
D savedquerystring...
D s 32767 varying
* For handling persistence
D sessionid s 15
D pathinfo s 250
D pathinfolen s 10i 0
D timeout s 5u 0 inz(3) min for httimeout hd
* Return code
D rc s 10I 0
* Indicators for GetHtmlIfsMult subprocedure
D IfsMultIndicators...
d ds
D NoErrors n
D NameTooLong n
D NotAccessible n
D NoFilesUsable n
D DupSections n
D FileIsEmpty n
D PgmName c 'PERSIST'
****************************************************************************
* Mainline
****************************************************************************
xxxxx * Write qualified job name to debug file. The *on
xxxxx * parameter forces output even if debugging is off.
xxxxx * Remove this parameter or change it to *off if you
xxxxx * want the output only if debugging is on.
xxxxxC* callp wrtjobdbg(*on)
xxxxxC callp wrtjobdbg
* Read htmlsrc. Gethtml does not read if source has
* already been read and member's timestamp is unchanged.
cccccC eval IfsMultIndicators = getHtmlIfsMult(
C '/cgidevexthtml/persist2.html':'«AS400»')
* Initialize wrotetop to *off
C eval wrotetop = *off
* Get pathinfo
C eval pathinfo = getenv('PATH_INFO':qusec)
C if pathinfo «» *blanks
C eval pathinfolen = %len(%trimr(pathinfo))
C eval pathinfo = %subst(pathinfo:2:pathinfolen-2)
C endif
* Write session id and pathinfo to debugging file
C callp wrtdebug(PgmName +': session id: ' +
C sessionid + ' pathinfo ' + pathinfo)
* Make sure pathinfo and sessionid are consistent
C select
C when sessionid «» *blanks and pathinfo «» *blanks
C and sessionid «» pathinfo
C exsr badsession
C when sessionid = *blanks and pathinfo «» *blanks
C exsr badsession
C when sessionid «» *blanks and pathinfo = *blanks
C exsr badsession
C endsl
* Create session id if there is none. The same session ID will be
* used repeatedly.
C if sessionid = *blanks
C eval sessionid = getsessionid
C endif
* Get input
C eval nbrVars =
C zhbgetinput(savedquerystring:qusec)
* Abort if any errors.
C if qusbavl » 0
C exsr *pssr
C endif
* Parse input variables
xxxxx * Dayin
xxxxxC if zhbGetVarCnt('dayin') » 0
xxxxxC eval dayin = zhbGetVar('dayin')
xxxxxC else
xxxxxC eval dayin = '0'
xxxxxC endif
xxxxx * If user asked to quit, exit program. By not writing persist section,
xxxxx * persistence is ended.
xxxxxC if dayinnbr = 8
xxxxxC eval timeout = 0
xxxxxC callp wrtsection('TOP')
xxxxxC eval wrotetop = *on For pssr
xxxxxC callp wrtsection('done bottom *fini')
xxxxxC eval *inlr = *on End program
xxxxxC exsr return
xxxxxC endif
xxxxx * If dayin between 1 and 7, update reqcnt and get that day's data
xxxxx * from the database file.
xxxxxC if dayinnbr » 0 and dayinnbr « 8
xxxxxC eval reqcnt = reqcnt + 1
xxxxx * Get hours for the selected day
xxxxxC if not %open(hoursop)
xxxxxC open hoursop Open file
xxxxxC endif
xxxxxC dayinnbr chain hoursrec Read record
xxxxxC endif dayinnbr » 0 and day
* Write HTML sections. The persist section makes the CGI persistent.
C exsr setvardata
C callp wrtsection('persist top')
C eval wrotetop = *on For pssr
xxxxxC callp wrtsection('form')
xxxxx * If a day was selected, output its hours. Otherwise, output the
xxxxx * no selection message.
xxxxxC if dayinnbr » 0
xxxxxC callp wrtsection('hours')
xxxxxC else
xxxxxC callp wrtsection('noselect')
xxxxxC endif
xxxxxC callp wrtsection('reqcount bottom')
C callp wrtsection('*fini')
C exsr return
****************************************************************************
* Set up HTML output data
****************************************************************************
C setvardata begsr
xxxxxC callp updHTMLvar('sessionid':sessionid:init)
xxxxxC callp updHTMLvar('timeout':
xxxxxC %trim(%char(timeout)))
xxxxxC callp updHTMLvar('reqcnt':
xxxxxC %editc(reqcnt:'P'))
xxxxxC callp updHTMLvar('days':days)
xxxxxC callp updHTMLvar('hours':hours)
C endsr
****************************************************************************
* Expired or invalid session ID
****************************************************************************
C badsession begsr
C eval sessionid = ''
C eval timeout = 0
C exsr setvardata
C callp wrtsection('top')
C eval wrotetop = *on
C callp wrtsection('expired bottom *fini')
C eval *inlr = *on
C exsr return
C endsr
****************************************************************************
C return begsr
****************************************************************************
C return
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
xxxxxC exsr return
C endif
* Set on switch to indicate we've been here
C eval pssrswitch=*on
C eval timeout = 0
* Write HTML sections (top if not already done, pssr, and *fini)
C if wrotetop=*off
C callp wrtsection('top')
C endif
C callp wrtsection('pssr')
C callp wrtsection('bottom')
C callp wrtsection('*fini')
* Send psds data to cgidebug physical file
C callp wrtpsds(psds)
C eval *inlr = *on
xxxxxC exsr return
C endsr
|
Member
PERSIST
in
CGIDEV2 / QRPGLESRC