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