**************************************************************************
* 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
|