‚*--------------------------------------------------------------------* ‚* Created on: April 27th, 2009. * ‚* Created by: Robert Hicks * ‚* Reason : String type procedures module. * ‚*--------------------------------------------------------------------* ‚*--------------------------------------------------------------------* ‚* COPYRIGHT (C) 2009 ROBERT HICKS. ALL RIGHTS RESERVED. * ‚* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS * ‚* AS IS AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, * ‚* BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF * ‚* MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE * ‚* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS * ‚* LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, * ‚* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * ‚* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; * ‚* LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) * ‚* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN * ‚* CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE * ‚* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS * ‚* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * ‚* SUCH DAMAGE. * ‚*--------------------------------------------------------------------* ‚*--------------------------------------------------------------------* ‚* MODIFICATIONS: * ‚* * ‚* Date Changed by Spec. # Description of changes * ‚* ---------- ---------- ---------- -------------------------------- * ‚*--------------------------------------------------------------------* ‚** ‚* Define the header specifications. HNOMAIN HDatFmt(*ISO) TimFmt(*HMS) BNDDIR('QC2LE') Option(*NoDebugIO) ‚** ‚* Prototypes. /COPY #FREESRC,M_STR.H ‚** ‚* Include templates. /COPY #FREESRC,M_STR_SCB1 ‚** ‚* Include constants. /COPY #FREESRC,M_STR_CCB1 ‚*--------------------------------------------------------------------* ‚* PROCEDURE: CVTOU - Convert a string to upper case. This can be * ‚* used for different CCSID's. * ‚* * ‚* The error parameter and the CCSID are optional. * ‚*--------------------------------------------------------------------* PCVTTOU B Export D PI 32767 Varying D $InputStr 32767 Value Varying D #InputLen 10I 0 Value D $Error Options(*NoPass: *Omit) D LikeDS($GenErr_t) D #CCSID 10I 0 Value Options(*NoPass) ‚** ‚* Work fields. D$ReqCB DS LikeDS($ReqCB01_t) D$OutputStr S 32767 D$wError DS LikeDS($Error) D#wCCSID S Like(#CCSID) /Free // Set default values. $wError.#BytAvl = 0; $wError.#BytPrv = %Size($wError); // Move #CCSID. If %Parms > 3; #wCCSID = #CCSID; EndIf; // Convert the character. $ReqCB.#ReqType = 1; $ReqCB.#CaseReq = C_#Upper; $ReqCB.#CCSID = #wCCSID; $ReqCB.$Resv = *ALLX'00'; QlgConvertCase($ReqCB: $InputStr: $OutputStr: #InputLen: $wError); // Return error string. If %Parms > 2 AND %Addr($Error) <> *Null; $Error = $wError; EndIf; // Return the converted string. If #InputLen > 0; Return %SubSt($OutputStr: 1: #InputLen); Else; $OutputStr = *BLANKS; Return $OutputStr; EndIf; /End-Free PCVTTOU E ‚*--------------------------------------------------------------------* ‚* PROCEDURE: CVTOL - Convert a string to lower case. * ‚* * ‚* The error parameter and the CCSID are optional. * ‚*--------------------------------------------------------------------* PCVTTOL B Export D PI 32767 Varying D $InputStr 32767 Value Varying D #InputLen 10I 0 Value D $Error Options(*NoPass: *Omit) D LikeDS($GenErr_t) D #CCSID 10I 0 Value Options(*NoPass) ‚** ‚* Work fields. D$ReqCB DS LikeDS($ReqCB01_t) D$OutputStr S 32767 D$wError DS LikeDS($Error) D#wCCSID S Like(#CCSID) /Free // Set default values. $wError.#BytAvl = 0; $wError.#BytPrv = %Size($wError); // Move #CCSID. If %Parms > 3; #wCCSID = #CCSID; EndIf; // Convert the character. $ReqCB.#ReqType = 1; $ReqCB.#CaseReq = C_#Lower; $ReqCB.#CCSID = #wCCSID; $ReqCB.$Resv = *ALLX'00'; QlgConvertCase($ReqCB: $InputStr: $OutputStr: #InputLen: $wError); // Return error string. If %Parms > 2 AND %Addr($Error) <> *Null; $Error = $wError; EndIf; // Return the converted string. If #InputLen > 0; Return %SubSt($OutputStr: 1: #InputLen); Else; $OutputStr = *BLANKS; Return $OutputStr; EndIf; /End-Free PCVTTOL E ‚*--------------------------------------------------------------------* ‚* PROCEDURE: GENSTR - Return if a string has leading/trailing * ‚* marker. * ‚* * ‚* The only required parameter is the input * ‚* string. * ‚*--------------------------------------------------------------------* PGENSTR B Export D PI N D $InputStr 32767 Value Varying D $LeadMarker N Options(*NoPass: *Omit) D $TrailMarker N Options(*NoPass: *Omit) D $Marker 1 Value Options(*NoPass) ‚** ‚* Work fields. D$wMarker S Inz(C_$Marker) Like($Marker) D$wLeadMarker S Inz('0') Like($LeadMarker) D$wTrailMarker S Inz('0') Like($TrailMarker) D#StrLen S 5I 0 Inz(0) /Free // Set the marker value. If %Parms > 3; $wMarker = $Marker; EndIf; // Check for a leading generic string. $InputStr = %Trim($InputStr); #StrLen = %Len(%TrimR($InputStr)); If %Len($InputStr) > 0; $wLeadMarker = %SubSt($InputStr: 1: 1) = C_$Marker; $wTrailMarker = %SubSt($InputStr: #StrLen: 1) = C_$Marker; EndIf; // Return if leading generic. If %Parms > 1 AND %Addr($LeadMarker) <> *Null; $LeadMarker = $wLeadMarker; EndIf; // Return if trailing generic. If %Parms > 2 AND %Addr($TrailMarker) <> *Null; $TrailMarker = $wTrailMarker; EndIf; // Return if generic string was found. Return $wLeadMarker OR $wTrailMarker; /End-Free PGENSTR E ‚*--------------------------------------------------------------------* ‚* PROCEDURE: RNDSTR - Return random string of characters. * ‚* * ‚* The replacement string ($RPLSTR) is the * ‚* only optional parameter. If it's not * ‚* passed, the procedure uses it's own * ‚* characters to produce a random string. * ‚*--------------------------------------------------------------------* PRNDSTR B Export D PI 10I 0 D $RtnStr 32767 Options(*VarSize) D #RtnLen 10I 0 Value D $RplStr 256 Value Options(*NoPass) ‚** ‚* Constants. DC_$DftSeedStr C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ- D abcdefghijklmnopqrstuvwxyz0- D 1234567890!@#$%¢&*()_+|\}¦- D {¬":;/?.>,<' ‚** ‚* Work fields. D#Idx1 S 10I 0 Inz(0) D$wRtnStr S Like($RtnStr) Inz(' ') D#RtnCode S 10I 0 Inz(C_#Success) D$wRplStr S Like($RplStr) Inz(C_$DftSeedStr) D#wRplStrLen S 10I 0 Inz(0) D#Seed S 10I 0 Inz(0) D#RndNbr S 8F D#NewNbr S 5U 0 Inz(0) /Free // Set default values. If %Parms > 2; $wRplStr = $RplStr; EndIf; #wRplStrLen = %Len(%TrimR($wRplStr)); // Return length must be valid. If #RtnLen < 0 OR #RtnLen > %Len($RtnStr); #RtnCode = C_#Error; EndIf; // Calculate the new random string. If #RtnCode = C_#Success; For #Idx1 = 1 TO #RtnLen; CEERAN0(#Seed: #RndNbr: *Omit); #NewNbr = (#RndNbr * #wRplStrLen) + 1; %SubSt($wRtnStr: #Idx1) = %SubSt($wRplStr: #NewNbr: 1); EndFor; EndIf; // Return if successful. If #RtnCode = C_#Success; %SubSt($RtnStr:1: #RtnLen) = %SubSt($wRtnStr: 1: #RtnLen); EndIf; Return #RtnCode; /End-Free PRNDSTR E ‚*--------------------------------------------------------------------* ‚* PROCEDURE: RNDNBR - Return random number. * ‚*--------------------------------------------------------------------* PRNDNBR B Export D PI 10I 0 D #RtnNbr 10I 0 D #MaxNbr 10I 0 Value ‚** ‚* Work fields. D#Idx1 S 10I 0 Inz(0) D#RtnCode S 10I 0 Inz(C_#Success) D#wMaxNbr S 10I 0 Inz(*HIVAL) D#Seed S 10I 0 Inz(0) D#RndNbr S 8F D#NewNbr S 10I 0 Inz(0) /Free // Set default values. If %Parms > 1; #wMaxNbr = #MaxNbr; EndIf; // Return length must be valid. If #MaxNbr <= 0 ; #RtnCode = C_#Error; EndIf; // Calculate the new random string. If #RtnCode = C_#Success; CEERAN0(#Seed: #RndNbr: *Omit); #NewNbr = (#RndNbr * #wMaxNbr) + 1; EndIf; // Return if successful. If #RtnCode = C_#Success; #RtnNbr = #NewNbr; EndIf; Return #RtnCode; /End-Free PRNDNBR E