home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / viscobv6.zip / vac22os2 / ibmcobol / samples / elookup1 / dbclss / dbclass.cbl next >
Text File  |  1998-01-10  |  19KB  |  471 lines
  1.       *************************************************************
  2.        IDENTIFICATION DIVISION.
  3.       * * * * * * * * * * * * * *
  4.        Class-ID.   DBClass inherits SOMObject.
  5.        AUTHOR.     Sample-Programmer.
  6.       *************************************************************
  7.       * Name:     DBClass                                       ***
  8.       *                                                         ***
  9.       * Language: IBM COBOL                                     ***
  10.       *                                                         ***
  11.       * Function: This class accesses the sample DB/2 database  ***
  12.       *           and  returns information from the employee    ***
  13.       *           table.                                        ***
  14.       *                                                         ***
  15.       *           This program could is an example of existing  ***
  16.       *           procedural code that has been simply modified ***
  17.       *           by making it into a class with the main       ***
  18.       *           procedure division into a mehtod.  One        ***
  19.       *           method was added to set the search name.      ***
  20.       *                                                         ***
  21.       * External subroutines: SERVC                             ***
  22.       *                                                         ***
  23.       * COPY members:                                           ***
  24.       *           DBCOM: Data area for communications           ***
  25.       *           SERVSC: Service Calculation parameters        ***
  26.       *                                                         ***
  27.       *************************************************************
  28.  
  29.       *************************************************************
  30.        ENVIRONMENT DIVISION.
  31.       * * * * * * * * * * * * * *
  32.        CONFIGURATION SECTION.
  33.        Repository.
  34.            CLASS SOMObject is "SOMObject"
  35.            CLASS DBClass is "DBClass".
  36.  
  37.       *************************************************************
  38.        DATA DIVISION.
  39.        Working-Storage Section.
  40.          01 In-LastName               PIC X(15).
  41.          01 LName.
  42.                49 LName-Len           PIC S9(4) COMP-5.
  43.                49 LName-Data          PIC X(15).
  44.  
  45.       *************************************************************
  46.        PROCEDURE DIVISION.
  47.       *************************************************************
  48.  
  49.       *************************************************************
  50.        Identification Division.
  51.        Method-ID. "somInit" override.
  52.       *************************************************************
  53.       *  This method overrides the somInit method and           ***
  54.       *  initializes the name for the search.                   ***
  55.       *************************************************************
  56.  
  57.        Procedure Division.
  58.             Move High-Values to In-LastName.
  59.             Move 0 to LName-Len.
  60.             Move High-Values to LName-Data.
  61.        End Method "somInit".
  62.       *************************************************************
  63.  
  64.       *************************************************************
  65.        Identification Division.
  66.        Method-ID. "setSrchName".
  67.       *************************************************************
  68.       *  This method sets the search name.                      ***
  69.       *************************************************************
  70.        Data Division.
  71.        Linkage Section.
  72.        01 SrchName.
  73.            03 Name-Length                PIC 9(9) COMP-5.
  74.            03 Name-String.
  75.            05 Name-Chars                 PIC X
  76.                        OCCURS 1 TO 255 TIMES
  77.                        DEPENDING ON Name-Length.
  78.  
  79.        Procedure Division Using SrchName.
  80.             Move Name-String to In-LastName.
  81.        End Method "setSrchName".
  82.       *************************************************************
  83.  
  84.       *************************************************************
  85.        Identification Division.
  86.        Method-ID. "doSearch".
  87.       *************************************************************
  88.       *  This method performs the actual database access; it    ***
  89.       *  checks whether the serach name is set to decide how    ***
  90.       *  to get the data from the database.                     ***
  91.       *************************************************************
  92.        Data Division.
  93.        Working-Storage Section.
  94.       *****************************************************
  95.       *    DECLARE host variables                         *
  96.       *****************************************************
  97.            EXEC SQL BEGIN DECLARE SECTION END-EXEC.
  98.            EXEC SQL INCLUDE 'DBCOM.CPY' END-EXEC.
  99.            EXEC SQL END DECLARE SECTION END-EXEC.
  100.  
  101.       **************************************************
  102.       *    Declare Cursors for Employee Database       *
  103.       **************************************************
  104.            EXEC SQL
  105.            DECLARE CSR1 CURSOR FOR
  106.              SELECT WORKDEPT, FIRSTNME,
  107.                    HIREDATE, LASTNAME,
  108.                    MIDINIT, PHONENO
  109.              FROM EMPLOYEE
  110.              ORDER BY LASTNAME
  111.            END-EXEC.
  112.  
  113.       *************************************************************
  114.       ***  Declare Cursor 2 here                                 **
  115.       *************************************************************
  116.            EXEC SQL
  117.            DECLARE CSR2 CURSOR FOR
  118.              SELECT WORKDEPT, FIRSTNME,
  119.                    HIREDATE, LASTNAME,
  120.                    MIDINIT, PHONENO
  121.              FROM EMPLOYEE
  122.                 WHERE LASTNAME LIKE :LNAME
  123.              ORDER BY LASTNAME
  124.            END-EXEC.
  125.  
  126.       *************************************************************
  127.       *  Internal variables                                       *
  128.       *************************************************************
  129.        01  ARRAY-MAX-ENTRIES.
  130.            05  EMP-ARRAY-MAX              PIC 9(2)  VALUE 50.
  131.            05  RESULT-DATA-MAX            PIC 9(2)  VALUE 0.
  132.  
  133.        01  PROGRAM-WORK-FIELDS.
  134.            05  EMP-PTR                    PIC 9(2).
  135.            05  BLANK-COUNT                PIC 9(2).
  136.            05  LASTNAME-LENGTH            PIC 9(2).
  137.            05  DEPT-LENGTH                PIC 9(2).
  138.            05  CHARPTR                    PIC 9(2).
  139.  
  140.        01  Workingfields.
  141.            10  EMP-ENTRY                  OCCURS 50 TIMES.
  142.                15  EMP-LAST-NAME          PIC X(15).
  143.                15  EMP-FIRST-NAME         PIC X(10).
  144.                15  EMP-MIDDLE-INITIAL     PIC X.
  145.                15  EMP-DEPT               PIC X(3).
  146.                15  EMP-PHONE              PIC X(12).
  147.                15  EMP-HIRE-DATE          PIC 9(6).
  148.        01 CS-Request                      PIC X.
  149.             88  CS-Display-All                      VALUE "D".
  150.             88  CS-Partial-Match                    VALUE "P".
  151.  
  152.        01  Display-Emp.
  153.            05 DISPLAY-EMP-DATA            PIC x(65) OCCURS 50 TIMES.
  154.        77  DISPLAY-FILLER                 PIC X(2)  VALUE HIGH-VALUE.
  155.        01  DISPLAY-INDEX                  PIC 9(2).
  156.  
  157.        01  GS-FULLNAME                    PIC X(30).
  158.        77  UPPER-ALPHA                    PIC X(26)   VALUE
  159.               "ABCDEFGHIJKLMNOPQRSTUVWXYZ".
  160.        77  LOWER-ALPHA                    PIC X(26)   VALUE
  161.               "abcdefghijklmnopqrstuvwxyz".
  162.  
  163.        01  LINE-COUNT                     PIC 9(2).
  164.        01  TOTAL-COUNT                    PIC 9(2).
  165.        01  THE-COUNT                      PIC 9(2) VALUE ZERO.
  166.        01  FIX-FIELDS.
  167.            05  LJUST-FIELD-1.
  168.                10  LJUST-LASTNAME-1       PIC X(15).
  169.            05  LJUST-FIELD-2.
  170.                10  LJUST-LASTNAME-2       PIC X(15).
  171.  
  172.            COPY SQLCA.
  173.            COPY SQL.
  174.  
  175.       * - - - - - SQL Values
  176.        01  NOT-FOUND                     PIC S9(4) COMP-4 VALUE 100.
  177.        01  FOUND                         PIC S9(4)  COMP-4  VALUE 0.
  178.  
  179.        01  SC-COMMAREA.
  180.            COPY SERVSC.
  181.  
  182.        Linkage Section.
  183.       * - - - - - DataArea (for communications)
  184.        01 DataArea.
  185.            COPY DATAAREA.
  186.  
  187.       *************************************************************
  188.        Procedure Division Returning DataArea.
  189.       *************************************************************
  190.       * 1000-MAIN: Main Processing
  191.       *
  192.       *   Return code is set if matches were found or not found.
  193.       *************************************************************
  194.         1000-MAIN.
  195.             EXEC SQL
  196.               CONNECT TO SAMPLE
  197.             END-EXEC.
  198.       * Initialize stuff
  199.             INITIALIZE CS-RESULT-DATA.
  200.             MOVE 0 TO RESULT-DATA-MAX.
  201.             MOVE 0 to CS-Return-Code.
  202.  
  203.       * Check whether the search name is set and process routines
  204.             If In-LastName = High-Value
  205.                Move "D" to CS-Request
  206.             Else
  207.                Perform 1600-FIX-NAME
  208.                Move "P" to CS-Request.
  209.  
  210.             EVALUATE TRUE
  211.               WHEN CS-DISPLAY-ALL
  212.                 PERFORM 1100-DISPLAY-ALL THRU
  213.                    1100-DISPLAY-ALL-EXIT
  214.                 subtract 1 from Results-Knt
  215.               WHEN CS-PARTIAL-MATCH
  216.                 PERFORM 1200-DISPLAY-MATCH THRU
  217.                    1200-DISPLAY-MATCH-EXIT
  218.               WHEN OTHER
  219.                 MOVE 3 TO CS-RETURN-CODE
  220.             END-EVALUATE.
  221.             GOBACK.
  222.  
  223.       *************************************************************
  224.       * 1100-DISPLAY-ALL:
  225.       *   Return all of the entries in EMP-ARRAY.
  226.       *   Calls FETCH-ALL to do the actual getting of the data.
  227.       *************************************************************
  228.         1100-DISPLAY-ALL.
  229.  
  230.       * Initialize retun code
  231.             MOVE 0 TO CS-SQL-CODE.
  232.       * Initialize subscripts
  233.             MOVE 1 TO Results-Knt.
  234.             MOVE 1 TO EMP-PTR.
  235.  
  236.       * Data Assistant generated code.  Do Not Modify.
  237.            EXEC SQL
  238.              OPEN CSR1
  239.            END-EXEC
  240.  
  241.       * If database error occurred, set DB error return code
  242.            IF SQLCODE NOT = 0
  243.              MOVE 2 TO CS-RETURN-CODE
  244.              MOVE SQLCODE TO CS-SQL-CODE
  245.            END-IF.
  246.  
  247.            PERFORM 1130-FETCH-ALL THRU 1130-FETCH-ALL-EXIT
  248.                    WITH TEST BEFORE UNTIL SQLCODE NOT = FOUND
  249.                           OR Results-Knt > EMP-ARRAY-MAX
  250.                           OR CS-RETURN-CODE NOT = 0.
  251.            MOVE SQLCODE TO CS-SQL-CODE.
  252.  
  253.       *  Close Cursor1
  254.              EXEC SQL
  255.                CLOSE CSR1
  256.              END-EXEC.
  257.  
  258.       * Indicate number of entries processed
  259.             MOVE EMP-ARRAY-MAX TO RESULT-DATA-MAX.
  260.  
  261.          1100-DISPLAY-ALL-EXIT. EXIT.
  262.  
  263.       *************************************************************
  264.       * 1130-FETCH-ALL:
  265.       *   Executes the SQL search
  266.       *   Move all of the entries from EMP-DATA to CS-RESULT-DATA.
  267.       *************************************************************
  268.          1130-FETCH-ALL.
  269.  
  270.            INITIALIZE SOLO.
  271.            EXEC SQL
  272.              FETCH CSR1
  273.              INTO  :WORKDEPT, :FIRSTNME,
  274.                    :HIREDATE, :LASTNAME,
  275.                    :MIDINIT, :PHONENO
  276.            END-EXEC.
  277.  
  278.            IF SQLCODE = FOUND and Results-Knt <= EMP-ARRAY-MAX
  279.              MOVE LASTNAME  TO CS-EMP-LASTNAME(Results-Knt)
  280.              MOVE FIRSTNME  TO CS-EMP-FIRSTNAME(Results-Knt)
  281.              MOVE MIDINIT   TO CS-EMP-INITIAL(Results-Knt)
  282.              MOVE WORKDEPT  TO CS-EMP-DEPT(Results-Knt)
  283.              MOVE PHONENO   TO CS-EMP-PHONE(Results-Knt)
  284.              MOVE HIREDATE  TO CS-EMP-HIRE-DATE(Results-Knt)
  285.       *******************************************
  286.       *      Call Service Routine               *
  287.       *******************************************
  288.              MOVE CS-EMP-HIRE-DATE(Results-Knt) TO SC-HIRE-DATE
  289.              MOVE 4 TO SC-RETURN-CODE
  290.  
  291.              CALL "SERVC" USING SC-COMMAREA
  292.  
  293.              IF SC-RETURN-CODE NOT = 0
  294.                 MOVE 4 TO CS-RETURN-CODE
  295.              END-IF
  296.              MOVE SC-SERVICE-LENGTH TO CS-SERVICE-LENGTH(Results-Knt)
  297.  
  298.              ADD 1 TO Results-Knt
  299.  
  300.            ELSE
  301.       *      If database error occurred, set DB error return code
  302.              IF SQLCODE NOT = NOT-FOUND and SQLCODE NOT = FOUND
  303.                MOVE 2 TO CS-RETURN-CODE
  304.                MOVE SQLCODE TO CS-SQL-CODE
  305.              END-IF
  306.            END-IF.
  307.  
  308.          1130-FETCH-ALL-EXIT.   EXIT.
  309.  
  310.       *************************************************************
  311.       * 1200-DISPLAY-MATCH
  312.       *   Return all of the entries in EMP-ARRAY.
  313.       *   Move all of the entries from EMP-DATA to CS-RESULT-DATA.
  314.       *************************************************************
  315.         1200-DISPLAY-MATCH.
  316.  
  317.       *   Determine the lengths of the client's inputs: IN-LASTNAME
  318.       *   and build the search target, LNAME.
  319.            PERFORM 1210-FIND-LENGTHS THRU 1210-FIND-LENGTHS-EXIT.
  320.            STRING
  321.               IN-LASTNAME
  322.               "%"
  323.                 DELIMITED BY SPACE
  324.                 INTO LNAME-DATA.
  325.  
  326.       * Initialize retun code
  327.            MOVE 0 TO CS-SQL-CODE.
  328.  
  329.       * Initialize subscripts
  330.            MOVE 0 TO Results-Knt.
  331.            MOVE 0 TO EMP-PTR.
  332.  
  333.       * Data Assistant generated code.  Do Not Modify.
  334.            EXEC SQL
  335.              OPEN CSR2
  336.            END-EXEC
  337.  
  338.       * If database error occured, set db error return code
  339.            IF SQLCODE NOT = 0
  340.              MOVE 2 TO CS-RETURN-CODE
  341.              MOVE SQLCODE TO CS-SQL-CODE
  342.            END-IF.
  343.  
  344.            PERFORM 1230-FETCH-MATCH THRU 1230-FETCH-MATCH-EXIT
  345.                    WITH TEST BEFORE UNTIL SQLCODE NOT = FOUND
  346.                                     OR Results-Knt > EMP-ARRAY-MAX
  347.                                     OR CS-RETURN-CODE NOT = 0.
  348.            MOVE SQLCODE TO CS-SQL-CODE.
  349.       *  Close Cursor2
  350.            EXEC SQL
  351.                CLOSE CSR2
  352.            END-EXEC.
  353.  
  354.       * Indicate number of entries processed and set return
  355.       * code if nothing's found
  356.            MOVE Results-Knt TO RESULT-DATA-MAX.
  357.            IF Results-Knt = 0  AND CS-RETURN-CODE = 0
  358.                MOVE 1 TO CS-RETURN-CODE
  359.            END-IF.
  360.       * Reset the search name
  361.            Move High-Values to In-LastName.
  362.            Move 0 to LName-Len.
  363.            Move High-Values to LName-Data.
  364.  
  365.          1200-DISPLAY-MATCH-EXIT. EXIT.
  366.  
  367.       *************************************************************
  368.       * 1210-FIND-LENGTHS: Determine length of what the user
  369.       *   entered, add 1 and set that as the length of the host
  370.       *   variable.
  371.       *************************************************************
  372.         1210-FIND-LENGTHS.
  373.             IF IN-LASTNAME = SPACES
  374.       * Lastname is blank
  375.                MOVE 0 TO LNAME-LEN
  376.             ELSE
  377.       * Lastname is not blank; determine its length
  378.                INITIALIZE BLANK-COUNT
  379.       * Determine the number of trailing blanks in last name
  380.       * input characters using intrinsic function REVERSE
  381.                INSPECT FUNCTION REVERSE(IN-LASTNAME)
  382.                    TALLYING BLANK-COUNT FOR LEADING SPACES
  383.       * Calculate field length (field size minus trailing blanks)
  384.                COMPUTE LNAME-LEN = 16 - BLANK-COUNT
  385.             END-IF.
  386.  
  387.         1210-FIND-LENGTHS-EXIT. EXIT.
  388.  
  389.       *************************************************************
  390.       * 1230-FETCH-MATCH
  391.       *   This rountine gets cursor 2 and gets the results if
  392.       *   a match is found.  It then calls the calcyear routine
  393.       *   to calculate the years of service.
  394.       *************************************************************
  395.          1230-FETCH-MATCH.
  396.  
  397.            INITIALIZE SOLO.
  398.  
  399.            EXEC SQL
  400.              FETCH CSR2
  401.              INTO  :WORKDEPT, :FIRSTNME,
  402.                    :HIREDATE, :LASTNAME,
  403.                    :MIDINIT, :PHONENO
  404.            END-EXEC.
  405.  
  406.            IF SQLCODE = FOUND and Results-Knt <= EMP-ARRAY-MAX
  407.               ADD 1 TO Results-Knt
  408.               MOVE LASTNAME  TO CS-EMP-LASTNAME(Results-Knt)
  409.               MOVE FIRSTNME  TO CS-EMP-FIRSTNAME(Results-Knt)
  410.               MOVE MIDINIT   TO CS-EMP-INITIAL(Results-Knt)
  411.               MOVE WORKDEPT  TO CS-EMP-DEPT(Results-Knt)
  412.               MOVE PHONENO   TO CS-EMP-PHONE(Results-Knt)
  413.               MOVE HIREDATE  TO CS-EMP-HIRE-DATE(Results-Knt)
  414.       *******************************************
  415.       *      Call Calcyear Routine              *
  416.       *******************************************
  417.               MOVE CS-EMP-HIRE-DATE(Results-Knt) TO SC-HIRE-DATE
  418.               MOVE 4  to SC-RETURN-CODE
  419.  
  420.               CALL "SERVC" USING SC-COMMAREA
  421.  
  422.               IF SC-RETURN-CODE NOT = 0
  423.                  MOVE 4 TO CS-RETURN-CODE
  424.               END-if
  425.               MOVE SC-SERVICE-LENGTH TO CS-SERVICE-LENGTH(Results-Knt)
  426.  
  427.            ELSE
  428.       * ---- If database error occured, set DB error return code
  429.               IF SQLCODE NOT = NOT-FOUND and SQLCODE NOT = FOUND
  430.                  MOVE 2 TO CS-RETURN-CODE
  431.                  MOVE SQLCODE TO CS-SQL-CODE
  432.               END-IF
  433.            END-IF.
  434.  
  435.          1230-FETCH-MATCH-EXIT.   EXIT.
  436.  
  437.       ***************************************************************
  438.       *  1600-FIX-NAME.                                             *
  439.       *  This routine sets up the search name for use in the        *
  440.       *  SQL call.  It converts to upper case and removes the       *
  441.       *  leading blanks, then set the search name actually used.    *
  442.       ***************************************************************
  443.  
  444.         1600-FIX-NAME.
  445.       ***************************************************************
  446.       *  This routine strips out the leading blanks from the entry. *
  447.       ***************************************************************
  448.            INITIALIZE LJUST-FIELD-1, LJUST-FIELD-2
  449.            INSPECT IN-LASTNAME
  450.                CONVERTING LOWER-ALPHA TO UPPER-ALPHA.
  451.  
  452.       * --- Left-justify the Last Name input
  453.            IF IN-LASTNAME NOT = SPACES
  454.               INSPECT IN-LASTNAME REPLACING LEADING SPACES BY
  455.                       HIGH-VALUES
  456.               UNSTRING IN-LASTNAME DELIMITED BY ALL HIGH-VALUES
  457.                       INTO LJUST-FIELD-1, LJUST-FIELD-2
  458.               IF LJUST-FIELD-1 = SPACES
  459.                  MOVE LJUST-LASTNAME-2 TO IN-LASTNAME
  460.               END-IF
  461.            END-IF.
  462.       ***************************************************************
  463.  
  464.        End Method "doSearch".
  465.  
  466.       ***************************************************************
  467.  
  468.        END CLASS DBClass.
  469.  
  470.  
  471.