home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / viscobv6.zip / vac22os2 / ibmcobol / samples / sdu / iwzzss2.cbl < prev    next >
Text File  |  1997-03-14  |  18KB  |  358 lines
  1.       **********************************************************
  2.       *
  3.       *  PRODUCT = Data Description and Conversion for OS/2
  4.       *
  5.       *  SOURCE FILE NAME = IWZZSS2.CBL
  6.       *
  7.       *  DESCRIPTIVE NAME = Conversion Plan Executor Example
  8.       *
  9.       *  FUNCTION = This sample program calls the function of the
  10.       *              conversion plan executor to convert data based on
  11.       *              the conversion plans created by the conversion
  12.       *              plan builder in program IWZZSS1.
  13.       *              In this sample the hex string C1C2C301234C will
  14.       *              be converted with specified plan COBOL_TO_C into
  15.       *              the hex string 41424300D204. Then the hex string
  16.       *              41424300d204 will be converted with the specified  
  17.       *              plan C_TO_COBOL into the hex string C1C2C301234C.
  18.       *              The result will be printed on screen.
  19.       *
  20.       **********************************************************
  21.         IDENTIFICATION DIVISION.
  22.         PROGRAM-ID. IWZZSS2.
  23.         ENVIRONMENT DIVISION.
  24.         CONFIGURATION SECTION.
  25.         SOURCE-COMPUTER. IBM-PS2.
  26.         OBJECT-COMPUTER. IBM-PS2.
  27.         INPUT-OUTPUT SECTION.
  28.         FILE-CONTROL.
  29.             SELECT Sample-SPC ASSIGN TO IWZZSS1F
  30.                               ORGANIZATION IS SEQUENTIAL.
  31.         DATA DIVISION.
  32.         FILE SECTION.
  33.         FD  Sample-SPC
  34.                  RECORD CONTAINS 5000 CHARACTERS
  35.                  RECORDING MODE IS F.
  36.         01  CnvPlnSpc  PICTURE X(5000).
  37.         WORKING-STORAGE SECTION.
  38.       **********************************************************
  39.       *  Parameters for FMTCPXI, FMTCPXC, and FMTCPXT
  40.       **********************************************************
  41.         77  CnvPlnSpcHdl PICTURE 9(6) USAGE IS BINARY.
  42.         77  PlnNamLength PICTURE 9(6) USAGE IS BINARY.
  43.         77  PlnNam PICTURE X(255).
  44.         77  InputParmNum PICTURE 9(6) USAGE IS BINARY.
  45.         77  OutputParmNum PICTURE 9(6) USAGE IS BINARY.
  46.         01  InputData.
  47.              05  InputDataPtr USAGE IS POINTER OCCURS 32 TIMES.
  48.         01  OutputData.
  49.              05  OutputDataPtr USAGE IS POINTER OCCURS 32 TIMES.
  50.         01     FeedBack.
  51.              05 Condition-ID.
  52.                 10 MsgSev  PICTURE 9(2) USAGE IS BINARY.
  53.                 10 MsgNo    PICTURE 9(2) USAGE IS BINARY.
  54.              05 Case-Severity-Control  PICTURE X.
  55.              05 Facility-ID  PICTURE X(3).
  56.              05 I-S-Info.
  57.                 10 AdlExId  PICTURE 9(6) USAGE IS BINARY.
  58.                 10 AdlCommAreaPtr REDEFINES AdlExId USAGE IS POINTER.
  59.                 10 User-ExitCtokPtr  REDEFINES AdlExId USAGE IS POINTER.
  60.       **********************************************************
  61.       *  ADL Communication Area
  62.       **********************************************************
  63.         01     AdlCommArea.
  64.             05 AdlCALength  PICTURE 9(6) USAGE IS BINARY.
  65.             05 ExId  PICTURE 9(6) USAGE IS BINARY.
  66.             05 SevCod  PICTURE 9(2) USAGE IS BINARY.
  67.             05 PlanId.
  68.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  69.                 10  CharData  PICTURE X(255).
  70.             05 PlanStmt  PICTURE 9(6) USAGE IS BINARY.
  71.             05 InpErrDta.
  72.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  73.                 10  CharData  PICTURE X(255).
  74.             05 SrcFldID.
  75.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  76.                 10  CharData  PICTURE X(255).
  77.             05 TrgFldId.
  78.                 10  PreLength  PICTURE 9(2) USAGE IS BINARY.
  79.                 10  CharData  PICTURE X(255).
  80.       **********************************************************
  81.       *  Return Codes and ADL Exception Codes
  82.       **********************************************************
  83.         77  CPX-NO-ERROR  PICTURE 9(6) USAGE IS BINARY
  84.                           VALUE IS 0.
  85.         77  CPX-ADL-EXCEPTION-SEV2  PICTURE 9(6) USAGE IS BINARY
  86.                           VALUE IS 102.
  87.         77  CPX-ADL-EXCEPTION-SEV3  PICTURE 9(6) USAGE IS BINARY
  88.                           VALUE IS 103.
  89.         77  CpxType  PICTURE X(7).
  90.       **********************************************************
  91.       *  Input and Output buffers and test data for SAMPLE2
  92.       **********************************************************
  93.         77  SizeOfInput  PICTURE 9(6) USAGE IS BINARY VALUE IS 6.
  94.         77  InValue  PICTURE X(6).
  95.         01  OutBuffer.
  96.              05 OutValue  PICTURE X(6).
  97.              05 OutValueTbl REDEFINES OutValue
  98.                             PICTURE X(1) OCCURS 6 TIMES
  99.                             INDEXED BY M.
  100.         01  OutHexBuffer VALUE IS "X'".
  101.              05 OutHexValue PICTURE X(1) OCCURS 15 TIMES
  102.                             INDEXED BY K.
  103.         77  EBCD  PICTURE X(6)  VALUE IS X"C1C2C301234C".
  104.         77  ASCII  PICTURE X(6)  VALUE IS X"41424300D204".
  105.       **********************************************************
  106.       *  Tables and Work Areas for displaying the value in the output
  107.       *  buffer in hex
  108.       **********************************************************
  109.         77  First-Digit  PICTURE 9(6) USAGE IS BINARY.
  110.         77  Second-Digit  PICTURE 9(6) USAGE IS BINARY.
  111.         77  I  PICTURE 9(6) USAGE IS BINARY.
  112.         77  Switch  PICTURE 9(6) USAGE IS BINARY.
  113.         01  HexIndex.
  114.              05 HexValue-1  PICTURE X(128)
  115.                              VALUE IS X"000102030405060708090A0B0C0D0E0F
  116.       -                                "101112131415161718191A1B1C1D1E1F
  117.       -                                "202122232425262728292A2B2C2D2E2F
  118.       -                                "303132333435363738393A3B3C3D3E3F
  119.       -                                "404142434445464748494A4B4C4D4E4F
  120.       -                                "505152535455565758595A5B5C5D5E5F
  121.       -                                "606162636465666768696A6B6C6D6E6F
  122.       -                              "707172737475767778797A7B7C7D7E7F".
  123.             05 HexTable-1  REDEFINES HexValue-1
  124.                                PICTURE X(1) OCCURS 128 TIMES.
  125.              05 HexValue-2  PICTURE X(128)
  126.                              VALUE IS X"808182838485868788898A8B8C8D8E8F
  127.       -                                "909192939495969798999A9B9C9D9E9F
  128.       -                                "A0A1A2A3A4A5A6A7A8A9AAABACADAEAF
  129.       -                                "B0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF
  130.       -                                "C0C1C2C3C4C5C6C7C8C9CACBCCCDCECF
  131.       -                                "D0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF
  132.       -                                "E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEF
  133.       -                            "F0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF".
  134.             05 HexTable-2  REDEFINES HexValue-2
  135.                                PICTURE X(1) OCCURS 128 TIMES.
  136.         01  Hex-To-Char.
  137.              05 CharValue  PICTURE X(16)
  138.                            VALUE IS "0123456789ABCDEF".
  139.              05 Hex-To-Char-Tbl  REDEFINES CharValue PICTURE X(1)
  140.                                  OCCURS 16 TIMES.
  141.         PROCEDURE DIVISION.
  142.       **********************************************************
  143.       *  Read the conversion plan space created in SAMPLE1
  144.       **********************************************************
  145.             OPEN INPUT Sample-SPC.
  146.             READ Sample-SPC.
  147.             CLOSE Sample-SPC.
  148.       **********************************************************
  149.       *  Call Conversion Plan Executor Initialization
  150.       **********************************************************
  151.             CALL "FMTCPXI" USING
  152.                         BY REFERENCE CnvPlnSpc
  153.                         BY REFERENCE CnvPlnSpcHdl
  154.                         BY REFERENCE FeedBack.
  155.       **********************************************************
  156.       *  Check the Condition Token
  157.       **********************************************************
  158.             IF MsgNo OF Condition-ID IN FeedBack NOT = CPX-NO-ERROR
  159.             THEN
  160.                MOVE "Init" TO CpxType
  161.                PERFORM PrintCtok
  162.             ELSE
  163.                SET AdlCommAreaPtr TO ADDRESS OF AdlCommArea
  164.       **********************************************************
  165.       *  Call Conversion Plan Executor Convert
  166.       *  In this conversion the plan COBOL_TO_C is executed. The input
  167.       *  data are:
  168.       *     "ABC"  in international EBCDIC format -> X'C1C2C3'
  169.       *     1234   in PACKED PRECISION(5) format  -> X'01234C'
  170.       *
  171.       *  The output data after conversion should be:
  172.       *     "ABC"  in Latin PC Data format + suffix -> X'41424300'
  173.       *     1234   in BINARY byte reversed format   -> X'D204'
  174.       **********************************************************
  175.                MOVE 10 TO PlnNamLength
  176.                MOVE "COBOL_TO_C" TO PlnNam
  177.                MOVE 1 TO InputParmNum
  178.                MOVE 1 TO OutputParmNum
  179.                MOVE EBCD TO InValue
  180.                MOVE SPACES TO OutValue
  181.                SET InputDataPtr(1) TO ADDRESS OF InValue
  182.                SET OutputDataPtr(1) TO ADDRESS OF OutValue
  183.                CALL "FMTCPXC" USING
  184.                            BY VALUE     CnvPlnSpcHdl
  185.                            BY VALUE     PlnNamLength
  186.                            BY REFERENCE PlnNam
  187.                            BY VALUE     InputParmNum
  188.                            BY REFERENCE InputData
  189.                            BY VALUE     OutputParmNum
  190.                            BY REFERENCE OutputData
  191.                            BY REFERENCE FeedBack
  192.                IF MsgNo OF Condition-ID IN FeedBack NOT = CPX-NO-ERROR
  193.                THEN
  194.       **********************************************************
  195.       *  An error occurred. Print the condition token
  196.       **********************************************************
  197.                   MOVE "Convert" TO CpxType
  198.                   PERFORM PrintCtok
  199.                   STOP RUN
  200.                ELSE
  201.       **********************************************************
  202.       *  Print the converted value
  203.       **********************************************************
  204.                   SET K TO 3
  205.                   PERFORM Hex-Convert VARYING M FROM 1 BY 1
  206.                                       UNTIL M > SizeOfInput
  207.                   MOVE "'" TO OutHexValue(K)
  208.                   DISPLAY " Converted value for plan COBOL_TO_C: "
  209.                                                 OutHexBuffer
  210.                END-IF
  211.       **********************************************************
  212.       *  Call Conversion Plan Executor Convert
  213.       *  In this conversion the plan C_TO_COBOL is executed. The input
  214.       *  data are:
  215.       *     "ABC"  in Latin PC Data format + suffix -> X'41424300'
  216.       *     1234   in BINARY byte reversed format   -> X'D204'
  217.       *
  218.       *  The output data after conversion should be:
  219.       *     "ABC"  in international EBCDIC format -> X'C1C2C3'
  220.       *     1234   in PACKED PRECISION(5) format  -> X'01234C'
  221.       **********************************************************
  222.                MOVE 10 TO PlnNamLength
  223.                MOVE "C_TO_COBOL" TO PlnNam
  224.                MOVE 1 TO InputParmNum
  225.                MOVE 1 TO OutputParmNum
  226.                MOVE ASCII TO InValue
  227.                MOVE SPACES TO OutValue
  228.                SET InputDataPtr(1) TO ADDRESS OF InValue
  229.                SET OutputDataPtr(1) TO ADDRESS OF OutValue
  230.                CALL "FMTCPXC" USING
  231.                            BY VALUE     CnvPlnSpcHdl
  232.                            BY VALUE     PlnNamLength
  233.                            BY REFERENCE PlnNam
  234.                            BY VALUE     InputParmNum
  235.                            BY REFERENCE InputData
  236.                            BY VALUE     OutputParmNum
  237.                            BY REFERENCE OutputData
  238.                            BY REFERENCE FeedBack
  239.                IF MsgNo OF Condition-ID IN FeedBack NOT = CPX-NO-ERROR
  240.                THEN
  241.       **********************************************************
  242.       *  An error occurred. Print the condition token
  243.       **********************************************************
  244.                   MOVE "Convert" TO CpxType
  245.                   PERFORM PrintCtok
  246.                ELSE
  247.       **********************************************************
  248.       *  Print the converted value
  249.       **********************************************************
  250.                   SET K TO 3
  251.                   PERFORM Hex-Convert VARYING M FROM 1 BY 1 
  252.                                       UNTIL M > SizeOfInput
  253.                   MOVE "'" TO OutHexValue(K)
  254.                   DISPLAY " Converted value for plan C_TO_COBOL: "
  255.                                                        OutHexBuffer
  256.                END-IF
  257.       **********************************************************
  258.       *  Call Conversion Plan Executor Termination
  259.       **********************************************************
  260.                CALL "FMTCPXT" USING
  261.                            BY VALUE     CnvPlnSpcHdl
  262.                            BY REFERENCE FeedBack
  263.       **********************************************************
  264.       *  Check the Condition Token
  265.       **********************************************************
  266.                IF MsgNo OF Condition-ID IN FeedBack NOT = CPX-NO-ERROR
  267.                THEN
  268.                   MOVE "Term" TO CpxType
  269.                   PERFORM PrintCtok
  270.                END-IF
  271.             END-IF.
  272.             STOP RUN.
  273.       **********************************************************
  274.       *  The procedure PrintCtok prints the condition token and the ADL
  275.       *  communication area after an error occurred in a conversion 
  276.       *  plan executor function.
  277.       *  Note: The Case-Severity-Control field is further divided into
  278.       *        three sub-fields. You may want to display it in hex.
  279.       **********************************************************
  280.          PrintCtok.
  281.             DISPLAY "Error in Conversion Plan Executor " CpxType.
  282.             DISPLAY "The Condition Token has the following contents:".
  283.             DISPLAY "Message Severity "
  284.                     MsgSev OF Condition-ID IN FeedBack
  285.                     " Number "
  286.                     MsgNo OF Condition-ID IN FeedBack.
  287.             DISPLAY "Case+Severity+Control "
  288.                     Case-Severity-Control IN FeedBack.
  289.             DISPLAY "Facility ID "
  290.                           Facility-ID OF FeedBack.
  291.       **********************************************************
  292.       *  Check whether an ADL exception occurred.
  293.       **********************************************************
  294.             IF MsgNo OF Condition-ID = CPX-ADL-EXCEPTION-SEV2  OR
  295.                 MsgNo OF Condition-ID = CPX-ADL-EXCEPTION-SEV3
  296.             THEN
  297.                IF CpxType = "INIT"
  298.                THEN
  299.                   DISPLAY "ADL exception " AdlExId IN FeedBack
  300.                ELSE
  301.                   DISPLAY
  302.                    "The ADL communication area has the following
  303.       -                         " contents:"
  304.                   DISPLAY "ADL exception: " ExId OF AdlCommArea
  305.                   DISPLAY "Severity of ADL exception: "
  306.                           SevCod OF AdlCommArea
  307.                   DISPLAY "Name of processed plan: "
  308.                           CharData OF PlanId OF AdlCommArea
  309.                   DISPLAY "Number of processed PLAN statement: "
  310.                           PlanStmt OF AdlCommArea
  311.                   DISPLAY "Input data portion that caused the error: "
  312.                           CharData OF InpErrDta OF AdlCommArea
  313.                   DISPLAY "Source identifier of processed assignment
  314.       -                          " statement: "
  315.                           CharData OF SrcFldId OF AdlCommArea
  316.                   DISPLAY "Target identifier of processed assignment
  317.       -                          " statement: "
  318.                           CharData OF TrgFldId OF AdlCommArea
  319.                END-IF
  320.             END-IF.
  321.       **********************************************************
  322.       *  The procedure Hex-Convert converts a byte string to a hex
  323.       *  string which can be DISPLAYed.
  324.       **********************************************************
  325.          Hex-Convert.
  326.             MOVE 0 TO Switch.
  327.             PERFORM Hex-Convert-1 VARYING I FROM 1 BY 1
  328.                                         UNTIL Switch = 1 OR I > 128.
  329.             IF Switch = 0
  330.             THEN
  331.                PERFORM Hex-Convert-2 VARYING I FROM 1 BY 1
  332.                                         UNTIL Switch = 1 
  333.             END-IF.
  334.          Hex-Convert-1.
  335.             IF OutValueTbl(M) = HexTable-1(I)
  336.             THEN
  337.                DIVIDE 16 INTO I GIVING First-Digit
  338.                                 REMAINDER Second-Digit
  339.                MOVE Hex-To-Char-Tbl(First-Digit + 1) 
  340.                                     TO OutHexValue(K)
  341.                SET K UP BY 1
  342.                MOVE Hex-To-Char-Tbl(Second-Digit) TO OutHexValue(K)
  343.                SET K UP BY 1
  344.                MOVE 1 TO Switch
  345.             END-IF.
  346.          Hex-Convert-2.
  347.             IF OutValueTbl(M) = HexTable-2(I)
  348.             THEN
  349.                DIVIDE 16 INTO I GIVING First-Digit
  350.                                 REMAINDER Second-Digit
  351.                MOVE Hex-To-Char-Tbl(First-Digit + 9)
  352.                            TO OutHexValue(K)
  353.                SET K UP BY 1
  354.                MOVE Hex-To-Char-Tbl(Second-Digit) TO OutHexValue(K)
  355.                SET K UP BY 1
  356.                MOVE 1 TO Switch
  357.             END-IF.
  358.