**************************************************************************
* 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 + '«br»'
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 '«!-- _' and ' --» 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 + '«html»«body»«head» -
C «title»State Demonstration«/title»«/head» -
C «body title="State"»«h1 align="center"» -
C State Demonstration -
C «/h1»«p»Error(s) ocurred. Programmer has -
C been notified. Please try again later. -
C «/p»«/body»«/html»'
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
|