Re: Productivity


"Pete Dashwood" <dashwood@xxxxxxxxxxxxxxxxxxxxxxxxx> wrote in message
news:4vlnqgF1c247oU1@xxxxxxxxxxxxxxxxxxxxx

OK, as promised here is a complete working program.

I really enjoyed doing this :-)

The hard parts were confining myself to the B margin and using upper case...

Fortunately the sun has come out and I'm off to a cocktail party so it might
not be perfect. I ran it and checked the output; (the ARGUMENTS array)... it
looked good.

You may need to remove all the *> comments if your compiler doesn't support
them; the rest should compile OK.

Should be able to cut and paste the code below directly into your editor. It
should run as written.

IDENTIFICATION DIVISION.
PROGRAM-ID. NVPARMS.
AUTHOR. PETER E. C. DASHWOOD.
DATE-WRITTEN. DECEMBER 30TH, 2006.
*REMARKS.
*
* A SET OF "PARAMETERS" MUST BE PARSED AND PRESENTED TO A
* PROGRAM
* FOR PROCESSING
*
* IN FACT, THESE ARE NOT "PARAMETERS" AT ALL BUT ARE REALLY
* AN INPUT
* FILE...
*
* NEVERTHELESS THE PROGRAM DEMONSTRATES SOME USES OF:
* UNSTRING
* COMPLEX PERFORM
* INSPECT
*
* THE COMPLETE PARAMETER SET IS STORED TO AN ARRAY DURING
* INITIALIZATION AS A 'ONE-TIME' TASK.
*
* THIS ARRAY COULD BE VALIDATED DURING INITIALIZATION ALSO,
* AND ENTRIES IN IT CROSS-REFERENCED IF REQUIRED.
*
* BY ISOLATING THE CODE TO LOAD THE ARGUMENTS INTO THE
* INITIALIZATION
* PART OF THE PROGRAM, THIS CODE COULD BE USED IN ANY PROGRAM
* THAT HAD A SIMILAR PARAMETER FORMAT. DOING IT FROM THE
* MAINLINE ON A PARAMETER BY PARAMETER BASIS PREVENTS THIS.
*

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-PC.
OBJECT-COMPUTER. IBM-PC.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 ARGUMENTS.
12 NAME-VALUE-PAIR OCCURS 40
INDEXED BY ARGS-X1.
15 ARG-NAME PIC X(25).
15 ARG-VALUE PIC X(25).
15 ARG-EOG PIC X. *> INDICATES THAT THIS ENTRY IS
*> THE END OF A "GROUP" OF
*> PARAMETERS.

88 ARG-END-OF-GROUP VALUE '1'.

01 ARGS-TABLE-LIMIT PIC S9(4) COMP VALUE 40.
*> MUST MATCH VALUE IN OCCURS ABOVE.

01 IN-DATA.
12 FILLER PIC X(50) VALUE
"userId=FJS¦location=AURO¦function=filmRequest¦acct".
12 FILLER PIC X(50) VALUE
"Number=1234567890¦userExtension=1403¦routing=branc".
12 FILLER PIC X(50) VALUE
"h¦routeLoc=K-MISS¦routeAttn=Joe¦comments=Comments ".
12 FILLER PIC X(50) VALUE
"Go Here¦debit¦date=121306¦amount=100.00¦sequenceNb".
12 FILLER PIC X(50) VALUE
"r=12345678¦¦credit¦date=051406¦amount=900.00¦seque".
12 FILLER PIC X(50) VALUE
"nceNbr=11122233¦¦ATM¦date=010106¦amount=123.45¦¦ch".
12 FILLER PIC X(50) VALUE
"argeback¦date=010106¦amount=500.00¦¦statement¦date".
12 FILLER PIC X(50) VALUE
"=032906¦amount=1000.00¦ ".
01 INPUT-DATA REDEFINES IN-DATA PIC X(400).


01 VARIOUS-COUNTS USAGE COMP.
12 MAX-ARGUMENTS PIC S9(4).
12 INPUT-DATA-POS PIC S9(4).
12 STRING-PARM-LEN PIC S9(4).
12 MYTALLY1 PIC S9(4).
12 MYTALLY2 PIC S9(4).
12 INPUT-DATA-LENGTH PIC S9(4).
12 NUMBER-NAME-VALUE-PAIRS PIC S9(4).


01 VARIOUS-OTHER-DATA.
12 INPUT-STRING-ID PIC X(25).
12 INPUT-STRING-PARM PIC X(25).
12 NV-WORK PIC X(60).
12 MSG-FIELD-DELIMITER PIC X VALUE "¦".
12 MSG-FIELD-SEPARATOR PIC X VALUE "=".

01 FLAGS.
12 FINISH-FLAG PIC X VALUE SPACE.
88 FINISHED VALUE '1'.
88 NOT-FINISHED VALUE '0'.
12 REQUEST-FLAG PIC X VALUE SPACE.
88 END-OF-REQUEST VALUE '1'.
88 NOT-END-OF-REQUEST VALUE '0'.



PROCEDURE DIVISION.
MAIN SECTION.
000.
PERFORM 100-INITIAL-SETUP
PERFORM 200-PROCESSING UNTIL FINISHED
* PERFORM 900-CLOSE-DOWN
STOP RUN
.
*>===========================================================
100-INITIAL-SETUP SECTION.
110-IS.
SET NOT-FINISHED TO TRUE
PERFORM 2000-LOAD-ARGUMENTS
*> IN THIS SCENARIO THE ARGUMENTS ARE PARSED AND LOADED
*> ONCE
*> DURING INITIALIZATION.
*>
*> IT IS A GENERAL PURPOSE LOAD ROUTINE. (WORKS FOR ANY
*> PROGRAM WITH PARAMETERS IN THE NAME=VALUE FORMAT).
*>
*>
*> ON COMPLETION ALL ARGUMENTS HAVE BEEN LOADED INTO THE
*> "ARGUMENTS" ARRAY. GROUPS OF ARGUMENTS THAT REPRESENT
*> A "RECORD" WILL HAVE THE GROUP FLAG SET IN THE LAST NAME
*> /VALUE PAIR OF THE GROUP
*>
*> INPUT-STRING-ID AND INPUT-STRING-PARM CAN BE LOADED FROM
*> THIS
*> ARRAY USING THE ARGS-X1 INDEX. THIS IS DONE BY PERFORMING
*> 2100-PARSE-INPUT-DATA.
*>
.
199-IS.
EXIT.
*>================================================================

200-PROCESSING SECTION.
210-P.
*> VARIOUS PROCESSING OCCURS HERE...

PERFORM 2100-PARSE-INPUT-DATA *> GET THE NEXT NAME/VALUE
*> PAIR

*> PROCESSING CONTINUES....USING INPUT-STRING-ID
*> AND INPUT-STRING-PARM
*> AS AT PRESENT.

SET FINISHED TO TRUE
.
299-P.
EXIT.
*>==============================================================
*>
*> SUBROUTINES ACTIVATED FROM ABOVE...
*>
*>==============================================================
2000-LOAD-ARGUMENTS SECTION.
2000-LA-000.
*> THE FOLLOWING CODE PARSES THE NAME/VALUE PAIRS IN
*> INPUT-DATA
*> AND LOADS THEM INTO THE ARGUMENTS ARRAY.
*>
MOVE SPACES TO ARGUMENTS
IF INPUT-DATA (1:1) = MSG-FIELD-DELIMITER
MOVE 2 TO INPUT-DATA-POS *> STEP OVER FIRST FIELD
*> DELIMITER
*> IF ONE IS PRESENT
ELSE
MOVE 1 TO INPUT-DATA-POS
END-IF
COMPUTE INPUT-DATA-LENGTH = FUNCTION STORED-CHAR-LENGTH
(INPUT-DATA)
*> IF YOUR ENVIRONMENT DOESN'T SUPPORT THE ABOVE
*> INTRINSIC FUNCTION, YOU WILL NEED TO ESTABLISH
*> THE TOTAL LENGTH OF THE PARAMETER STRINGS
*> IN "INPUT-DATA" USING "INSPECT" OR ONE OF THE
*> TECHNIQUES DISCUSSED IN CLC
MOVE ARGS-TABLE-LIMIT TO MAX-ARGUMENTS
PERFORM
VARYING ARGS-X1
FROM 1
BY 1
UNTIL ARGS-X1 > MAX-ARGUMENTS OR
INPUT-DATA-POS > INPUT-DATA-LENGTH
MOVE SPACES TO NV-WORK
UNSTRING
INPUT-DATA
DELIMITED BY MSG-FIELD-DELIMITER
INTO NV-WORK
COUNT IN STRING-PARM-LEN
WITH POINTER INPUT-DATA-POS
END-UNSTRING
IF INPUT-DATA (INPUT-DATA-POS:1) =
MSG-FIELD-DELIMITER
SET ARG-END-OF-GROUP (ARGS-X1) TO TRUE
ADD 1 TO INPUT-DATA-POS
END-IF
MOVE ZERO TO MYTALLY1
INSPECT NV-WORK
TALLYING MYTALLY1 FOR CHARACTERS
BEFORE MSG-FIELD-SEPARATOR
IF MYTALLY1 = STRING-PARM-LEN
MOVE NV-WORK (1: MYTALLY1)
TO ARG-NAME (ARGS-X1)
MOVE SPACES TO ARG-VALUE (ARGS-X1)
ELSE
MOVE NV-WORK (1: MYTALLY1)
TO ARG-NAME (ARGS-X1)
MOVE NV-WORK (MYTALLY1 + 2: STRING-PARM-LEN
- MYTALLY1 + 1)
TO ARG-VALUE (ARGS-X1)
END-IF
END-PERFORM
SET NUMBER-NAME-VALUE-PAIRS TO ARGS-X1
SUBTRACT 1 FROM NUMBER-NAME-VALUE-PAIRS
SET ARGS-X1 TO 1 *> SET INDEX FOR USE FROM MAINLINE CODE
SET ARGS-X1 DOWN BY 1
.
2000-LA-999.
EXIT.
*>==============================================================
2100-PARSE-INPUT-DATA SECTION.
2100-PID-000.
*> THIS CODE LOADS INPUT-STRING-ID AND INPUT-STRING-PARM WITH
*> THE NEXT
*> VALID NAME/VALUE PAIR.
*> IT DOESN'T PARSE THE INPUT-DATA BUT THE EFFECT IS THE SAME AS
*> IF IT HAD...
SET ARGS-X1 UP BY 1
IF ARGS-X1 NOT > NUMBER-NAME-VALUE-PAIRS
MOVE ARG-NAME (ARGS-X1) TO INPUT-STRING-ID
MOVE ARG-VALUE (ARGS-X1) TO INPUT-STRING-PARM
IF ARG-END-OF-GROUP (ARGS-X1)
SET END-OF-REQUEST TO TRUE
ELSE
SET NOT-END-OF-REQUEST TO TRUE
END-IF
ELSE
MOVE SPACE TO INPUT-STRING-ID
INPUT-STRING-PARM
END-IF
.
2100-PID-999.
EXIT.
*>============================ END OF PROGRAM ===================

Cheers,

Pete.


.

Quantcast