Learn from sources
       Member XXXDATA in CGIDEV2 / QRPGLESRC

       **************************************************************************
       * This material is provided by IBM for illustrative purposes             *
       * only and has not been thoroughly tested under all conditions.          *
       * IBM, therefore, cannot guarantee or imply reliability,                 *
       * serviceability, or function of this material.  IBM provides            *
       * no program services for this material.  All material contained         *
       * herein is provided to you "AS IS" without any warranties of            *
       * any kind.  THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS          *
       * FOR A PARTICULAR PURPOSE AND NON-INFRINGMENT ARE EXPRESSLY             *
       * DISCLAIMED.  SOME JURISDICTIONS DO NOT ALLOW THE EXCLUSION             *
       * OF IMPLIED WARRANTIES, SO THE ABOVE EXCLUSIONS MAY NOT APPLY           *
       * TO YOU.  IN NO EVENT WILL IBM BE LIABLE TO ANY PARTY FOR ANY           *
       * DIRECT, INDIRECT, SPECIAL OR OTHER CONSEQUENTIAL DAMAGES FOR           *
       * ANY USE OF THIS MATERIAL, INCLUDING, WITHOUT LIMITATION, ANY           *
       * LOST PROFITS, BUSINESS INTERRUPTION, LOSS OF PROGRAMS OR OTHER         *
       * DATA ON YOUR INFORMATION HANDLING SYSTEM OR OTHERWISE, EVEN            *
       * IF WE ARE EXPRESSLY ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.        *
       *                                                                        *
       * (C) Copyright IBM Corp. 1997, 2005                                     *
       * All rights reserved.                                                   *
       * US Government Users Restricted Rights -                                *
       * Use, duplication, or disclosure restricted                             *
       * by GSA ADP Schedule Contract with IBM Corp.                            *
       *                                                                        *
       * Licensed Materials - Property of IBM                                   *
       **************************************************************************
      Hnomain
       /copy qrpglesrc,hspecs
 
       /copy qrpglesrc,prototypeb
 
       /copy qrpglesrc,usec
 
       * Program status data structure
      Dpsds            sds
      D  psdsdata                    429
 
      D callerPgmLib    ds
      D  callerPgm                    10
      D  callerLib                    10
 
       * Prototypes
       * System's Convert Case (QlgConvertCase) API
      D SysConvertCase  pr                  extproc('QlgConvertCase')
      D  ControlBlock                   *   value
      D  Input                          *   value
      D  Output                         *   value
      D  Length                       10i 0 const
      D  Error                              like(qusec)
       * 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
 
       **************************************************************************
       * char2hex subprocedure
       **************************************************************************
       * Input: variable length character field
       * Output variable length character field, twice as long, containing
       *        the hex digits for each input character.
       *
       * Example:      eval      hex = char2hex('ABC') returns the characters C1C2C3
       *
       * Uses MI instruction cvthc. Bind with binding directory QSYS/QC2LE.
       *
      Pchar2hex         b                   export
      Dchar2hex         pi         32000    varying
      D  charsin                   16000    const varying options(*varsize)
 
      Dhexchars         s          32000
      Dhexcharsout      s          32000    varying
      Dchars            s          16000
      Dsize             s             10i 0
      D
      C                   eval      size=%len(charsin) * 2
      C                   eval      chars = charsin
      C                   callp     cvthc(%addr(hexchars):%addr(chars):size)
      C                   eval      hexcharsout =
      C                             %subst(hexchars:1:size)
      C                   return    hexcharsout
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
 
      Pchar2hex         e
 
       **************************************************************************
       * hex2char subprocedure
       **************************************************************************
       * Input: variable length character field containing hex characters
       * Output variable length character field, half as long, containing
       *        the character representation of each input pair of hex
       *        characters.
       *
       * Example:      eval      hex = char2hex('ABC') returns the characters C1C2C3
       *
       * Uses MI instruction cvtch. Bind with binding directory QSYS/QC2LE.
       *
      Phex2char         b                   export
      Dhex2char         pi         16000    varying
      D  hexcharsin                32000    const varying options(*varsize)
 
      Dhexchars         s          32000
      Dcharsout         s          16000    varying
      Dchars            s          16000
      Dsize             s             10i 0
      D
      C                   eval      size=%len(hexcharsin)
      C                   eval      hexchars = hexcharsin
      C                   callp     cvtch(%addr(chars):%addr(hexchars):size)
      C                   eval      size = size / 2
      C                   eval      charsout = %subst(chars:1:size)
      C                   return    charsout
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
 
      Phex2char         e
 
       **************************************************************************
       * c2n subprocedure
       **************************************************************************
       * Converts a character string to a floating point variable.  If
       * non-zero, adds a small fuzz to the result in an attempt to
       * ensure that subsequent rounding works as expected.
       *
       * Input: variable length character field containing a valid
       *        decimal number in display format.
       * Output: floating point number which can then be converted to
       *        some other form either by assignment or via %DEC, %DECH,
       *        %INT, or %INTH built-in functions.
       *
       * The only characters included in the conversion are digits, the
       * minus sign, and the current RPG decimal point character.
       * If multiple decimal points are found, only the first one is used.
       *
       *
       * Example:      eval      float = c2n('-123.34')
       *
       * Uses MI instruction cvtefnd.  Bind with binding directory QSYS/QC2LE.
       *
      pc2n              b                   export
      Dc2n              pi             8f
      D  c                            32    const varying options(*varsize)
 
      Dc2               s             32
      Dcwork            s             32
      Dlength           s             10i 0
      Dfloat            s              8f
      Dmask             ds             3    static
      D  cursym                        1
      D  comma                         1
      D  decpoint                      1
      Dvalidchars       s             12    inz('0123456789-') static
      Ddecfound         s              1    inz(*off)
      Dbeenhere         s              1    inz(*off) static
      Di                s             10i 0
      Dfuzz             c                   0.000000000000001
 
 
       * Initialize mask by editing a number and extracting the
       * currency symbol, comma, and decimal point characters.
      C                   if        beenhere = *off
      C                   eval      beenhere = *on
      C                   eval      c2 = %editc(123456.789:'1':*cursym)
      C                   eval      cursym = %subst(c2:1:1)
      C                   eval      comma = %subst(c2:5:1)
      C                   eval      decpoint = %subst(c2:9:1)
      C                   eval      c2 = *blanks
      C                   eval      validchars = %trimr(validchars) + decpoint
      C                   endif
 
      C                   eval      length = %len(c)
      C     1             do        length        i
      C                   if        %scan(%subst(c:i:1):validchars) » 0
      C                   if        %subst(c:i:1) = decpoint
      C                   if        decfound= *on
      C                   iter
      C                   else
      C                   eval      decfound= *on
      C                   endif
      C                   endif
      C                   eval      c2 = %trimr(c2) + %subst(c:i:1)
      C                   endif
      C                   enddo
      C                   eval      length = %len(%trimr(c2))
      C                   if        length » 0
      C                   eval      float = cvtefnd(c2:length:mask) + fuzz
      C                   else
      C                   eval      float = 0.0
      C                   endif
      C                   return    float
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
 
      Pc2n              e
 
       ******************************************************************
       * c2n2 subprocedure
       ******************************************************************
       * Converts a character string to a 30,9 packed variable.
 
       * Adapted from getnum subprocedure, written by Barbara Morris,
       * IBM Toronto laboratory.
       *
       * This subprocedure avoids precision problems with large
       * floating point numbers by doing virtually all its work with
       * characters.  Performance is improved too.
 
       * Input: variable length character field containing a valid
       *        decimal number in display format.
       * Output: 30p 9 number
       *
       * The only characters included in the conversion are digits, the
       * minus sign, and the current RPG decimal point character.
       * If multiple decimal points are found, only the first one is used.
       *
       * Example:      eval      number = c2n2('-123.34')
 
      Pc2n2             b                   export
      Dc2n2             pi            30p 9
      D  string                       32    const varying
 
      Dbeenhere         s              1    inz(*off) static
      Ddecpoint         s              1    static
      Dc2               s             32
      Dvalidchars       s             12    varying inz('0123456789-') static
      Dwork             s                   like(string)
 
       * structure for building result
      D                 ds
      Dresult                         30s 9 inz(0)
      DresChars                       30a   overlay(result)
       * variables for gathering digit information
       * pNumPart points to the area currently being gathered
       * (the integer part or the decimal part)
      DpNumPart         s               *
      DnumPart          s             30a   varying based(pNumPart)
      DintPart          s             30a   varying inz('')
      DdecPart          s             30a   varying inz('')
       * other variables
      DintStart         s             10i 0
      DdecStart         s             10i 0
      Dsign             s              1    inz('+')
      Di                s             10i 0
      Dlen              s             10i 0
      Dc                s              1
 
       * Initialize decpoint by extracting it from and edited field.
      C                   if        beenhere = *off
      C                   eval      beenhere = *on
      C                   eval      c2 = %editc(123456.789:'1':*cursym)
      C                   eval      decpoint = %subst(c2:9:1)
      C                   eval      validchars = validchars + decpoint
      C                   endif
       * Trim and get length of input string
      C                   eval      work = %trim(string)
      C                   eval      len = %len(work)
       * Read the integer part
      C                   eval      pNumPart = %addr(intPart)
       * Loop through characters
      C                   do        len           i
      C                   eval      c = %subst(work:i:1)
 
      C                   select
       * Ignore any characters other than digits, the minus sign, and the
       * decimal point character.
      C                   when      %scan(c:validchars) = 0
      C                   iter
       * Decimal point: switch to reading the decimal part
      C                   when      c = decPoint
      C                   eval      pNumPart = %addr(decPart)
      C                   iter
       * Sign: remember the most recent sign
      C                   when      c = '-'
      C                   eval      sign = c
      C                   iter
       * A digit: add it to the current build area
      C                   other
      C                   eval      numPart = numPart + c
 
      C                   endsl
      C                   enddo
 
       * Copy the digit strings into the correct positions in the
       * zoned variable, using the character overlay
      C                   eval      decStart = %len(result) - %decPos(result)
      C                                      + 1
      C                   eval      intStart = decStart - %len(intPart)
      C                   eval      %subst(resChars
      C                                  : intStart
      C                                  : %len(intPart))
      C                               = intPart
      C                   eval      %subst(resChars
      C                                  : decStart
      C                                  : %len(decPart))
      C                               = decPart
       * If the sign is negative, return a negative value
      C                   if        sign = '-'
      C                   return    - result
       * otherwise, return the positive value
      C                   else
      C                   return    result
      C                   endif
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
 
      Pc2n2             e
 
 
       **************************************************************************
       * chknbr subprocedure
       **************************************************************************
       * Checks a character string to see if it contains a valid number.
       * The only valid characters are -0123456789 and the character being used
       * as the decimal point.
       *
       * Optionally, when errors are found, uses AddMsg to write records into the
       * error message arrays.
 
       * Inputs: - variable length character field containing data intended to
       *           be a valid decimal number.
       *         - maximum number of digits to the left of the decimal point
       *           (optional parameter).  0 or not passed means don't check it.
       *           If greater than 21, it is changed to 21.
       *         - whether to add messages to the message arrays using AddMsg
       *           if errors are found.
       *         - field's description for AddMsg purposes
       *         - whether to consider a negative value an error for AddMsg
       *           purposes.  If this parameter is not passed, negative
       *           numbers do not cause a message to be added by AddMsg.
 
       * Returns: Data structure containing indicators (seven indicators)
       *        1 = *on = one or more errors as described in indicators
       *                  2 through 6 below.  Indicator 7 being on does
       *                  not set on indicator 1.
       *        2 = non-numeric characters (includes minus sign in wrong place)
       *        3 = multiple decimal points
       *        4 = multiple signs (both leading and trailing)
       *        5 = zero length input or no numeric characters
       *        6 = error in number of digits to left or right of decimal
       *            point.  Set on if:
       *            - more than 21 digits to the left of the decimal point
       *            - more than 9 digits to the right of the decimal point
       *            - more digits to the left of the decimal point than
       *              specified in maxdigits parameter.
       *        7 = The value is less than 0.  This condition does not
       *            set on indicator one.
 
      pchknbr           b                   export
      Dchknbr           pi             7
      D  chars                        32    const varying options(*varsize)
      D  MaxDigits                    10i 0 const options(*nopass)
      D  AddMsgs                        n   const options(*nopass)
      D  FieldDescription...
      D                               32    const varying options(*nopass)
      D  NegIsError                     n   const options(*nopass)
 
      D c2              s             32
      D thischar        s              1
      D length          s             10i 0
      D decpoint        s              1    static
      D validchars      s              2    inz('-') static
      D validnbrs       s             10    inz('0123456789') static
      D beenhere        s              1    inz(*off) static
      D i               s             10i 0
      D rc              s             10i 0
      D countinvalid    s             10i 0
      D countdecimal    s             10i 0
      D countnumbers    s             10i 0
      D countfraction   s             10i 0
      D workf           s              8f
      D wk              s             32    varying
      D FieldDesc       s             32    varying
      D NegIsErr        s               n
      D MaxDigitsX      s                   like(MaxDigits) inz(21)
      D indicators      ds
      D   anyerrs                       n
      D   invalidchrs                   n
      D   multdecpts                    n
      D   multsigns                     n
      D   nonbrs                        n
      D   toobig                        n
      D   lessthan0                     n
 
       * One-time processing
 
       * Initialize decpoint by editing a number and extracting the
       * decimal point character.
      C                   if        beenhere = *off
      C                   eval      beenhere = *on
      C                   eval      c2 = %editc(123456.789:'1':*cursym)
      C                   eval      decpoint = %subst(c2:9:1)
       * Add the decimal point character to the list of valid characters.
      C                   eval      validchars = %trimr(validchars) + decpoint
      C                   endif
 
      C                   clear                   indicators
       * Set MaxDigitsX
      C                   if        %parms » 1
      C                   eval      MaxDigitsX = MaxDigits
      C                   if        MaxDigitsX » 21
      C                   eval      MaxDigitsX = 21
      C                   endif
      C                   endif
 
       * Get length of input string
      C                   eval      length = %len(chars)
       * If length is 0 return with nonbrs indicator on.
      C                   if        length = 0
      C                   eval      nonbrs = *on
      C                   eval      anyerrs = *on
      C                   else
       * If first and last characters are '-', and length is greater than
       * one, turn on multiple signs indicator.
      C                   if        length » 1 and
      C                             %subst(chars:1:1) = '-' and
      C                             %subst(chars:length:1) = '-'
      C                   eval      multsigns = *on
      C                   eval      anyerrs = *on
      C                   endif
       * Examine each character.
      C     1             do        length        i
      C                   eval      thischar = %subst(chars:i:1)
      C                   select
       * If a valid number, increment count of valid numbers
      C                   when      %scan(thischar:validnbrs) » 0
      C                   eval      countnumbers = countnumbers + 1
      C                   if        countdecimal » 0
      C                   eval      countfraction = countfraction + 1
      C                   endif
       * Not a number.  If not - or decimal character, increment
       * count of invalid characters
      C                   when      %scan(thischar:validchars) = 0
      C                   eval      countinvalid = countinvalid + 1
       * If a minus sign, and not first or last character, increment
       * count of invalid characters
      C                   when      thischar = '-' and i » 1 and i « length
      C                   eval      countinvalid = countinvalid + 1
       * If a decimal point, increment count of decimal points
      C                   when      thischar = decpoint
      C                   eval      countdecimal = countdecimal + 1
      C                   endsl
      C                   enddo
       * If have more than 0 invalid characters, turn on invalid characters
       * indicator
      C                   if        countinvalid » 0
      C                   eval      invalidchrs = *on
      C                   eval      anyerrs = *on
      C                   endif
       * If have more than 1 decimal points, turn on multdecpts indicator
      C                   if        countdecimal » 1
      C                   eval      multdecpts = *on
      C                   eval      anyerrs = *on
      C                   endif
       * If have no valid numbers, turn on no numbers indicator
      C                   if        countnumbers = 0
      C                   eval      nonbrs = *on
      C                   eval      anyerrs = *on
      C                   endif
       * If no indicators on, number is valid so far.  Make sure no more than
       * maxDigitsX digits to the left of the decimal point, and no more than 9 digits
       * to the right of the decimal point.  If requested, check
       * that number of digits to the left of decimal point not greater
       * than maxDigitsx.
      C                   if        not anyerrs
      C                   if        countnumbers - countfraction » 21 or
      C                             countfraction » 9 or
      C                             countnumbers - countfraction » MaxDigitsX
      C                   eval      toobig = *on
      C                   eval      anyerrs = *on
      C                   endif
      C                   endif
       * If no errors and sign is negative, turn on indicator lessthan0
      C                   if        not anyerrs and
      C                             c2n2(chars) « 0
      C                   eval      lessthan0 = *on
      C                   endif
      C                   endif
 
       * Handle optional sending of messages
      C                   if        %parms » 2 and addmsgs
      C                   if        %parms » 4
      C                   eval      NegIsErr = NegIsError
      C                   else
      C                   eval      NegIsErr = *off
      C                   endif
      C                   if        anyerrs or
      C                             (lessthan0 and NegIsErr)
       *   Set up fields
      C                   if        %parms » 3
      C                   eval      FieldDesc = FieldDescription
      C                   else
      C                   eval      FieldDesc = ''
      C                   endif
       *   Write the error messages
      C                   if        FieldDesc «» ''
      C                   eval      rc = addmsg(FieldDesc:1)
      C                   endif
      C                   if        invalidchrs
      C                   eval      rc = addmsg('Has one or more invalid -
      C                             characters.':2)
      C                   endif
      C                   if        multdecpts
      C                   eval      rc = addmsg('Has more than one decimal -
      C                             point.':2)
      C                   endif
      C                   if        multsigns
      C                   eval      rc = addmsg('Has more than one minus -
      C                             sign.':2)
      C                   endif
      C                   if        nonbrs
      C                   eval      rc = addmsg('Has no numbers or is blank.':2)
      C                   endif
      C                   if        toobig
      C                   eval      rc = addmsg('Has too many digits to -
      C                             the left of the decimal point.  -
      C                             The maximum is ' +
      C                             %trim(%editc(MaxDigitsX:'Z')) + '.':2)
      C                   endif
      C                   endif
      C                   if        lessthan0 and NegIsErr
      C                   eval      rc = addmsg('Cannot be negative.':2)
      C                   endif
      C                   endif
 
       * Return the indicators
      C                   return    indicators
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
 
      Pchknbr           e
 
       **************************************************************************
       * xlatwCCSIDs (translate with CCSIDs) subprocedure
       **************************************************************************
       * Translates input data to output data using CCSIDs.
 
       * If optional parameters 3 and 4 are specified, their CCSIDs are used
       * and the toebcdic parameter is ignored.
 
       * Otherwise, the CCSIDS contained in environment variables CGI_EBCDIC_CCSID
       * and CGI_AS CII_CCSID are used and the direction of translation is as
       * specified by the toebcdic parameter (*on = to EBCDIC, *off = from EBCDIC).
 
      PxlatwCCSIDs      b                   export
      DxlatwCCSIDs      pi         32767    varying
      D  toebcdic                       n   value
      D  input                     32767    value varying
      D  fromCCSID                    10u 0 value options(*nopass)
      D  toCCSID                      10u 0 value options(*nopass)
 
       * variables to hold CCSIDs from environment variables
      DCCSIDASC         s             10u 0 static
      DCCSIDEBC         s             10u 0 static
       * variables for CDRCVRT API
      DCCSIDin          s             10u 0
      Dstrtype          s             10i 0 inz(0)                               not null terminated
      Dinputstr         s          32767
      Dinputlen         s             10i 0
      Doutputstr        s          32767
      Drtnlen           s             10i 0                                      length returned
      Dconvalt          s             10i 0 inz(0)                               installation dft
      Dreserved         s             10i 0                                      reserved
      Dfeedback         s             10i 0 dim(3) inz(0)
      DCCSIDout         s             10u 0
       * Whether subprocedure initialized
      Dinitialized      s               n   inz(*off) static
       * Return variable
      Doutput           s          32767    varying
 
      C                   if        not initialized
      C                   eval      initialized = *on
       * Prime the ASCII and EBCDIC CCSIDS using the server's CGI_EBCDIC_CCSID and
       * CGI_ASCII_CCSID environment variables.
      C                   eval      CCSIDEBC = %inth(c2n2(
      C                             getenv('CGI_EBCDIC_CCSID':qusec)))
      C                   eval      CCSIDASC = %inth(c2n2(
      C                             getenv('CGI_ASCII_CCSID':qusec)))
      C                   endif
      C                   if        %parms = 4
      C                   eval      CCSIDin = fromCCSID
      C                   eval      CCSIDout = toCCSID
      C                   else
       * Set CCSIDS to reflect conversion direction
      C                   if        toebcdic
      C                   eval      CCSIDin = CCSIDASC
      C                   eval      CCSIDout = CCSIDEBC
      C                   else
      C                   eval      CCSIDin = CCSIDEBC
      C                   eval      CCSIDout = CCSIDASC
      C                   endif
      C                   endif
       * Perform translation
      C                   eval      inputlen = %len(input)
      C                   eval      inputstr = %subst(input:1:inputlen)
      C                   call      'CDRCVRT'                                    cvt to EBCDIC char
      C                   parm                    CCSIDin
      C                   parm                    strtype
      C                   parm                    inputstr
      C                   parm                    inputlen
      C                   parm                    CCSIDout
      C                   parm                    strtype
      C                   parm                    convalt
      C                   parm                    inputlen
      C                   parm                    outputstr
      C                   parm                    rtnlen
      C                   parm                    reserved
      C                   parm                    feedback
       * Return result
      C                   eval      output = %subst(outputstr:1:rtnlen)
      C                   return    output
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
 
      PxlatwCCSIDs      e
 
       ******************************************************************
       * uppify subprocedure
       ******************************************************************
       * Converts lowercase characters to uppercase
 
       * Examples:
       *   eval charstring =  uppify(charstring)
       *        Uppify uses XLATE on English language characters
       *        a through z only.
       *   eval charstring =  uppify(charstring:0)
       *        Uppify uses SysConvertCase API with the characters
       *        in the job's CCSID
       *   eval charstring =  uppify(charstring:n)
       *        Uppify uses SysConvertCase API with the characters
       *        in CCSID n where n is a valid CCSID number.
 
       * If the optional parameter, CCSID, is not passed, the RPG
       * XLATE operation code is used with standard English language
       * characters.
 
       * When the CCSID parameter is passed, the characters operated
       * upon are all the lower case characters of the CCSID. If
       * the passed CCSID is 0, the job's CCSID is used.
 
       * If the CCSID causes an error, uppify tries to use the job's
       * CCSID.  It that fails, then it uses English language characters
       * only.  Any failures result in a message being forced into the
       * CGIDEBUG file.
 
       * Performance notes
       * -----------------
       * If you want the best possible performance and the
       * English language characters are sufficient, do
       * not use the CCSID parameter.
 
       * If you must use the CCSID parameter, use a specific
       * CCSID rather than 0 (job's CCSID).  Using a specific
       * CCSID takes about twice as long as no CCSID.  Using CCSID
       * 0 (job's CCSID) takes about 3 times as long as no
       * CCSID.
 
       * In order to maximize performance, all CGIDEV2 internal
       * uses of uppify use no CCSID parameter.  It is recommended
       * that you not use national language characters in section
       * names or substitution variable names.
 
      Puppify           b                   export
      Duppify           pi         32767    varying
      D  data                      32767    const varying options(*varsize)
      D  CCSID                        10i 0 const options(*nopass)
 
      D ThisSubProc     c                   'Uppify: '
 
       * For English only
      D EngLow          c                   'abcdefghijklmnopqrstuvwxyz'
      D EngUp           c                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
 
       * For CCSIDs
      D Uppercase       c                   0
      D ControlBlock    ds
      D  RqsType                      10i 0 inz(1)
      D  WkCCSID                            like(CCSID)
      D  Direction                    10i 0 inz(uppercase)
      D  Reserved                     10    inz(*allx'00')
      D Input           s          32767    varying
      D                 ds
      D Output                     32767    varying
      D OutputLn                       5u 0 overlay(Output:1)
      D OutputData                 32767    overlay(Output:3)
 
       * If no CCSID specified, use job's CCSID
      C                   if        %parms = 1
      C                   eval      output = data
      C     EngLow:EngUp  xlate     output        output
      C                   return                  output
      C                   endif
 
       * Use the CCSID that was passed.  If it fails, use job CCSID.  If it
       * fails, use English.
      C                   eval      input = data
      C                   eval      wkCCSID = CCSID
      C                   dou       qusbavl = 0 or wkccsid = 0
      C                   if        qusbavl » 0
      C                   eval      callerPgmLib = RtvPgmStack(2)
      C                   callp     WrtDebug(ThisSubproc + 'failed when -
      C                             using CCSID ' + %trim(%char(CCSID)) +
      C                             '. Message ID = ' + qusei +
      C                             '. Uppify now will use CCSID = 0. +
      C                              Program ' +
      C                             %trim(callerLib) + '/' + %trim(callerPgm) +
      C                             ' in job ' +
      C                             %trim(%subst(psdsdata:264:6)) + '/' +
      C                             %trim(%subst(psdsdata:254:10)) + '/' +
      C                             %trim(%subst(psdsdata:244:10)) +
      C                             '.':*on)
      C                   eval      wkccsid = 0
      C                   reset                   qusec
      C                   endif
      C                   eval      output = ''
      C                   callp     SysConvertCase(%addr(ControlBlock):
      C                             %addr(input)+2:%addr(OutputData):
      C                             %len(Input):qusec)
      C                   enddo
      C                   if        qusbavl = 0
      C                   eval      outputLn  = %len(input)
      C                   return    output
      C                   endif
       * CCSID failed, use XLATE and send a message
      C                   eval      output = data
      C     EngLow:EngUp  xlate     output        output
      C                   eval      callerPgmLib = RtvPgmStack(2)
      C                   callp     WrtDebug(ThisSubProc + 'failed when using -
      C                             CCSID = 0.  Message ID = ' +
      C                             qusei + '.  Uppify used XLATE with -
      C                             English characters only. +
      C                              Program ' +
      C                             %trim(callerLib) + '/' + %trim(callerPgm) +
      C                             ' in job ' +
      C                             %trim(%subst(psdsdata:264:6)) + '/' +
      C                             %trim(%subst(psdsdata:254:10)) + '/' +
      C                             %trim(%subst(psdsdata:244:10)) +
      C                             '.':*on)
      C                   return                  output
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
      Puppify           e
 
       ******************************************************************
       * LowFy subprocedure
       ******************************************************************
       * Converts uppercase characters to lowercase
 
       * Examples:
       *   eval charstring =  lowfy(charstring)
       *        Lowfy uses XLATE on English language characters
       *        a through z only.
       *   eval charstring =  lowfy(charstring:0)
       *        Lowfy uses SysConvertCase API with the characters
       *        in the job's CCSID
       *   eval charstring =  lowfy(charstring:n)
       *        Lowfy uses SysConvertCase API with the characters
       *        in CCSID n where n is a valid CCSID number.
 
       * If the optional parameter, CCSID, is not passed, the RPG
       * XLATE operation code is used with standard English language
       * characters.
 
       * When the CCSID parameter is passed, the characters operated
       * upon are all the lower case characters of the CCSID. If
       * the passed CCSID is 0, the job's CCSID is used.
 
       * If the CCSID causes an error, lowfy tries to use the job's
       * CCSID.  It that fails, then it uses English language characters
       * only.  Any failures result in a message being forced into the
       * CGIDEBUG file.
 
       * Performance notes
       * -----------------
       * If you want the best possible performance and the
       * English language characters are sufficient, do
       * not use the CCSID parameter.
 
       * If you must use the CCSID parameter, use a specific
       * CCSID rather than 0 (job's CCSID).  Using a specific
       * CCSID takes about twice as long as no CCSID.  Using CCSID
       * 0 (job's CCSID) takes about 3 times as long as no
       * CCSID.
 
       * In order to maximize performance, all CGIDEV2 internal
       * uses of lowfy use no CCSID parameter.  It is recommended
       * that you not use national language characters in section
       * names or substitution variable names.
 
      Plowfy            b                   export
      Dlowfy            pi         32767    varying
      D  data                      32767    const varying options(*varsize)
      D  CCSID                        10i 0 const options(*nopass)
 
      D ThisSubProc     c                   'Lowfy: '
 
       * For English only
      D EngLow          c                   'abcdefghijklmnopqrstuvwxyz'
      D EngUp           c                   'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
 
       * For CCSIDs
      D Lowercase       c                   1
      D ControlBlock    ds
      D  RqsType                      10i 0 inz(1)
      D  WkCCSID                            like(CCSID)
      D  Direction                    10i 0 inz(lowercase)
      D  Reserved                     10    inz(*allx'00')
      D Input           s          32767    varying
      D                 ds
      D Output                     32767    varying
      D OutputLn                       5u 0 overlay(Output:1)
      D OutputData                 32767    overlay(Output:3)
 
       * If no CCSID specified, use job's CCSID
      C                   if        %parms = 1
      C                   eval      output = data
      C     EngUp:EngLow  xlate     output        output
      C                   return                  output
      C                   endif
 
       * Use the CCSID that was passed.  If it fails, use job CCSID.  If it
       * fails, use English.
      C                   eval      input = data
      C                   eval      wkCCSID = CCSID
      C                   dou       qusbavl = 0 or wkccsid = 0
      C                   if        qusbavl » 0
      C                   eval      callerPgmLib = RtvPgmStack(2)
      C                   callp     WrtDebug(ThisSubproc + 'failed when -
      C                             using CCSID ' + %trim(%char(CCSID)) +
      C                             '. Message ID = ' + qusei +
      C                             '. Uppify now will use CCSID = 0. +
      C                              Program ' +
      C                             %trim(callerLib) + '/' + %trim(callerPgm) +
      C                             ' in job ' +
      C                             %trim(%subst(psdsdata:264:6)) + '/' +
      C                             %trim(%subst(psdsdata:254:10)) + '/' +
      C                             %trim(%subst(psdsdata:244:10)) +
      C                             '.':*on)
      C                   eval      wkccsid = 0
      C                   reset                   qusec
      C                   endif
      C                   eval      output = ''
      C                   callp     SysConvertCase(%addr(ControlBlock):
      C                             %addr(input)+2:%addr(OutputData):
      C                             %len(Input):qusec)
      C                   enddo
      C                   if        qusbavl = 0
      C                   eval      outputLn  = %len(input)
      C                   return    output
      C                   endif
       * CCSID failed, use XLATE and send a message
      C                   eval      output = data
      C     EngUp:EngLow  xlate     output        output
      C                   eval      callerPgmLib = RtvPgmStack(2)
      C                   callp     WrtDebug(ThisSubProc + 'failed when using -
      C                             CCSID = 0.  Message ID = ' +
      C                             qusei + '.  Uppify used XLATE with -
      C                             English characters only. +
      C                              Program ' +
      C                             %trim(callerLib) + '/' + %trim(callerPgm) +
      C                             ' in job ' +
      C                             %trim(%subst(psdsdata:264:6)) + '/' +
      C                             %trim(%subst(psdsdata:254:10)) + '/' +
      C                             %trim(%subst(psdsdata:244:10)) +
      C                             '.':*on)
      C                   return                  output
 
       ***********************************************************************
      C     *pssr         begsr
       ***********************************************************************
       * Program status subroutine
      C                   callp     wrtpsds(psds)
      C                   endsr
      Plowfy            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 rc              s             10i 0
      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
0.342 sec.s