**************************************************************************
* 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, 2006 *
* 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
* Prototype for Generate Pseudorandom Numbers
D GenPRN pr extproc('Qc3GenPRNs')
D PRNdata * value
D PRNlength 10u 0 const
D PRNtype 1 const
D PRNparity 1 const
D ErrorCode like(qusec)
***********************************************************************
* Random subprocedure
***********************************************************************
* Returns a random unsigned integer between low and high.
*
* Inputs: low end of range. Min=1 Max=maxrange
* high end of range Min=2 Max=maxrange + 1
* difference must be at least 2
* Maxrange is a constant, 2147483646, defined in module xxxrandom
*
* Uses CEERAN0. On first call, sets seed to 0 so that CEERAN0 uses GMT.
* On subsequent calls, uses seed as modified by previous calls to CEERAN0.
*
* Exceptions:
* If (abs(high - low) < 2) or (abs(high - low) > maxrange + 1)
* then range is changed to 1 to (maxrange + 1)
Prandom b export
Drandom pi 10u 0 Random number
D low 10u 0 value Low end of range
D high 10u 0 value High end of range
Drange s 10u 0
Dseed s 10u 0 static inz(0)
Dswap s 10u 0 For swapping
Dmaxrange c 2147483646
Dworkfloat s 8f
Dmax8 s 20u 0 inz(*hival)
Dworkdata s 20u 0
****************************************************************************
* Subprocedure logic
****************************************************************************
* Swap low and high if low > high
C if low > high
C eval swap = low
C eval low = high
C eval high = swap
C endif
* If low less than 0 or greater than maxrange, change it to 1
C if low < 0 or low > maxrange
C eval low = 1
C endif
* If high greater than maxrange + 1 or less than 2, change it to maxrange + 1
C if high > (maxrange + 1) or high < 2
C eval high = maxrange + 1
C endif
* If high and low are equal, change them to 1 and maxrange + 1
C if high = low
C eval low = 1
C eval high = maxrange + 1
C endif
* Calculate the range
C eval range = high - low + 1
* Generate random number.
C callp GenPRN(%addr(workdata):%size(workdata):
C '0':'0':qusec)
C eval workfloat = workdata / max8
* Return random number
C return %uns(workfloat * range) + low
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P random e
***********************************************************************
* RandomString subprocedure
***********************************************************************
* Returns a random, varying length string up to 1024 characters
* in length.
* You can select its format as shown below. The characters
* used are 0 - 9, a - z, and A - Z.
*
* Parameters
* - Number of characters to return (0 - 1024)
* If 0, a null string is returned.
* If > 1024, 1024 characters are returned.
* - First character (if not passed, defaults to *mixedDigit)
* - *upperLetter (upper case letter only)
* - *lowerLetter (lower case letter only)
* - *mixedLetter (upper or lower case letter only)
* - *upperDigit (upper case letter or digit)
* - *lowerDigit (lower case letter or digit)
* - *mixedDigit (upper or lower case letter or digit)
* - *digit (digit only)
* - Remaining characters (if not passed, defaults to *mixedDigit)
* - same choices as first character
* - UpperChars - characters that are "upper case")
* - If not passed or has length = 0,
* defaults to 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
* - LowerChars - characters that are "lower case")
* - If not passed or has length = 0,
* defaults to 'abcdefghijklmnopqrstuvwzyz'
* - DigitChars - characters that are "digits")
* - If not passed or has length = 0, defaults to '0123456789'
* -
* Returns
* - Varying string containing the random characters
P randomString b export
D randomString pi 1024 varying
D length 10u 0 value
D firstChar 12 value options(*nopass)
D remainChar 12 value options(*nopass)
D UpperChars 100 value varying options(*nopass)
D LowerChars 100 value varying options(*nopass)
D DigitChars 100 value varying options(*nopass)
D Digits s 100 varying inz('0123456789')
D Upper s 100 varying
D inz('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
D Lower s 100 varying
D inz('abcdefghijklmnopqrstuvwxyz')
D remainCharX s like(remainChar)
D firstCharX s like(firstChar)
D Test1 s 110 varying
D Test2 s 110 varying
D TheName s 1024 varying
D i s 10i 0
D r s 10i 0 dim(4)
****************************************************************************
* Subprocedure logic
****************************************************************************
* Handle length = 0 or length > 1024
C if length = 0
C return ''
C endif
C if length > 1024
C eval length = 1024
C endif
* Handle unpassed parms
C if %parms = 6 and %len(digitChars) > 0
C eval Digits = digitChars
C endif
C if %parms >= 5 and %len(lowerChars) > 0
C eval Lower = lowerChars
C endif
C if %parms >= 4 and %len(upperChars) > 0
C eval Upper = upperChars
C endif
C if %parms >= 3
C eval remainCharX= uppify(remainChar)
C endif
C if %parms >= 2
C eval firstCharX = uppify(firstChar)
C endif
C
* Set up test1 and test 2 to contain the valid characters
* for first character and remaining characters, respectively
C select
C when firstCharX = '*UPPERLETTER'
C eval test1 = Upper
C when firstCharX = '*LOWERLETTER'
C eval test1 = Lower
C when firstCharX = '*MIXEDLETTER'
C eval test1 = Upper + Lower
C when firstCharX = '*UPPERDIGIT'
C eval test1 = Upper + Digits
C when firstCharX = '*LOWERDIGIT'
C eval test1 = Lower + Digits
C when firstCharX = '*MIXEDDIGIT'
C eval test1 = Upper + Lower + Digits
C when firstCharX = '*DIGIT'
C eval test1 = Digits
C other
C eval test1 = Digits + Upper + Lower
C endsl
C select
C when remaincharX = '*UPPERLETTER'
C eval test2 = Upper
C when remaincharX = '*LOWERLETTER'
C eval test2 = Lower
C when remaincharX = '*MIXEDLETTER'
C eval test2 = Upper + Lower
C when remaincharX = '*UPPERDIGIT'
C eval test2 = Upper + Digits
C when remaincharX = '*LOWERDIGIT'
C eval test2 = Lower + Digits
C when remaincharX = '*MIXEDDIGIT'
C eval test2 = Upper + Lower + Digits
C when remaincharX = '*DIGIT'
C eval test2 = Digits
C other
C eval test2 = Digits + Upper + Lower
C endsl
* First character
C eval TheName =
C %subst(Test1:random(1:%len(test1)):1)
* Remaining characters
C for i = 2 to length
C eval TheName = TheName +
C %subst(Test2:random(1:%len(test2)):1)
C endfor
* Return result
C return TheName
***********************************************************************
C *pssr begsr
***********************************************************************
* Program status subroutine
C callp wrtpsds(psds)
C endsr
P RandomString e
|