SeanHoppe.com › EXTOL EDI Examples › EXTOL External Call RPG Programs › EXTOL RPG Program: EXPARSER
H/TITLE Parse input string on word breaks; call repeatedly
H Y
Z* CRTRPGPGM
Z* OPTION(*NOXREF) GENOPT(*OPTIMIZE)
*
W* Warning: This program does not set on the LR indicator
*
*
E DI 80 1 param string
E DO 80 1 param string
*
I DS
* Parameter strings as arrays
I 1 80 DI
I 1 80 DIF
I DS
I 1 80 DO
I 1 80 DOF
I DS
I 1 1 DQ1CH
I 2 2 DQ2CH
I 1 10DQ1
I 1 20DQ2
I 1 12 DQF
I 3 12 TESTIN
*
I DS
* Default string for testing for break points:
I I ' ,;-()/\!?' 1 10 TESTDF
* Parameter declarations
I DS
* I : Code trans directions 1
I 1 1 P1CDTT
* I : Code table reference 10
I 2 11 P2TABL
* B : Code in standard form 80
I 12 91 P3CDST
* B : Code qualifier data 80
I 92 171 P4CDQD
* B : Code in local form 80
I 172 251 P5CDLC
*
/EJECT
*****************************************************************
* Entry parameters
C *ENTRY PLIST
C PARM P0RTN 7
C P1CDTT PARM WP0001 1 Code trans dire
C P2TABL PARM WP0002 10 Code table refe
C P3CDST PARM P3CDST WP0003 80 Code in standar
C P4CDQD PARM P4CDQD WP0004 80 Code qualifier
C P5CDLC PARM P5CDLC WP0005 80 Code in local f
*****************************************************************
*
* Reset output to blanks
C MOVE *BLANKS P5CDLC
* CASE: PAR.Code trans directions is Inward translation
C P1CDTT IFEQ 'I'
*
* The qualifier specifies what kind of parsing is to be done.
* It should be a left-justified one- or two-digit number on the
* first call for a given input string, and blanks for each repeat
* call for the same input string.
*
* On the first call:
* Initialize the "desired output length" to the qualifier value.
* Save the input string & (if specified) the "break" characters.
* Return the characters starting in position 1 up to the maximum
* length possible within the "desired output length" without
* breaking up words.
* On the repeat calls:
* Use the saved value of the "desired output length", and the
* saved position where the last output string ended.
* Return the characters starting from the last ending position +1
* up to the "desired output length" without breaking up words.
*
* Check qualifier value:
C MOVELP4CDQD DQF
C DQ1CH IFGE '0'
* Numeric qualifier - re-initialize for new input string
C Z-ADD1 IS 30 start position
* Use Code in standard form as input
C MOVELP3CDST DIF
* Use qual characters 3-12 as test characters, use defaults if blank
C TESTIN IFNE *BLANK
C MOVELTESTIN TEST 10 use qual input
C ELSE
C MOVELTESTDF TEST use defaults
C END
*
* Convert 1 or 2-digit string to ID = "desired output length"
C DQ2CH IFGE '0'
C Z-ADDDQ2 ID 30 if 2-digit
C ELSE
C Z-ADDDQ1 ID if 1-digit
C END
C ID IFLT 1 limit to min=1
C Z-ADD1 ID
C END
C ID IFGT 80 limit to max=80
C Z-ADD80 ID
C END
*
* End of initialization on new string:
C END
* Initialize output work variable:
C MOVE *BLANKS DOF
* Skip with no error if start position IS is > 80 (past end)
* (It will be >80 if called after entire string has been parsed)
C IS IFGT 80 skip
* A "Return code" of blank means there is no error
C MOVEL*BLANK P0RTN *Return code
C ELSE
*
* Find desired end position:
C IS ADD ID IE 30 end position +1
C SUB 1 IE end position
* Save original length:
C Z-ADDID IL 30 actual length
* Adjust if over limit:
C IE IFGE 80 limit to max=80
C Z-ADD80 IE
C IE SUB IS IL length -1
C ADD 1 IL length
C END
* Save original end point:
C Z-ADDIE IE1 30
*
* Get substring from IS through IE constrained by word
* breaks, if possible. (If not possible, just break words.)
C IS IFGT 0 skip
C IL ANDGT0 pathological
C IE ANDGEIS cases...
* Determine last blank character position (or other breakpoint):
C MOVELDI,IE DIIE 1 (performance)
* The CHECK will set NOT to 1 if DIEE is NOT found in TEST:
C TEST CHECKDIIE NOT 10
* (NOT will be zero if the character IS in TEST)
C IE DOWGEIS
C NOT ANDNE0
C SUB 1 IE
C SUB 1 IL
C IE IFGE 1
C MOVELDI,IE DIIE
C TEST CHECKDIIE NOT
C END
C END
* Check whether a breakpoint was found:
C IE IFLT IS
* If no breaks found, cannot break. Use original ID (br eak words):
C Z-ADDID IL actual length
C Z-ADDIE1 IE actual end
C ELSE
* Otherwise, break before '('; break on others:
C DI,IE IFEQ '('
C IE ANDGTIS
C SUB 1 IE
C SUB 1 IL
C END
*
C END
* Extract substring of length IL starting at IS:
C IL SUBSTDIF:IS DOF P
* A "Return code" of blank means there is no error
C MOVEL*BLANK P0RTN *Return code
* Set up for next call - end point + 1 => next start point
C IE ADD 1 IS
*
C ELSE
* If here, "pathological" case (probably invalid qualifier constant)
* A "Return code" of non-blank will be logged as a translation error:
C MOVEL'PARSER' P0RTN *Return code
C END
*
C END
* Move to output parm:
C MOVELDOF P5CDLC
*
C ELSE
* CASE: PAR.Code trans directions is Outward translation
C P1CDTT IFEQ 'O'
* (not intended for outward; just pass local to standard...)
C MOVELP5CDLC P3CDST
* A "Return code" of blank means there is no error
C MOVEL*BLANK P0RTN *Return code
C END
*
C END
*
* Exit program - leave active (*INLR is off)
C RETRN