*=============================================================================================
* EXPORTED SUBPROCEDURES IN THIS MODULE
* - ClrHtmlBuffer
* - CrtTagOpt
* - Encode
* - Encode2
* - EncodeBlanks
* - GetHtml
* - GetHtmlBytesBuffered
* - GetHtmlIFS
* - GetHtmlIFSMult
* - RtvHtmlRcd
* - RtvSubsVarInfo
* - UpdHTMLvar
* - UpdHTMLvar2
* - WrtHTMLToStmfX (the original WrtHtmlToStmf)
* - WrtHTMLToStmf (the new one, supporting also UTF CCSID's)
* - AppHTMLToStmf
* - WrtNoSection
* - WrtSection
* - GetHtmlBufferP
* - WrtSectionToStmf Giovanni 2014-02-25
*
* C LANGUAGE PROCEDURES
* - memcpy
* - TS_Malloc
* - TS_Free
* - TS_ReAlloc
*
* LOCAL SUBPROCEDURES
* - AddHrec
* - InitHtml
* - SetUpArrays
* - StdOut
* - GetPgmStack
* - RtvStmfCCSID
* - RtvJobCCSID
* - Endjob Giovanni 2011-07-21
*=============================================================================================
* UPGRADES
* 2014-07-25 Joe Guetzlaff (mindstream solutions llc, FL, US) suggested some small changes
* in order to recognize a section, if the section name has leading blanks/is
* indented. Changes are marked with "Guetzlaff".
*=============================================================================================
Hnomain
/copy CGIDEV2/qrpglesrc,hspecs
******************************************************************
* Global files
******************************************************************
* HTMLSRC file's record length can be up to 240 bytes (228 bytes of source
* data). The one that comes with the CGIDEV2 library is 240 bytes.
Fhtmlsrc if f 240 disk usropn
* CGIDEV2 library prototypes
/copy qrpglesrc,prototypeb
* Standard error data structure
/copy CGIDEV2/qrpglesrc,usec
******************************************************************
* Prototypes for local subprocedures.
******************************************************************
* See implementations in this member for descriptions.
D AddHrec pr
D Hrec 32767 const varying
D InitHtml pr
D sectionDelim...
D Start 20 const varying options(*nopass)
D sectionDelim...
D End 20 const varying options(*nopass)
D varDelimStart 20 const varying options(*nopass)
D varDelimEnd 20 const varying options(*nopass)
D SetUpArrays pr
D CallingProc 50 const varying
D NoErrors n
D DupSections n
* Writes Length bytes of data at Location into address of BufP
D StdOut pr
D Location * value
D Length 10u 0 const
* Defines API QWVRCSTK (used by internal subprocedure RtvPgmStack) as an external program
D GetPgmStack pr extpgm('QWVRCSTK')
D Rcv 6000
D RcvLen 10i 0
D RcvFmt 8
D JId 56
D JobIdFmt 8
D qusec 516
* Retrieves the program calling a procedure in this module
D RtvPgmStack pr 20
D CallLevel 10i 0 value
* Retrieves the CCSID of a stream file
D RtvStmfCCSID pr 5u 0 returned CCSID
D xStmf * value options(*string) stream file name
* Retrieves the CCSID of the current job
D RtvJoBCCSID pr 5u 0
* Ends the HTTP job servicing the current request Giovanni 2011-07-21
D Endjob pr Giovanni 2011-07-21
D DebugMsg 2000 varying Giovanni 2011-07-21
******************************************************************
* Other prototypes
******************************************************************
* C Language procedure to copy bytes from one memory location to another
D memcpy pr extproc('memcpy')
D dest * value
D src * value
D length 10u 0 value
* C Language procedures for teraspace dynamic memory operations
D TS_Malloc pr * extproc('_C_TS_malloc')
D size 10u 0 value
D TS_Free pr extproc('_C_TS_free')
D pointer * value
D TS_Realloc pr * extproc('_C_TS_realloc')
D pointer * value
D size 10u 0 value
******************************************************************
* Global variables, structures, etc.
******************************************************************
* Substitution variables' names, values. Storage is allocated dynamically.
D ds based(varPtr) align
D varstuff 64 dim(32767)
D varnm 30 varying
D overlay(varstuff:1)
D varP * overlay(varstuff:33)
D varLen 10i 0 overlay(varstuff:*next)
* Initial number of variables to allocate
D varinit c 10
* Additional number of variables to allocate
D varaddl c 10
* Number of variables currently allocated
D varallocated s 10u 0 inz(0)
* Number of variables currently used
D varcurrent s 10u 0 inz(0)
* Number of bytes allocated
D varbytes s 10u 0 inz(0)
* File to override
D FileToOvr s 10 inz('HTMLSRC')
* Html stream
* - Dynamically allocated in 32K chunks.
* - Addressed by pointer HtmlP.
* - Contains right-trimmed records, each in varying length format.
* - Indexed by array HtmlOfs. Each element is the offset
* into the stream for that record.
D Html s 32767 based(HtmlP)
* Html stream increment size
D HtmlIncr c 32769
* Current bytes allocated to Html stream.
D HtmlAlloc s 10i 0
* Number of bytes currently used
D HtmlUsed s 10i 0
* Current count of records in HTML stream
D HtmlCount s 10i 0
* Array of offsets into the Html stream
D HtmlOfs s 10i 0 dim(32767) based(HtmlOfsP)
* Allocated entries in HtmlOfs
D HtmlOfsAlloc s 10i 0
* Used entries in HtmlOfs
D HtmlOfsUsed s 10i 0
* HtmlOfs increment count
D HtmlOfsIncr c 100
* Default section name start delimiter
D secdelim1dft c '/$'
* Default section name end delimiter
D secdelim2dft c ' '
* Actual section name start delimiter
D secdelim1 s 20 varying
* Actual section name end delimiter
D secdelim2 s 20 varying
* Section delimiter lengths
D SecDelim1Len s 10i 0
D SecDelim2Len s 10i 0
* Maximum number of section names
D seccnt c 1000
* Array of section names
D secname s 50 dim(seccnt)
* Array of starting RRNs for section names
* If not records in a section, secstart has relative record
* number of the section record and secend has 0.
D secstart s 10u 0 dim(seccnt)
* Array of ending RRNs for section names
D secend s 10u 0 dim(seccnt)
* Section names used
D SecUsed s 10u 0 inz(0)
* First section name in the arrays. The are loaded from
* the top down.
D SecFirst s 10u 0 inz(seccnt)
* Output buffer, dynamically allocated. Can grow to much bigger size.
D OutBuff s 32767 based(outbuffP)
* Initial allocation (bytes)
DOutBuffAllocInit...
D s 10u 0 inz(100000)
* Additional allocation (bytes)
D OutBuffAllocAddl...
D s 10u 0 inz(100000)
* Currently allocated (bytes)
D OutBuffAlloc s 10u 0
* Current number of bytes used
D OutBuffUsed s 10u 0
* Next available position in OutBuff
D OutBuffNextP s *
* Output Buffer Window
D OutBuffWindow s 32767 based(OutBuffNextP)
* Default starting delimiter for variable names in HTML
D delim1dft c '/%'
* Default ending delimiter for variable names in HTML
D delim2dft c '%/'
* Actual starting delimiter for variable names in HTML
D delim1 s 20 varying
* Actual ending delimiter for variable names in HTML
D delim2 s 20 varying
* Length of starting delimiter for variable names in HTML
D delim1ln s 10u 0 inz(%len(delim1dft))
* Length of ending delimiter for variable names in HTML
D delim2ln s 10u 0 inz(%len(delim1dft))
D rc s 10i 0 For docmd
* Arrays for storing location of substitution variables in HTML
D ds based(SubsArrP)
D SubsArr 92 dim(32767) ascend
D SubsRRN 10u 0 overlay(SubsArr:1)
D SubsStartPos 10u 0 overlay(SubsArr:5)
D SubsVarName 30 overlay(SubsArr:9)
D SubsVarLen 10u 0 overlay(SubsArr:39)
D SubsSection 50 overlay(SubsArr:43)
D SubsAllocated s 10u 0
D SubsCount s 10u 0
D SubsInit c 20
D SubsAddl c 20
D SubsBytes s 10u 0
* Last request type
D LastReqType s 1 inz(LrtNone)
D LrtNone c '0'
D LrtSrcPf c '1'
D LrtIfs c '2'
* Variable set and used by GetHtmlIfsMult.
* Arrays of file names, their starting relative, current
* and previous file names and timestamps, etc.
D MaxFiles c 127
D SecFileName s 263 dim(MaxFiles) varying
D SecFileRrn s 10i 0 dim(MaxFiles) ascend
D PrevFileDS ds
D PrevArr 269 dim(MaxFiles)
D PrevFileName 255 varying overlay(PrevArr:1)
D PrevTimeLastChg...
D 10i 0 overlay(PrevArr:258)
D CurrFileDS ds
D CurrArr 269 dim(MaxFiles)
D CurrFileName 255 varying overlay(CurrArr:1) prev IFS file name
D CurrTimeLastChg...
D 10i 0 overlay(CurrArr:258)
D CurrFileHandle...
D 10i 0 overlay(CurrArr:262)
D CurrFileBytes...
D 10i 0 overlay(CurrArr:266)
* Program status data structure
D psds sds
D psdsdata 429
D psdsjobnam 10 overlay(psdsdata:244)
D psdsusrnam 10 overlay(psdsdata:254)
D psdsjobnbr 6 overlay(psdsdata:264)
* Buffer for IFS stat function
D StatusBuffer ds align
D StsPermissions...
D 10u 0
D StsFileID 10u 0
D StsLinkCount 5u 0
D StsUserIDNbr 10u 0
D StsGroupIdNbr 10u 0
D StsBytesInFile...
D 10i 0
D StsTimeLastAcc...
D 10i 0
D StsTimeLastChg...
D 10i 0
D StsTimeStsLastChg...
D 10i 0
D StsFileSysID 10u 0
D StsBlockSize 10u 0
D StsAllocBytes 10u 0
D StsObjectType 11
D StsCodePage 5u 0
D 62
D StsGenerationID...
D 10u 0
* Input specifications for program described file htmlsrc
IHtmlSrc ns
I 13 240 srcdta
******************************************************************
* Exported Subprocedures
******************************************************************
******************************************************************
* ClrHtmlBuffer subprocedure
******************************************************************
* Clears the HTML output buffer.
*
* Use this subprocedure to empty the buffer without sending it
* to either the browser or to a stream file.
*
* This is useful when program logic dictates you need to output
* something other than what has already been buffered.
P ClrHtmlBuffer b export
D ClrHtmlBuffer pi
* Message for WRTDEBUG Giovanni 2011-07-21
D DebugMsg s 2000 varying Giovanni 2011-07-21
D ThisSubProc c 'ClrHtmlBuffer: '
/free
// THIS SUBPROCEDURE WAS RE-WRITTEN ACCORDING TO SUGGESTION Giovanni 2011-07-23
// PROVIDED BY Henrik Rützou Giovanni 2011-07-23
// 2011-07-22 Easy400Group message #16738 Giovanni 2011-07-23
// The original version was saved in CGIDEV2/QRPGLESAVE member XXXWRKHTML 2011-07-23
// 1-Release memory //Giovanni 2011-07-23
monitor; //Giovanni 2011-07-23
TS_Free(OutBuffP); //Giovanni 2011-07-23
on-error; //Giovanni 2011-07-23
DebugMsg=ThisSubProc + 'Job ' +
%trim(psdsjobnbr) + '/' +
%trim(psdsusrnam) + '/' +
%trim(psdsjobnam) +
' forced to end because of memory re-allocation +
error.'; //Giovanni 2011-07-23
endjob(DebugMsg); //WrtDebug and EndJob //Giovanni 2011-07-23
endmon; //Giovanni 2011-07-23
// 2-Allocate new memory //Giovanni 2011-07-23
OutBuffP=Ts_Malloc(OutBuffAllocInit); //Giovanni 2011-07-23
OutBuffAlloc=OutBuffAllocInit; //Giovanni 2011-07-23
OutBuffUsed=0; //Giovanni 2011-07-23
OutBuffNextP=OutBuffP; //Reset next pointer //Giovanni 2011-07-23
wrtdebug(ThisSubProc + 'Previously +
written HTML has been cleared.'); //Giovanni 2011-07-23
/end-free
P ClrHtmlBuffer e
******************************************************************
* CrtTagOpt subprocedure
******************************************************************
* Creates an option tag.
* Use this subprocedure to build selection boxes when the
* contents are not static, or the SELECTED option varies.
* Do not use it for static selection boxes. Static, externally
* defined HTML is much more efficient.
* Inputs:
* - String to be used for the value attribute
* - String for the tag's associated text.
* - Optional input containing the value of the option to have
* the SELECTED attribute. If this parameter matches the
* first parameter, the SELECTED attribute is output.
* Ouput:
* Examples
* CrtTagOpt('AZ':Arizona) returns
*
* CrtTagOpt('AZ':Arizona:'AZ') returns
*
* CrtTagOpt('AZ':Arizona:'MN') returns
*
* CrtTagOpt('AZ':Arizona:'MN') returns
* '
C else
C return ''
C endif
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P CrtTagOpt e
******************************************************************
* Encode subprocedure
******************************************************************
* Returns a varying length field built from an input varying
* length field in which the following characters are converted
* to their HTML character entities:
* Character Character Entity
* --------- ----------------
* " "
* & &
* < <
* > >
* The input field can be any size up to 32767. Be sure
* that it has a correct length as shown in any of the
* following examples:
* - Passing a literal
* eval result = encode('')
* - Assigning value to a varying field.
* eval vfield = ''
* eval result = encode(vfield)
* - Assigning a value to a fixed field
* eval ffield = ''
* eval result = encode(%trimr(ffield))
* - Passing an expression
* eval result = encode('abc' + %trimr(ffield) +
* vfield + 'xyz')
P Encode b export
D Encode pi 32767 varying
D Input 32767 const options(*varsize) varying
D result s 32767 varying
D i s 10i 0
D c s 1
C for i = 1 to %len(input)
C eval c = %subst(input:i:1)
C if %scan(c:'"&<>') > 0
C select
C when c = '<'
C eval result = result + '<'
C when c = '>'
C eval result = result + '>'
C when c = '"'
C eval result = result + '"'
C when c = '&'
C eval result = result + '&'
C endsl
C else
C eval result = result + c
C endif
C endfor
C return result
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P Encode e
******************************************************************
* Encode2 subprocedure
******************************************************************
* Uses an input varying length field to create and return a
* varying length field in which selected input characters are
* changed to the their corresponding character entities.
* The characters to be converted are defined in an IFS file,
* specified in the third parameter. If the third parameter is
* not passed, a default file, /cgidevexthml/encod2arr.txt, is used.
*
* Characters not defined in the IFS file are not converted. Instead,
* the are returned without change. For example:
*
* Input:
* Output: >HTML<
*
* Parameters
* ----------
* - Input
* - Char 8191, varying. The string to be encoded.
* - ReturnCode
* - 10i 0
* 0 successful,
* -1 file error (could be any of the following)
* (at run time, a detailed message is sent to the CGIDEBUG
* debugging file):
* - file not found
* - file not accessible (authority, etc.)
* - file empty
* - file contains no valid records
* -2 one or more data errors, usually invalid entity value
* (details in debugging file)
*
* - EntitiesFile - file that contains the arrays of characters
* and character entities
* - Char 256, *options(*nopass) varying
* - Arrays of characters and entities are loaded at run time
* this file. If the EntitiesFile parameter is not passed, file
* /cgiexthtml/encode2fil.txt is used. Otherwise, the
* EntitiesFile file is used.
*
* Testing Encode2
* ---------------
* Test encode2 from a browser using sample CGI program DSPENCODE2.
* If something does not work as expected, change encode2's arrays
* as follows:
*
* Customizing the character entity list
* -------------------------------------
* - The default data are stored in /cgidevExtHTML/encode2fil.txt.
* It is recommended that you NOT modify, move, or rename this
* file because it could be replaced whenever CGIDEV2 is updated
* or reinstalled. Instead,
* - Copy the default file to an IFS file of your own.
* - Make sure user QTMHHTP1 has *RX authority to your file
* - Modify your file.
* - One record per line
* - Comment records
* - Positions 1 -2 must be //.
* - Data records
* - Position 1: the character to be encoded
* - Positions 2 - 9: the character entity to be substituted for
* the character. If these positions are blank,
* the record is ignored.
* - Remainder of record: blanks or comments
* - Use your file in the EntitiesFile parameter.
* The input field can be up to 8191 bytes. Because
* it is varying, be sure that its length is set
* correctly. Here are a few examples:
* - Passing a literal
* eval result = encode2('':rc)
* - Passing a varying field.
* eval vfield = ''
* eval result = encode2(vfield:rc)
* - Passing from a fixed length field
* eval ffield = ''
* eval result = encode2(%trimr(ffield):rc)
* - Passing an expression
* eval result = encode2('abc' + %trimr(ffield) +
* vfield + 'xyz':rc)
P Encode2 b export
D Encode2 pi 65528 varying
D InputString 8191 const options(*varsize) varying
D ReturnCode 10i 0
D EntitiesFile 256 const varying options(*nopass)
D ThisSubProc c 'Encode2: '
* Entities array. Indexed by numeric value of input character
* Loaded from the EntitiesFile file. For optimum performance,
* it is reloaded only when EntitiesFile's name or timestamp changes.
D Entities s 8 varying dim(255) static
* File and file handling variables
D TheFile s like(EntitiesFile)
D inz('/cgidevexthtml/encode2fil.txt')
D FileHandle s 10i 0
D PrevFile s like(EntitiesFile) static
D PrevFileTS s 10i 0 static
D FileData ds 65528 based(FileDataP)
D TheChar 1
D TheEntity 8
D FirstTwo 2 overlay(FileData:1)
D n2 3u 0 overlay(FileData:1)
D WkFileP s *
* Input and output variables
D wkInputString s like(InputString)
D result s 65528 varying
D OneChar ds based(p)
D c 1
D n 3u 0 overlay(c)
* Variables for handling newline characters
D TwoChars ds
D c1 1
D c2 1
D hex250D s 2 inz(x'250D')
D NewLineSeq s 2 varying
D NewLineSeqLen s 10i 0
* Other variables
D GoodRecords s 10i 0 static
D BytesRead s 10i 0
D i s 10i 0
/free
// Set up file name
if %parms = 3;
TheFile = EntitiesFile;
endif;
// Check file's existence
ReturnCode = 0;
if stat(TheFile:%addr(StatusBuffer)) = -1;
wrtDebug(ThisSubproc + 'Could not access IFS file ' +
TheFile + '. errno and text are: ' +
%trim(%editc(errno:'P')) + ', ' +
%trimr(ErrnoTxt(Errno)):*on);
ReturnCode = -1;
PrevFile = '';
PrevFileTS = 0;
GoodRecords = 0;
Return result;
endif;
// If file is not the the same as before, read it
if (PrevFile <> TheFile) or (PrevFileTS <> StsTimeLastChg); // new file
goodRecords = 0;
// Check for empty file
if StsBytesInFile = 0;
wrtDebug(ThisSubproc + ' ' + theFile +
' is empty.':*on);
ReturnCode = -1;
PrevFile = '';
PrevFileTS = 0;
Return result;
endif;
// Open the file
FileHandle = open(TheFile:O_RDONLY + O_TEXTDATA);
if FileHandle = -1;
wrtdebug(ThisSubProc + ' Could not open file ' + TheFile +
' File system reported the following error: ' +
errnotxt(errno):*on);
Returncode = -1;
PrevFile = '';
PrevFileTS = 0;
Return result;
endif;
// Save file name and timestamp
PrevFile = TheFile;
PrevFileTS = StsTimeLastChg;
// Read the file into dynamically allocated storage
FileDataP = %alloc(StsBytesInFile + 32767);
BytesRead = read(FileHandle:FileDataP:StsBytesInFile);
// Close file
rc = close(FileHandle);
// Handle read failed
if BytesRead = -1;
wrtdebug(ThisSubProc + ' Could not read file ' + TheFile +
' File system reported the following error: ' +
errnotxt(errno):*on);
ReturnCode = -1;
PrevFile = '';
PrevFileTS = 0;
Return result;
endif;
// Determine what is being used to define a new line. It is
// usually x'0D25', but could be x'250D', x'25', x'0D'
// Find first x'0d' or x'25'. Then examine next character to
// determine what the end of line sequence is.
i = 1;
dou %scan(c1:hex250d) > 0;
c1 = %subst(FileData:i:1);
i = i + 1;
enddo;
c2 = %subst(FileData:i:1);
if twochars = x'0D25' or twochars = x'250D';
NewLineSeq = twochars;
else;
NewLineSeq = c1;
endif;
NewLineSeqLen = %len(NewLineSeq);
// Add an additional newline to end of file
WkFileP = FileDataP;
FileDataP = FileDataP + StsBytesInFile;
%subst(FileData:1:%len(NewLineSeq)) = NewLineSeq;
FileDataP = WkFileP;
// Build and process array elements
entities(*) = '';
i = 1;
dow FileDataP - WkFileP < StsBytesInFile;
i = %scan(NewLineSeq:FileData);
// skip comments
if firsttwo = '//' or TheEntity = *blanks;
FileDataP = FileDataP + i + NewLineSeqLen - 1;
iter;
endif;
// skip invalid entities but set return code to -2
if %subst(TheEntity:1:1) <> '&' or
%subst(TheEntity:%len(%trimr(theEntity)):1) <> ';';
wrtDebug(ThisSubproc + ' Invalid entity, ' + %trimr(TheEntity) +
' for character ' + theChar + '.':*on);
ReturnCode = -2;
FileDataP = FileDataP + i + NewLineSeqLen - 1;
Iter;
endif;
// add entry to arrays
Entities(n2) = %trim(TheEntity);
FileDataP = FileDataP + i + NewLineSeqLen - 1;
GoodRecords = GoodRecords + 1;
enddo;
if GoodRecords = 0;
ReturnCode = -1;
Return result;
endif;
// Deallocate storage
FileDataP = WkFileP;
dealloc FileDataP;
endif; // it's a new file
// Process the request
if GoodRecords = 0;
returnCode = -1;
return result;
endif;
wkInputString = InputString;
p = %addr(wkInputString) + 1;
for i = 1 to %len(wkInputString);
p = p + 1;
if Entities(n) <> '';
result = result + Entities(n);
else;
result = result + c;
endif;
endfor;
return result;
//***********************************************************************
// Program status subroutine
//********************************************************************
begsr *pssr;
wrtpsds(psds);
endsr;
/end-free
P Encode2 e
******************************************************************
* EncodeBlanks subprocedure
******************************************************************
* Returns a varying length field built from an input varying
* length field in which any blanks are converted to the HTML
* entity, (non-breaking space).
* The input field can be any size up to 32767. Be sure
* that it has a correct length as shown in any of the
* following examples:
* - Passing a literal
* eval result = EncodeBlanks('')
* - Assigning value to a varying field.
* eval vfield = ''
* eval result = EncodeBlanks(vfield)
* - Assigning a value to a fixed field
* eval ffield = ''
* eval result = EncodeBlanks(%trimr(ffield))
* - Passing an expression
* eval result = EncodeBlanks('abc' +
* %trimr(ffield) + vfield + 'xyz')
P EncodeBlanks b export
D EncodeBlanks pi 32767 varying
D Input 32767 const options(*varsize) varying
D result s 32767 varying
D i s 10i 0
D c s 1
C for i = 1 to %len(input)
C eval c = %subst(input:i:1)
C if c = ' '
C eval result = result + ' '
C else
C eval result = result + c
C endif
C endfor
C return result
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P EncodeBlanks e
******************************************************************
* Gethtml subprocedure
******************************************************************
* Overrides to specified source physical file and loads arrays with HTML
* data from the source physical file. Arrays subsequently used by
* wrtsection, etc.
*
* The optional sectionDelimStart parameter is used to override
* the default starting section delimiter of /$.
*
* The optional sectionDelimEnd parameter is used to override the
* default non-existent ending section delimiter.
*
* The optional varDelimStart parameter is used to override the default
* start variable delimiter of /%
* The optional varDelimEnd parameter is used to override the default
* end variable delimiter of %/
*
P gethtml b export
D gethtml pi
D fn 10 const
D lib 10 const
D mbr 10 const
D sectionDelim...
D Start 20 const varying options(*nopass)
D sectionDelim...
D End 20 const varying options(*nopass)
D varDelimStart 20 const varying options(*nopass)
D varDelimEnd 20 const varying options(*nopass)
* Local variables
D prevfn s 10 static inz(*blanks) prev file name
D prevlib s 10 static inz(*blanks) prev library
D prevmbr s 10 static inz(*blanks) prev member
* Indicators required by SetupArrays subprocedure but not used
* by GetHtml
D Noerrors s n
D DupSections s n
* For QUSRMBRD (Retrieve Member Description) API
D mbrds ds 266
D mbrchgdate 13 overlay(mbrds:161)
D mbrdssize s 10i 0 inz(%size(mbrds))
D mbrfmt s 8 inz('MBRD0200')
D mbrqualfile ds
D mbrfile 10
D mbrlib 10
D mbrmbr s 10
D mbrovr s 1 inz('0')
D mbrchgdateprev s like(mbrchgdate) static
D ThisSubProc c 'GetHtml: '
D WorkPtr s *
* If the current job CCSID is 65535, and data area CGIDEV2DT/SETJBCCSID contains '*YES',
* set the current job CCSID to its default CCSID value
C callp SetJobCCSID
* Retrieve member's change date
C eval mbrfile = fn
C eval mbrlib = lib
C call 'QUSRMBRD'
C parm mbrds
C parm mbrdssize
C parm mbrfmt
C parm mbrqualfile
C parm mbr mbrmbr
C parm mbrovr
C parm qusec
* If an error, set previous file name failed,
* send message to debugging file and return.
C if qusbavl > 0
C callp wrtdebug(ThisSubProc + 'Error -
C retrieving member description information -
C for ' + %trim(mbrlib) + '/' +
C %trim(mbrfile) + ',' + %trim(mbr) +
C '. Error id is ' + qusei + '.':*on)
C eval prevfn = '*FAILED'
C return
C endif
* Return if
* - Last request was LrtSrcPf and
* - File, library, and member have not changed and
* - Member's change date has not changed
C if LastReqType = LrtSrcPf and
C fn = prevfn and
C lib = prevlib and
C mbr = prevmbr and
C mbrchgdateprev = mbrchgdate
C callp wrtdebug(ThisSubProc + 'No records -
C read because file has not changed. -
C Previously, ' +
C %trim(%editc(HtmlCount:'P')) +
C ' records were read.')
C return
C endif
* Set last request type to source physical file
C eval LastReqType = LrtSrcPf
* Initialize
C select
C when %parms = 7
C callp InitHTML(SectionDelimStart:
C SectionDelimEnd:
C VarDelimStart:
C VarDelimEnd)
C when %parms = 6
C callp InitHTML(SectionDelimStart:
C SectionDelimEnd:
C VarDelimStart)
C when %parms = 5
C callp InitHTML(SectionDelimStart:
C SectionDelimEnd)
C when %parms = 4
C callp InitHTML(SectionDelimStart)
C other
C callp InitHTML
C endsl
C
* Set up arrays SecFileName and SecFileRrn arrays
C eval SecFileName(1) =
C %trim(lib) + '/' + %trim(fn) +
C ',' + %trim(mbr)
C eval SecFileRrn(1) = 1
* Save memberchgdateprev
C eval mbrchgdateprev = mbrchgdate
* Save file name, library, and member
C eval prevfn = fn
C eval prevlib = lib
C eval prevmbr = mbr
* Override and open htmlsrc file
C eval rc = docmd('OVRDBF FILE(' +
C %trimr(FileToOvr) + ') TOFILE(' +
C %trimr(lib) + '/' + %trimr(fn) +
C ') MBR(' + %trimr(mbr) + ') +
C SECURE(*YES) OVRSCOPE(*JOB) +
C SEQONLY(*YES 250)')
C open(e) htmlsrc
* Load the records into the HTML stream
C read htmlsrc
C dow not %eof
C callp AddHrec(%trimr(srcdta))
C read htmlsrc
C enddo
* Finished reading HTMLSRC file. Close it and delete its override.
C close(e) htmlsrc
C eval rc = docmd('DLTOVR FILE(' +
C %trimr(FileToOvr) + ') LVL(*JOB)')
* Tell debugging file how many records were read.
C callp wrtdebug(ThisSubProc +
C %trim(%editc(HtmlCount:'P')) +
C ' records read.')
* Set up section arrays and substitution variables arrays
C callp SetUpArrays(ThisSubProc:
C NoErrors:DupSections)
C return
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
Pgethtml e
******************************************************************
* GetHtmlBytesBuffered Subprocedure
******************************************************************
* Returns the number of bytes in the output HTML buffer.
* This number is incremented each time output is written with
* WrtSection or WrtNoSection.
* It is reset to 0 when either WrtSection('*fini') or
* WrtHtmlToStmfX is run.
* If this number is allowed to grow to more than 16 MB, the CGI
* program will fail.
P GetHtmlBytesBuffered...
P b export
D GetHtmlBytesBuffered...
D pi 10i 0
C return OutBuffUsed
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P GetHtmlBytesBuffered...
P e
******************************************************************
* GetHtmlIFS subprocedure
******************************************************************
* Calls subprocedure GetHtmlIFSMult to accomplish the following:
* Loads arrays with HTML data from an IFS file.
* The arrays are subsequently used by wrtsection, etc.
*
* The optional sectionDelimStart parameter is used to override
* the default starting section delimiter of /$.
*
* The optional sectionDelimEnd parameter is used to override the
* default non-existent ending section delimiter.
*
* The optional varDelimStart parameter is used to override the default
* start variable delimiter of /%
* The optional varDelimEnd parameter is used to override the default
* end variable delimiter of %/
*
P GetHtmlIFS b export
D GetHtmlIFS pi
D IfsFile 1024 const varying
D sectionDelim...
D Start 20 const varying options(*nopass)
D sectionDelim...
D End 20 const varying options(*nopass)
D varDelimStart 20 const varying options(*nopass)
D varDelimEnd 20 const varying options(*nopass)
* Local variables
D ThisSubProc c 'GetHtmlIFS: '
* Error indicators returned by GetHtmlIfsMult
D ErrInds ds
D NoErrors n
D NameTooLong n
D NotAccessible n
D NoFilesUsable n
D DupSections n
D FileIsEmpty n
* If the current job CCSID is 65535, and data area CGIDEV2DT/SETJBCCSID contains '*YES',
* set the current job CCSID to its default CCSID value
C callp SetJobCCSID
* Call GetHTMLIfsMult to process request
C select
C when %parms = 5
C eval ErrInds = GetHtmlIFSMult(IFSFile:
C SectionDelimStart:SectionDelimEnd:
C VarDelimStart:VarDelimEnd)
C when %parms = 4
C eval ErrInds = GetHtmlIFSMult(IFSFile:
C SectionDelimStart:SectionDelimEnd:
C VarDelimStart)
C when %parms = 3
C eval ErrInds = GetHtmlIFSMult(IFSFile:
C SectionDelimStart:SectionDelimEnd)
C when %parms = 2
C eval ErrInds = GetHtmlIFSMult(IFSFile:
C SectionDelimStart)
C other
C eval ErrInds = GetHtmlIFSMult(IFSFile)
C endsl
C return
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P GetHtmlIFS e
******************************************************************
* GetHtmlIFSMult subprocedure
******************************************************************
* Loads arrays with HTML data from multiple IFS files.
* The arrays are subsequently used by wrtsection, etc.
* Inputs
* ------
* The IfsFiles parameter contains the names of the files. A blank
* signifies the end of a file's name. The following limitations
* apply:
* - Maximum length per file name: 255 bytes not counting the
* blank seperator
* - Maximum length of all the input file names, including any
* blank separators: 32767
* - Maximum number of file names: 127
* All the files must use the same section name delimiters
* and substitution variable delimiters.
* The optional sectionDelimStart parameter is used to override
* the default starting section delimiter of /$.
* The optional sectionDelimEnd parameter is used to override the
* default non-existent ending section delimiter.
*
* The optional varDelimStart parameter is used to override the default
* start variable delimiter of /%
* The optional varDelimEnd parameter is used to override the default
* end variable delimiter of %/
* Return value
* ------------
* GetHtmlIFSMult returns a data structure containing an array of six
* indicators that can be checked to find out if any errors occurred.
* The indicators and their meanings are:
* - NoErrors: *on = no error occurred
* *off = one or more errors. Check other indicators.
* - NameTooLong *on = one or file's name exceeds 255 characters.
* File is ignored.
* - NotAccessible *on = File or directory not found, authorization
* failure, etc. File is ignored.
* - NoFilesUsable *on = All the files have been ignored.
* - DupSections *on = One or more duplicate sections were found.
* Only the first occurrence is used.
* - FileIsEmpty *on = File is empty and is ignored.
P GetHtmlIFSMult b export
D GetHtmlIFSMult pi 6
D IfsFiles 32767 const varying options(*varsize)
D sectionDelim...
D Start 20 const varying options(*nopass)
D sectionDelim...
D End 20 const varying options(*nopass)
D varDelimStart 20 const varying options(*nopass)
D varDelimEnd 20 const varying options(*nopass)
D CurrFileCount s 10i 0
D IfsFilesIn s like(IfsFiles)
D TempFileName s 255 varying
* Error Indicators
D ErrInds ds
D NoErrors n
D NameTooLong n
D NotAccessible n
D NoFilesUsable n
D DupSections n
D FileIsEmpty n
* Bytes read from the IFS file
D BytesRead s 10i 0
* File Buffer
D FileBuffer s 32767 based(FileBufferP)
* Work Pointer
D WorkP s *
* Constants
D ThisSubProc c 'GetHtmlIfsMult: '
* Work variables
D f s 10i 0
D i s 10i 0
D j s 10i 0
D r s 10i 0
D s s 10i 0
D rc s 10i 0
D c1 s 1
D c2 s 1
D hex250d s 2 inz(x'250D')
* New Line Sequence
D NewLineSeq s 2 varying
D NewLineSeqLen s 10i 0
* Current file extension
D CurrFileExt s 255
* Stream file CCSID
D StmfCCSID s 5u 0
* Current job CCSID
D JobCCSID s 5u 0
* Variables for subprocedure CvtStg
D InpCodePage s 10u 0
D InpBufP s *
D InpBufLen s 10u 0
D OutCodePage s 10u 0
D OutBufP s *
D OutBufLen s 10u 0
D OutDtaLen s 10u 0
* For testing output from CvtStg
D TestInpData s 500 based(InpBufP)
D TestOutData s 500 based(OutBufP)
* If the current job CCSID is 65535, and data area CGIDEV2DT/SETJBCCSID contains '*YES',
* set the current job CCSID to its default CCSID value
C callp SetJobCCSID
* Initialize return indicator variables
C eval ErrInds = *all'0'
C eval NoErrors = *on
* Initialize CurrArr array and current file count
C clear CurrArr
C eval CurrFileCount = 0
* Parse first parameter and build CurrArr
* If a file is not usable, an appropriate message is
* sent to the debugging file and the file is not used.
C eval IfsFilesIn = %trim(IfsFiles) + ' '
C eval i = 1
C eval j = 1
C dow j > 0 and %len(IfsFilesIn) > 0
C eval j = %scan(' ':IfsFilesIn)
C if j = 0
C leave
C endif
C if j > 256
C eval NoErrors = *off
C eval NameTooLong = *on
C callp WrtDebug(ThisSubproc +
C 'IFS file name is ' +
C %trim(%editc(j-1:'Z')) + ' characters, -
C which exceeds the maximum length of 255. -
C File is being ignores. -
C File name is ' + %subst(IfsFilesIn:1:j-1) +
C '.':*on)
C eval IfsFilesIn =
C %triml(%subst(IfsFilesIn:j))
C iter
C endif
* Length of name is okay. Check file's status.
C eval TempFileName =
C %subst(IfsFilesIn:1:j-1)
C eval IfsFilesIn =
C %triml(%subst(IfsFilesIn:j))
C if stat(TempFileName:
C %addr(StatusBuffer)) = -1
C eval NoErrors = *off
C eval NotAccessible = *on
C callp wrtDebug(ThisSubproc +
C 'Could not access IFS file ' +
C TempFileName +
C '. File is being ignored. -
C Errno and text are: ' +
C %trim(%editc(errno:'N')) + ' ' +
C %trimr(ErrnoTxt(Errno)):*on)
C iter
C endif
* Make sure file is not empty.
C if StsBytesInFile = 0
C eval NoErrors = *off
C eval FileIsEmpty = *on
C callp WrtDebug(ThisSubproc +
C 'File ' +
C TempFileName +
C ' is empty. File is being ignored.':*on)
C iter
C endif
* File is okay. Add its name, timestamp, and number of bytes
* to the current arrays.
C eval CurrFileName(i) = TempFileName
C eval CurrTimeLastChg(i) = StsTimeLastChg
C eval CurrFileBytes(i) = StsBytesInFile
C eval CurrFileCount = CurrFileCount + 1
C eval j = 1
C eval i = i + 1
C enddo
* If we have at least one file left, continue. Otherwise, send
* message to debugging file.
C if CurrFileCount = 0
C eval NoErrors = *off
C eval NoFilesUsable = *on
C callp wrtDebug(ThisSubproc +
C 'None of the requested files -
C was usable. No files were -
C read and no externally described -
C HTML is available for output.':*on)
C return ErrInds
C endif
* If the previous set of files whose names and timestamps
* match the current set, and the previous request type
* was for IFS files, return. Otherwise, process all files.
C if CurrFileDs = PrevFileDs and
C LastReqType = LrtIfs
C callp wrtdebug(ThisSubProc + ' No -
C records read because none of the -
C requested files has changed. -
C Previously, ' +
C %trim(%editc(HtmlCount:'P')) +
C ' records were read.')
C return ErrInds
C endif
* Save this set of files
C eval PrevFileDs = CurrFileDs
* Set last request type to IFS file
C eval LastReqType = LrtIfs
* Initialize
C select
C when %parms = 5
C callp InitHTML(SectionDelimStart:
C SectionDelimEnd:
C VarDelimStart:
C VarDelimEnd)
C when %parms = 4
C callp InitHTML(SectionDelimStart:
C SectionDelimEnd:
C VarDelimStart)
C when %parms = 3
C callp InitHTML(SectionDelimStart:
C SectionDelimEnd)
C when %parms = 2
C callp InitHTML(SectionDelimStart)
C other
C callp InitHTML
C endsl
C
* Processing for each file through open...
C do currfilecount f
* Save file name and its starting HTML relative record number.
C eval SecFileName(f) = CurrFileName(f)
C eval SecFileRrn(f) = 0
* Get file's status in order to find out how many bytes are in it.
C eval rc = stat(CurrFileName(f):
C %addr(StatusBuffer))
* Retrieve the CCSID of the stream file
C eval StmfCCSID=RtvStmfCCSID(CurrFileName(f))
* Open file.
/free
if stmfCCSID<>1208; //not Unicode
CurrFileHandle(f)=open(CurrFileName(f):O_RDONLY + O_TEXTDATA);
else; //unicode
CurrFileHandle(f)=open(CurrFileName(f):O_RDONLY);
endif;
/end-free
C if CurrFileHandle(f) = -1
C callp wrtdebug(ThisSubProc + ' Could -
C not open file ' + CurrFileName(f) +
C ' File system reported the following -
C error: ' + errnotxt(errno):*on)
C eval NoErrors = *off
C eval NotAccessible = *on
C endif
C enddo
* If any errors, return
C if not NoErrors
C return ErrInds
C endif
* Process each file's contents
C do currfilecount f
C eval SecFileRRN(f) = htmlcount + 1
* Find current file extension, save it in field CurrFileExt
C eval CurrFileExt=' '
C eval s=1
C eval r=1
C dow r>0
C eval r=%scan('.':CurrFileName(f):s)
C if r>0
C eval CurrFileExt=%subst(CurrFileName(f):r+1)
C eval s=r+1
C endif
C enddo
C eval CurrFileExt=uppify(CurrFileExt)
C
* Read the file into dynamically allocated storage
C eval i = CurrFileBytes(f) + 32769
C alloc i FileBufferP
C eval bytesread = read(CurrFileHandle(f):
C FileBufferP:CurrFileBytes(f))
C
* If the stream file CCSID is Unicode, convert the file data to the job CCSID
/free
if stmfCCSID=1208; //Unicode
// 1-Retrieve the job CCSID
jobCCSID=rtvJobCCSID();
// 2-Set parameters to call subprocedure CvtStg
inpCodePage=stmfCCSID;
inpBufP=FileBufferP;
inpBufLen=CurrFileBytes(f);
outBufP=FileBufferP;
outCodePage=jobCCSID;
outBufLen=CurrFileBytes(f)+32767;
// 3-Convert string, from UNICODE to job CCSID, over itself
cvtStg(inpCodePage:inpBufP:inpBufLen:
outCodePage:outBufP:outBufLen:
outDtaLen); // perform conversion from Unicode
// 4-Update data saved in arrays
CurrFileBytes(f)=outDtaLen; // adjust file data length
endif;
/end-free
C
* Determine what is being used to define a new line. It is
* usually x'0D25', but could be x'250D', x'25', x'0D'
* Find first x'0d' or x'25'. Then examine next character to
* determine what the end of line sequence is.
C eval i = 1
C dou %scan(c1:hex250D) > 0
C eval c1 = %subst(FileBuffer:i:1)
C eval i = i + 1
C enddo
C eval c2 = %subst(FileBuffer:i:1)
C
C select
C when c1 = x'0D' and c2 = x'25'
C eval NewLineSeq = x'0D25'
C when c2 = x'0D' and c1 = x'25'
C eval NewLineSeq = x'250D'
C when c1 = x'0D'
C eval NewLineSeq = x'0D'
C when c1 = x'25'
C eval NewLineSeq = x'25'
C endsl
C eval NewLineSeqLen = %len(NewLineSeq)
* Add an additional newline to end of file
C eval WorkP = FileBufferP
C eval FileBufferP = FileBufferP + CurrFileBytes(f)
C eval %subst(FileBuffer:1:%len(NewLineSeq)) =
C NewLineSeq
C eval FileBufferP = Workp
* Build records
C eval i = 1
C DOW FileBufferP - WorkP < CurrFileBytes(f)
C eval i = %scan(NewLineSeq:FileBuffer)
C IF i > 0
C if %subst(CurrFileExt:1:3)='HTM' or
C CurrFileExt='TEXT' or
C CurrFileExt='TXT' or
C CurrFileExt='CGI' or
C CurrFileExt='JSP' or
C %subst(FileBuffer:1:i-1)=' '
C callp addhrec(%trimr(%subst(FileBuffer:1:i-1)))
C else
C callp addhrec(%subst(FileBuffer:1:i-1))
C endif
C eval FileBufferP = FileBufferP + i +
C + NewLineSeqLen - 1
C eval i = 1
C ELSE
C leave
C ENDIF
C ENDDO
* Deallocate storage
C eval FileBufferP = WorkP
C dealloc FileBufferP
* Close file
C eval rc = close(CurrFileHandle(f))
C enddo
* All available IFS HTML files have been read.
* Tell debugging file how many records were read.
C callp wrtdebug(ThisSubproc +
C %trim(%editc(HtmlCount:'P')) +
C ' records read.')
* Set up section arrays and substitution variables arrays
C callp SetUpArrays(ThisSubProc:
C NoErrors:DupSections)
C return ErrInds
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P GetHtmlIFSMult e
******************************************************************
* RtvHtmlRcd subprocedure
******************************************************************
* Retrieves a single record from the externally described HTML
* Parameters
* - Section name (input). If *NONE, gets record by relative
* record number regardless of section.
* - Relative record number (absolute or by section) (input)
* - Return code (output)
* 0 = record found and returned
* -1 = section not found
* -2 = record not found
* -3 = record part of a duplicate section
* Returns
* - If not found (less than 1 or greater than number of records
* read), or part of a duplicate section: a null field,
* - Otherwise, the record's contents.
P RtvHtmlRcd b export
D RtvHtmlRcd pi 32767 varying
D Section 50 const
D RelRcd 10i 0 const
D RetCode 10i 0
* Return codes
D RecordFound c 0
D SectionNotFound...
D c -1
D RecordNotFound c -2
D DuplicateRecord...
D c -3
D h1 s 10i 0 inz(1)
D h2 s 10i 0 inz(1)
D HtmlWindow s 32767 varying based(HtmlWindowP)
D WkSection s 50
C eval RetCode = RecordFound
C eval WkSection = Uppify(section)
* Handle request with section name = *NONE
C if WkSection = '*NONE'
C if RelRcd <1 or RelRcd > HtmlCount
C eval RetCode = RecordNotFound
C return ''
C endif
C eval h1 = SecFirst
C eval RetCode = DuplicateRecord
C dow h1 <= seccnt
C if SecEnd(h1) = 0 or
C (RelRcd >= SecStart(h1) - 1 and
C RelRcd <= SecEnd(h1))
C eval RetCode = RecordFound
C leave
C endif
C eval h1 = h1 + 1
C enddo
C if RetCode = RecordFound
C eval HtmlWindowP = HtmlP + HtmlOfs(RelRcd)
C return HtmlWindow
C else
C return ''
C endif
C endif
C
* Handle request with section name
C eval h1 = SecFirst
C WkSection lookup secname(h1) 99
C if not *in99 Section not found
C eval RetCode = SectionNotFound
C return ''
C endif
C if secend(h1) = 0 or
C relrcd < 1 or
C relrcd >
C secend(h1) - secstart(h1) + 1
C eval RetCode = RecordNotFound
C return ''
C endif
* Set up addressability to place in HTML stream where current
* record is and copy it into wk.
C eval h2 = secstart(h1) + RelRcd - 1
C eval HtmlWindowP = HtmlP + HtmlOfs(h2)
C return HtmlWindow
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P RtvHtmlRcd e
******************************************************************
* RtvSubsVarInfo subprocedure
******************************************************************
* Retrieves information about substitution variables
* Parameters
* - Section name (input). If *NONE, gets information by
* sequence number regardless of section.
* - Relative sequence number (absolute or by section) (input)
* - Data structure containing the following (output)
* - Section name
* - Character 50 varying
* - Null if return code not 0
* - Variable name
* - Character 30 varying
* - null if return code not 0
* - Variable's starting position in the html record
* - 10 digit unsigned
* - 0 if return code not 0
* - Length of variable's name (output)
* - 10 digit unsigned
* - 0 if return code not 0
* Returns
* - Return code (output)
* - 10-digit signed integer
* 0 = Substitution variable found and returned
* -1 = section not found
* -2 = Sequence number out of range for section or
* for list of all substitution variables
P RtvSubsVarInfo b export
D RtvSubsVarInfo pi 10i 0
D SectionIn 50 const
D RelSeqNo 10i 0 const
D ReturnDS 92
* Return codes
D VarFound c 0
D SectionNotFound...
D c -1
D OutOfRange c -2
* Return structure
D RetDS ds based(RetDSP)
D RetSection 50 varying
D RetVar 30 varying
D RetStartPos 10u 0
D RetLen 10u 0
D i s 10i 0
D j s 10i 0
D WkSection s 50
* Initialize
C eval RetDSP = %Addr(ReturnDS)
C eval RetSection = ''
C eval RetVar = ''
C eval RetStartPos = 0
C eval RetLen = 0
C eval WkSection = Uppify(SectionIn)
* Handle request with section name = *NONE
C if WkSection = '*NONE'
C if RelSeqNo < 1 or RelSeqNo > SubsCount
C return OutOfRange
C endif
C eval RetSection = %trim(SubsSection(RelSeqNo))
C eval RetVar = %trim(SubsVarName(RelSeqNo))
C eval RetStartPos = SubsStartPos(RelSeqNo)
C eval RetLen = SubsVarLen(RelSeqNo)
C return VarFound
C endif
* Handle request with section name
* Find first entry that matches the input section name. Will
* come out at end of for loop if not found. Otherwise,
* will return to caller before completing the for loop.
C do subscount i
* If find a matching section name, calculate index to
* desired entry. If it is higher than the number of
* entries, return OutOfRange. Otherwise, if the
* section name of the calculated entry does not match
* the requested section name, return OutOfRange.
* Otherwise, return the entry's values and return VarFound.
C if SubsSection(i) = WkSection
C eval j = i - 1 + RelSeqNo
C if j > SubsCount
C return OutOfRange
C endif
C if SubsSection(j) <> WkSection
C return OutOfRange
C endif
C eval RetSection = %trim(SubsSection(j))
C eval RetVar = %trim(SubsVarName(j))
C eval RetStartPos = SubsStartPos(j)
C eval RetLen = SubsVarLen(j)
C return VarFound
C endif
C enddo
* Finished for loop without finding section
C return SectionNotFound
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P RtvSubsVarInfo e
******************************************************************
* UpdHTMLvar subprocedure
******************************************************************
* Updates arrays containing variable names and values
* Inputs
* - variable name
* - variable value
* - action (optional)
* - '1' = replace this variable if it exists, otherwise add it (default)
* - '0' = clear arrays and write this one as the first
* - trim instructions (optional)
* - %trim - trim left and right (default)
* - %triml - trim left only
* - %trimr - trim right only
* - %trim0 - don't trim
P updHTMLvar b export
D updHTMLvar pi
D name 30 const varying options(*varsize)
D value 1000 const varying options(*varsize)
D action 1 value options(*nopass)
D trim 6 value varying options(*nopass)
D name2 s 30 varying
D value2 s 1000 varying
D trimx s like(trim)
D actionx s like(action)
D init c '0'
D next c '1'
/free
// If fourth variable not passed, set trimx to %trim
if %parms < 4;
trimx = '%trim';
else;
trimx = trim;
endif;
// If third variable not passed, set actionx to next
if %parms < 3;
actionx = next;
else;
actionx = action;
endif;
// Move const variable, name, to local variable, name2
name2 = name;
// Assign input value to local variable, value2 with trim if requested.
value2 = value;
// Call UpdHTMLVar2 to write the variable
UpdHtmlVar2(name2:%addr(value2)+2:%len(value2):actionx:trimx);
return;
//*******************************************************************
// Program status subroutine
//*******************************************************************
begsr *pssr;
// Program status subroutine
wrtpsds(psds);
endsr;
/end-free
PupdHTMLvar e
******************************************************************
* UpdHTMLvar2 subprocedure
******************************************************************
* Updates arrays containing variable names and pointers and
* the dynamic storage pointed to by the pointers
* Inputs
* - variable's name
* - variable's address (pointer)
* - variable's length
* - maximum is 16 MB
* - action (optional)
* - '1' = replace this variable in the arrays if it is already
* there. Otherwise add it to the arrays (default).
* - '0' = clear arrays and write variable as the first element.
* - trim instructions (optional)
* - %trim - trim left and right (default)
* - %triml - trim left only
* - %trimr - trim right only
* - %trim0 - don't trim
* - '1' = replace this variable if it exists, otherwise add it (default)
* - '0' = clear arrays and write this one as the first
P updHTMLvar2 b export
D updHTMLvar2 pi
D name 30 value varying
D address * value
D length 10i 0 value
D action 1 value options(*nopass)
D trim 6 value varying options(*nopass)
D init c '0'
D next c '1'
D actionx s like(action)
D trimx s like(trim)
D i s 10u 0
D c1 s 1 based(address)
D c2 s 1 based(address2)
/free
// If fifth variable not passed, set trimx to %trim
if %parms < 5;
trimx = '%trim';
else;
trimx = trim;
endif;
// If fourth variable not passed, set actionx to next
if %parms < 4;
actionx = next;
else;
actionx = action;
endif;
// Handle initialization
if actionx= init and varallocated > 0;
varcurrent = 0;
endif;
// Handle initial allocation, if neccessary
if varallocated = 0;
varallocated = varinit;
varbytes = %size(varstuff) * varallocated;
varPtr = %alloc(varbytes);
for i = 1 to varallocated;
varnm(i)='';
varP(i) = *null;
varlen(i) = 0;
endfor;
endif;
// Handle reallocation if necessary
if varcurrent = varallocated;
varallocated = varallocated + varaddl;
varbytes = %size(varstuff) * varallocated;
varPtr = %realloc(varPtr:varbytes);
for i = varcurrent + 1 to varallocated;
varnm(i)='';
varP(i) = *null;
varlen(i) = 0;
endfor;
endif;
// Uppify the name
name = uppify(name);
// Calculate array element to use and assign it to i
select;
// When actionx is init, add this variable to the arrays. The arrays
// have already been initialized.
when actionx = init;
varcurrent = varcurrent + 1;
i = varcurrent;
// When actionx is next, replace variable if it is already there, otherwise add it.
when actionx = next;
i = %lookup(name:varnm:1:varcurrent);
if i = 0;
varcurrent = varcurrent + 1;
eval i = varcurrent;
endif;
endsl;
// Handle any trimming
if length > 0 and trimx <> '%trim0';
address2 = address + length - 1;
if trimx = '%trimr' or trimx = '%trim';
dow address2 > address and c2 = *blanks;
address2 = address2 - 1;
enddo;
endif;
if trimx = '%triml' or trimx = '%trim';
dow address < address2 and c1 = *blanks;
address = address + 1;
enddo;
endif;
length = address2 - address + 1;
if length = 1 and c1 = ' ';
eval length = 0;
endif;
endif;
// allocate or reallocate this variable's pointer, as required.
select;
when varP(i) = *null and length < 1;
when varP(i) = *null and length > 0;
varP(i) = %alloc(length);
when varlen(i) < length;
varp(i) = %realloc(varp(i):length);
endsl;
// Write the name
varnm(i) = name;
//Write the length
varlen(i) = length;
// Write the data
if length > 0;
memcpy(varP(i):address:length);
endif;
return;
//*******************************************************************
// Program status subroutine
//*******************************************************************
begsr *pssr;
// Program status subroutine
wrtpsds(psds);
endsr;
/end-free
PupdHTMLvar2 e
******************************************************************
* WrtHTMLToStmfX subprocedure
* (This was the original procedure WrtHtmlToStmf(), now renamed to WrtHtmlStmfX()
******************************************************************
* The contents of the HTML buffer are written to Stmf.
* If the CodePage parameter is passed, it is used in
* writing the streamfile. Otherwise, the codepage used is
* determined by the system.
* The return value is the C errno if an error was detected.
* Otherwise, it is 0
* Writes HTML stored in OutBuff to a stream file.
* Resets OutBuff by logically emptying it.
PWrtHTMLToStmfX b export
DWrtHTMLToStmfX pi 10i 0
D Stmf 1024 const varying
D CodePage 10u 0 const options(*nopass)
D FileHandle s 10i 0
D rc s 10i 0
D i s 10i 0
D NewLine c x'15'
D StmfTemp s 1024 varying
D ErrNoRet s 10i 0
D TempBuff s 2 based(TempBuffP)
D TempBuffAlloc s 10i 0
D TempBuffPSave s *
D TempBuffUsed s 10i 0
D C s 1 based(OutBuffNextP)
D cmd s 1024
D NewObj s 1024 varying
D r s 10i 0
D s s 10i 0
* Constants
D ThisSubProc c 'WrtHtmlToStmf: '
D callerPgmLib ds
D callerPgm 10
D callerLib 10
* Set up temporary file name. File will be created with
* this file name, then the real file will be unlinked and
* the new one linked with the real file's name.
* This is done to allow us to create the new file while
* users are still accessing the existing file. Unlinking
* then removes the link. The unlinked file is destroyed
* by the system when the link count is 0 and no one has it
* open. After removing the link, we assign the existing
* name to the new file with the link API and remove the
* temporary name with the unlink API.
C eval StmfTemp = Stmf + 'TEMP' + psdsjobnbr
* Unlink (Delete) temporary file if it already exists.
C dow stat(%trim(StmFTemp):
C %addr(StatusBuffer)) = 0
C eval rc = docmd('del ''' + StmFTemp + '''') Giovanni 2012-11-09
C**************===> eval rc = unlink(StmfTemp) <===*******************Giovanni 2012-11-09
C enddo
C
* Open and close temporary file StmfTemp to create it. Use CCSID if it was supplied.
* Otherwise, let the system determine what CCSID to use.
* NOTES.
* - O_CCSID used instead of O_CODEPAGE to support
* UTF-8 (CCSID 1208),
* UTF-16 (CCSID 1200), and
* UCS-2 (CCSID 13488)
* - O_LARGEFILE enables support for files larger than 2gb
* - O_INHERITMODE creates the file with the same data authorities as the parent directory
* that the file is created in.
C if %parms = 2
C eval FileHandle = open(
C StmfTemp:
C O_CREAT + O_WRONLY + O_INHERITMODE +
C O_CCSID +
C O_LARGEFILE:
C S_IRUSR+S_IWUSR+S_IRGRP+S_IWGRP+S_IROTH:
C CodePage)
C else
C eval FileHandle = open(
C StmfTemp:
C O_CREAT + O_WRONLY + O_INHERITMODE +
C O_LARGEFILE:
C S_IRUSR+S_IWUSR+S_IRGRP+S_IWGRP+S_IROTH)
C endif
C if FileHandle = -1
C eval ErrNoRet = errno
C callp WrtDebug(ThisSubProc + 'Open of IFS file ' +
C StmfTemp + ' failed. Message text is ' +
C errnotxt(ErrNoRet):*on)
C return ErrNoRet
C endif
C eval rc = close(FileHandle)
C if rc = -1
C eval ErrNoRet = errno
C callp WrtDebug(ThisSubProc + 'Close of IFS -
C file ' + Stmf + ' failed. Message text -
C is ' + errnotxt(ErrNoRet):*on)
C return ErrNoRet
C endif
* Open the temporary stream file for output
* NOTES.
* - The fourth parameter is related to the CCSID to translate *FROM*;
* value 0 means "the current job's CCSID"
C eval FileHandle = open(
C StmfTemp:
C O_CREAT + O_WRONLY +
C O_CCSID + O_TEXTDATA +
C O_LARGEFILE:
C 0:
C 0)
C if FileHandle = -1
C eval ErrNoRet = errno
C callp WrtDebug(ThisSubProc + 'Open of IFS file ' +
C Stmf + ' failed. Message text is ' +
C errnotxt(ErrNoRet):*on)
C return ErrNoRet
C endif
* Allocate temporary storage TempBuff to receive the CGI output stream (buffer) with
* X'15's replaced by x'0D25's
C eval TempBuffAlloc = OutBuffAlloc + 53000
C if TempBuffP = *null
C eval TempBuffP = Ts_Malloc(TempBuffAlloc)
C else
C eval TempBuffP = Ts_Realloc(TempBuffP:
C TempBuffAlloc)
C endif
C eval TempBuffPSave = TempBuffP
* Loop through output buffer, writing one byte at a time
* to the temporary buffer TempBuff, replacing x'15's with x'0D25's
C eval OutBuffNextP = OutBuffP
C for i = 1 to OutBuffUsed
C if c = newline
C eval TempBuff = x'0D25'
C eval TempBuffUsed = TempBuffUsed + 2
C eval TempBuffP = TempBuffP + 2
C else
C eval TempBuff = C
C eval TempBuffUsed = TempBuffUsed + 1
C eval TempBuffP = TempBuffP + 1
C endif
C eval OutBuffNextP += 1
C endfor
* Write the temporary buffer TempBuff to the streamfile StmfTemp (previously opened)
C eval TempBuffP = TempBuffPSave
C eval rc = write(FileHandle:
C TempBuffP:TempBuffUsed)
C if rc = -1
C eval ErrNoRet = errno
C callp WrtDebug(ThisSubProc + 'Write into IFS -
C file ' + StmfTemp + ' failed. Message text -
C is ' + errnotxt(ErrNoRet):*on)
C callp ClrHTmlBuffer Giovanni 2016-12-21
C return ErrNoRet
C endif
* Close streamfile Stmftemp
C eval rc = close(FileHandle)
C if rc = -1
C eval ErrNoRet = errno
C callp WrtDebug(ThisSubProc + 'Close of IFS -
C file ' + StmfTemp + ' failed. -
C Message text is ' + errnotxt(ErrNoRet):*on)
C callp ClrHTmlBuffer Giovanni 2016-12-21
* Change IFS obj authorities
/free
rc=DoCmd('CHGAUT OBJ(''' + %trim(StmfTemp) + ''') +
USER(*PUBLIC) DTAAUT(*RX) OBJAUT(*ALL)');
/end-free
C return ErrNoRet
C endif
*==========================================================================
* NEW CODE APPLIED to support also the output stream file Stmf Giovanni 2012-11-09
* in the QNTC subsystem instead of the IFS one Giovanni 2012-11-09
* Giovanni 2012-11-09
* Delete stream file Stmf if already existing Giovanni 2012-11-09
/free
if ChkIfsObj4(Stmf); //Giovanni 2012-11-09
rc=docmd('del ''' + Stmf + ''''); //Giovanni 2012-11-09
if rc<>0; //the stream file exists //Giovanni 2012-11-09
ErrNoRet = errno;
//release the memory allocated for the temporary buffer Giovanni 2012-11-09
dealloc(n) TempBuffP; //Giovanni 2012-11-09
//delete stream file Stmf; Giovanni 2012-11-09
rc=docmd('del ''' + Stmf + ''''); //Giovanni 2012-11-09
//if stream file Stmf cannot be deleted, ... //Giovanni 2012-11-09
if rc<>0; //Giovanni 2012-11-09
WrtDebug(ThisSubProc + 'Stream file ' + Stmf +
'cannot be deleted. WrtHtmlToStmf gives up.'); //Giovanni 2012-11-09
ClrHtmlBuffer(); //Giovanni 2016-12-21
return ErrNoRet; //Giovanni 2012-11-09
endif; //Giovanni 2012-11-09
endif; //Giovanni 2012-11-09
endif; //Giovanni 2012-11-09
//build "newObj" (stream file name without path) from Stmf Giovanni 2012-11-09
r=1;
s=1;
dow r>0;
r=%scan('/':Stmf:s);
if r>0;
s=r+1;
endif;
enddo;
NewObj=%subst(Stmf:s);
rc=DoCmd('CHGAUT OBJ(''' + %trim(StmfTemp) + ''') +
USER(*PUBLIC) DTAAUT(*RX) OBJAUT(*ALL)');
//rename stream file StmfTemp as Stmf Giovanni 2012-11-09
cmd='REN OBJ(''' + StmfTemp + ''') NEWOBJ(''' + NewObj + ''')'; //Giovanni 2012-11-09
rc=docmd(cmd); //Giovanni 2012-11-09
if rc<>0; //Giovanni 2012-11-09
WrtDebug(ThisSubProc + 'Temporary IFS stream file ' +
StmfTemp + 'failed to be renamed as ' + Stmf +
'. WrtHtmlToStmf gives up.'); //Giovanni 2012-11-09
errnoRet=errno;
ClrHTmlBuffer(); //Giovanni 2016-12-21
return errNoRet; //Giovanni 2012-11-09
endif;
//return 0; removed by Giovanni 2016-11-04
/end-free
*=================================== start of old code ================== Giovanni 2012-11-09
*THE FOLLOWING IS THE PREVIOUS VERSION OF THE NEW CODE ABOVE Giovanni 2012-11-09
* Unlink existing streamfile |
C* eval rc = unlink(Stmf) |
* Link new streamfile |
* Note - The link() function provides an alternative path name for the existing file, |
* so that the file can be accessed by either the existing name or the new name. |
C* eval rc = link(StmfTemp:Stmf) V
C* if rc = -1 |
C* eval ErrNoRet = errno |
C* callp WrtDebug(ThisSubProc + 'Link of new IFS - |
C* file ' + Stmf + ' failed. Message text - |
C* is ' + errnotxt(ErrNoRet):*on) |
C* return ErrNoRet |
C* endif |
* Unlink temporary file name |
C* eval rc = unlink(StmfTemp) |
C* if rc = -1 |
C* eval ErrNoRet = errno |
C* callp WrtDebug(ThisSubProc + 'Unlink of - |
C* temporary IFS file' + |
C* Stmf + ' failed. Message text - V
C* is ' + errnotxt(ErrNoRet):*on) |
C* return ErrNoRet |
C* endif |
*=================================== end of old code ==================== Giovanni 2012-11-09
* Write message "successful completion"
C eval callerPgmLib = RtvPgmStack(2)
C callp WrtDebug(ThisSubProc + 'Pgm ' +
C %trim(callerlib) + '/' +
C %trim(callerpgm) +
C ' in job ' +
C %trim(%subst(psdsdata:264:6)) + '/' +
C %trim(%subst(psdsdata:254:10)) + '/' +
C %trim(%subst(psdsdata:244:10)) +
C ' wrote ' +
C %trim(%editc(TempBuffUsed:'1')) +
C ' bytes into IFS file ' +
C Stmf + '.':*on)
* Reset buffers
C if OutBuffUsed > OutBuffAllocInit
C eval OutBuffAlloc = OutBuffAllocInit
C eval OutBuffP = Ts_Realloc(OutBuffP:
C OutBuffAlloc)
C endif
C eval OutBuffUsed = 0
C eval OutBuffNextP = OutBuffP
C
C eval TempBuffUsed = 0
C callp TS_Free(TemPBuffP)
* Added by Giovanni on March 25, 2011
C callp ClrHtmlBuffer
* Return
C return ErrNoRet
******************************************************************
C *pssr begsr
******************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C return -1
C endsr
PWrtHTMLToStmfX e
*=========================================================================
* Subprocedure WrtHtmlToStmF: Writes HTML to stream file
* (Includes support for UTF CCSID: 1200 to 1237)
* _ This is a NEW procedure written on March 18, 2018
* - calls original procedure WrtHtmlStmfX
* - if needed, uses command CGIDEV2/STMFCVT to convert the output to UTF
*==================
* - The contents of the HTML buffer are written to a temporary stream file
* (in directory /tmp) with the default job CCSID
* - Command CGIDEV2/STMFCVT is used to convert the temporary stream file
* to the requested stream file
* - the temporary stream file is deleted
* The return value is the C errno if an error was detected.
* Otherwise, it is 0
P WrtHTMLToStmf b export
D WrtHtmlToStmf pi 10i 0
D Stmf 1024 const varying
D xStmfCCSID 10u 0 const options(*nopass)
D StmfCCSID s 10u 0
D outBuffUsed s 10i 0
D stmfExt s 50
D random30 s 30
D tempname s 100
D tempStmf s 1024 varying
D objFoundInd s n
D cmd s 2000
D rc s 10i 0
D l s 10i 0
D r s 10i 0
D s s 10i 0
/copy CGIDEV2/qrpglesrc,JOBI0400
/free
//Fix requested stmf CCSID, if missing
if %parms<2;
StmfCCSID=819;
else;
StmfCCSID=xStmfCCSID;
endif;
//If the CCSID of the output stream file is not an UTF CCSID, switch to WrtHtmlToStmf()
if stmfCCSID<1200 or stmfCCSID>1237;
rc=WrtHtmlToStmfX(Stmf:stmfCCSID);
return rc;
endif;
//Retrieve the size of the output HTML
outBuffUsed=GetHtmlBytesBuffered();
//Retrieve the job default CCSID into variable "jiDftCCSID" of data structure JOBI0400
JOBI0400=RtvJobI();
//Retrieve the extension of the output stmf into variable "stmfExt"
clear stmfExt;
l=%len(Stmf);
r=1;
s=1;
dow r>0;
r=%scan('.':Stmf:s);
if r>0;
s=r+1;
if s>=l;
leave;
endif;
stmfExt=%subst(Stmf:s);
endif;
enddo;
// Create a name ("tempStmf") for the temporary stream file
objFoundInd=*on;
dow objFoundInd=*on;
random30=randomString(30:'*mixedLetter':'*mixedDigit');
tempname='/tmp/'+random30;
if stmfExt<>' ';
tempname=%trim(tempname)+'.'+%trim(stmfext);
endif;
objFoundInd=ChkIfsObj4(%trim(tempname));
enddo;
tempStmf=%trim(tempname);
// Write the HTML buffer to this temporary stream file, with the job default CCSID
rc=wrtHtmlToStmfX(tempStmf:jiDftCCSID); // calls the original WrtHtmlStmf() procedure
if rc<>0; //if failed, ...
return rc;
endif;
rc=DoCmd('CHGAUT OBJ(''' + %trim(tempstmf) + ''') +
USER(*PUBLIC) DTAAUT(*RX) OBJAUT(*ALL)');
// Clear the HTML buffer
ClrHtmlBuffer();
// Use command CGIDEV2/STMFCVT to copy+convert the temporary stmf to the desired stmf
cmd='CGIDEV2/STMFCVT SRCSTMF(''' + %trim(tempStmf) + ''') +
TGTSTMF(''' + %trim(Stmf) + ''') +
TGTCODEPAG(' + %trim(%editc(stmfCCSID:'3')) + ') +
DSPTGT(*NO)';
rc=doCmd(cmd);
if rc=0; //success!
rc=doCmd('del ''' + %trim(tempStmf) + ''''); // delete the temporary stream file
return 0;
endif;
// As command CGIDEV2/STMFCVT failed, copy the temporary stream file
// to the desired stream file, converting it to CCSID 819
cmd='CPY OBJ(''' + %trim(tempStmf) + ''') +
TOOBJ(''' + %trim(Stmf) + ''') +
TOCCSID(819) REPLACE(*YES)';
rc=doCmd(cmd);
if rc=0;
rc=doCmd('del ''' + %trim(tempStmf) + ''''); // delete the temporary stream file
return -1;
else;
rc=doCmd('del ''' + %trim(tempStmf) + ''''); // delete the temporary stream file
return -2;
endif;
//==================
Begsr *pssr;
wrtpsds(psds);
return -1;
Endsr;
/end-free
P WrtHTMLToStmf e
******************************************************************
* AppHTMLToStmf subprocedure
******************************************************************
* The contents of the HTML buffer are appended to Stmf.
* The return value is the C errno if an error was detected.
* Otherwise, it is 0
* Appends HTML stored in OutBuff to a stream file.
* Resets OutBuff by logically emptying it.
P AppHTMLToStmf b export
D AppHTMLToStmf pi 10i 0
D Stmf 1024 const varying
D stmfType s 11 varying
D stmfSize s 10i 0
D stmfStamp s z
D stmfCodePage s 5u 0
D stmfCCSID s 5u 0
D jobCCSID s 5u 0
D FileHandle s 10i 0
D rc s 10i 0
D i s 10i 0
D NewLine c x'15'
D StmfTemp s 1024 varying
D ErrNoRet s 10i 0
D TempBuff s 2 based(TempBuffP)
D TempBuffAlloc s 10i 0
D TempBuffPSave s *
D TempBuffUsed s 10i 0
D C s 1 based(OutBuffNextP)
D chkifsobject s 512
* Constants
D ThisSubProc c 'AppHtmlToStmf: '
D callerPgmLib ds
D callerPgm 10
D callerLib 10
* Check the stream file
/free
if not chkifsobj3(Stmf:stmfType:stmfSize:stmfStamp:
stmfCodePage:stmfCCSID);
WrtDebug(ThisSubProc + 'Stream file ' + Stmf +
' not found or not accessible':*on);
rc=-1;
return rc;
endif;
//Retrieve job CCSID
jobCCSID=rtvJobCCSID();
//Open the streamfile
FileHandle = open(Stmf:O_RDWR + O_APPEND + O_TEXTDATA +
O_CCSID +
O_LARGEFILE:
S_IRUSR+S_IWUSR+S_IRGRP+S_IWGRP+S_IROTH:
jobCCSID);
if FileHandle = -1;
ErrNoRet = errno;
WrtDebug(ThisSubProc + 'Open of IFS file ' + Stmf +
' failed. Message text is ' +
errnotxt(ErrNoRet):*on);
return ErrNoRet;
endif;
/end-free
* Allocate temporary storage to receive output stream with
* X'15's replaced by x'0D25's
C eval TempBuffAlloc = OutBuffAlloc + 53000
C if TempBuffP = *null
C eval TempBuffP = Ts_Malloc(TempBuffAlloc)
C else
C eval TempBuffP = Ts_Realloc(TempBuffP:
C TempBuffAlloc)
C endif
C eval TempBuffPSave = TempBuffP
* Loop through output buffer, writing one byte at a time
* to the temporary buffer, replacing x'15's with x'0D25's
C eval OutBuffNextP = OutBuffP
C for i = 1 to OutBuffUsed
C if c = newline
C eval TempBuff = x'0D25'
C eval TempBuffUsed = TempBuffUsed + 2
C eval TempBuffP = TempBuffP + 2
C else
C eval TempBuff = C
C eval TempBuffUsed = TempBuffUsed + 1
C eval TempBuffP = TempBuffP + 1
C endif
C eval OutBuffNextP += 1
C endfor
* Write temporary buffer to the streamfile
C eval TempBuffP = TempBuffPSave
C eval rc = write(FileHandle:
C TempBuffP:TempBuffUsed)
C if rc = -1
C eval ErrNoRet = errno
C callp WrtDebug(ThisSubProc + 'Write into IFS -
C file ' + StmfTemp + ' failed. Message text -
C is ' + errnotxt(ErrNoRet):*on)
C return ErrNoRet
C endif
* Close streamfile
C eval rc = close(FileHandle)
C if rc = -1
C eval ErrNoRet = errno
C callp WrtDebug(ThisSubProc + 'Close of IFS -
C file ' + Stmf + ' failed. -
C Message text is ' + errnotxt(ErrNoRet):*on)
C return ErrNoRet
C endif
* Write message
C eval callerPgmLib = RtvPgmStack(2)
C callp WrtDebug(ThisSubProc + 'Pgm ' +
C %trim(callerlib) + '/' +
C %trim(callerpgm) +
C ' in job ' +
C %trim(%subst(psdsdata:264:6)) + '/' +
C %trim(%subst(psdsdata:254:10)) + '/' +
C %trim(%subst(psdsdata:244:10)) +
C ' appended ' +
C %trim(%editc(TempBuffUsed:'1')) +
C ' bytes to IFS file ' +
C Stmf + '.':*on)
* Reset buffers
C if OutBuffUsed > OutBuffAllocInit
C eval OutBuffAlloc = OutBuffAllocInit
C eval OutBuffP = Ts_Realloc(OutBuffP:
C OutBuffAlloc)
C endif
C eval OutBuffUsed = 0
C eval OutBuffNextP = OutBuffP
C
C eval TempBuffUsed = 0
C callp TS_Free(TemPBuffP)
*
C callp ClrHtmlBuffer
* Return
C return ErrNoRet
******************************************************************
C *pssr begsr
******************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P AppHTMLToStmf e
******************************************************************
* WrtNoSection subprocedure
******************************************************************
* Writes data for the browser without using substitution variables
* or sections.
* This subprocedure can be used when a large block of data is to
* written. This is more likely to happen when writing non-textual
* data such as images.
*
* DataP is a pointer to the storage containing the data to be written.
* DataLength is the number of bytes to be written, starting at that
* location.
*
* Examples
* callp WrtNoSection(%addr(MyBuffer):MyBufferLength)
* callp WrtNoSection(MyPointer:MyBufferLength)
P WrtNoSection b export
D WrtNoSection pi
D DataP * const
D DataLength 10i 0 const
D WkP s *
* Constants
D ThisSubProc c 'WrtNoSection: '
* Initialize HTML buffer if not already done
C if OutBuffP = *null
C callp InitHtml
C endif
* If data length is less than or equal to 0 or pointer is null,
* write error message(s) to debugging file and return
C if DataLength <= 0 or
C DataP = *null
C if DataLength <= 0
C callp WrtDebug(ThisSubProc + 'Wrote no data. -
C Data length was ' +
C %trim(%editc(DataLength:'N')):*on)
C endif
C if DataP = *null
C callp WrtDebug(ThisSubProc + 'Wrote no data. -
C Pointer was *null':*on)
C endif
C return
C endif
* Write
C callp StdOut(DataP:DataLength)
C return
******************************************************************
C *pssr begsr
******************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P WrtNoSection e
******************************************************************
* wrtsection subprocedure
******************************************************************
* Writes one or more sections to the browser
*
* Parameters
* ----------
* Sections.
* - One or more section names.
* - If more than one, separate them with one or more blanks.
*
* NoNewLine:
* - If not passed, wrtsection assumes *off
* _ *off: wrtsection inserts (a newline character, x'15'), at the
* end of each html output line.
* - *on: causes each output html line to be written without a newline
* character being inserted. This is useful when binary data are
* being sent to the browser.
*
* NoDataString
* - What to do when a substitution variable is encountered and no
* value has been set up with UpdHtmlVar.
* - If not passed, uses the default value **Missing Data**
* - Otherwise, uses the value passed.
*
* Examples (using free form syntax)
* --------
* Write sections a, b, and c with newline characters, and display
* nothing when a substitution variable has no value:
* wrtSection('a b c':*off:'');
* Write sections a, b, and c without newline characters, and display
* 'error' when a substitution variable has no value:
* wrtSection('a b c':*on:'error');
* Write sections a, b, and c with newline characters, and use
* default value when a substitution variable has no value:
* wrtSection('a b c');
P wrtsection b export
D wrtsection pi
D sections 1000 value varying
D nonewline n options(*nopass) value
D NoDataString 30 options(*nopass) value varying
D section s 50
D wknonewline s n
D DebugRcd s 32000 varying
* Message for WRTDEBUG Giovanni 2011-07-21
D DebugMsg s 2000 varying Giovanni 2011-07-21
D BufPStart s *
* Work variables
D i s 10u 0
D i1 s 10u 0
D i2 s 10u 0
D i3 s 10u 0
D i4 s 10u 0
D h1 s 10u 0
D h2 s 10u 0
D p1 s *
D HtmlWindow s 32767 varying based(HtmlWindowP)
D HtmlWindowLen s 10u 0
D callerPgmLib ds
D callerPgm 10
D callerLib 10
* Constants
D ThisSubProc c 'WrtSection: '
* newline character
D NewLine s 1 inz(x'15')
* Variable's value not found
D Missing s 25 varying inz('**Missing Data**')
/free
if %parms > 1 and nonewline = *on;
wknonewline = *on;
else;
wknonewline = *off;
endif;
sections = uppify(%trim(sections)) + ' ';
dow sections <> *blanks;
i = %scan(' ':sections);
section = %subst(sections:1:i-1);
sections = %triml(%subst(sections:i));
exsr wrtonesection;
enddo;
return;
// ******************************************************************
// Subroutine WrtOneSection
// ******************************************************************
// Writes a section from the HTML stream including variable substitution
begsr wrtonesection;
if section = '*FINI';
exsr wrtbuffer; // Flush buffer
else;
h1 = %lookup(section:secname:secfirst:secused);
if h1 = 0; // not found
eval callerPgmLib = RtvPgmStack(2);
callp WrtDebug(ThisSubProc + 'Section ' + %trimr(section) +
' not found for pgm ' + %trim(callerLib) +
'/' + %trim(callerPgm) +
' in job ' +
%trim(%subst(psdsdata:264:6)) + '/' +
%trim(%subst(psdsdata:254:10)) + '/' +
%trim(%subst(psdsdata:244:10)) +
'.':*on);
return;
endif;
for h2 = secstart(h1) to secend(h1);
exsr output;
endfor;
endif;
endsr;
//******************************************************************************************
// Output subroutine
//******************************************************************************************
// Writes one HTML record and its substitution variables into
// the output buffer
// Input is h2, the index to the current record
begsr output;
// Set up addressability to place in HTML stream where current
// record is.
HtmlWindowP = HtmlP + HtmlOfs(h2);
// Save current location in the output buffer
BufPStart = OutBuffNextP;
// Output the record if there are no substitution variables
// Perform following logic only if there are one or more variables
// in the Html stream
if SubsCount = 0;
i1 = 0;
else;
i1=%lookupge(h2:Subsrrn:1:SubsCount);
endif;
if i1 = 0 or SubsRRn(i1) <> h2;
StdOut(HtmlWindowP+2:%len(HtmlWindow));
i4 = %len(HtmlWindow);
if Not WkNoNewLine;
StdOut(%addr(Newline):1);
i4 = i4 + 1;
endif;
exsr DoDebug;
leavesr;
endif;
// Alternately output constant and substitution variable data.
// Find the value of the variable pointed to by SubsVarName(i1)
// If variable name is found in varnm array, substitute varval. Else,
// insert a string indicating that the variable's value was not found.
// Search using do loop instead of lookup because array is dynamically
// allocated.
// p1 = pointer to first position, after the 2 byte length, of current HTML record
// i1 = index into SubsArr array. Contains HTML substitution variable
// information (HTML RRN, start pos, ending pos, etc.)
// i2 = index to varnm and varvalue arrays, etc. Contains substitution
// values.
// i3 = current location in record
// i4 = bytes written for this record
HtmlWindowLen = %len(HtmlWindow);
i3 = 1;
i4 = 0;
p1 = %addr(HtmlWindow) + 2;
dow i1 <= subscount and SubsRRN(i1) = h2;
if SubsStartPos(i1) > i3; // there is data before the substitution data
StdOut(p1+i3-1:SubsStartPos(i1) - i3); // write it
i4 = i4 + SubsStartPos(i1) - i3;
i3 = SubsStartPos(i1); // increment i3 to beginning of subst string
endif;
// now output substitution data
i2 = %lookup(SubsVarName(i1):varnm:1:varcurrent);
select;
when i2 = 0; // no substitution data available
if %parms < 3; // used default for missing data
StdOut(%addr(missing)+2:%len(missing));
i4 = i4 + %len(missing);
else;
StdOut(%addr(noDataString)+2:%len(noDataString));
i4 = i4 + %len(noDataString);
endif;
when VarLen(i2) = 0; // substitution data is null, do nothing
other; // write susbtitution data
StdOut(varP(i2):VarLen(i2));
i4 = i4 + VarLen(i2);
endsl;
i3 = i3 + SubsVarLen(i1);
i1 = i1 + 1;
enddo; // DoW SubsRRN(i1) = h2
if i3 <= HtmlWindowLen; // Output any remaining data
StdOut(p1+i3-1:HtmlWindowLen-i3+1);
i4 = i4 + HtmlWindowLen-i3+1;
endif;
if Not WkNoNewLine;
StdOut(%addr(Newline):1);
i4 = i4 + 1;
endif;
exsr DoDebug; // Handle debugging information
endsr;
//******************************************************************************************
// DoDebug Subroutine
//******************************************************************************************
// Debug Output
Begsr DoDebug;
if isdebug;
if i4 > 29950;
i4 = 29950;
endif;
%len(DebugRcd) = i4;
memcpy(%addr(DebugRcd)+2:bufPStart:i4);
wrtdebug(ThisSubProc + 'HTML = ' + DebugRcd);
endif;
endsr;
//******************************************************************************************
// WrtBuffer Subroutine
//******************************************************************************************
// Writes buffer to standard output.
begsr wrtbuffer;
QtmhWrStout(OutBuffP:OutBuffUsed:qusec);
if qusbavl > 0;
qusbavl = qusbavl - 16;
select;
when qusbavl <= 0; // no message data
qusbavl = 0;
when qusbavl <= %size(msgdata); // message data fits in msgdata
other; // message data too big for msgdata
qusbavl = %size(msgdata);
endsl;
WrtDebug(ThisSubProc + 'Failed when calling QtmhWrStout. +
Msgid = ' + qusei + '. Message data: ' +
%subst(msgdata:1:qusbavl):*on);
if qusei = 'TCP7531'; // Output buffer damaged
DebugMsg=ThisSubProc + 'Job ' +
%trim(psdsjobnbr) + '/' +
%trim(psdsusrnam) + '/' +
%trim(psdsjobnam) +
' forced to end because of error ' + qusei + '.'; //Giovanni 2011-07-21
endjob(DebugMsg); //Giovanni 2011-07-21
endif; //Giovanni 2011-07-21
else; //Giovanni 2011-07-21
WrtDebug(ThisSubProc + 'Sent ' + %trim(%editc(OutBuffUsed:'1')) +
' bytes to the browser');
endif; //Giovanni 2011-07-21
if OutBuffAlloc > OutBuffAllocInit;
OutBuffAlloc = OutBuffAllocInit;
OutBuffP = TS_Realloc(OutBuffP:OutBuffAllocInit);
endif;
OutBuffUsed = 0; // Reset outbuff
OutBuffNextP = OutBuffP; // Reset next pointer
endsr;
//******************************************************************************************
// Program status subroutine
//******************************************************************************************
begsr *pssr;
wrtpsds(psds);
endsr;
/end-free
Pwrtsection e
******************************************************************
* Local Subprocedures
******************************************************************
**********************************************************************
* AddHrec subprocedure
**********************************************************************
* Adds a record to the HTML stream
P AddHrec b
D AddHrec pi
D Hrec 32767 const varying
D Workvar s 32767 varying based(WorkPtr)
D WorkBytes s 10u 0
* Increase allocated Html storage if not large enough
C dow HtmlUsed + %len(hrec) + 2 > HtmlAlloc
C eval HtmlAlloc = HtmlAlloc + HtmlIncr
C realloc HtmlAlloc HtmlP
C enddo
C
* Add the record
C eval WorkPtr = HtmlP + HtmlUsed
C eval WorkVar = Hrec
C eval HtmlUsed = HtmlUsed + %len(Hrec) + 2
C eval HtmlCount = HtmlCount + 1
* Increase allocated storage for HtmlOfs array if not large enough
C dow HtmlOfsUsed + 1 > HtmlOfsAlloc
C eval HtmlOfsAlloc = HtmlOfsAlloc + HtmlOfsIncr
C eval WorkBytes = HtmlOfsAlloc * %size(HtmlOfs)
C realloc WorkBytes HtmlOfsP
C enddo
* Add the record's offset to the HtmlOfs array
C eval HtmlOfsUsed = HtmlOfsUsed + 1
C eval HtmlOfs(HtmlOfsUsed) = WorkPtr - HtmlP
C return
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P AddHrec e
**********************************************************************
* InitHTML subprocedure
**********************************************************************
P InitHTML b
D InitHtml pi
D sectionDelim...
D Start 20 const varying options(*nopass)
D sectionDelim...
D End 20 const varying options(*nopass)
D varDelimStart 20 const varying options(*nopass)
D varDelimEnd 20 const varying options(*nopass)
* Html stream.
* - Dynamically allocated in 32K chunks.
* - Addressed by pointer HtmlP.
* - Contains right-trimmed records, each in varying length format.
* - Indexed by array HtmlOfs. Each element is the offset
* into the stream for that record.
D WorkBytes s 10u 0
* Set up Html stream if not already done
C if HtmlP = *null
C alloc HtmlIncr HtmlP
C eval HtmlAlloc = HtmlIncr
C endif
* Initialize stream record count
C eval HtmlCount = 0
* Initialize stream bytes used
C eval HtmlUsed = 0
C
* Set up HtmlOfs array if not already done
C if HtmlOfsP = *null
C eval HtmlOfsAlloc = HtmlOfsIncr
C eval WorkBytes = HtmlOfsIncr * %size(HtmlOfs)
C alloc WorkBytes HtmlOfsP
C endif
* Initialize count for HtmlOfs array to 0
C eval HtmlOfsUsed = 0
C* Set up initial allocations for SubsArr array if not already set
C if SubsArrP = *null
C eval SubsAllocated = SubsInit
C eval SubsBytes = %size(SubsArr) * SubsInit
C alloc SubsBytes SubsArrP
C endif
* Set current count for SubsArr arrays to 0
C eval SubsCount = 0
* Set up arrays for section information
C eval secstart(*) = 0
C eval secend(*) = 0
C eval secname(*) = *blanks
C eval SecFileName(*) = *blanks
C eval SecFileRrn(*) = *hival
C eval SecUsed = 0
C eval SecFirst = SecCnt
* Set up initial allocations for output buffer if not already set
C if OutBuffP = *null
C eval OutBuffAlloc = OutBuffAllocInit
C eval OutBuffP = Ts_Malloc(OutBuffAlloc)
C eval OutBuffNextP = OutBuffP
C eval OutBuffUsed = 0
C endif
* Set up section delimiters and their lengths
C if %parms > 0
C eval secdelim1 = uppify(%trim(sectionDelimStart))
C else
C eval secdelim1 = secdelim1dft
C endif
C eval SecDelim1Len = %len(secdelim1)
C if %parms > 1
C eval secdelim2 = uppify(%trim(sectionDelimEnd))
C else
C eval secdelim2 = secdelim2dft
C endif
C eval SecDelim2Len = %len(secdelim2)
* Set up variable delimiters
C if %parms > 2
C eval delim1 = uppify(varDelimStart)
C else
C eval delim1 = delim1dft
C endif
C eval delim1ln = %len(delim1)
C if %parms > 3
C eval delim2 = uppify(varDelimEnd)
C else
C eval delim2 = delim2dft
C endif
C eval delim2ln = %len(delim2)
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P InitHTML e
*************************************************************************************
* SetUpArrays Subprocedure
*************************************************************************************
* Sets up section arrays and substitution variables arrays
P SetUpArrays b
D SetUpArrays pi
D CallingProc 50 const varying
D NoErrors n
D DupSections n
* For each record placed into dynamic Html storage by the AddHrec subprocedure
* - retrieves record
* - if a section record, updates section arrays
* - else
* - if it contains any substitution variables, updates the
* substitution variable arrays
* Wk variable for current record
D Wk s 32767 varying based(WorkP)
D WkLn s 10i 0
D WkUp s like(wk)
* Current section name
D ThisSection s 50 varying
D TempSection s 50
* Counter for number of records in section
D ThisSectionCnt s 10i 0
* Main loop counter
D i s 10i 0
* Work indexes
D i1 s 10i 0
D i2 s 10i 0
D i3 s 10i 0
D i4 s 10i 0
D i5 s 10i 0
D i6 s 10i 0
D PrevFile s 255 varying
D ThisFile s 255 varying
* In the original version "ArrType" used to be dim(100).
* However, on March 21, 2012 an user found out that this subprocedure was bumping out
* when the number of output /%variables%/ in a HTML row was greater than 50 (=100/2).
* I raised to 1000 the number of entries in array "ArrType"
* thus allowing to specify up to 500 output /%variables% in a HTML row (Giovanni B. Perotti)
D*ArrType s 1 dim(100)
D ArrType s 1 dim(1000)
D SubsStartCnt s 10i 0
D SubsEndCnt s 10i 0
D SeqErr s n
D CntErr s n
D IgnoreFlag s n inz(*off)
C eval SecUsed = 1
C eval ThisSection = 'NONAME'
C eval ThisSectionCnt = 0
* Read and process all records
C do HtmlCount i
* Set up addressability to this record
C eval WorkP = HtmlP + HtmlOfs(i)
* Set up uppercase version of this record and calculate its length
C* eval WkUp = Uppify(Wk) Guetzlaff no-op
C* eval WkLn = %len(Wk) Guetzlaff no-op
C eval WkUp = %triml(Uppify(Wk)) Guetzlaff added
C eval WkLn = %len(WkUp) Guetzlaff added
* Section records
C if WkLn > SecDelim1Len and
C %subst(WkUp:1:SecDelim1Len) = SecDelim1
* Found a new section.
* Write previous section if still pending
C if ThisSection <> *blanks
C if ThisSectionCnt = 0
C eval SecStart(SecFirst) = i - 1
C eval SecEnd(SecFirst) = 0
C else
C eval SecStart(SecFirst) = i - ThisSectionCnt
C eval SecEnd(SecFirst) = i - 1
C endif
C eval SecName(SecFirst) = ThisSection
C eval ThisSection = *blanks
C endif
* Extract newly found section's name. If already in list of
* sections, send message and ignore all its records.
C eval TempSection = %replace('':
C WkUp:%scan(SecDelim1:WkUp:1):
C SecDelim1Len)
C if SecDelim2Len > 0
C eval i1 = %scan(SecDelim2:TempSection)
C else
C eval i1 = %scan(' ':TempSection)
C endif
C if i1 > 0
C eval TempSection = %subst(TempSection:1:i1-1)
C endif
C eval i1 = SecFirst
C TempSection lookup secname(i1) 99
C if *in99
* It's a duplicate section. Get this section's and the
* previous section's file names
C eval i6 = 1
C secstart(i1) lookup secfilerrn(i6) 98 99
C if *in99
C eval PrevFile = SecFileName(i6)
C else
C eval PrevFile = SecFileName(i6-1)
C endif
C eval i6 = 1
C i lookup secfilerrn(i6) 98 99
C if *in99
C eval ThisFile = SecFileName(i6)
C else
C eval ThisFile = SecFileName(i6-1)
C endif
C eval IgnoreFlag = *on
C callp WrtDebug(CallingProc +
C 'Section name ' + %trimr(TempSection) +
C ' from file ' + ThisFile +
C ' is a duplicate with the same -
C section from file ' + PrevFile +
C ' This section is being ignored.':*on)
C eval NoErrors = *off
C eval DupSections = *on
C iter
C endif
* This section not to be ignored. Set IgnoreFlag off and continue.
C eval IgnoreFlag = *off
* Initialize for the new section
C eval ThisSection = %trim(TempSection)
C eval SecUsed = SecUsed + 1
* If SecUsed exceeds the maximum number of sections, seccnt, send
* message and return.
C if SecUsed > SecCnt
C eval i6 = 1
C i lookup secfilerrn(i6) 98 99
C if *in99
C eval ThisFile = SecFileName(i6)
C else
C eval ThisFile = SecFileName(i6-1)
C endif
C callp WrtDebug(CallingProc +
C 'Section name ' + %trimr(TempSection) +
C ' from file ' + ThisFile +
C ' is the ' + %trim(%editc(SecUsed:'Z')) +
C 'th section. The maximum number -
C of sections is ' +
C %trim(%editc(SecCnt:'Z')) +
C '. No more HTML will be processed.':*on)
C return
C endif
C eval SecFirst = SecFirst - 1
C eval ThisSectionCnt = 0
* Data records -- set up arrays for storing locations of substitution variables
C else
* ReAssign values untrimmed Guetzlaff added
C eval WkUp = Uppify(Wk) Guetzlaff added
C eval WkLn = %len(WkUp) Guetzlaff added
* Examines current record, but ignore if ignoreflag is on.
* If it contains any substitution variables, add the information
* to the SubsArr arrays.
* First, check the record for equal numbers of starting
* and ending delimiters and that they are paired properly.
C if IgnoreFlag
C iter
C endif
* Initialize
C eval ArrType = *blanks
C eval CntErr = *off
C eval SeqErr = *off
C eval SubsStartCnt = 0
C eval SubsEndCnt = 0
C eval i2 = 0
* Do loop, check each position for starting or ending delimiter.
* If a hit, record the type (S or E) in array ArrType and increment
* the count for that type.
* If two adjacent elements are the same, set on the sequence
* error indicator and leave the loop.
* Start of do loop
C do WkLn i1
* Logic to check for starting delimiter
C if WkLn - i1 + 1 >= Delim1Ln
C and %subst(WkUp:i1:Delim1Ln) =
C Delim1
C eval i2 = i2 + 1
C if i2>1000 Giovanni 2012-03-21
C leave Giovanni 2012-03-21
C endif Giovanni 2012-03-21
C eval ArrType(i2) = 'S'
C eval SubsStartCnt = SubsStartCnt + 1
C eval i1 = i1 + Delim1Ln - 1
C if i2 > 1 and ArrType(i2-1) = 'S'
C eval SeqErr = *on
C leave
C else
C iter
C endif
C endif
* Logic to check for ending delimiter
C if WkLn - i1 + 1 >= Delim2Ln
C and %subst(WkUp:i1:Delim2Ln) =
C Delim2
C eval i2 = i2 + 1
C if i2>1000 Giovanni 2012-03-21
C leave Giovanni 2012-03-21
C endif Giovanni 2012-03-21
C eval ArrType(i2) = 'E'
C eval SubsEndCnt = SubsEndCnt + 1
C eval i1 = i1 + Delim2Ln - 1
C if i2 > 1 and ArrType(i2-1) = 'E'
C eval SeqErr = *on
C leave
C else
C iter
C endif
C endif
C enddo
* If not sequencing error, test for unequal start and end counts
C if Not SeqErr and
C SubsStartCnt <> SubsEndCnt
C eval CntErr = *on
C endif b
* Process data record
C do
* Increment this section's count
C eval ThisSectionCnt = ThisSectionCnt + 1
C if WkLn < delim1ln
C leave
C endif
C if CntErr
C callp WrtDebug(CallingProc +
C 'There are unequal numbers of -
C starting and ending substitution -
C variables in HTML record: ' +
C wk + '. The record is being set -
C to all asterisks.':*on)
C endif
C if SeqErr
C callp WrtDebug(CallingProc +
C 'One or more substitution -
C variable delimiters is out -
C of sequence in HTML record: ' +
C wk + '. The record is being set -
C to all asterisks.':*on)
C endif
C if CntErr or SeqErr
C eval i1 = WkLn
C do i1 i2
C eval %subst(wk:i2:1)='*'
C eval %subst(WkUp:i2:1)='*'
C enddo
C endif
C eval i1 = 1 Index to 1st delim
C dow i1 > 0 and i1 <= %len(wk)
C eval i1 = %scan 1st delimiter start
C (delim1:WkUp:i1)
C if i1 = 0
C leave
C endif
C eval i2 = %scan 2nd delimiter start
C (delim2:WkUp:i1)
* Length of string from and including first delimiter,
* variable name, and second delimiter
C eval i3 = i2 + delim2ln - i1
* Location where variable name starts
C eval i4 = i1 + delim1ln
* Add this occurrence to the SubsArr array
C eval SubsCount = SubsCount + 1
C if SubsCount > SubsAllocated
C eval SubsAllocated = SubsAllocated + SubsAddl
C eval SubsBytes = SubsAllocated * %size(SubsArr)
C realloc SubsBytes SubsArrP
C endif SubCount > SubsAlloc
C eval i5 = SubsCount
C eval SubsRRN(i5) = i
C eval SubsStartPos(i5) = i1
C eval SubsVarName(i5) =
C %subst(WkUp:i4:i3 -
C delim1ln - delim2ln)
C eval SubsVarLen(i5) = i3
C eval SubsSection(i5) = ThisSection
C eval i1 = i1 + i3
C enddo
C enddo
C endif
C enddo
* Last section
C if ThisSection <> *blanks
C eval SecName(SecFirst) = ThisSection
C eval SecStart(SecFirst) = i - ThisSectionCnt
C eval SecEnd(SecFirst) = i - 1
C endif
C return
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P SetUpArrays e
**********************************************************************
* Stdout subprocedure
**********************************************************************
* Writes Length bytes of data at Location into address of OutB
P StdOut b
D StdOut pi
D Location * value
D Length 10u 0 const
* Add data to the output buffer, reallocating storage for OutBuff
* as required
C if OutBuffUsed + Length > OutBuffAlloc
C eval OutBuffAlloc = OutBuffAlloc +
C Length + OutBuffAllocAddl
C eval OutBuffP = Ts_Realloc(OutBuffP:
C OutBuffAlloc)
C eval OutBuffNextP = OutBuffP + OutBuffUsed
C endif
C callp memcpy(OutBuffNextP:Location:Length)
C eval OutBuffNextP = OutBuffNextP + Length
C eval OutBuffUsed = OutBuffUsed + Length
C return
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P StdOut e
*=============================================================================================
* RTVPGMStack subprocedure - Retrieves call stack information
* Returns the name and the library of the program calling a subprocedure in this module.
* Uses Retrieve Call Stack (QWVRCSTK) API
* http://publib.boulder.ibm.com/infocenter/iseries/v5r4/topic/apis/qwvrcstk.htm
* API QWVRCSTK returns the call stack information for the specified thread.
* The first call stack entry returned corresponds to the most recent call in the thread.
P RtvPgmStack b
D RtvPgmStack pi 20
D pgmLevel 10i 0 value
D
D pgmLevel1 s 10i 0
D returnPgmLib ds
D returnPgm 10
D returnLib 10
*====================================================
* Required parameter group for QWVRCSTK API
* 1-Receiver variable
D Rcv ds 6000
D RcvBRet 10i 0 Bytes returned
D RcvBAvl 10i 0 Bytes available
D RcvNbrEnt 10i 0 No. stack entries
D RcvOffset 10i 0 Offset to stack entr
D RcvNbrEntRet 10i 0 No.StckEntrsReturned
* 2-Receiver variable length
D RcvLen s 10i 0 inz(%size(Rcv))
* 3-Format of receiver information
D RcvFmt s 8 inz('CSTK0100')
* 4-Job identification information
D JId ds 56
D JIDJob 26 inz('*')
D JIDIntJobId 16 inz(' ')
D JIDReserved 2 inz(*loval)
D JIDThreadInd 9b 0 inz(1)
D JIDThreadId 8 inz(*loval)
* 5-Format of job identification information
D JobIdFmt s 8 inz('JIDF0100')
*====================================================
D VarP s * variable pointer
* Format of a call stack entry for Format JIDF0100
D StkE ds 256 based(VarP)
D StkELen 10i 0 Entry length
D StkEPgm 10 overlay(StkE:025) Program name
D StkEPgmLib 10 overlay(StkE:035) Program library name
*====================================================
* API error data structure
Dqusec ds
D qusbprv 10i 0 inz(%size(qusec)) Bytes Provided
D qusbavl 10i 0 inz(0) Bytes Available
D qusei 7 Exception Id
D 1 Reserved
D msgdata 500
*====================================================
D x00 s 1 inz(x'00')
D j s 10i 0
D i s 10i 0
D chkifsobject s 512
/free
// Initialize variables
eval pgmLevel1=PgmLevel;
eval returnPgm=' ';
eval returnLib=' ';
// Invoke API QWVRCSTK
callp GetPgmStack(Rcv:RcvLen:RcvFmt:JId:JobIdFmt:qusec);
//Go across call stack entries
IF qusei=' ';
eval j=RcvNbrEntRet; //No. of entries in the thread
eval i=0; //position in the thread going back from the most recent one (i=0)
DOW j>0;
if j=RcvNbrEntRet;
eval VarP=%addr(Rcv)+RcvOffset; //->1st entry (most recent call in the thread)
else;
eval VarP=VarP+StkELen; //->next entry (previous call in the thread)
endif;
if i>=pgmLevel;
//if StkEPgm not a *srvpgm, take it and exit;
//otherwise, get prepared to get the next level pgm.
eval returnPgm=StkEPgm;
eval returnLib=StkEPgmLib;
eval chkifsobject='/QSYS.LIB/' +
%trim(uppify(returnLib)) + '.LIB/' +
%trim(uppify(returnPgm)) + '.SRVPGM';
if not chkifsobj2(%trim(chkifsobject));
leave;
else;
if j>1;
eval pgmLevel1=pgmLevel1+1;
endif;
endif;
endif;
eval j=j-1;
eval i=i+1; //position in the thread going back from the most recent one (i=0)
ENDDO;
ENDIF; //qusei=' '
//Back to caller
return returnPgmLib;
/end-free
*====================================================
C *pssr begsr
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P RtvPgmStack e
*=============================================================================================
* GetHtmlBufferP subprocedure - Retrieves the pointer to the Html output buffer
* Returns a data structure containing
* - the pointer to the Html output buffer
* - the used length of the Html output buffer
* Example:
* D OutBuffer s 32767 based(OutbufferP)
* D OutBufferInfo ds
* D OutBufferP *
* D OutBufferLen 10u 0
* C eval OutBufferInfo=callp(GetHtmlBufferP)
P GetHtmlBufferP b export
D GetHtmlBufferP pi 20
D OutBufferInfo ds
D OutBufferP *
D OutBufferLen 10u 0
/free
outBufferP=outbuffP;
outBufferLen=outbuffUsed;
return OutBufferInfo;
/end-free
*====================================================
C *pssr begsr
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P GetHtmlBufferP e
*=============================================================================================
* Subprocedure WrtSectionToStmF: Writes a section to stream file
*
* One or more sections are written to the HTML buffer,
* the contents of the HTML buffer are written to Stmf,
* the buffer is cleared.
* On the first call
* - if the stream file already exists, it is deleted
* - the stream file is then created
* Input parameters:
* - Sections:
* -- One or more blank-separated section names
* -- Section name '*FINI' should be used to end the stream file
* tells that this is the first section to be written
* - Path and name of the IFS stream file - Requested only on the first call.
* - DataType - Requested only on the first call:
* -- *TEXT (text data to be converted to the STMF CCSID)
* -- *BIN (binary data not to be converted)
* - CCSID Requested only on the first call, it is used to establish the CCSID
* of the stream file. Defaul value is 819 (ASCII).
*
P WrtSectionToStmF...
P b export
D WrtSectionToStmF...
D pi
D sections 1000 value varying
D Stmf 1024 const varying options(*nopass)
D DataType 5 const varying options(*nopass)
D CCSID 10u 0 const options(*nopass)
‚ * QMHSNDPM prototype
D qmhsndpm PR ExtPgm('QMHSNDPM')
D i_msgID 7a const
D i_qMsgF 20a const
D i_msgText 32767a const options(*varsize)
D i_lenMsgText 10i 0 const
D i_msgType 10a const
D i_stackEntry 10a const
D i_stackCountr 10i 0 const
D i_msgKey 4 const
D io_errCode 32767a options(*varsize)
D thsSections s 1000 varying
D thsStmf s 1024 varying static
D thsDataType s 5 varying static
D thsCCSID s 10u 0 static
D nbrParms s 10i 0
D initInd s n static
D msg s 1000
D port s 10
D handle s 10i 0 static
D ifsInd s n
D finiInd s n
D buffer s 1000 based(outPntr)
D outBufferInfo ds
D outPntr *
D outLen 10u 0
D wrtLen s 10i 0
D newLine c x'15'
D EOR c x'0D25'
D newBufferSize s 10i 0
D newPntr s *
D oldPntr1 s *
D newPntr1 s *
D newLen s 10i 0
D oldChar s 1 based(oldPntr1)
D newChar1 s 1 based(newPntr1)
D newChar2 s 2 based(newPntr1)
/free
// Check parameter "sections"
thsSections=uppify(sections);
if thsSections=' ';
msg='Subprocedure WrtSectionToStmf()- No sections specified';
exsr ErrorMsg;
endif;
// Check parameter "Stmf"
nbrParms=%parms();
if initInd=*off;
if nbrParms>1 and Stmf<>thsStmf;
thsStmf=Stmf;
initInd=*on; //stream file must be created
if handle<>-7; //if stream file left open, close it now.
rc=close(handle);
endif;
endif;
endif;
// Check parameter "DataType"
if initInd=*on;
if nbrParms>2;
thsDataType=uppify(DataType);
else;
thsDataType='*TEXT';
endif;
if thsDataType<>'*TEXT' and
thsDataType<>'*BIN';
thsDataType='*TEXT';
endif;
endif;
// Check parameter "CCSID"
if initInd=*on;
if nbrParms>2;
thsCCSID=CCSID;
else;
thsCCSID=819;
endif;
endif;
// If stream file to be created and already exists, delete it
if initInd=*on;
ifsInd=chkIfsObj4(thsStmf);
if ifsInd=*on;
rc=doCmd('del ''' + thsStmf + '''');
if rc<>0;
msg='Subprocedure WrtSectionToStmf()- +
IFS object ' + thsStmf +
' could not be deleted';
exsr ErrorMsg;
endif;
endif;
endif;
// If stream file to be created, create it
if initInd=*on;
Handle=open(thsStmf:
O_CREAT + O_WRONLY + O_CCSID + O_LARGEFILE:
S_IRUSR+S_IWUSR+S_IRGRP+S_IWGRP+S_IROTH:
thsCCSID);
if handle<0;
msg='Subprocedure WrtSectionToStmf()- +
Stream file ' + thsStmf +
' could not be created';
exsr ErrorMsg;
endif;
rc=close(handle);
endif;
// If stream file to be opened, open it
if initInd=*on;
if thsDataType='*TEXT';
handle=open(thsStmf:O_WRONLY+O_TEXTDATA);
else;
handle=open(thsStmf:O_WRONLY);
endif;
if handle<0;
msg='Subprocedure WrtSectionToStmf()- +
Stream file ' + thsStmf +
' could not be opened';
exsr ErrorMsg;
endif;
endif;
// Signal stream file as opened
if initInd=*on;
initInd=*off;
endif;
// Check if sections contain *FINI
rc=%scan('*FINI':thsSections);
if rc>0;
finiInd=*on;
%subst(thsSections:rc:5)=' '; //remove *FINI
else;
finiInd=*off;
endif;
// Write the sections to the output buffer, write the buffer to the stream file
if sections<>' ';
clrHtmlBuffer();
if thsDataType='*TEXT';
wrtsection(thsSections);
else;
wrtsection(thsSections:*on); //no newline
endif;
exsr CopyWrite; //copy out-buffer to replace newline char.s an write it to stmf
endif;
// If section *FINI specified, ...
if finiInd=*on;
rc=close(handle);
exsr ClearStatic;
endif;
// Back to caller
return;
// Copy the output buffer to another allocated buffer,
//replacing characters x'15' with characters x'0D25' (CarriageReturnLineFeed)
//if data type is *TEXT.
// Write the new buffer to the stream file
Begsr CopyWrite;
OutBufferInfo=GetHtmlBufferP();
newBufferSize=outLen+53000;
newPntr=%alloc(newBufferSize);
oldPntr1=outPntr;
newPntr1=newPntr;
newLen=0;
dow oldPntr1