Learn from sources
       Member XXXWRKHTML in CGIDEV2 / QRPGLESRC

       *=============================================================================================
       *  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
0.344 sec.s