|
* 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
.
¤ Dauer der Verarbeitung: 0.47 Sekunden
(vorverarbeitet)
¤
|
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.
|
