Ziele Untersuchung
mit Columbo Integrität von
Datenbanken Interaktion und
Portierbarkeit Ergonomie der
Schnittstellen

Angebot Produkte Projekt Beratung

Mittel Analytik Modellierung Sprachen Algebra Logik Hardware Denken Kreativität

Zusammenhänge Gesellschaft Wirtschaft Branche Firma


products/Sources/formale Sprachen/Cobol/Test-Suite/SQL M/ Datei vom 4.1.2008 mit Größe 21 kB

Quelle reportb.cob Sprache: Cobol

      * Standard COBOL (file "REPORTB.SCO") calling SQL
      * procedures in file "REPORTB.MCO".
      * EMBEDDED COBOL ("file REPORTB.PCO")

      ****************************************************************
      *
      *                COMMENT SECTION
      * 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.
      *
      *
      * WRITTEN BY:  J. Sullivan
      * TRANSLATED AUTOMATICALLY FROM EMBEDDED C BY CHRIS SCHANZLE
      *
      * This routine inserts the result value from TESTREPORT into
      * the T_REQ row and then maps these test/binding/status/result
      * rows into the report structure R_STRUCTURE.
      *
      * A test is run only once, but it is reported in each profile
      * which requires it.
      *
      * This join of T_REQ and R_STRUCTURE is written as an ASCII
      * file, passfail.dat, for use by the following report program.
      * A restriction of REPORTFEATURE (only rows needed for the
      * report) is written as ASCII file heading.dat.
      * A restriction of TESTCASE (only rows needed for problem
      * tests) is written as ASCII file testcase.dat.
      * Interactive SQL reporting is ignored by this program.
      *
      * Debugging is turned on by setting debug1 = 1
      *
      ****************************************************************

       IDENTIFICATION DIVISION.
       PROGRAM-ID.  REPORTB.

       ENVIRONMENT DIVISION.

       CONFIGURATION SECTION.
       SOURCE-COMPUTER.  xyz.
       OBJECT-COMPUTER.  xyz.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
           SELECT PASSFA ASSIGN TO "passfail.dat".
           SELECT HEADIN ASSIGN TO "heading.dat".
           SELECT TESTCA ASSIGN TO "testcase.dat".

       DATA DIVISION.

       FILE SECTION.
       FD PASSFA
           RECORD CONTAINS 30 CHARACTERS.
       01  PASSFA-REC PIC X(30).
       FD HEADIN
           RECORD CONTAINS 37 CHARACTERS.
       01  HEADIN-REC PIC X(37).
       FD TESTCA
           RECORD CONTAINS 73 CHARACTERS.
       01  TESTCA-REC PIC X(73).

       WORKING-STORAGE SECTION.
       01  WS-PASSFA.
           02  C11  PIC X(4).
           02       PIC X VALUE SPACES.
           02  C12  PIC X(4).
           02       PIC X VALUE SPACES.
           02  C13  PIC X(4).
           02       PIC X VALUE SPACES.
           02  C14  PIC X(3).
           02       PIC X VALUE SPACES.
           02  C15  PIC X(3).
           02       PIC X VALUE SPACES.
           02  C16  PIC X(7).
       01  WS-HEADIN.
           02  C21  PIC X(4).
           02       PIC X VALUE "=".
           02  C22  PIC X(32).
       01  WS-TESTCA.
           02  C31  PIC X(4).
           02       PIC X VALUE SPACES.
           02  C32  PIC X(50).
           02       PIC X VALUE SPACES.
           02  C33  PIC X(6).
           02       PIC X VALUE SPACES.
           02  C34  PIC X(10).
      * EXEC SQL BEGIN DECLARE SECTION END-EXEC
       01  prog PIC  X(6).
       01  tpnote PIC  X(10).
       01  testno PIC  X(4).
       01  descr PIC  X(50).
       01  feat1 PIC  X(4).
       01  feat2 PIC  X(4).
       01  result PIC  X(4).
       01  resul7 PIC  X(7).
       01  bind1 PIC  X(3).
       01  reqopt PIC  X(3).
       01  featur PIC  X(32).
       01  bindmx PIC  X(3).
       01  bindct PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  indic1 PIC S9(4) DISPLAY SIGN LEADING SEPARATE.
       01  uid PIC  X(18).
       01  uidx PIC  X(18).
       01  SQLSTATE PIC  X(5).
      *  EXEC SQL END DECLARE SECTION END-EXEC
       01  indivt PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  SQLCODE PIC S9(9) COMP.
       01  errcnt PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  iii PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  debug1 PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  bindii PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
      *date_time declaration
       01  TO-DAY PIC 9(6).
       01  THE-TIME PIC 9(8).

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

       PROCEDURE DIVISION.
       P0.

             MOVE "HU " 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
             DISPLAY
           "SQL Test Suite, V6.0, Embedded COBOL, reportb.pco"
             DISPLAY
           "59-byte ID"
             DISPLAY "TEd Version #"

      *date_time print
           ACCEPT TO-DAY FROM DATE
           ACCEPT THE-TIME FROM TIME
           DISPLAY " "
           DISPLAY "Date run YYMMDD: " TO-DAY " at hhmmssff: " THE-TIME

             MOVE 0 TO errcnt

      *to debug program, set debug1 = 1
             MOVE 0 TO debug1
      *to suppress print of Profile P998, set indivt = 0
             MOVE 1 TO indivt

      *set up

      *  EXEC SQL COMMIT WORK;
             CALL "SUB2" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD

      *We want to verify later, as we write passfail.dat records,
      *  that the binding pattern is cyclic -
      *  as expected by the report program.
      *For example, every 3rd row is 'PC'.
             DISPLAY " "
             DISPLAY "REPORTB step 1: Check BINDING_CLAIMED table."

      *  EXEC SQL SELECT COUNT(*) INTO :bindct
      *    FROM BINDING_CLAIMED
      *    WHERE BINDING1 <> 'SQL';
             CALL "SUB3" USING SQLCODE SQLSTATE bindct
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               COMPUTE errcnt = errcnt + 1
               DISPLAY "#ERR1 Error counting BINDING_CLAIMED rows,"
               DISPLAY " or BINDING_CLAIMED is empty"
               DISPLAY " or has only one row with value SQL."
               DISPLAY "This program does not report on Interactive
      -    " SQL."
               DISPLAY "SQLCODE = ", SQL-COD, " "
      *Suicide note #1
             END-IF
      *  EXEC SQL SELECT MAX(BINDING1) INTO :bindmx
      *    FROM BINDING_CLAIMED
      *    WHERE BINDING1 <> 'SQL';
             CALL "SUB4" USING SQLCODE SQLSTATE bindmx
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               COMPUTE errcnt = errcnt + 1
               DISPLAY "#ERR2 Error selecting MAX(BINDING1) from
      -    " BINDING_CLAIMED."
               DISPLAY "SQLCODE = ", SQL-COD
      *Suicide note #2
             END-IF
      *  EXEC SQL COMMIT WORK;
             CALL "SUB5" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD

      *Insert TESTREPORT pass/fail/nogo result into T_REQ
      *Assign "miss" value for missing results
      *Assign "    " value for NA tests as well as DL and WD tests

             DISPLAY  " "
             DISPLAY "REPORTB step 2: Merge pass/fail/nogo values from
      -    " TESTREPORT"
             DISPLAY " into table T_REQ (list of tests
      -    " required)."
             DISPLAY "This could take a while...."

      *  EXEC SQL UPDATE T_REQ SET RESULT = '    ';
             CALL "SUB6" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *  EXEC SQL COMMIT WORK;
             CALL "SUB7" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD

      *  EXEC SQL DECLARE T_REQ_CURSOR CURSOR FOR
      *    SELECT TESTNO, BINDING1, REQOPTNA
      *    FROM T_REQ
      *    WHERE BINDING1 <> 'SQL' END-EXEC
      *  EXEC SQL OPEN T_REQ_CURSOR;
             CALL "SUB8" USING SQLCODE, SQLSTATE
             MOVE SQLCODE TO SQL-COD

           .
        P100.
      *  EXEC SQL FETCH T_REQ_CURSOR INTO :testno, :bind1, :reqopt
      * ;
             CALL "SUB9" USING SQLCODE SQLSTATE testno bind1 reqopt
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               GO TO P199
             END-IF

             if (reqopt   =   "NA " ) then
               MOVE " " TO result
               GO TO P150
             END-IF
             if (reqopt   =   "DL "  OR  reqopt   =   "WD ") then
               MOVE " " TO result
               GO TO P150
             END-IF
      *  EXEC SQL SELECT DISTINCT RESULT INTO :result
      *    FROM  TESTREPORT
      *    WHERE TESTNO   = :testno
      *    AND TESTTYPE = :bind1;
             CALL "SUB10" USING SQLCODE SQLSTATE result testno bind1
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  =  100) then
               MOVE "miss" TO result
               GO TO P150
             END-IF
             if (SQLCODE  <  0) then
               GO TO P110
             END-IF
             if (result   =   "pass") then
               GO TO P150
             END-IF
             if (result   =   "fail") then
               GO TO P150
             END-IF
             if (result   =   "nogo") then
               GO TO P150
             END-IF
             MOVE "fail" TO result
      *Suicide note #3a
             COMPUTE errcnt = errcnt + 1
             DISPLAY  " "
             DISPLAY "#ERR3a Illegal value in TESTREPORT (RESULT) = ",
             result
             GO TO P150
           .
        P110.
      *No suicide note, just get attention with a FAIL
             DISPLAY  " "
             DISPLAY "#ERR3b Conflicting results for TESTREPORT rows."
             DISPLAY "The final result is FAIL:"
             DISPLAY "SQLCODE = ", SQL-COD, " "
      *  EXEC SQL DECLARE ERROR1 CURSOR FOR
      *    SELECT DISTINCT RESULT
      *    FROM TESTREPORT
      *    WHERE TESTNO   = :testno
      *    AND TESTTYPE = :bind1
      *    ORDER BY RESULT END-EXEC
      *  EXEC SQL OPEN ERROR1;
             CALL "SUB11" USING SQLCODE SQLSTATE testno bind1
             MOVE SQLCODE TO SQL-COD
           .
        P120.
      *  EXEC SQL FETCH ERROR1 INTO :result;
             CALL "SUB12" USING SQLCODE SQLSTATE result
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  <  0) then
               DISPLAY "FETCH ERROR1 SQLCODE = ", SQL-COD, " "
             END-IF
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               GO TO P121
             END-IF
             DISPLAY "TESTNO = ", testno, ", RESULT = ", result, ",
      -    " TESTTYPE = ", bind1
             GO TO P120
           .
        P121.
      *  EXEC SQL CLOSE ERROR1;
             CALL "SUB13" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
             MOVE "fail" TO result

           .
        P150.
      *result value has been obtained for this row
             if (debug1  =  1) then
               DISPLAY "Updated T_REQ = ", testno, ", ", bind1, ", ",
             reqopt, ", ", result
             END-IF
      *  EXEC SQL UPDATE T_REQ SET RESULT = :result
      *    WHERE CURRENT OF T_REQ_CURSOR;
             CALL "SUB14" USING SQLCODE SQLSTATE result
             MOVE SQLCODE TO SQL-COD
      * same as WHERE TESTNO = :testno AND BINDING1 = :bind1;
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               COMPUTE errcnt = errcnt + 1
               DISPLAY "#ERR4 Failed to UPDATE row ", testno, " ",
             bind1, " with result ", result
      *Suicide note #4
             END-IF
             GO TO P100
           .
        P199.
             if (SQLCODE  <  0) then
               COMPUTE errcnt = errcnt + 1
               DISPLAY "#ERR5 Error reading T_REQ_CURSOR."
               DISPLAY "SQLCODE = ", SQL-COD, " "
      *Suicide note #5
             END-IF
      *  EXEC SQL CLOSE T_REQ_CURSOR;
             CALL "SUB15" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *  EXEC SQL COMMIT WORK;
             CALL "SUB16" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD

      *Join R_STRUCTURE to T_REQ
      *and write as ASCII file passfail.dat
             DISPLAY  " "
             DISPLAY "REPORTB step 3: Write ASCII file passfail.dat."

             MOVE 0 TO bindii

      *  EXEC SQL DECLARE TESTLIST CURSOR FOR
      *    SELECT DISTINCT C1, P1, R_STRUCTURE.TESTNO,
      *    BINDING1, REQOPTNA, RESULT
      *    FROM R_STRUCTURE, T_REQ
      *    WHERE R_STRUCTURE.TESTNO = T_REQ.TESTNO
      *    AND BINDING1 <> 'SQL'
      *    ORDER BY 1, 2, 3, 4 END-EXEC
      *  EXEC SQL OPEN TESTLIST;
             CALL "SUB17" USING SQLCODE, SQLSTATE
             MOVE SQLCODE TO SQL-COD

      *open ASCII file passfail.dat
             OPEN OUTPUT PASSFA
             MOVE 0 TO iii

             if (debug1  =  1) then
               DISPLAY "Derived list of test cases:"
             END-IF

           .
        P200.
      *  EXEC SQL FETCH TESTLIST INTO :feat1, :feat2,
      *    :testno, :bind1, :reqopt, :resul7;
             CALL "SUB18" USING SQLCODE SQLSTATE feat1 feat2 testno
             bind1 reqopt resul7
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  <  0) then
               COMPUTE errcnt = errcnt + 1
               DISPLAY "#ERR6 Error reading TESTLIST cursor."
               DISPLAY "SQLCODE = ", SQL-COD, " "
      *Suicide note #6
             END-IF
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               GO TO P202
             END-IF

      *X/Open profiles do not exist for bindings other than PC and PCO
             if (feat2  NOT  =   "P210"  AND  feat2  NOT  =   "P230")
             then
               GO TO P201
             END-IF
             if (bind1   =   "PC "  OR  bind1   =   "PCO") then
               GO TO P201
             END-IF
             MOVE "NA " TO reqopt
             MOVE " " TO resul7

           .
        P201.
      *Profile P998, by default prints, but can be suppressed.
             if (feat1   =   "P998"  AND  indivt  =  0) then
               GO TO P200
             END-IF

             if (resul7   =   "miss ") then
               MOVE "missing" TO resul7
             END-IF

      *Result value has been obtained from TESTREPORT.
      *Write passfail.dat record.
             MOVE feat1 TO C11
             MOVE feat2 TO C12
             MOVE testno TO C13
             MOVE bind1 TO C14
             MOVE reqopt TO C15
             MOVE resul7 TO C16
             MOVE WS-PASSFA TO PASSFA-REC
             IF iii = 0
               WRITE PASSFA-REC
               MOVE 1 TO iii
             ELSE
               WRITE PASSFA-REC AFTER ADVANCING 1 LINE
             END-IF

             if (debug1  =  1) then
               DISPLAY feat1, " ", feat2, " ", testno, " ", bind1, " ",
             reqopt, " ", resul7
             END-IF

      *Verify every nth bind1 value is the max value
             COMPUTE bindii = bindii + 1
             if (bindii  NOT <  bindct) then
               MOVE 0 TO bindii
               if (bind1  NOT  =   bindmx) then
                 COMPUTE errcnt = errcnt + 1
                 DISPLAY "#ERR7 Binding values are not cyclic at
      -    " PASSFAIL row:"
                 DISPLAY "SQLCODE = ", SQL-COD, " "
                 DISPLAY feat1, " ", feat2, " ", testno, " ", bind1
      *Suicide note #7
               END-IF
             END-IF
             GO TO P200

           .
        P202.
      *  EXEC SQL CLOSE TESTLIST;
             CALL "SUB19" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *  EXEC SQL COMMIT WORK;
             CALL "SUB20" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *close ASCII file passfail.dat
             CLOSE PASSFA

      *create file heading.dat
      *pick up names for profile C1 and subprofile P1

             DISPLAY  " "
             DISPLAY "REPORTB step 4: Write ASCII file heading.dat."

      *  EXEC SQL DECLARE HEADING_DAT CURSOR FOR
      *    SELECT DISTINCT FEATURE1, FEATURENAME
      *    FROM REPORTFEATURE, R_STRUCTURE
      *    WHERE FEATURE1 = C1 OR FEATURE1 = P1
      *    ORDER BY FEATURE1 END-EXEC
      *  EXEC SQL OPEN HEADING_DAT;
             CALL "SUB21" USING SQLCODE, SQLSTATE
             MOVE SQLCODE TO SQL-COD

      *open ASCII file heading.dat
             OPEN OUTPUT HEADIN
             MOVE 0 TO iii

           .
        P601.
      *  EXEC SQL FETCH HEADING_DAT INTO :feat1, :featur;
             CALL "SUB22" USING SQLCODE SQLSTATE feat1 featur
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  <  0) then
               COMPUTE errcnt = errcnt + 1
               DISPLAY "#ERR8 Error reading HEADING_DAT cursor."
               DISPLAY "SQLCODE = ", SQL-COD, " "
      *Suicide note #8
             END-IF
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               GO TO P602
             END-IF
             MOVE feat1 TO C21
             MOVE featur TO C22
             MOVE WS-HEADIN TO HEADIN-REC
             IF iii = 0
               WRITE HEADIN-REC
               MOVE 1 TO iii
             ELSE
               WRITE HEADIN-REC AFTER ADVANCING 1 LINE
             END-IF
             GO TO P601
           .
        P602.
      *  EXEC SQL CLOSE HEADING_DAT;
             CALL "SUB23" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *  EXEC SQL COMMIT WORK;
             CALL "SUB24" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *close ASCII file heading.dat
             CLOSE HEADIN

      *create file testcase.dat
      *for problem test numbers

             DISPLAY  " "
             DISPLAY "REPORTB step 5: Write ASCII file testcase.dat."

      *  EXEC SQL DECLARE TESTCASE_DAT CURSOR FOR
      *    SELECT TESTNO, DESCR, PROG, T_NOTE
      *    FROM TESTCASE
      *    WHERE TESTNO IN
      *    (SELECT TESTNO FROM T_REQ
      *    WHERE RESULT = 'fail' OR RESULT = 'miss')
      *    ORDER BY TESTNO END-EXEC
      *  EXEC SQL OPEN TESTCASE_DAT;
             CALL "SUB25" USING SQLCODE, SQLSTATE
             MOVE SQLCODE TO SQL-COD

      *open ASCII file testcase.dat
             OPEN OUTPUT TESTCA
             MOVE 0 TO iii

           .
        P701.
      *  EXEC SQL FETCH TESTCASE_DAT INTO :testno, :descr, :prog,
      *  :tpnote :indic1;
             CALL "SUB26" USING SQLCODE SQLSTATE testno descr prog
             tpnote indic1
             MOVE SQLCODE TO SQL-COD
             if (SQLCODE  <  0) then
               COMPUTE errcnt = errcnt + 1
               DISPLAY "#ERR9 Error reading TESTCASE_DAT cursor."
               DISPLAY "SQLCODE = ", SQL-COD, " "
      *Suicide note #9
             END-IF
             if (SQLCODE  <  0  OR  SQLCODE  =  100) then
               GO TO P702
             END-IF
             if (indic1  <  0) then
               MOVE " " TO tpnote
             END-IF
             MOVE testno TO C31
             MOVE descr TO C32
             MOVE prog TO C33
             MOVE tpnote TO C34
             MOVE WS-TESTCA TO TESTCA-REC
             IF iii = 0
               WRITE TESTCA-REC
               MOVE 1 TO iii
             ELSE
               WRITE TESTCA-REC AFTER ADVANCING 1 LINE
             END-IF
             GO TO P701
           .
        P702.
      *  EXEC SQL CLOSE TESTCASE_DAT;
             CALL "SUB27" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *  EXEC SQL COMMIT WORK;
             CALL "SUB28" USING SQLCODE SQLSTATE
             MOVE SQLCODE TO SQL-COD
      *close ASCII file testcase.dat
             CLOSE TESTCA

      *Did we get any suicide notes?
             if (errcnt  >  0) then
               MOVE 0 TO iii
               PERFORM P50 UNTIL iii > 9
             END-IF

      *=========================================================

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

      *    ****  Procedures for PERFORM statements

        P50.
                 DISPLAY " ***************************************"
                 DISPLAY " **** Do not run the REPORT program. ***"
                 DISPLAY " **** Correct ", errcnt, " errors and rerun!
      -    " ****"
                 DISPLAY " ***************************************"
               ADD 1 TO iii
           .

quality93%

¤ Dauer der Verarbeitung: 0.17 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.