Printing 1099’s in Cobol, circa 1991

20 years ago, this is how we printed 1099’s…Many liked to call Cobol “wordy” but it was more accurate to say “self documenting”:

MOVE YTD-FED-GROSS-FINAL TO DATA-2 IN LINE-1.
WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 6.

“Look Mom, no need for comments”:

IDENTIFICATION DIVISION.

       PROGRAM-ID.  PRR1099.

      *    PRINT PAYROLL 1099 FORMS
      * 11/25/91  JOHN WATSON - CREATED.

           COPY HEADER OF CBLCPYSRC SUPPRESS.

       SPECIAL-NAMES.  LOCAL-DATA IS WS.

       INPUT-OUTPUT SECTION.

       FILE-CONTROL.

           COPY ADM1SL OF CBLCPYSRC SUPPRESS.

           SELECT EMPLFILE ASSIGN TO DATABASE-PRCYTDPF
               ORGANIZATION IS SEQUENTIAL
               ACCESS MODE IS SEQUENTIAL
               FILE STATUS IS IO-STATUS.

           SELECT SCRNFILE ASSIGN TO WORKSTATION-PRRPTSSC-SI
               ORGANIZATION IS TRANSACTION.

           SELECT PRNTFILE ASSIGN TO PRINTER-TRCSPRTF.

       DATA DIVISION.

       FILE SECTION.

           COPY SCRNFD OF CBLCPYSRC SUPPRESS.

           COPY PRNTFD OF CBLCPYSRC SUPPRESS.

       FD  ADM1FILE.
       01  ADM1-REC.
               COPY DD-ADM1DATA OF ADM1FILE.

       FD  EMPLFILE.
       01  EMPL-REC.
               COPY DD-EMPLDATA OF PRCYTDPF.
                                                             EJECT.
       WORKING-STORAGE SECTION.

       77  X                           PIC 999.
       77  LIMITER                     PIC X  VALUE "*".

       01  FILE-STATUS.
           03  ADM1FILE-STATUS         PIC XX.
           03  IO-STATUS               PIC XX.

       01  PROGRAM-FLAGS.
           03  END-FILE-FLAG           PIC 9.

       01  PROGRAM-COUNTERS.
           03  1099-COUNT              PIC 9(5).
           03  FORM-COUNT              PIC 9.

       01  FINAL-TOTAL-FIELDS.
           03  STATE-GROSS-FINAL       PIC S9(8)V99   COMP-3.
           03  FED-GROSS-FINAL         PIC S9(8)V99   COMP-3.
           03  YTD-STATE-TAX-FINAL     PIC S9(8)V99   COMP-3.
           03  YTD-FED-TAX-FINAL       PIC S9(8)V99   COMP-3.

       01  ERROR-MESSAGE-LINES.
           03  CONFIRM-SCREEN-MESSAGE.
               05  CONFIRM-SCREEN-MESSAGE-1      PIC X(49) VALUE SPACES.
               05  CONFIRM-SCREEN-MESSAGE-2      PIC X(21) VALUE
                   "CONFIRM DATA ENTERED.".

           COPY ZBEGINDD OF CBLCPYSRC SUPPRESS.

       01  SCREEN-RECORD-IN.
           03  PAGE1-IN.
               COPY DD-W2S01 OF PRRPTSSC.

       01  ERROR-SCREEN-IN.
           03  PAGEERROR-IN.
               COPY DD-ERRORSCR OF PRRPTSSC SUPPRESS.

           COPY XPRNTDD OF CBLCPYSRC.

       01  LINE-1.
           03                          PIC X(6).
           03  DATA-1                  PIC X(32).
           03                          PIC X(3).
           03  DATA-2                  PIC -------9.99.
           03                          PIC X(3).
           03  DATA-3                  PIC -------9.99.

       01  LINE-2.
           03                          PIC X(6).
           03  DATA-1                  PIC X(32).
           03                          PIC X(12).
           03  DATA-2                  PIC X.
           03                          PIC X(13).
           03  DATA-3                  PIC X.

       01  LINE-3.
           03                          PIC X(6).
           03  DATA-1                  PIC X(15).
           03                          PIC X(2).
           03  DATA-2                  PIC X(15).
           03                          PIC X(3).
           03  DATA-3                  PIC -------9.99.
           03                          PIC X(3).
           03  DATA-4                  PIC -------9.99.

       01  LINE-4.
           03                          PIC X(6).
           03  DATA-1                  PIC X(32).
           03                          PIC X(2).
           03  DATA-2                  PIC X.
           03                          PIC X(9).
           03  DATA-3                  PIC X.

       01  LINE-5.
           03                          PIC X(6).
           03  DATA-1                  PIC X(32).
           03                          PIC X(3).
           03  DATA-2                  PIC -------9.99.
           03                          PIC X(2).
           03  DATA-3                  PIC X(13).
                                                             EJECT.
       PROCEDURE DIVISION.
       DECLARATIVES.
           COPY ADM1ERR OF CBLCPYSRC SUPPRESS.

       EMPLFILE-ERROR SECTION.
           USE AFTER ERROR PROCEDURE ON EMPLFILE.
       EMPLFILE-DECL.
               MOVE "EMPL" TO ERROR-FILE
               MOVE IO-STATUS TO ERROR-CODE
               MOVE FILE-ERROR-MESSAGE TO ERROR-LINE-1 OF ERRORSCR-O
               WRITE SCREEN-RECORD FROM PAGEERROR-IN FORMAT "ERRORSCR"
                   INDICATORS ARE SCREEN-INDICATORS
               READ SCRNFILE RECORD INTO PAGEERROR-IN FORMAT "ERRORSCR"
                   INDICATORS ARE SCREEN-INDICATORS
               STOP RUN.
       END DECLARATIVES.
                                                             EJECT.
       MAIN SECTION.

       CLEAR-SCREEN.
           MOVE "PRR1099 - 1099 FORMS" TO PROGRAM-NAME OF ERRORSCR-O.
           OPEN I-O    SCRNFILE
                INPUT  ADM1FILE, EMPLFILE
                OUTPUT PRNTFILE.

           COPY ZBEGIN OF CBLCPYSRC.

           INITIALIZE PROGRAM-FLAGS, PROGRAM-COUNTERS, 
                      FINAL-TOTAL-FIELDS.

           READ ADM1FILE RECORD.

       SET-UP.
           MOVE SPACES TO SCREEN-RECORD-IN.
           INITIALIZE W2S01-O.
           MOVE 1 TO START-W2-NO OF W2S01-I.

       ACCEPT-1.
           WRITE SCREEN-RECORD FROM PAGE1-IN FORMAT "W2S01"
               INDICATORS ARE SCREEN-INDICATORS.
           READ SCRNFILE RECORD INTO PAGE1-IN FORMAT "W2S01"
               INDICATORS ARE SCREEN-INDICATORS.
           IF SCR-IND(93) = B"1"
               GO TO END-PROGRAM.

           IF START-W2-NO OF W2S01-I = ZERO
               MOVE "INVALID CONTROL NUMBER.  RE-ENTER."
                   TO ERRLINE OF W2S01-I
               GO TO ACCEPT-1.
                                                             EJECT.
       READ-EMPLFILE.
           READ EMPLFILE NEXT RECORD
               AT END MOVE 1 TO END-FILE-FLAG
               GO TO CHECK-SUBTOT-FLAG.

       CHECK-START-1099-NO.
           MOVE 0 TO SUBTOT-FLAG.
           ADD 1 TO 1099-COUNT.
           IF START-W2-NO OF W2S01-I GREATER THAN 1099-COUNT
               GO TO ACCUM-1.

       CHECK-FIRST-PRINTING.
           IF FIRST-PRINTING = 1
               GO TO MOVE-DATA.
           WRITE PRINT-RECORD FROM BLANK-LINE BEFORE ADVANCING 5.
           MOVE 1 TO FIRST-PRINTING.

           INITIALIZE LINE-1.
           MOVE SCHOOL-NAME TO DATA-1 IN LINE-1.
           MOVE EMP-YTD-FED-GROSS TO DATA-2 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-2 BEFORE ADVANCING 1.

           INITIALIZE LINE-1.
           MOVE SCHOOL-ADDR-1 TO DATA-1 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-2 BEFORE ADVANCING 1.

           MOVE SCHOOL-ADDR-2 TO DATA-1 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-3 BEFORE ADVANCING 1.

           MOVE SCHOOL-ADDR-3 TO DATA-1 IN LINE-1.
           MOVE EMP-YTD-FED-GROSS TO DATA-2 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-3 BEFORE ADVANCING 6.

           INITIALIZE LINE-2.
           MOVE FEDERAL-ID TO DATA-1 IN LINE-2.
           MOVE SOC-SEC-NO TO DATA-2 IN LINE-2.
           MOVE EMP-YTD-FED-TAX TO DATA-4 IN LINE-2.
           WRITE PRINT-RECORD FROM LINE-2 BEFORE ADVANCING 3.

           INITIALIZE LINE-1.
           MOVE EMP-FULL-NAME TO DATA-1 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 3.

           INITIALIZE LINE-1.
           MOVE ADDR-LINE-1 TO DATA-1 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 1.

           MOVE ADDR-LINE-2 TO DATA-1 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 2.

           INITIALIZE LINE-1.
           INSPECT CITY REPLACING ALL "  " BY "**".
           STRING CITY DELIMITED BY LIMITER SPACE SPACE
               STATE-CODE DELIMITED BY LIMITER SPACE
               ZIP-CODE DELIMITED BY LIMITER
               INTO DATA-1 OF LINE-1.
           WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 3.

           INITIALIZE LINE-5.
           MOVE EMP-YTD-STATE-TAX TO DATA-2 IN LINE-5.
           MOVE STATE-ID TO DATA-3 IN LINE-5.
           WRITE PRINT-RECORD FROM LINE-5 BEFORE ADVANCING PAGE.

       ACCUM-TOTALS.
           ADD EMP-YTD-FED-TAX TO YTD-FED-TAX-FINAL.
           ADD EMP-YTD-FED-GROSS TO FED-GROSS-FINAL.
           ADD EMP-YTD-STATE-TAX TO YTD-STATE-TAX-FINAL.
           ADD EMP-YTD-STATE-GROSS TO STATE-GROSS-FINAL.

       CHECK-END-FILE-FLAG.
           IF END-FILE-FLAG = 1
               GO TO PRINT-FINAL-TOTALS.
           IF START-W2-NO OF W2S01-I GREATER THAN 1099-COUNT
               GO TO READ-EMPLFILE.
           GO TO READ-EMPLFILE.

      * * * * *      FINAL SUBTOTALS     * * * * *

       PRINT-FINAL-TOTALS.
           WRITE PRINT-RECORD FROM BLANK-LINE BEFORE ADVANCING 5.
           INITIALIZE LINE-1.
           MOVE "   FINAL TOTALS" TO DATA-1 IN LINE-1.
           MOVE YTD-FED-GROSS-FINAL TO DATA-2 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 3.

           INITIALIZE LINE-1.
           MOVE YTD-FED-GROSS-FINAL TO DATA-2 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 6.

           INITIALIZE LINE-2.
           MOVE YTD-FED-TAX-FINAL TO DATA-4 IN LINE-2.
           WRITE PRINT-RECORD FROM LINE-2 BEFORE ADVANCING 12.

           INITIALIZE LINE-1.
           MOVE YTD-STATE-TAX-FINAL TO DATA-3 IN LINE-1.
           WRITE PRINT-RECORD FROM LINE-1 BEFORE ADVANCING 1.

       END-PROGRAM.
           CLOSE ADM1FILE, EMPLFILE, PRNTFILE, SCRNFILE.
           STOP RUN.

      *********************** R O U T I N E S ************************

           COPY XDATE OF CBLCPYSRC SUPPRESS.

Extracting MSDS Finished Goods from MAPICS/38 using PL/1

Okay, this has to take the cake for a rare combination…a PL/1 program that walks down an assembly chain for a finished good product and explodes out the complete list of raw materials that make up the product. I had to build a “shadow” bill of materials for each finished good item that consisted of the raw materials so I could then simulate chemical reactions and determine the remaining ingredients that where left. If these ingredients were then above certain thresholds they have to be declared on a Material Safety Data Sheet. Wonder how it might look in C# in an OO style using today’s patterns?

/*   MSD710P - Load a Product Structure into MSDS from PDM   */

 MSD710P: PROCEDURE (BR_ITEM_IN) RETURNS(CHAR(2));

 /********************************************************************/
 /*     NAME: MSD710P                                                */
 /*  PURPOSE: Load the Mapics/38 Product Structure into MSDS System  */
 /*  WRITTEN: 01/30/90                                               */
 /*   AUTHOR: John Watson                                            */
 /*   SYSTEM: IBM System/38                                          */
 /* LANGUAGE: PL/I                                                   */
 /* SECURITY: None                                                   */
 /*    DESCR: This pgm extracts the product structure of an item     */
 /*           from the Mapics/38 Product Structure file (PSTRUC)     */
 /*           and builds the MSDS Finished Good/Component file       */
 /*           (COMPNT).  Only final raw materials are output to the  */
 /*           MSDS system.  That is, phantoms and sub-assemblies are */
 /*           exploded down to their raw materials as well.  The raw */
 /*           material quantities are converted to pounds or gallons */
 /*           in a batch size of 100 (100 lbs / 100 gals) for the    */
 /*           100 Unit Formula used by the MSDS system.              */
 /*              NOTE:  This is designed as a function to            */
 /*                   FACILITATe returning to the caller             */
 /*                     with return codes.                           */
 /*                                                                  */
 /*   RETURN: 00 = Successful completion                             */
 /*           1x = Problem w/ finished good item                     */
 /*            0 =   Item A record not found                         */
 /*            1 =   Deleted Item A                                  */
 /*            2 =   Assembly chain not found                        */
 /*           2x = Problem w/ a component                            */
 /*            0 =   PSTRUC not found, assy chain broken/bad         */
 /*            1 =   component Item A record not found               */
 /*            2 =   RRNs don't match                                */
 /*            3 =   component Item A deleted                        */
 /*            4 =   compare portions don't match                    */
 /*            5 =   bad low level code (exceeds 99)                 */
 /*            6 =   MSFILM record not found - cannot convert qty    */
 /*                                                                  */
 /********************************************************************/

 /* DECLARE FILES */
 DCL
  ITEMAKEY FILE RECORD INPUT DIRECT KEYED INTERNAL
             ENV(BUFSIZE(256) INDEXED KEYDISP(1) KEYLENGTH(16)),
  ITEMARRN FILE RECORD INPUT DIRECT ENV(BUFSIZE(256)) INTERNAL,
  ITEMAC   FILE RECORD INPUT DIRECT KEYED ENV(DESCRIBED INDEXED),
  PSTRUC   FILE RECORD INPUT DIRECT ENV(BUFSIZE(96)) INTERNAL,
  MSFILMPF FILE RECORD INPUT DIRECT KEYED ENV(DESCRIBED INDEXED),
  MSBSRMPF FILE RECORD SEQUENTIAL KEYED ENV(DESCRIBED INDEXED);

 /* DECLARE RECORDS FOR INPUT FROM FILES */

 DCL 1 COMPNT,
           %INCLUDE MSBSRMPF(COMPNT,RECORD);
 DCL 1 CFMT,
           %INCLUDE ITEMAC(CFMT,RECORD);
 DCL 1 RMFILM,
           %INCLUDE MSFILMPF(RMFILM,RECORD);
   /**************************************************/
   /* ITEMAS is internally described because we need */
   /* std batch qty of parent from pos. 244-249.     */
   /**************************************************/
 DCL 1 ITEMA_P,
       2  PR_ACREC  CHAR(1),    /* active record code                */
       2  PR_ITNBR  CHAR(15),   /* item number                       */
       2  PR_FILL1  CHAR(1),    /* filler 1                          */
       2  PR_IIREC  DEC(7,0),   /* RRN for this item                 */
       2  PR_LOLEV  PIC '9R',   /* low level code                    */
       2  PR_IIFAC  DEC(7,0),   /* RRN of first assembly component   */
       2  PR_FILL2  CHAR(105),  /* filler 2                          */
       2  PR_UNMSR  CHAR(2),    /* unit of measure                   */
       2  PR_ITTYP  CHAR(1),    /* item type                         */
       2  PR_FILL3  CHAR(108),  /* filler 3                          */
       2  PR_SBQTY  DEC(11,3),  /* standard batch quantity           */
       2  PR_FILL4  CHAR(7);    /* filler 4                          */
 DCL 1 ITEMA_C,
       2  PC_ACREC  CHAR(1),    /* active record code                */
       2  PC_ITNBR  CHAR(15),   /* item number                       */
       2  PC_FILL1  CHAR(1),    /* filler 1                          */
       2  PC_IIREC  DEC(7,0),   /* RRN for this item                 */
       2  PC_LOLEV  PIC '9R',   /* low level code                    */
       2  PC_IIFAC  DEC(7,0),   /* RRN of first assembly component   */
       2  PC_FILL2  CHAR(105),  /* filler 2                          */
       2  PC_UNMSR  CHAR(2),    /* unit of measure                   */
       2  PC_ITTYP  CHAR(1),    /* item type                         */
       2  PC_FILL3  CHAR(108),  /* filler 3                          */
       2  PC_SBQTY  DEC(11,3),  /* standard batch quantity           */
       2  PC_FILL4  CHAR(7);    /* filler 4                          */
 DCL 1 PSTRUCT,
       2  PPCIM     DEC(7,0),   /* component item A RRN              */
       2  PPPIM     DEC(7,0),   /* parent item "A" RRN               */
       2  PPNAC     DEC(7,0),   /* next assembly component RRN       */
       2  PPFIL1    CHAR(8),    /* filler 1                          */
       2  CCMPI     CHAR(1),    /* compare portion of item number    */
       2  PCOMP     CHAR(1),    /* compare portion of parent item    */
       2  PPFIL2    CHAR(16),   /* filler 2                          */
       2  EDATM     DEC(6,0),   /* effective from date               */
       2  EDATO     DEC(6,0),   /* effective to date                 */
       2  PPFIL3    CHAR(44),   /* filler 3                          */
       2  QTYPR     DEC(11,3);  /* quantity per unit                 */

 /* DECLARE VARIABLES */
 DCL BATCH_SZ         DEC(7,3),  /* batch size */
     CMP(100)         CHAR(1),   /* compare characters */
     CMP_CHAR         CHAR(1),   /* compare character  */
     CNTRL_ID         CHAR(3),   /* used to redefine PPCIM */
     BR_ITEM_IN       CHAR(6),
     LVL              DEC(3,0),  /* array subscript */
     STD_BAT_QTY      DEC(11,3),
     RRN(100)         DEC(7,0),  /* RRNs to chase down assy chains   */
     REC_NO           DEC(7,0),  /* RRN workfield */
     SBQ(100)         DEC(11,3), /* Std batch qty for a given level  */
     WRK_QTY          FLOAT(7);

 /* SYSTEM DATE */
 DCL CHR_DATE        CHAR(6),
     TST_DATE        DEC(6,0);    /* YYMMDD */

 DCL 1 PROGRAM_FLAGS STATIC,
       2 NO                 BIT(1) ALIGNED INIT('0'B),
       2 YES                BIT(1) ALIGNED INIT('1'B),
       2 VALID_ITEM_A       BIT(1) ALIGNED,
       2 VALID_ITEM_C       BIT(1) ALIGNED,
       2 VALID_PSTRUC       BIT(1) ALIGNED,
       2 VALID_RMFILM       BIT(1) ALIGNED,
       2 MORE_COMPNT_RECS   BIT(1) ALIGNED;

 /* OPEN FILES */
 OPEN FILE(ITEMAKEY);
 OPEN FILE(ITEMARRN);
 OPEN FILE(ITEMAC);
 OPEN FILE(MSFILMPF);
 OPEN FILE(PSTRUC);

 /* ERROR HANDLING */
 ON KEY(ITEMAKEY) VALID_ITEM_A=NO;
 ON KEY(ITEMARRN) VALID_ITEM_A=NO;
 ON KEY(ITEMAC) VALID_ITEM_C=NO;
 ON KEY(PSTRUC) VALID_PSTRUC=NO;
 ON KEY(MSFILMPF) VALID_RMFILM=NO;
 ON KEY(MSBSRMPF) MORE_COMPNT_RECS=NO;
 ON ENDFILE(MSBSRMPF) MORE_COMPNT_RECS=NO;

 %PAGE;
 /*    M A I N L I N E   */

 CHR_DATE=DATE();
 TST_DATE=DECIMAL(CHR_DATE,6,0);

 BATCH_SZ=100;
 LVL=1;
 RRN=0;
 SBQ=0;
 CMP=' ';

    /* Get parent Item A */

 VALID_ITEM_A=YES;
 READ FILE(ITEMAKEY) INTO(ITEMA_P) KEY(BR_ITEM_IN);
 SELECT;
   WHEN (VALID_ITEM_A=NO) RETURN('10');       /* record not found */
   WHEN (PR_ACREC='D') RETURN('11');          /* deleted record */
   WHEN (PR_IIFAC=9999999) RETURN('12');      /* no assembly chain */
   OTHERWISE;
   END;
 REC_NO=PR_IIFAC;
 STD_BAT_QTY=PR_SBQTY;
 CMP_CHAR=SUBSTR(PR_ITNBR,1,1);

        /* Clear out old COMPNT records */

 OPEN FILE(MSBSRMPF) UPDATE;
 MORE_COMPNT_RECS=YES;
 READ FILE(MSBSRMPF) INTO (COMPNT) KEY(BR_ITEM_IN);
 DO WHILE (MORE_COMPNT_RECS);
   DELETE FILE(MSBSRMPF);
   READ FILE(MSBSRMPF) INTO (COMPNT);
   IF BR_PARENTª=BR_ITEM_IN THEN MORE_COMPNT_RECS=NO;
   END;
 CLOSE FILE(MSBSRMPF);
 OPEN FILE(MSBSRMPF) OUTPUT;

   /* begin down an assembly chain */

 TOP:;
 RRN(LVL)=REC_NO;               /* point to first component */
 SBQ(LVL)=BATCH_SZ;             /* set batch size */
 CMP(LVL)=CMP_CHAR;             /* set compare values */

   /* start of loop for next component */

 CHAIN: DO UNTIL(REC_NO=9999999);

       /* get next component */

   VALID_PSTRUC=YES;
   READ FILE(PSTRUC) INTO(PSTRUCT) KEY(REC_NO);
   IF VALID_PSTRUC=NO THEN RETURN('20');
       /* check for control record */
   CNTRL_ID=CHAR(PPCIM,3);
   IF CNTRL_ID='.PS' THEN RETURN('20');
       /* check dates */
   IF (EDATM>=TST_DATE) ³ (EDATOª=0 & EDATO<=TST_DATE) THEN DO;
      REC_NO=PPNAC;  /* outside dates - get next component */
      ITERATE CHAIN;
      END;

      /* get component Item A */

   VALID_ITEM_A=YES;
   READ FILE(ITEMARRN) INTO(ITEMA_C) KEY(PPCIM);
   SELECT;
     WHEN(VALID_ITEM_A=NO) RETURN('21');         /* no comp. Item A */
     WHEN(PC_IIRECª=PPCIM) RETURN('22');         /* RRNs don't match */
     WHEN(PC_ACREC='D') RETURN('23');            /* Item A deleted */
     WHEN(SUBSTR(PC_ITNBR,1,1)ª=CCMPI) RETURN('24'); /* compare char */
     WHEN(PC_LOLEV>99) RETURN('25');              /* bad low level */
     OTHERWISE;
     END;

      /* Check if this component is an intermediate. */
      /* If so, push current parent's values into    */
      /* arrays, set up work fields with new parent  */
      /* information and goto top to start down      */
      /* the chain of the new parent.                */

   IF (PC_ITTYP='1') ³ (PC_IIFACª=9999999) THEN DO;
        /* save current parent values */
     RRN(LVL)=PPNAC;
     SBQ(LVL)=STD_BAT_QTY;
     CMP(LVL)=CMP_CHAR;
        /* set up work fields with new parent values */
     REC_NO=PPNAC;
     STD_BAT_QTY=PR_SBQTY;
     CMP_CHAR=SUBSTR(PC_ITNBR,1,1);
        /* increase current level */
     LVL=LVL+1;
     GOTO TOP;
     END;

      /* get component Item C */

   READ FILE(ITEMAC) INTO (CFMT) KEY(PC_ITNBR);

      /* extend component qty & convert to lbs */

   WRK_QTY=BATCH_SZ/STD_BAT_QTY*QTYPR;
   SELECT;
      WHEN(PC_UNMSR='LB');
      WHEN(PC_UNMSR='GA') WRK_QTY=WRK_QTY*MC#GAL;
      WHEN(PC_UNMSR='GM') WRK_QTY=WRK_QTY/453.59;
      WHEN(PC_UNMSR='FL') WRK_QTY=(WRK_QTY*MC#GAL)/128;
      WHEN(PC_UNMSR='OZ') WRK_QTY=WRK_QTY/16;
      WHEN(PC_UNMSR='LY') DO;
        READ FILE(MSFILMPF) INTO(RMFILM) KEY(PC_ITNBR);
        IF VALID_RMFILM THEN DO;
          WRK_QTY=WRK_QTY*RF_WIDTH*RF_THICKNESS*.155844*MC#GAL;
          END;
        ELSE RETURN('26');   /* no MSFILMPF record */
        END;
      OTHERWISE;
      END;

      /* write out COMPNT */

   BR_COMP_QTY=WRK_QTY;
   BR_PARENT=BR_ITEM_IN;
   BR_COMPONENT=SUBSTR(PC_ITNBR,1,6);
   WRITE FILE(MSBSRMPF) FROM (COMPNT) KEYFROM(*);

   REC_NO=PPNAC;
 END;  /* DO group */

    /* At this point, we have reached the end of an  */
    /* assembly chain (PPNAC=9999999).  Check to see */
    /* if we encountered any intermediates along the */
    /* way.  If we did, pull back up one level and   */
    /* continue down the previous parent's chain.    */

 DO WHILE(LVL>1);
   LVL=LVL-1;
   IF RRN(LVL)ª=9999999 THEN DO;
     REC_NO=RRN(LVL);
     STD_BAT_QTY=SBQ(LVL);
     CMP_CHAR=CMP(LVL);
     GOTO CHAIN;
     END;
   END;

 RETURN('00');   /* DONE! */
 END MSD710P;

Code Generation circa 1988 using RPG II 1/2

While cleaning out my shelves I came across this old code sample disk. The company is long gone and the language is well…small. RPG II’s roots went back to punch-card days:

• Column position on each line was important
• Column 6 contains a one letter “record type”, e.g. H = header, C = calculation
• The OPCODE in the middle of the calc spec was max 6 chars long, e.g. EXSR = execute subroutine.

If I remember, the “1/2” was a commercial 3rd party tool/enhancement that added stuff like “IF” and “DO” instead of having to use the left-hand indicators (e.g. N90) to condition execution of the line.
0001 H       024                B        1                  SAL010
0002 H*===================================================================
0003 H*@ PROPERTY OF XXXXXXXXXXXX, KEENE, NEW HAMPSHIRE 1988
0004 H*T Generate #GSORT OCL to retrieve customer/item sales history
0005 H*M  144 07Dec88 Written *** Uses RPG II 1/2 ***
0005 H*D Accepts up to 18 selection criterion and generates the necessary
0005 H*D OCL code to run #GSORT to extract/sort the customer/item sales
0005 H*D history file. The calling report proc is stored in LDA to
0005 H*D determine various report-specific sort specs such as the header
0005 H*D and field specs.  To add another procedure the following must
0005 H*D be done:  Add proc name to PROC array, add the new sort header
0005 H*D spec to HDR, add the record type spec(s) to REC if necessary,
0006 H*S EDIT$    Edits the selection criteria
0006 H*S INIT$    Program Initialization
0009 H*I 40-57    Screen error indicators.
0014 H*===============================================================
0015 FWORKSTN CD  E               WORKSTN
0019 FPROC    O     120 120           DISK
0021 E* workstation arrays
0022 E              $FN         18  2 0         field number
0022 E              $OP         18  2         operation code
0022 E              $CR         18 15         selection criteria
0021 E* program work arrays
0022 E              OPNS      6   6  2         operation codes
0022 E              PROC      8   8  6         procedure names
0022 E              TABPRC  8   8  6   TABNUM  2 0 proc names & # of #GSORT field specs
0021 E* sort specs (OCL code)
0022 E              BEG      1   5 80         common 'beginning' OCL statements
0022 E              HDR      1   8 80         header specs
0022 E              REC      1  11 80         record selection specs
0037 I         UDS
0038 I                          1   8 @USER
0039 I                          9  10 @WS
     I                        505 512 @PROC       ?WS? + ?TIME?
0040 C*==============================================HILOEQ===========
0042 C     #@INIT    IFNE 1
0043 C               EXSR INIT$
0044 C               END
     C*
     C     T$1000    TAG
     C               EXFMTSCRN100
     C  KG           SETON             U7
     C  KG           GOTO T$9999
     C* call edit routine to check for errors
     C               EXSR EDIT$
     C* if any error occured, redisplay screen
     C     #@ERR     IFEQ 1
     C               GOTO T$1000
     C               END
     C* if Cmd/1 wasn't pressed loop back and redisplay
     C NKA           GOTO T$1000
     C* set array element pointer for procedure name
     C               SETOF             90
     C               Z-ADD1      Z      20
     C         @PROC       LOKUPPROC,Z             90
     C N90           DO
     C               SETON             U7    *proc not found - cancel job
     C               GOTO T$9999
     C               END
     C* display 'prompt' screen
     C               EXCPTWK110
     C* output // COPY statement with proc name
     C               EXCPTOCL1
     C* output common begining sort specs
     C               DO    5      X
     C               EXCPTOCL2
     C               END
     C* output sort header spec
     C               EXCPTOCL3
     C* output user-selected record type specs
     C               MOVE *BLANKS   #AND           *clear 'AND' code
     C               DO    18      X
     C         $FN,X       IFGE 1               *assume if valid $FN
     C         $FN,X       IFLE 18               *   then valid $OP and $CR
     C               SETOF             90
     C               Z-ADD1      Y      20
     C         $OP,X       LOKUPOPNS,Y             90*assume valid OPN since passed EDIT$
     C               EXCPTOCL4
     C               END
     C               MOVE 'A'      #AND           *set 'AND' code for remainder of loop
     C               END
     C* output field records for this proc
     C               DO    28      X
     C               SETOF             90
     C         @PROC       IFEQ PNAM,X
     C               EXCPTOCL5
     C               END
     C               END
     C*==============================================HILOEQ===========
     CSR     EDIT$       BEGSR
     C*
     C               Z-ADD0      #@ERR   10       *clear error flag
     C               DO    18      X      20       .DO once for each screen line
     C         X     ADD    39      Y      20        point to screen indicator
     C               Z-ADD0      *IN,Y         clear screen indicator
     C* if field num is blank, blank out operation and criterion
     C         $FN,X IFEQ *BLANKS
     C         $FN,X OREQ *ZEROS
     C               MOVE *BLANKS   $OP,X
     C               MOVE *BLANKS   $CR,X
     C               GOTO EDITX
     C               END
     C* if operation is blank, blank out field num and criterion
     C         $OP,X IFEQ *BLANKS
     C         $OP,X OREQ *ZEROS
     C               MOVE *ZEROS      $FN,X
     C               MOVE *BLANKS   $CR,X
     C               GOTO EDITX
     C               END
     C* check for valid field number range
     C         $FN,X IFLT 1
     C         $FN,X ORGT 11
     C               Z-ADD1      *IN,Y         turn on corresponding indicator
     C               Z-ADD1      #@ERR         set error flag
     C               END
     C* check for valid operation code
     C               SETOF             90
     C         $OP,X LOKUPOPNS             90
     C N90           Z-ADD1      *IN,Y          turn on corresponding indicator
     C N90           Z-ADD1      #@ERR          set error flag
     C               END                   .END
     C*
     C         EDITX       TAG
     C*
     CSR           ENDSR
     C*==============================================HILOEQ==========
     OPROC    E            OCL1
     O                     23 '// COPY LIBRARY-P,NAME-'
     O                   @PROC     31
     O          E            OCL2
     O                   COM,X     80
     O          E            OCL3
     O                   HDR,Z     80
     O          E            OCL4
     O                   REC,X     80
     O                   #AND      7
     O                   OPN,Y     18
     O                   $CR,X     34
     O          E            OCL5
     O                   FLD,X     80
**   operation codes
EQGEGTLELTNE
**   procedure names
SAL299SAL297SAL296SAL295SAL294SAL293SAL292SAL291
**   table of procedure names & number of sort field specs
SAL29905SAL29703SAL29603SAL29503SAL29403SAL29303SAL29205SAL29103
**   common 'beginning' sort specs
// REGION SIZE-64
// LOAD #GSORT
// FILE NAME-INPUT,LABEL-PRO.SCD,DISP-SHR
// FILE NAME-OUTPUT,LABEL-SAL010?WS?
// RUN
**   header specs for each program
//   HSORTA    17A      3       N           *SAL299
//   HSORTA    18A      3       N           *SAL297
//   HSORTA    18A      3       N           *SAL296
//   HSORTA    5A      3       N           *SAL295
//   HSORTA    18A      3       N           *SAL294
//   HSORTA    18A      3       N           *SAL293
//   HSORTA    8A      3       N           *SAL292
//   HSORTA    18A      3       N           *SAL291
**   common record selection and field specs (insert AND code & test condition)
//   I C   3   8  D                   *customer number
//   I C   9  23  C                   *item number
//   I C  36  36  C                   *sbu
//   I C  37  38  C                   *product group
//   I C 548 548  C                   *product line
//   I C 549 550  C                   *product class
//   I C  39  40  C                   *item class
//   I C  41  42  C                   *customer type
//   I C  43  44  C                   *company code
//   I C  33  34  C                   *sales region
//   I C  35  35  C                   *sales territory
**   proc names and their respective #GSORT field specs
SAL299//   FNC    33  34                     *sales region

Simple Circles–NHibernate Unit Testing (Part 7c)

This post is part of a series on building a simple to use web-based contact and customer relationship management application. The goal is to support various audiences including businesses, teams, clubs, religious organizations, etc.

In Part 7a I implemented the Repository pattern using NHibernate and in Part 7b I used Fluent NHibernate to implement the Data Mapper pattern between the domain layer and the relational database layer. In this post I’ll build unit tests to exercise these implementations.

One of the problems with attempting to test a data access strategy is ensuring the database is in a known state at the start of each test. Previously I’ve used teardown and setup SQL scripts to empty out data and preload initial values in a database instance. That approach is tedious because it means maintaining two sets of scripts in a different syntax (SQL instead of C#) and using a different toolset (SSMS). Another approach that’s becoming more popular and prevalent is to use a lighter footprint database engine capable of running in-memory. In fact, Fluent NHibernate makes this easy with its standard configuration – all it takes is setting up an NHibernate session configured to use the in-memory database as shown here:

SessionFactory Class

namespace Circles.NHibernateTests
{
  using Circles.NHibernateRepository;

  using FluentNHibernate.Cfg;
  using FluentNHibernate.Cfg.Db;

  using NHibernate;
  using NHibernate.Cfg;
  using NHibernate.Tool.hbm2ddl;

  public class SessionFactory
  {
    private static Configuration staticConfig;

    public static ISessionFactory CreateSessionFactory()
    {
      return
        Fluently.Configure()
          .Database(SQLiteConfiguration.Standard.InMemory().ShowSql())
          .Mappings(m => m.FluentMappings.AddFromAssemblyOf<PartyRepository>().ExportTo(System.Console.Out))
          .ExposeConfiguration((c) => staticConfig = c)
          .BuildSessionFactory();
    }

    public static void BuildSchema(ISession session)
    {
      var export = new SchemaExport(staticConfig);
      export.Execute(script: true, export: true, justDrop: false, connection: session.Connection, exportOutput: null);
    }
  }
}

Lines 20-22 contain all the “magic”: line 20 configures the database to use the standard in-memory configuration for SQLite. Line 21 sets up the mappings to be read from the PartyRepository assembly; in addition, the ExportTo() method call will dump the generated hbm.xml to the console. Line 22 exposes the configuration being set up before it is passed to NHibernate for session creation. In this case, the Lambda expression stores the newly built configuration in a static variable for later reuse by the BuildSchema method.

xUnit does not implement or use constructs such as [Setup] / [Teardown] like nUnit does or [TestInitialize] / [TestCleanup] like MSTest does since the authors feel it is problematic. You can read more about the rational on James Newkirk’s blog post “Why you should not use Setup and TearDown in NUnit”. Pretty compelling when the main author himself tells you not to; however, I’m going to bend the rules a little. I’ve implemented a base testing class that contains a virtual method called TestInitialize() whose purpose is to prepare the testing database and put it in a known state before each test is executed:

TestBase Class

namespace Circles.NHibernateTests
{
  using NHibernate;

  /// <summary>
  /// Base class for NHibernate / SQLite tests
  /// </summary>
  public abstract class TestBase
  {
    protected static readonly object LockObject = new object();

    private static ISessionFactory sessionFactory;

    protected ISession Session { get; set; }

    /// <summary>
    /// Code to run before the test to allocate 
    /// and configure any resources needed.
    /// </summary>
    public virtual void TestInitialize()
    {
      sessionFactory = SessionFactory.CreateSessionFactory();
      Session = sessionFactory.OpenSession();
      SessionFactory.BuildSchema(Session);
    }

    public void Dispose()
    {
      Session.Dispose();
    }
  }
}

Each test class can now easily prepare an in-memory database and place it in a known state prior to executing tests by overriding TestInitialize() with its own specific behavior:

TestInitialize() Method

public override void TestInitialize()
{
  Monitor.Enter(LockObject);

  base.TestInitialize();

  using (var tx = Session.BeginTransaction())
  {
    var householdType = new PartyType(new Guid(Constants.PartyTypeIdHousehold))
    {
      TypeName = "Household"
    };
    Session.Save(householdType);

    var personType = new PartyType(new Guid(Constants.PartyTypeIdPerson))
    {
      TypeName = "Person"
    };
    Session.Save(personType);

    var person = new Person
    {
      FirstName = "Nancy",
      LastName = "Davolio",
      Gender = GenderEnum.Female,
      Birthday = new DateTime(1948, 12, 8),
      PartyType = personType
    };
    Session.Save(person);

    Session.Flush();
    tx.Commit();
  }

  Session.Clear();

  Monitor.Exit(LockObject);
}

The Monitor.Enter and Monitor.Exit calls (lines 3 & 38) ensure that access to the NHibernate Session remains serialized and two test methods can’t accidently interfere with each other in multi-threaded harnesses. The first call is to the base class’ implementation which creates the in-memory database. Following that I create PartyType instances for Household and Person and then create and persist a well-known Person instance.

With the base class and SessionFactory implemented and in place, constructing unit tests that can exercise (indirectly) the mappings as well as an actual, deployed database layer becomes trivial:

CanAddHousehold() Test Method

[Fact]
public void CanAddHousehold()
{
  this.TestInitialize();

  IPartyRepository repository;
  Household household;

  // arrange
  using (var tx = Session.BeginTransaction())
  {
    repository = new PartyRepository(Session);
    var partyType = repository.FindPartyTypeById(new Guid(Constants.PartyTypeIdHousehold));

    // act
    household = new Household
    {
      PartyName = "Eisenhower",
      FormalGreeting = "President Dwight D. and Mrs. Mamie",
      InformalGreeting = "Ike and Mamie",
      PartyType = partyType
    };

    repository.Add(household);
    tx.Commit();
  }

  // assert
  Assert.NotNull(household);
  Assert.NotNull(repository.FindById(household.PartyId));
}

Line 4 initializes the database including preparing the known state, Line 12 initializes a PartyRepository instance using the in-memory database session. This particular line of code deserves special attention – I’m creating a PartyRepository and giving it the in-memory database to operate against. Recall in Part 7a on Line 47 of the fourth code fragment (DBSession class)  that a PartyRepository instance was created using the “real” NHibernate DbSession there. Here’s where designing the NHibernate repository to accept an ISession implementation gives flexibility.

Line 13 retrieves the household party type that is known to be there because it was created and saved during TestInitialize(). Finally the household is created and saved. An interesting side effect of this test was when I first ran it – it failed. I had forgotten to specify/assign a PartyType to the household instance. When I referred back to the earlier tests that I put together using the FakeRepository I realized that it too wasn’t assigning or checking the party type. This oversight illustrates a problem with trying to fake or mock an implementation – you have to remember to code and test all the validation and business rules necessary to be a “real” repository. This is the best reason to have taken these steps of setting up a reusable, fast way to test the real repository – as you code the repository, you can test it without having to write double the code by updating the fake one.

This discovery led to adding a negative test to ensure the repository doesn’t allow a household without a party type:

Negative Test

[Fact]
public void CanNotAddHouseholdWithMissingPartyType()
{
  this.TestInitialize();

  // arrange
  using (var tx = Session.BeginTransaction())
  {
    var repository = new PartyRepository(Session);

    // act
    var household = new Household
    {
      PartyName = "Eisenhower",
      FormalGreeting = "President Dwight D. and Mrs. Mamie",
      InformalGreeting = "Ike and Mamie",
      /* PartyType = partyType */
    };

    // assert
    Assert.Throws<NHibernate.PropertyValueException>(
      delegate
      {
        repository.Add(household);
      });

    tx.Rollback();
  }
}

Lines 21-25 uses the xUnit Assert.Throws<> method to wrap the attempt to add a household without a party type. If the repository doesn’t throw an NHibernate.PropertyValueException then the test is considered to have failed.

This post was pretty densely packed with concepts - an entire framework for testing an NHibernate-based data layer. The accompanying code base is growing larger and can be downloaded from here.

Simple Circles–NHibernate Mapping (Part 7b)

This post is part of a series on building a simple to use web-based contact and customer relationship management application. The goal is to support various audiences including businesses, teams, clubs, religious organizations, etc.
In a previous post, I used AutoMapper to implement the DataMapper pattern to map and flatten the domain model into view models for the MVC user interface. The same approach applies to mapping the domain model to a relational database. In fact, this is the heart of an object-relational mapping (ORM) tool like NHibernate. Originally, NHibernate used XML-based mapping files similar to its Hibernate lineage. More recently, James Gregory’s Fluent NHibernate tool has emerged as a leading alternative with strengths such as supporting the fluent interface programming style, convention-based mappings, and compile-time checking (a huge time saver).
After adding Fluent NHibernate v1.2.0.712 – that version is compiled against the NHibernate version I’m using – I created a \Maps folder and created the mapping classes. Before diving into the mapping, it’s time to introduce a best practice for managing concurrency and allowing detection of stale objects. By convention, NHibernate supports a special-named property called ‘Version’ that can be numeric (preferred), a timestamp or a DB timestamp. You can find more information at the NHibernate site or Ayende’s post. In the Circles data model, I’ve got a base Entity class which is a great place to put the Version property so every Entity automatically gets the benefit of optimistic concurrency checking. Here's the mappings for Party and PartyType:

namespace Circles.NHibernateRepository.Maps
{
  using Circles.Domain;

  using FluentNHibernate.Mapping;

  public class PartyMap : ClassMap<Party>
  {
    public PartyMap()
    {
      Id(x => x.PartyId).GeneratedBy.GuidComb();
      Version(x => x.Version);
      References(x => x.PartyType, "TypeId")
          .Not.Nullable();
      Map(x => x.PartyName)
          .Not.Nullable()
          .Length(255)
          .Index("ukPartyName");
    }
  }

  public class PartyTypeMap : ClassMap<PartyType>
  {
    public PartyTypeMap()
    {
      Id(x => x.TypeId).GeneratedBy.GuidComb();
      Version(x => x.Version);
      Map(x => x.TypeName)
          .Not.Nullable()
          .Length(255)
          .Index("ukTypeName");
    }
  }
}

Line #11 above maps the Id property to a column called PartyId and specifies that the Guid.Comb Identifier Strategy be used to generate new ids. Lines #12 and #13 map the referenced PartyType within a Party by creating a foreign key using TypeId as the column name.

Fluent NHibernate has the ability to not only define mappings but to configure NHibernate using the mappings along with other settings you specify. Using this ability, its also possible to export the configuration to .hbm.xml files combined with NHibernate’s ability to export .hbm files to SQL DDL. There’s a lot of power packed into the following:

namespace NHibernateSchemaExport
{
  using Circles.NHibernateRepository;

  using FluentNHibernate.Cfg;
  using FluentNHibernate.Cfg.Db;

  using NHibernate.Cfg;
  using NHibernate.Tool.hbm2ddl;

  class Program
  {
    static void Main(string[] args)
    {
      Fluently.Configure()
        .Database(SQLiteConfiguration.Standard
            .ConnectionString(c => c.FromConnectionStringWithKey("circlesdb"))
            .ShowSql)
        .Mappings(m => m.FluentMappings.AddFromAssemblyOf()
            .ExportTo("."))
        .ExposeConfiguration(BuildSchema)
        .BuildSessionFactory();
    }

    static void BuildSchema(Configuration cfg)
    {
      new SchemaExport(cfg)
             .SetOutputFile("CirclesSchema.sql")
             .Execute(script: true, export: false, justDrop: false);
    }
  }
}

Line #18 shows the ExportTo() method being using to export the configured mappings to the current directory. Line #19 uses the ExposeConfiguration() method along with NHibernate’s SchemaExport() method on line #26 to output the database schema. These techniques give us the ability to “see into” the dynamically generated hbm and sql files.

There’s more details in the accompanying change set for this post that can be downloaded here. Next up is implementing the PartyRepository now that NHibernate is configured and the domain-to-database mapping is coming together.