Quelle dml084.cob Sprache: Cobol

       IDENTIFICATION DIVISION.
       PROGRAM-ID.  DML084.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER.  xyz.
       OBJECT-COMPUTER.  xyz.
       DATA DIVISION.
       WORKING-STORAGE SECTION.

      * Standard COBOL (file "DML084.SCO") calling SQL
      * procedures in file "DML084.MCO".
      * STANDARD COBOL (file "DML084.SCO")

      ****************************************************************
      *
      *                 COMMENT SECTION
      *
      * DATE 1992/07/14 STANDARD COBOL LANGUAGE
      * NIST SQL VALIDATION TEST SUITE V6.0
      *  DISCLAIMER:
      *  This program was written by employees of NIST to test SQL
      *  implementations for conformance to the SQL standards.
      *  NIST assumes no responsibility for any party's use of
      *  this program.
      *
      * DML084.SCO
      * WRITTEN BY: DAVID W. FLATER
      *
      *   THIS ROUTINE TESTS THE SQLSTATE STATUS CODE.
      *
      * REFERENCES
      *   ANSI SQL-1992
      *     22.1  SQLSTATE
      *
      ****************************************************************

      * EXEC SQL BEGIN DECLARE SECTION END-EXEC
       01  uid PIC  X(18).
       01  uidx PIC  X(18).
       01  ct1 PIC  X(2).
       01  tmpcnt PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
      *  EXEC SQL END DECLARE SECTION END-EXEC
       01  ii PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  SQLCODE PIC S9(9) COMP.
       01  SQLSTATE PIC  X(5).
       01  norm1 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  norm2 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  ALPNUM-TABLE VALUE IS
               "01234ABCDEFGH56789IJKLMNOPQRSTUVWXYZ".
           05  ALPNUM PIC X OCCURS 36 TIMES.

       01  NR-TAB.
           05  NORMSQ PIC X OCCURS 5 TIMES.
       01  SQLST1 PIC  X(5).
       01  SQLST2 PIC  X(5).
       01  SQLST3 PIC  X(5).
       01  SQLST4 PIC  X(5).
       01  SQLST5 PIC  X(5).
       01  SQLCD1 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  SQLCD2 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  SQLCD3 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  SQLCD4 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  SQLCD5 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  errcnt PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
      *date_time declaration
       01  TO-DAY PIC 9(6).
       01  THE-TIME PIC 9(8).
       01  flag PIC S9(9) DISPLAY SIGN LEADING SEPARATE.

       01  SQL-COD PIC S9(9) DISPLAY SIGN LEADING SEPARATE.

       PROCEDURE DIVISION.
       P0.

             MOVE "SCHANZLE" TO uid
             CALL "AUTHID" USING uid
             MOVE "not logged in, not" TO uidx
      *  EXEC SQL SELECT USER INTO :uidx FROM HU.ECCO;
             CALL "SUB1" USING SQLCODE SQLSTATE uidx
             MOVE SQLCODE TO SQL-COD
             if (uid  NOT  =   uidx) then
               DISPLAY "ERROR: User ", uid " expected. User ", uidx "
      -    " connected"
             STOP RUN
             END-IF
             MOVE 0 TO errcnt
             MOVE 1 TO flag

           DISPLAY
              "SQL Test Suite, V6.0, Standard COBOL, dml084.sco"
           DISPLAY
           "59-byte ID"
             DISPLAY "TEd Version #"
      *date_time print
           ACCEPT TO-DAY FROM DATE
           ACCEPT THE-TIME FROM TIME
           DISPLAY "Date run YYMMDD: " TO-DAY " at hhmmssff: " THE-TIME

      ******************** BEGIN TEST0503 *******************
             MOVE 1 TO flag

             DISPLAY " TEST0503 "
             DISPLAY "SQLSTATE = 42000: syntax error or access rule vio.
      -    " 1"
             DISPLAY "Note: VALID implementation-defined subclass will
      -    " be"
             DISPLAY " accepted instead of no-subclass value of 000
      -    " "
             DISPLAY "Reference ANSI SQL-1992,"
             DISPLAY " section 6.3 Access Rule #1"
             DISPLAY " section 3.3.4.3 Terms denoting rule
      -    " requirements"
             DISPLAY " section 3.3.4.4 Rule evaluation order"
             DISPLAY " - - - - - - - - - - - - - - - - - - -"

             DISPLAY "Test numbers 0503 and 0504 check for SQLSTATE"
             DISPLAY "42000 on syntax errors and access violations."
             DISPLAY "SQL-92 permits, but does not require, an"
            DISPLAY "implementation to achieve a high level of security"
             DISPLAY "by returning the same error for an access"
             DISPLAY "violation as for a reference to a non-existent"
             DISPLAY "table. This test exercises several different"
             DISPLAY "types of syntax errors and access violations. If"
             DISPLAY "you are trying for a high security level, please"
             DISPLAY "insure that the compilation AND the run time"
             DISPLAY "behavior of all these errors are"
             DISPLAY "indistinguishable."
             DISPLAY " "
             DISPLAY "For minimal SQL-92 conformance, each run time"
             DISPLAY "error must produce SQLSTATE 42000 or 42 with some"
             DISPLAY "implementor-defined subclass. The subclass can"
             DISPLAY "be different for each error. Compile time errors"
             DISPLAY "are also permissible."
             DISPLAY  " "
             DISPLAY  " "
             DISPLAY  " "
             DISPLAY  " "

      *HU.UPUNIQ has a row (1,'A'), but SCHANZLE has no privileges
             MOVE 0 TO SQLCODE
             MOVE "x" TO ct1
             MOVE "x" TO SQLSTATE
             DISPLAY "SELECT COL2 INTO :ct1 FROM HU.UPUNIQ WHERE NUMKEY
      -    " = 1;"
      *  EXEC SQL SELECT COL2 INTO :ct1 FROM HU.UPUNIQ WHERE NUMKEY
      *  = 1;
             CALL "SUB2" USING SQLCODE SQLSTATE ct1
             MOVE SQLCODE TO SQL-COD
             MOVE SQLSTATE TO SQLST1
             MOVE SQLCODE TO SQLCD1
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             DISPLAY "ct1 should NOT be 'A '; its value is ", ct1
             if (SQLCODE  NOT <  0  OR  ct1   =   "A ") then
               MOVE 0 TO flag
             END-IF
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF

      *SCHANZLE has no privileges on table HU.UPUNIQ - attempt UPDATE
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "UPDATE HU.UPUNIQ SET COL2 = 'xx';"
      *  EXEC SQL UPDATE HU.UPUNIQ SET COL2 = 'xx';
             CALL "SUB3" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             MOVE SQLSTATE TO SQLST2
             MOVE SQLCODE TO SQLCD2
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF

      *SCHANZLE has no privileges on table HU.UPUNIQ - attempt DELETE
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "DELETE FROM HU.UPUNIQ;"
      *  EXEC SQL DELETE FROM HU.UPUNIQ;
             CALL "SUB4" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             MOVE SQLSTATE TO SQLST3
             MOVE SQLCODE TO SQLCD3
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF

      *SCHANZLE has no privileges on table HU.UPUNIQ - attempt insert
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "INSERT INTO HU.UPUNIQ VALUES (9,'M');"
      *  EXEC SQL INSERT INTO HU.UPUNIQ VALUES (9,'M');
             CALL "SUB5" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             MOVE SQLSTATE TO SQLST4
             MOVE SQLCODE TO SQLCD4
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF

      *Subtest 0503e begins.
      *If it will not compile, save error message
      *and then delete the subtest with TEd "hooks".

      *Privilege violation in 'inessential part' - middle subquery
             COMPUTE tmpcnt = -1
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "SELECT COUNT(*) INTO :tmpcnt FROM HU.STAFF"
             DISPLAY "WHERE GRADE <"
             DISPLAY " (SELECT MAX(HOURS) FROM HU.WORKS)"
             DISPLAY "OR GRADE >"
             DISPLAY " (SELECT MAX(NUMKEY) FROM HU.UPUNIQ)"
             DISPLAY "OR GRADE + 100 >"
             DISPLAY " (SELECT MIN(HOURS) FROM HU.WORKS);"
      *  EXEC SQL SELECT COUNT(*) INTO :tmpcnt FROM HU.STAFF
      *    WHERE GRADE <
      *    (SELECT MAX(HOURS) FROM HU.WORKS)
      *    OR    GRADE >
      *    (SELECT MAX(NUMKEY) FROM HU.UPUNIQ)
      *    OR    GRADE + 100 >
      *    (SELECT MIN(HOURS) FROM HU.WORKS);
             CALL "SUB6" USING SQLCODE SQLSTATE tmpcnt
             MOVE SQLCODE TO SQL-COD
             MOVE SQLSTATE TO SQLST5
             MOVE SQLCODE TO SQLCD5
             DISPLAY "tmpcnt should not be 5; its value is ", tmpcnt
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (tmpcnt  =  5  OR  SQLCODE  NOT <  0  OR  NR-TAB  NOT  =
               "42000") then
               MOVE 0 TO flag
             END-IF
      *Subtest 0503e ends

      *Subtest 0503f begins.
      *If it will not compile, save error message
      *and then delete the subtest with TEd "hooks".

      *Privilege violation AND syntax error (column 2 is CHAR(2))
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "INSERT INTO HU.UPUNIQ VALUES (13,44);"
      *  EXEC SQL INSERT INTO HU.UPUNIQ VALUES (13,44);
             CALL "SUB7" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF
             if (SQLCODE  NOT =  SQLCD4  OR  SQLSTATE  NOT  =   SQLST4)
             then
               DISPLAY "Optional security note:"
               DISPLAY "Different message for access violation and "
               DISPLAY " access violation with syntax error (CHAR
      -    " column) "
             END-IF
      *Subtest 0503f ends

      *Subtest 0503g begins.
      *If it will not compile, save error message
      *and then delete the subtest with TEd "hooks".

      *Privilege violation AND syntax error (2 columns in row)
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "INSERT INTO HU.UPUNIQ VALUES (555666777);"
      *  EXEC SQL INSERT INTO HU.UPUNIQ VALUES
      *       (555666777);
             CALL "SUB8" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF
             if (SQLCODE  NOT =  SQLCD4  OR  SQLSTATE  NOT  =   SQLST4)
             then
               DISPLAY "Optional security note:"
               DISPLAY "Different message for access violation and "
               DISPLAY " access violation with syntax error (wrong #
      -    " columns) "
             END-IF
      *Subtest 0503g ends

      *  EXEC SQL ROLLBACK WORK;
             CALL "SUB9" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD

             if ( flag  =  1 ) then
               DISPLAY " *** pass *** "
      *    EXEC SQL INSERT INTO HU.TESTREPORT
      *      VALUES('0503','pass','MCO');
               CALL "SUB10" USING SQLCODE SQLSTATE
               MOVE SQLCODE TO SQL-COD
             else
               DISPLAY " dml084.sco *** fail *** "
      *    EXEC SQL INSERT INTO HU.TESTREPORT
      *      VALUES('0503','fail','MCO');
               CALL "SUB11" USING SQLCODE SQLSTATE
               MOVE SQLCODE TO SQL-COD
               COMPUTE errcnt = errcnt + 1
             END-IF

             DISPLAY "==============================================="

      *  EXEC SQL COMMIT WORK;
             CALL "SUB12" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      ******************** END TEST0503 ********************

      ******************** BEGIN TEST0504 *******************
             MOVE 1 TO flag

             DISPLAY " OPTIONAL TEST0504 "
             DISPLAY "SQLSTATE = 42000: syntax error or access rule vio.
      -    " 2"
             DISPLAY "Note: VALID implementation-defined subclass will
      -    " be"
             DISPLAY " accepted instead of no-subclass value of 000
      -    " "
             DISPLAY "Reference ANSI SQL-1992,"
             DISPLAY " section 6.3

Access Rule #1"
             DISPLAY " section 3.3.4.3 Terms denoting rule
      -    " requirements"
             DISPLAY " section 3.3.4.4 Rule evaluation order"
             DISPLAY " - - - - - - - - - - - - - - - - - - -"

             DISPLAY "Test numbers 0503 and 0504 check for SQLSTATE"
             DISPLAY "42000 on syntax errors and access violations."
             DISPLAY "SQL-92 permits, but does not require, an"
            DISPLAY "implementation to achieve a high level of security"
             DISPLAY "by returning the same error for an access"
             DISPLAY "violation as for a reference to a non-existent"
             DISPLAY "table. This test exercises several different"
             DISPLAY "types of syntax errors and access violations. If"
             DISPLAY "you are trying for a high security level, please"
             DISPLAY "insure that the compilation AND the run time"
             DISPLAY "behavior of all these errors are"
             DISPLAY "indistinguishable."
             DISPLAY " "
             DISPLAY "For minimal SQL-92 conformance, each run time"
             DISPLAY "error must produce SQLSTATE 42000 or 42 with some"
             DISPLAY "implementor-defined subclass. The subclass can"
             DISPLAY "be different for each error. Compile time errors"
             DISPLAY "are also permissible."
             DISPLAY  " "
             DISPLAY  " "
             DISPLAY  " "

      *HU.UPUPUP DOES NOT EXIST  - attempt SELECT
             MOVE 0 TO SQLCODE
             MOVE "x" TO ct1
             MOVE "x" TO SQLSTATE
             DISPLAY "SELECT COL2 INTO :ct1 FROM HU.UPUPUP WHERE NUMKEY
      -    " = 1;"
      *  EXEC SQL SELECT COL2 INTO :ct1 FROM HU.UPUPUP WHERE NUMKEY
      *  = 1;
             CALL "SUB13" USING SQLCODE SQLSTATE ct1
             MOVE SQLCODE TO SQL-COD
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF
             if (SQLCODE  NOT =  SQLCD1  OR  SQLSTATE  NOT  =   SQLST1)
             then
               DISPLAY "Optional security note:"
               DISPLAY "Different message for SELECT access violation "
               DISPLAY "and SELECT on table which does not exist."
             END-IF

      *HU.UPUPUP does not exist - attempt UPDATE
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "UPDATE HU.UPUPUP SET COL2 = 'xx';"
      *  EXEC SQL UPDATE HU.UPUPUP SET COL2 = 'xx';
             CALL "SUB14" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF
             if (SQLCODE  NOT =  SQLCD2  OR  SQLSTATE  NOT  =   SQLST2)
             then
               DISPLAY "Optional security note:"
               DISPLAY "Different message for UPDATE access violation "
               DISPLAY "and UPDATE of table which does not exist."
             END-IF

      *HU.UPUPUP does not exist - attempt DELETE
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "DELETE FROM HU.UPUPUP;"
      *  EXEC SQL DELETE FROM HU.UPUPUP;
             CALL "SUB15" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF
             if (SQLCODE  NOT =  SQLCD3  OR  SQLSTATE  NOT  =   SQLST3)
             then
               DISPLAY "Optional security note:"
               DISPLAY "Different message for DELETE access violation "
               DISPLAY "and DELETE for table which does not exist."
             END-IF

      *HU.UPUPUP does not exist - attempt insert
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "INSERT INTO HU.UPUPUP VALUES (9,'M');"
      *  EXEC SQL INSERT INTO HU.UPUPUP VALUES (9,'M');
             CALL "SUB16" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (SQLCODE  NOT <  0  OR  NR-TAB  NOT  =   "42000") then
               MOVE 0 TO flag
             END-IF
             if (SQLCODE  NOT =  SQLCD4  OR  SQLSTATE  NOT  =   SQLST4)
             then
               DISPLAY "Optional security note:"
               DISPLAY "Different message for INSERT access violation "
               DISPLAY "and INSERT for table which does not exist."
             END-IF

      *HU.UPUPUP DOES NOT EXIST - inessential part of middle subquery
             COMPUTE tmpcnt = -1
             DISPLAY  " "
             MOVE 0 TO SQLCODE
             MOVE "x" TO SQLSTATE
             DISPLAY "SELECT COUNT(*) INTO :tmpcnt FROM HU.STAFF"
             DISPLAY "WHERE GRADE <"
             DISPLAY " (SELECT MAX(HOURS) FROM HU.WORKS)"
             DISPLAY "OR GRADE >"
             DISPLAY " (SELECT MAX(NUMKEY) FROM HU.UPUPUP)"
             DISPLAY "OR GRADE + 100 >"
             DISPLAY " (SELECT MIN(HOURS) FROM HU.WORKS);"
      *  EXEC SQL SELECT COUNT(*) INTO :tmpcnt FROM HU.STAFF
      *    WHERE GRADE <
      *    (SELECT MAX(HOURS) FROM HU.WORKS)
      *    OR    GRADE >
      *    (SELECT MAX(NUMKEY) FROM HU.UPUPUP)
      *    OR    GRADE + 100 >
      *    (SELECT MIN(HOURS) FROM HU.WORKS);
             CALL "SUB17" USING SQLCODE SQLSTATE tmpcnt
             MOVE SQLCODE TO SQL-COD
             DISPLAY "tmpcnt should not be 5; its value is ", tmpcnt
             DISPLAY "SQLCODE should be < 0; its value is ", SQL-COD
             DISPLAY "SQLSTATE should be '42000'; its value is ",
             SQLSTATE
             PERFORM NOSUBCLASS THRU EXIT-NOSUBCLASS
             if (tmpcnt  =  5  OR  SQLCODE  NOT <  0  OR  NR-TAB  NOT  =
               "42000") then
               MOVE 0 TO flag
             END-IF
             if (SQLCODE  NOT =  SQLCD5  OR  SQLSTATE  NOT  =   SQLST5)
             then
               DISPLAY "Optional security note:"
               DISPLAY "Different message for access violation and "
               DISPLAY " access violation with syntax error (wrong #
      -    " columns) "
             END-IF

      *  EXEC SQL ROLLBACK WORK;
             CALL "SUB18" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD

             if ( flag  =  1 ) then
               DISPLAY " *** pass *** "
      *    EXEC SQL INSERT INTO HU.TESTREPORT
      *      VALUES('0504','pass','MCO');
               CALL "SUB19" USING SQLCODE SQLSTATE
               MOVE SQLCODE TO SQL-COD
             else
               DISPLAY " dml084.sco *** fail *** "
      *    EXEC SQL INSERT INTO HU.TESTREPORT
      *      VALUES('0504','fail','MCO');
               CALL "SUB20" USING SQLCODE SQLSTATE
               MOVE SQLCODE TO SQL-COD
               COMPUTE errcnt = errcnt + 1
             END-IF

             DISPLAY "==============================================="

      *  EXEC SQL COMMIT WORK;
             CALL "SUB21" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      ******************** END TEST0504 ********************

      **** TESTER MAY CHOOSE TO INSERT CODE FOR errcnt > 0
           STOP RUN.

      *    ****  Procedures for PERFORM statements
       NOSUBCLASS.

      *This routine replaces valid implementation-defined
      *subclasses with 000.  This replacement equates valid
      *implementation-defined subclasses with the 000 value
      *expected by the test case; otherwise the test will fail.
      *After calling NOSUBCLASS, NORMSQ will be tested
      *                          SQLSTATE will be printed.

           MOVE SQLSTATE TO NR-TAB

           MOVE 3 TO norm1
      *subclass begins in position 3 of char array NORMSQ
           MOVE 14 TO norm2
           PERFORM P90 UNTIL norm2 > 36

           if (NR-TAB   =   SQLSTATE) then
             GO TO EXIT-NOSUBCLASS
           END-IF
      *Quit if NORMSQ is unchanged.  Subclass is not impl.-def.
      *Changed NORMSQ means implementation-defined subclass,
      *so proceed to zero it out, if valid (0-9,A-Z)

           MOVE 4 TO norm1
      *examining position 4 of char array NORMSQ
           MOVE 1 TO norm2
           PERFORM P89 UNTIL norm2 > 36

           MOVE 5 TO norm1
      *examining position 5 of char array NORMSQ
           MOVE 1 TO norm2
           PERFORM P88 UNTIL norm2 > 36


      *implementation-defined subclasses are allowed for warnings
      *(class = 01).  These equate to successful completion
      *SQLSTATE values of 00000.
      *Reference SQL-92 4.28 SQL-transactions, paragraph 2

           if (NORMSQ(1)  =  "0"  AND  NORMSQ(2)  =  "1") then
             MOVE "0" TO NORMSQ(2)
           END-IF
           GO TO EXIT-NOSUBCLASS
           .

       P90.
      *valid subclass begins with 5-9, I-Z, end of ALPNUM table
           if (NORMSQ(norm1)  =  ALPNUM(norm2)) then
             MOVE "0" TO NORMSQ(norm1)
           END-IF
           ADD 1 TO norm2
           .

       P89.
      *valid characters are 0-9, A-Z
           if (NORMSQ(norm1)  =  ALPNUM(norm2)) then
             MOVE "0" TO NORMSQ(norm1)
           END-IF
           ADD 1 TO norm2
           .

       P88.
      *valid characters are 0-9, A-Z
           if (NORMSQ(norm1)  =  ALPNUM(norm2)) then
             MOVE "0" TO NORMSQ(norm1)
           END-IF
           ADD 1 TO norm2
           .

       EXIT-NOSUBCLASS.
           EXIT.

quality100%

¤ Dauer der Verarbeitung: 0.16 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.