home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / viscobv6.zip / vac22os2 / ibmcobol / samples / purpt / y2kx2pg.sqb < prev    next >
Text File  |  1997-03-13  |  19KB  |  467 lines
  1.        Identification Division.
  2.        Program-ID. Y2KX2PG.
  3.        Author. TE
  4.       ******************************************************************
  5.       *                                                                *
  6.       *    Licensed Material - Property of IBM                         *
  7.       *                                                                *
  8.       *    5622-793 (C) Copyright IBM Corp., 1997                      *
  9.       *    All rights reserved                                         *
  10.       *                                                                *
  11.       *    US Government Users Restricted Rights - Use,                *
  12.       *    duplication or disclosure restricted by GSA ADP             *
  13.       *    Schedule Contract with IBM Corp.                            *
  14.       *                                                                *
  15.       ******************************************************************
  16.       *                                                                *
  17.       * Y2KX2PG is an example program that can be called from          *
  18.       * the DCZY2KR program using the Y2KEXIT capability. This         *
  19.       * program takes the information passed to it from the DCZY2KR    *
  20.       * program and then updates a set of DB2 tables with the          *
  21.       * information.                                                   *
  22.       *                                                                *
  23.       * You will have to do the following things to use this           *
  24.       * exit:                                                          *
  25.       *                                                                *
  26.       * 1) Install OS/2 DB2.                                           *
  27.       * 2) Run the command file Y2KX2CD.CMD to create the DB2          *
  28.       *    database and tables. You may need to modify this            *
  29.       *    command file to allocate the database on the drive you      *
  30.       *    want.                                                       *
  31.       * 3) Run the command file Y2KX2PR.CMD to create the              *
  32.       *    exit Y2KX2PG.DLL.                                           *
  33.       * 4) Change the source in DCZY2KR to enable the exit.            *
  34.       *    Set the VALUE clause for the Y2K-Exit-Flag data item to 'Y'.*
  35.       *    Set the VALUE clause for the Y2K-Exit-Program data item     *
  36.       *    to 'Y2KX2PG'.                                               *
  37.       * 5) Compile and link the modified DCZY2KR program.              *
  38.       *                                                                *
  39.       * Associated files:                                              *
  40.       * * Y2KX2DC.CMD - Command file that creates the DB2 database     *
  41.       *   and tables used by this program.                             *
  42.       * * Y2KX2DC.DEF - DEF file for this program.                     *
  43.       * * Y2KX2PR.CMD - command file to create a DLL for this program. *
  44.       *                                                                *
  45.       *================================================================*
  46.        Environment Division.
  47.       *================================================================*
  48.        Configuration Section.
  49.        Input-Output Section.
  50.        File-Control.
  51.        I-O-Control.
  52.  
  53.       *================================================================*
  54.        Data Division.
  55.       *================================================================*
  56.  
  57.       *================================================================*
  58.        File Section.
  59.       *================================================================*
  60.  
  61.       *================================================================*
  62.        Working-Storage Section.
  63.       *================================================================*
  64.            COPY "sql.cbl".
  65.            COPY "sqlcodes.cbl".
  66.            COPY "sqlenv.cbl".
  67.            COPY "sqlstate.cbl".
  68.            COPY "sqlutil.cbl".
  69.            COPY "sqlaprep.cbl".
  70.  
  71.            EXEC SQL INCLUDE SQLCA END-EXEC.
  72.  
  73.            EXEC SQL BEGIN DECLARE SECTION END-EXEC.
  74.  
  75.        01  program-name         pic x(30).
  76.        01  source-file-name     pic x(56).
  77.        01  data-item-name       pic x(30).
  78.       *    Data item qid is a timestamp. When grouped with
  79.       *    data-item-name we have a unique key.
  80.        01  data-item-qid        pic x(18).
  81.       *    Data item qualified flag.
  82.        01  data-item-qaul-flag  pic x(1).
  83.       *    Line where the data item was defined.
  84.        01  data-item-def-line   pic X(6).
  85.       *    Data item name with full qualification.
  86.        01  data-item-qname.
  87.            49 data-item-qname-len pic s9(4) comp-5.
  88.            49 data-item-qname-str pic x(1500).
  89.       *    Cause data.
  90.        01  cause-data             pic x(11).
  91.  
  92.            EXEC SQL END DECLARE SECTION END-EXEC.
  93.  
  94.       *  turn off SQL EXCEPTION processing
  95.  
  96.            EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC.
  97.            EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC.
  98.            EXEC SQL WHENEVER NOT FOUND CONTINUE END-EXEC.
  99.  
  100.       *  Data items for DISPLAY
  101.        01  PN                         PIC X(9) VALUE 'Y2KX2PG: '.
  102.        01  BN                         PIC X(9) VALUE '         '.
  103.        01  DB-func                    PIC X(60) value spaces.
  104.  
  105.       *  Misc items.
  106.        77  WORKFLAG                   PIC X(1).
  107.        77  J2                         PIC 9(2).
  108.        77  error-code                 Pic 9(4).
  109.       *----------------------------------------------------------------*
  110.       *  Data items used for the Y2K-EXIT.                             *
  111.       *----------------------------------------------------------------*
  112.       *    Function code values.                                       *
  113.        77  Y2K-EXIT-func-init         Pic 9(4) Value 0.
  114.        77  Y2K-EXIT-func-pgm-name     Pic 9(4) Value 1.
  115.        77  Y2K-EXIT-func-dataitem-def Pic 9(4) Value 2.
  116.        77  Y2K-EXIT-func-dataitem-rsn Pic 9(4) Value 3.
  117.        77  Y2K-EXIT-func-source       Pic 9(4) Value 4.
  118.        77  Y2K-EXIT-func-term         Pic 9(4) Value 9000.
  119.        77  Y2K-EXIT-func-term-error   Pic 9(4) Value 9001.
  120.  
  121.  
  122.       *================================================================*
  123.        Linkage Section.
  124.       *================================================================*
  125.       *    Function code.                                              *
  126.        01  Y2K-EXIT-func              Pic 9(4).
  127.        01  Y2k-exit-pgm-name          Pic X(30).
  128.        01  y2k-exit-file-name.
  129.            03 y2k-File-Name-CharZ     Pic X
  130.                                       Occurs 1 to 256 Times
  131.                                       Depending on
  132.                                         y2k-exit-file-name-len.
  133.        01  y2k-exit-file-Name-Len     Pic 9(3).
  134.        01  y2k-exit-item-name         Pic x(30).
  135.        01  y2k-exit-item-q            Pic x(01).
  136.        01  Y2K-EXIT-item-line         Pic 9(6).
  137.        01  y2k-exit-cause             Pic x(11).
  138.        01  y2k-exit-kind              Pic x(03).
  139.        01  y2k-Qualified-Name-Struct.
  140.            02 y2k-Qualified-Name-Size Pic 9999.
  141.            02 y2k-Qualified-Name.
  142.               03 y2k-Qualified-Name-Char
  143.                    Occurs 1 to 1500 Times
  144.                      Depending on y2k-Qualified-Name-Size
  145.                                       Pic X.
  146.  
  147.       * Place holder linkage section items for parameters
  148.       * that change from call to call.
  149.        01  y2k-exit-data1             Pic X(1).
  150.        01  y2k-exit-data2             Pic X(1).
  151.        01  y2k-exit-data3             Pic X(1).
  152.        01  y2k-exit-data4             Pic X(1).
  153.        01  y2k-exit-data5             Pic X(1).
  154.       *================================================================*
  155.        Procedure Division Using Y2K-EXIT-func
  156.                                 y2k-exit-pgm-name
  157.                                 y2k-exit-file-name
  158.                                 y2k-exit-file-name-len
  159.                                 y2k-exit-data1
  160.                                 y2k-exit-data2
  161.                                 y2k-exit-data3
  162.                                 y2k-exit-data4
  163.                                 y2k-exit-data5
  164.                                 .
  165.       *================================================================*
  166.  
  167.       *==============================================================*
  168.       *   Main processing section starts                             *
  169.       *==============================================================*
  170.        Main-processing Section.
  171.  
  172.            move 0 to error-code
  173.  
  174.  
  175.            evaluate Y2K-Exit-func
  176.  
  177.       *       If initialize, connect to the database.
  178.               when Y2K-EXIT-func-init
  179.                  Perform Connect-to-DB
  180.  
  181.       *       If terminate normally, commit the database updates.
  182.               when Y2K-EXIT-func-term
  183.                  Perform Commit-DB-Update
  184.  
  185.       *       If terminate with error, rollback the database updates.
  186.               when Y2K-EXIT-func-term-error
  187.                  Perform Rollback-DB-Update
  188.  
  189.       *       For a new program, remove any existing rows for this
  190.       *       program.
  191.               when Y2K-EXIT-func-pgm-name
  192.                  move y2k-exit-pgm-name to program-name
  193.                  Perform Remove-pgm-from-tables
  194.  
  195.       *       For a data item definition call, add a row to the
  196.       *       data item table.
  197.               when Y2K-EXIT-func-dataitem-def
  198.  
  199.       *          Set addressability to incoming data.
  200.                  set address of y2k-exit-item-name to
  201.                      address of y2k-exit-data1
  202.                  set address of y2k-exit-item-q to
  203.                      address of y2k-exit-data2
  204.                  set address of y2k-Qualified-Name-Struct to
  205.                      address of y2k-exit-data3
  206.                  set address of y2k-exit-item-line to
  207.                      address of y2k-exit-data4
  208.  
  209.       *          Move data into host variables.
  210.                  move y2k-exit-pgm-name to program-name
  211.                  move y2k-exit-file-name to source-file-name
  212.                  move y2k-exit-item-name to data-item-name
  213.                  move y2k-exit-item-q to data-item-qaul-flag
  214.                  move y2k-exit-item-line to data-item-def-line
  215.                  move y2k-Qualified-Name-Size to
  216.                       data-item-qname-len
  217.                  move y2k-Qualified-Name to
  218.                       data-item-qname-str
  219.  
  220.       *          Add the row to the item table.
  221.                  Perform Add-row-to-item-tbl
  222.  
  223.       *       For a reason call, add a row to the reason table.
  224.               when Y2K-EXIT-func-dataitem-rsn
  225.  
  226.       *          Set addressability to incoming data.
  227.                  set address of y2k-exit-item-name to
  228.                      address of y2k-exit-data1
  229.                  set address of y2k-exit-cause to
  230.                      address of y2k-exit-data3
  231.  
  232.       *          Move interesting data into host variables.
  233.       *          No need to move the other data since it was already
  234.       *          moved on the data item definition call.
  235.                  move y2k-exit-cause to cause-data
  236.                  Perform Add-row-to-reason-tbl
  237.  
  238.       *       For a source file call, add a row to the source table.
  239.               when Y2K-EXIT-func-source
  240.                  move y2k-exit-pgm-name to program-name
  241.                  move y2k-exit-file-name to source-file-name
  242.  
  243.                  Perform Add-row-to-source-tbl
  244.  
  245.               when other
  246.                  continue
  247.            end-evaluate
  248.  
  249.       *    Set the return code for the caller so it will know if
  250.       *    processing went well or not.
  251.            move error-code to return-code
  252.  
  253.            goback
  254.            .
  255.  
  256.       ******************************************************************
  257.       * Connect to the database.
  258.       ******************************************************************
  259.        Connect-to-DB.
  260.  
  261.            Move 'CONNECT to PURPT' to DB-func
  262.  
  263.            EXEC SQL CONNECT TO PURPT    END-EXEC
  264.  
  265.            if sqlcode not equal to 0 then
  266.               Perform DB-ERROR
  267.            end-if
  268.            .
  269.  
  270.       ******************************************************************
  271.       * Commit the DB updates.
  272.       ******************************************************************
  273.        Commit-DB-Update.
  274.  
  275.            Move 'COMMIT' to DB-func
  276.  
  277.            EXEC SQL COMMIT WORK END-EXEC
  278.  
  279.            if sqlcode not equal to 0 then
  280.               Perform DB-ERROR
  281.            end-if
  282.            .
  283.  
  284.       ******************************************************************
  285.       * Rollback the DB Updates.
  286.       ******************************************************************
  287.        Rollback-DB-Update.
  288.  
  289.            Move 'ROLLBACK' to DB-func
  290.  
  291.            EXEC SQL ROLLBACK WORK END-EXEC
  292.  
  293.            if sqlcode not equal to 0 then
  294.               Perform DB-ERROR
  295.            end-if
  296.            .
  297.  
  298.       ******************************************************************
  299.       * Before adding the rows for the program, delete any
  300.       * existing rows for the program.
  301.       ******************************************************************
  302.        Remove-pgm-from-tables.
  303.  
  304.            Move 'DELETE program from RSNTBL' to DB-func
  305.  
  306.            EXEC SQL DELETE FROM RSNTBL
  307.                     where progname = :program-name
  308.            END-EXEC
  309.  
  310.            if  sqlcode not equal to 0
  311.                and sqlcode not equal to 100 then
  312.                Perform DB-ERROR
  313.            end-if.
  314.  
  315.            Move 'DELETE program from DITEMTBL' to DB-func
  316.  
  317.            EXEC SQL DELETE FROM DITEMTBL
  318.                     where progname = :program-name
  319.            END-EXEC
  320.  
  321.            if  sqlcode not equal to 0
  322.                and sqlcode not equal to 100 then
  323.                Perform DB-ERROR
  324.            end-if.
  325.  
  326.            Move 'DELETE program from SRCTBL' to DB-func
  327.  
  328.            EXEC SQL DELETE FROM SRCTBL
  329.                     where progname = :program-name
  330.            END-EXEC
  331.  
  332.            if  sqlcode not equal to 0
  333.                and sqlcode not equal to 100 then
  334.                Perform DB-ERROR
  335.            end-if
  336.            .
  337.  
  338.       ******************************************************************
  339.       * Add a row for the program and source to the SRCTBL.
  340.       ******************************************************************
  341.        Add-row-to-source-tbl.
  342.  
  343.            EXEC SQL INSERT INTO SRCTBL
  344.                     VALUES(:program-name,
  345.                            :source-file-name)
  346.            END-EXEC
  347.  
  348.            if  sqlcode not equal to 0
  349.                Perform DB-ERROR
  350.            end-if
  351.            .
  352.  
  353.       ******************************************************************
  354.       * Add a row for the data item to the DITEMTBL.
  355.       ******************************************************************
  356.        Add-row-to-item-tbl.
  357.  
  358.       * Initialize the items that are used to build a unique id
  359.       * for a data item.
  360.            move function current-date(1:16) to data-item-qid(1:16)
  361.            move 0 to j2
  362.  
  363.       * Initialize the flag that controls the perform loop.
  364.            move '0' to workflag
  365.  
  366.       * Loop until the insert works, or there is an error.
  367.            perform with test after until workflag = '1'
  368.  
  369.       * Append a value on to the unique item id.
  370.               move j2                          to data-item-qid(17:2)
  371.  
  372.               EXEC SQL INSERT INTO
  373.                        DITEMTBL(ITEMNAME,
  374.                                 ITEMQID,
  375.                                 PROGNAME,
  376.                                 SRCNAME,
  377.                                 ITEMQTYP,
  378.                                 ITEMDLIN,
  379.                                 ITEMQNAM)
  380.                        VALUES(:data-item-name,
  381.                               :data-item-qid,
  382.                               :program-name,
  383.                               :source-file-name,
  384.                               :data-item-qaul-flag,
  385.                               :data-item-def-line,
  386.                               :data-item-qname)
  387.               END-EXEC
  388.  
  389.  
  390.               evaluate sqlcode
  391.       *          If the insert went OK, set flag to get out of the loop.
  392.                  when 0
  393.                     move '1' to workflag
  394.       *          If the row already exists, bump the counter and try
  395.       *          again.
  396.                  when 100
  397.                     add 1 to j2
  398.                        on size error
  399.                           Display pn 'Unable to add variable.'
  400.                           move '1' to workflag
  401.                     end-add
  402.                  when other
  403.       *          Some unexpected SQL error, get out.
  404.                     Perform DB-ERROR
  405.                     move '1' to workflag
  406.               end-evaluate
  407.  
  408.            end-perform
  409.            .
  410.  
  411.       ******************************************************************
  412.       * Add a row for the reason why a data item was chosen to the
  413.       * RSNTBL.
  414.       ******************************************************************
  415.        Add-row-to-reason-tbl.
  416.  
  417.            Move 'INSERT reason into RSNTBL' to DB-func
  418.  
  419.            EXEC SQL INSERT INTO
  420.                     RSNTBL(ITEMNAME,
  421.                            ITEMQID,
  422.                            PROGNAME,
  423.                            SRCNAME,
  424.                            CAUSE)
  425.                     VALUES(:data-item-name,
  426.                            :data-item-qid,
  427.                            :program-name,
  428.                            :source-file-name,
  429.                            :cause-data)
  430.            END-EXEC
  431.  
  432.       * No problem if row already exists.
  433.  
  434.            if  sqlcode not equal to 0
  435.                and sqlcode not equal to SQLA-RC-INV-INSERT
  436.                Perform DB-ERROR
  437.            end-if
  438.            .
  439.  
  440.       ******************************************************************
  441.       * DB-ERROR: Come here for unexpected DB errors and DISPLAY
  442.       * diagnostic info.
  443.       ******************************************************************
  444.        DB-ERROR.
  445.            EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC.
  446.            EXEC SQL WHENEVER SQLERROR CONTINUE END-EXEC.
  447.  
  448.            DISPLAY pn "DB ERROR!! " sqlcode
  449.            DISPLAY bn "DB function = " DB-func
  450.            DISPLAY bn "sqlcode = " sqlcode
  451.  
  452.            EXEC SQL ROLLBACK WORK END-EXEC
  453.            if  sqlcode  not equal to 0  then
  454.               DISPLAY pn "ROLLBACK FAILED!"
  455.               DISPLAY bn "sqlcode = " sqlcode
  456.            end-if
  457.  
  458.            move 1 to error-code
  459.            .
  460.       *================================================================*
  461.        End Program Y2KX2PG.
  462.       *================================================================*
  463.       *================================================================*
  464.       *  End of Y2KX2PG exit                                           *
  465.       *================================================================*
  466.       *================================================================*
  467.