| Quellcodebibliothek Statistik Leitseite products/Sources/formale Sprachen/Cobol/Test-Suite/SQL M/ Datei vom 4.1.2008 mit Größe 44 kB |
|
Quelle reporta.cob Sprache: Cobol |
|||||||||
|
IDENTIFICATION DIVISION.
PROGRAM-ID. REPORTA. ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. xyz. OBJECT-COMPUTER. xyz. DATA DIVISION. WORKING-STORAGE SECTION. * Standard COBOL (file "REPORTA.SCO") calling SQL * procedures in file "REPORTA.MCO". * EMBEDDED COBOL ("file REPORTA.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 populates the tables R_STRUCTURE and T_REQ * and lists programs to be executed for each BINDING_CLAIMED. * This list is not needed for testing a common profile such * as Entry FIPS 127-2, Transitional FIPS 127-2, FIPS Sizing, * X/Open with IEF, or X/Open without IEF, because a canned * list is provided for each common profile. * * * BACKGROUND: * The test numbers to be run are derived from the * FEATURE_CLAIMED table. * The derivation is recursive, based on links in table * IMPLICATION. Profiles contain subprofiles (recursively) * which contain features (eventually). * The derived features are joined with table TESTFEATRUE (which * links tests to features) to populate table R_STRUCTURE * (report structure), a list of tests for each FEATURE_CLAIMED. * T_REQ contains the product of R_STRUCTURE and BINDING_CLAIMED * Each row represents a test required for a binding claimed. * The status column REQOPTNA of T_REQ is updated through * program logic (SQL "rules") to values REQ, OPT, or NA * * A TEd file is generated to specify delete of extraneous * tests (from the list of programs to be executed). * This list is not needed for testing common profiles. * * Debugging is turned on by setting debug1 = 1 * **************************************************************** * EXEC SQL BEGIN DECLARE SECTION END-EXEC 01 prog PIC X(6). 01 tpnote PIC X(10). 01 testno PIC X(4). 01 feat1 PIC X(4). 01 feat2 PIC X(4). 01 feat3 PIC X(4). 01 featur PIC X(32). 01 bind1 PIC X(3). 01 reqopt PIC X(3). 01 result PIC X(4). 01 iii PIC S9(9) DISPLAY SIGN LEADING SEPARATE. 01 lvl 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 bindlc PIC X(3). 01 bind0 PIC X(3). 01 SQLCODE PIC S9(9) COMP. 01 errcnt PIC S9(9) DISPLAY SIGN LEADING SEPARATE. 01 loopct PIC S9(9) DISPLAY SIGN LEADING SEPARATE. 01 debug1 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, reporta.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 *Profile P998 will set indivt = 1 MOVE 0 TO indivt **************************************************************** * EXEC SQL DECLARE SHOW_CLAIM CURSOR FOR * SELECT REPORTFEATURE.FEATURE1, FEATURENAME, BINDING1 * FROM FEATURE_CLAIMED, REPORTFEATURE, BINDING_CLAIMED * WHERE REPORTFEATURE.FEATURE1 * = FEATURE_CLAIMED.FEATURE1 * ORDER BY 1, 2, 3 END-EXEC * EXEC SQL OPEN SHOW_CLAIM; CALL "SUB2" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY " " DISPLAY "These are the profiles and bindings to be tested:" MOVE 0 TO SQLCODE MOVE 0 TO iii . P250. * EXEC SQL FETCH SHOW_CLAIM INTO :feat1, :featur, :bind1 * ; CALL "SUB3" USING SQLCODE SQLSTATE feat1 featur bind1 MOVE SQLCODE TO SQL-COD if (SQLCODE < 0 OR SQLCODE = 100) then GO TO P252 END-IF *X/Open profiles do not exist for bindings other than PC and PCO if (bind1 = "PC " OR bind1 = "PCO" ) then GO TO P251 END-IF if (feat1 = "P210" ) then GO TO P250 END-IF if (feat1 = "P230" ) then GO TO P250 END-IF . P251. if (bind1 = "P998") then MOVE 1 TO indivt END-IF COMPUTE iii = iii + 1 DISPLAY feat1, " ", bind1, " ", featur GO TO P250 . P252. * EXEC SQL CLOSE SHOW_CLAIM; CALL "SUB4" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB5" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY iii, " claim(s) selected" if (iii = 0) then DISPLAY "Either BINDING_CLAIMED or FEATURE_CLAIMED is - " empty!" DISPLAY "You must INSERT at least one row into each - " table." DISPLAY "See instructions in file other/report_l.doc" GO TO P411 END-IF **************************************************************** DISPLAY " " DISPLAY "REPORTA step 1: Check to make sure that each test - " number" DISPLAY " is linked to the reporting - " structure;" DISPLAY " i.e., that each TESTCASE row has - " at" DISPLAY " least one TESTFEATURE row." * EXEC SQL DECLARE ERROR1 CURSOR FOR * SELECT TESTNO * FROM TESTCASE * WHERE TESTNO NOT IN * (SELECT TESTNO FROM TESTFEATURE) * ORDER BY TESTNO END-EXEC * EXEC SQL OPEN ERROR1; CALL "SUB6" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD MOVE 0 TO iii . P120. * EXEC SQL FETCH ERROR1 INTO :testno; CALL "SUB7" USING SQLCODE SQLSTATE testno 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 COMPUTE iii = iii + 1 DISPLAY "TESTCASE without TESTFEATURE row: ", testno GO TO P120 . P121. * EXEC SQL CLOSE ERROR1; CALL "SUB8" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (iii > 0) then COMPUTE errcnt = errcnt + 1 DISPLAY "#ERR1 reference-coding error. TESTFEATURE rows - " missing!" PERFORM PFTEMP THRU P220 *Suicide note #1 END-IF *========================================================= *Recursive derivation of features to be tested *========================================================= *The goal is for table F_REQ to contain a row for each *feature implied by a row in table FEATURE_CLAIMED. *In general, each FEATURE_CLAIMED is a profile *(begins with the letter P) as opposed to an individual *feature (begins with a digit). *Each profile in FEATURE_CLAIMED will generate 3 reports. *This reporting structure allows individual features to *be claimed; although, it is not expected that this *form of reporting will be commonly used in validations. *All the individual features in FEATURE_CLAIMED will *be grouped together in a pseudo profile, P998, under the *heading "Individual Features," for ease in reporting. *After the recursive process below, each individual *feature required for testing will be represented in *F_REQ column F1. The C1 column ("claim") will contain *the value from the table FEATURE_CLAIMED (except for *individual features claimed, which will have C1 value *'P998'). The P1 column is the immediate profile of *the F1 column. For example, if FEATURE_CLAIMED has *a row with value 'P135' for Transitional SQL, then *many features will be derived, among them '0IEF', and *there will be a F_REQ row with (C1, P1, F1) values: * C1 = 'P135' "claimed" Transitional SQL * P1 = 'P120' "immediate profile" Entry SQL * F1 = '0IEF' "feature" IEF *In the rare case that '0IEF' is claimed as an individual *feature to be tested, by inserting value '0IEF' in table *FEATURE_CLAIMED, then F_REQ would have a row with *(C1, P1, F1) values ('P998','0IEF','0IEF'). DISPLAY " " DISPLAY "REPORTA step 2: Derive all features to be - " tested." *setup * EXEC SQL DELETE FROM F_REQ; CALL "SUB9" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL DELETE FROM F_TEMP; CALL "SUB10" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB11" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *#step 1# *Begin work on the features claimed. *FEATURE1 is either an individual feature or (most likely) a pro *Individual features claimed will be inserted into table F_REQ, *and they need no more processing. *P998 is the report category "Individual Features". *Everything else (profiles) needs more processing (recursion), *and they will be inserted into table F_TEMP. MOVE 0 TO iii * EXEC SQL INSERT INTO F_REQ * SELECT 'P998',FEATURE1,FEATURE1,0 * FROM FEATURE_CLAIMED * WHERE FEATURE1 NOT LIKE 'P%'; CALL "SUB12" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #1 INSERT INTO F_REQ, SQLCODE = ", SQL-COD END-IF if (SQLCODE = 100) then COMPUTE iii = iii + 1 END-IF * EXEC SQL COMMIT WORK; CALL "SUB13" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (debug1 = 1) then DISPLAY "Table F_REQ with individual features claimed:" PERFORM PFREQ THRU P210 END-IF *#step 2# *set up initial C1, P1 values for profiles. *If F_REQ.F1 is a profile (begins with "P"), *move the FEATURE_CLAIMED value to all columns *and prepare to recurse. * EXEC SQL INSERT INTO F_TEMP * SELECT FEATURE1,FEATURE1,FEATURE1,1 * FROM FEATURE_CLAIMED * WHERE FEATURE1 LIKE 'P%' * AND FEATURE1 <> 'P998'; CALL "SUB14" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #2 INSERT INTO F_TEMP, SQLCODE = ", SQL-COD END-IF if (SQLCODE = 100) then COMPUTE iii = iii + 1 END-IF * EXEC SQL COMMIT WORK; CALL "SUB15" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *We now have individual features table in F_REQ and *profiles in table F_TEMP. if (debug1 = 1) then DISPLAY "Table F_TEMP with profiles claimed:" PERFORM PFTEMP THRU P220 END-IF if (iii = 2) then DISPLAY "Table FEATURE_CLAIMED is empty!" DISPLAY "User MUST specify profiles to test by" DISPLAY " inserting value(s) into table FEATURE_CLAIMED." END-IF MOVE 0 TO loopct . P100. COMPUTE loopct = loopct + 1 *#step 3# *recurse here, until done. *#step 3a# *Generate the next level in the hierarchy, *keeping the first two columns and replacing the link. *Rows are optimistically sent back to F_REQ, assuming that *the recursion is complete. If it isn't, we'll move the *rows with profiles out again to recurse another level. * EXEC SQL INSERT INTO F_REQ * SELECT C1,P1,CHILD_F,LVL * FROM F_TEMP, IMPLICATION * WHERE F1 = PARENT_F; CALL "SUB16" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #4 INSERT INTO F_REQ, SQLCODE = ", SQL-COD END-IF * EXEC SQL DELETE FROM F_TEMP WHERE F1 IN * (SELECT PARENT_F FROM IMPLICATION); CALL "SUB17" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #5 DELETE FROM F_TEMP, SQLCODE = ", SQL-COD END-IF * EXEC SQL COMMIT WORK; CALL "SUB18" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *We have now moved every F_TEMP row back into F_REQ, *after replacing the F1 profile value with its "child." *The "child" is either a profile or a feature. if (debug1 = 1) then DISPLAY "Table F_REQ after ", loopct, " recursion(s)" PERFORM PFREQ THRU P210 DISPLAY "Table F_TEMP after ", loopct, " recursion(s)" DISPLAY "Table F_TEMP should be empty" PERFORM PFTEMP THRU P220 END-IF MOVE 1 TO iii * EXEC SQL SELECT COUNT(*) INTO :iii FROM F_TEMP; CALL "SUB19" USING SQLCODE SQLSTATE iii MOVE SQLCODE TO SQL-COD if (iii > 0 OR SQLCODE < 0 OR SQLCODE = 100) then COMPUTE errcnt = errcnt + 1 DISPLAY "#ERR2 reference-coding error. F_TEMP not empty!" PERFORM PFTEMP THRU P220 *Suicide note #2 END-IF * EXEC SQL COMMIT WORK; CALL "SUB20" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *It's a reference-coding error if F_TEMP has any rows at all. *F_TEMP contains only profiles without features. *so, F_TEMP should be empty. *#step 3b# *If F_REQ.F1 is a profile (begins with "P"), *move the profile values from F_REQ to F_TEMP *and prepare to recurse. *The child feature from the next level of recursion will belong *to both the grandparent feature and the parent feature. *Column LVL is the level of recursion for column F1. * EXEC SQL INSERT INTO F_TEMP * SELECT C1,F1,F1,LVL+1 * FROM F_REQ * WHERE F1 LIKE 'P%'; CALL "SUB21" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #7a INSERT INTO F_TEMP, SQLCODE = ", SQL-COD END-IF * EXEC SQL INSERT INTO F_TEMP * SELECT C1,P1,F1,LVL * FROM F_REQ * WHERE F1 LIKE 'P%'; CALL "SUB22" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #7b INSERT INTO F_TEMP, SQLCODE = ", SQL-COD END-IF * EXEC SQL DELETE FROM F_REQ * WHERE F1 LIKE 'P%'; CALL "SUB23" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #8 DELETE FROM F_REQ, SQLCODE = ", SQL-COD END-IF * EXEC SQL COMMIT WORK; CALL "SUB24" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *We now have individual features in F_REQ and *profiles in table F_TEMP. if (debug1 = 1) then DISPLAY "Table F_REQ with features derived at this - " point:" PERFORM PFREQ THRU P210 DISPLAY "Table F_TEMP with profiles for next recursion:" PERFORM PFTEMP THRU P220 END-IF MOVE 0 TO iii * EXEC SQL SELECT COUNT(*) INTO :iii FROM F_TEMP; CALL "SUB25" USING SQLCODE SQLSTATE iii MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB26" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *It's time to quit if F_TEMP is empty; *otherwise, continue the recursion. if (iii > 0) then GO TO P100 END-IF if (loopct = 1) then DISPLAY "Recursion exhausted after 1 pass." else DISPLAY "Recursion exhausted after ", loopct, " passes." END-IF *========================================================= *Determine which tests are required for the derived features *========================================================= DISPLAY " " DISPLAY "REPORTA step 3: Determine which tests are - " required." *set up * EXEC SQL DELETE FROM R_STRUCTURE; CALL "SUB27" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB28" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *Find all related tests *Replace feature with TESTNO: * EXEC SQL INSERT INTO R_STRUCTURE * SELECT DISTINCT C1, P1, TESTNO, LVL * FROM F_REQ, TESTFEATURE * WHERE FEATURE1 = F1; CALL "SUB29" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #9 INSERT INTO R_STRUCTURE, SQLCODE = ", SQL-COD END-IF * EXEC SQL COMMIT WORK; CALL "SUB30" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (debug1 = 1) then DISPLAY "Table R_STRUCTURE with all related tests:" PERFORM PRSTR THRU P230 END-IF *Drop related tests not fully supported by combined claims: * EXEC SQL DELETE FROM R_STRUCTURE * WHERE TESTNO IN * (SELECT TESTNO FROM TESTFEATURE * WHERE FEATURE1 NOT IN * (SELECT F1 FROM F_REQ)); CALL "SUB31" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #10 DELETE FROM R_STRUCTURE, SQLCODE = - " ", SQL-COD END-IF if (SQLCODE NOT < 0 AND SQLCODE NOT = 100) then DISPLAY "Partially supported tests WERE DELETED." END-IF * EXEC SQL COMMIT WORK; CALL "SUB32" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (debug1 = 1) then DISPLAY "Table R_STRUCTURE with all fully supported - " tests:" PERFORM PRSTR THRU P230 END-IF *One big happy profile when indivt = 1. *Every test will print under every profile * for which it has at least one feature, * provided the entire test is supported by the entire profile. if (indivt = 1) then GO TO P150 END-IF *Drop tests not fully supported in each subprofile. *This will give stable counts to each subprofile (except P998). * EXEC SQL DELETE FROM R_STRUCTURE * WHERE C1 <> 'P998' * AND TESTNO IN * (SELECT TESTNO FROM TESTFEATURE * WHERE FEATURE1 NOT IN * (SELECT F1 FROM F_REQ * WHERE F_REQ.C1 = R_STRUCTURE.C1 * AND F_REQ.P1 = R_STRUCTURE.P1)); CALL "SUB33" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #11a UPDATE R_STRUCTURE, SQLCODE = ", SQL-COD END-IF if (SQLCODE NOT < 0 AND SQLCODE NOT = 100) then DISPLAY "Some tests were not fully contained in a - " subprofile." END-IF *Identify each tests's highest level within its profile. *F_TEMP column P1 is holding TESTNO values. * EXEC SQL INSERT INTO F_TEMP (C1, P1, LVL) * SELECT C1, TESTNO, MAX (LVL) * FROM R_STRUCTURE * GROUP BY C1, TESTNO; CALL "SUB34" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *For duplicate testno within a profile, drop lowest subprofile. *F_TEMP column P1 is holding TESTNO values. * EXEC SQL DELETE FROM R_STRUCTURE * WHERE C1 <> 'P998' * AND NOT EXISTS (SELECT * FROM F_TEMP * WHERE F_TEMP.C1 = R_STRUCTURE.C1 * AND F_TEMP.P1 = R_STRUCTURE.TESTNO * AND F_TEMP.LVL = R_STRUCTURE.LVL); CALL "SUB35" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #11b DELETE FROM R_STRUCTURE, SQLCODE = - " ", SQL-COD END-IF . P150. * EXEC SQL COMMIT WORK; CALL "SUB36" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (debug1 = 1) then DISPLAY "Table R_STRUCTURE with P998 resolved:" PERFORM PRSTR THRU P230 END-IF *Note that R_STRUCTURE now has the full reporting structure. *Some tests will be reported in more than one profile. *========================================================= *Multiply tests required by bindings claimed. *And pick up TESTNO's program name. *========================================================= DISPLAY " " DISPLAY "REPORTA step 4: Multiply tests required by - " bindings claimed." *set up * EXEC SQL DELETE FROM T_REQ; CALL "SUB37" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB38" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL INSERT INTO T_REQ * SELECT DISTINCT TESTCASE.TESTNO, TESTCASE.PROG, * BINDING1, 'REQ', ' ' * FROM TESTCASE, R_STRUCTURE, BINDING_CLAIMED * WHERE TESTCASE.TESTNO = R_STRUCTURE.TESTNO; CALL "SUB39" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #12 INSERT INTO T_REQ, SQLCODE = ", SQL-COD END-IF if (SQLCODE = 100) then DISPLAY "Table FEATURE_CLAIMED or BINDING_CLAIMED is - " empty!" DISPLAY "User MUST specify bindings to test by" DISPLAY " inserting value(s) into table BINDING_CLAIMED." END-IF * EXEC SQL COMMIT WORK; CALL "SUB40" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (debug1 = 1) then DISPLAY "Before setting value of column REQOPTNA" PERFORM PTREQ THRU P240 END-IF *========================================================= *Mark 'NA' each test not required for certain bindings *Mark 'DL','UR','WD' tests deleted, under review, withdrawn *========================================================= DISPLAY " " DISPLAY "REPORTA step 5: Mark 'NA' tests which do not - " exist for a particular" DISPLAY " language." *For Version 5.1, which does not yet contain translations for * Transitional SQL tests in the interfaces for * Module FORTRAN, Embedded Pascal, and Module Pascal: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 IN ('PPA','MFO','MPA') * AND TESTNO > '0555' * AND TESTNO <> '0564' * AND PROG NOT BETWEEN 'flg010' AND 'flg013'; CALL "SUB41" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For X/Open Testing, which has only PC and PCO bindings: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 <> 'PC' AND BINDING1 <> 'PCO' * AND PROG LIKE 'xop%'; CALL "SUB42" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'PC' * AND TESTNO IN ('0712','0724','0725'); CALL "SUB43" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For the language-specific programs: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE PROG LIKE 'cob%' AND BINDING1 <> 'PCO' * AND BINDING1 <> 'MCO' * OR PROG LIKE 'for%' AND BINDING1 <> 'PFO' * AND BINDING1 <> 'MFO' * OR PROG LIKE 'ccc%' AND BINDING1 <> 'PC' * AND BINDING1 <> 'MC' * OR PROG LIKE 'pas%' AND BINDING1 <> 'PPA' * AND BINDING1 <> 'MPA' * OR PROG LIKE 'ada%' AND BINDING1 <> 'PAD' * AND BINDING1 <> 'MAD' * OR PROG LIKE 'sql%' AND BINDING1 <> 'SQL'; CALL "SUB44" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *If we have MUMPS or PLI tests, we will add the following: *OR PROG LIKE 'pli%' AND BINDING1 <> 'PPL' AND BINDING1 <> 'MPL' *OR PROG LIKE 'mum%' AND BINDING1 <> 'PMU' AND BINDING1 <> 'MMU' * For the NON-module language interfaces: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 NOT LIKE 'M%' * AND PROG IN ('dml074','dml088','yts814'); CALL "SUB45" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For the NON-embedded interfaces: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 NOT LIKE 'P%' * AND PROG IN ('dml017','dml063','dml067', * 'dml071','flg010','flg013'); CALL "SUB46" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For the NON-interactive SQL interfaces: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 <> 'SQL' AND PROG = 'mpquic'; CALL "SUB47" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For Interactive SQL: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'SQL' AND 0 = * (SELECT ISQL_CT FROM TESTCASE * WHERE TESTCASE.TESTNO = T_REQ.TESTNO); CALL "SUB48" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For C, MUMPS, PLI - varchar host language declaration: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 <> 'PC' AND BINDING1 <> 'MC' * AND PROG IN * ('dml092','dml093','dml129','dml146','dml155', * 'isi008','ist008'); CALL "SUB49" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For C only: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'MC' * AND TESTNO IN ('0183','0192','0193','0398','0399') * ; CALL "SUB50" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For COBOL only: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'PCO' AND TESTNO = '0288'; CALL "SUB51" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'MCO' * AND TESTNO IN ('0185','0206','0207'); CALL "SUB52" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For COBOL only - OPTIONAL due to floating point data type: * EXEC SQL UPDATE T_REQ * SET REQOPTNA = 'OPT' * WHERE (BINDING1 = 'MCO' OR BINDING1 = 'PCO') * AND TESTNO = '0157'; CALL "SUB53" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For FORTRAN only: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'MFO' * AND TESTNO IN ('0217','0223','0392'); CALL "SUB54" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For PASCAL only: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'MPA' * AND TESTNO IN ('0238','0239'); CALL "SUB56" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For Ada only: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'PAD' * AND TESTNO IN ('0445','0456'); CALL "SUB57" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE BINDING1 = 'MAD' * AND TESTNO IN ('0424','0445'); CALL "SUB58" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * Placeholder for deleted tests (permanently removed): * TEd maintenance changes will provide any appropriate test numb * EXEC SQL UPDATE T_REQ * SET REQOPTNA = 'DL' WHERE REQOPTNA <> 'NA' * AND TESTNO IN ('DL#1','DL#2'); CALL "SUB59" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * Placeholder for tests under review (to be run, but not judged * TEd maintenance changes will provide any appropriate test numb * EXEC SQL UPDATE T_REQ * SET REQOPTNA = 'UR' WHERE REQOPTNA <> 'NA' * AND TESTNO IN ('UR#1','UR#2'); CALL "SUB60" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * Placeholder for withdrawn tests (removed until Version 6.0): * TEd maintenance changes will provide any appropriate test numb * EXEC SQL UPDATE T_REQ * SET REQOPTNA = 'WD' WHERE REQOPTNA <> 'NA' * AND TESTNO IN ('WD#1','WD#2'); CALL "SUB61" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * For the few MUMPS programs: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE (BINDING1 = 'PMU' OR BINDING1 = 'MMU') * AND PROG NOT LIKE 'mum%' * AND PROG NOT IN ('XXXXXX','YYYYYY'); * For the few PL/I programs: * EXEC SQL UPDATE T_REQ SET REQOPTNA = 'NA' * WHERE (BINDING1 = 'PPL' OR BINDING1 = 'MPL') * AND PROG NOT LIKE 'pli%' * AND PROG NOT IN ('AAAAAA','BBBBBB'); * EXEC SQL COMMIT WORK; CALL "SUB62" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD if (debug1 = 1) then DISPLAY "After setting value of column REQOPTNA" PERFORM PTREQ THRU P240 END-IF *========================================================= *========================================================= *Print programs to be EXECuted for each binding. *This is equivalent to RUNPC.BAS, RUNSQL.BAS, etc. *========================================================= DISPLAY " " DISPLAY "REPORTA step 6: List programs for each binding." * EXEC SQL DECLARE RUNALL_BAS CURSOR FOR * SELECT DISTINCT BINDING1, AUTHID, TESTPROG.PROG, P_NOTE * FROM T_REQ, TESTPROG * WHERE T_REQ.PROG = TESTPROG.PROG * AND REQOPTNA IN ('OPT','REQ','UR') * ORDER BY 1, 2, 3 END-EXEC * EXEC SQL OPEN RUNALL_BAS; CALL "SUB63" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #13 OPEN RUNALL_BAS, SQLCODE = ", SQL-COD END-IF MOVE 0 TO SQLCODE MOVE " " TO bind0 DISPLAY " " DISPLAY "Run the following programs to test the interfaces - " specified:" . P310. if (SQLCODE = 100) then GO TO P311 END-IF * EXEC SQL FETCH RUNALL_BAS INTO :bind1, :uidx, :prog, * :tpnote :indic1; CALL "SUB64" USING SQLCODE SQLSTATE bind1 uidx prog tpnote indic1 MOVE SQLCODE TO SQL-COD if (indic1 < 0) then MOVE " " TO tpnote END-IF if (bind0 NOT = bind1) then MOVE bind1 TO bind0 DISPLAY " " DISPLAY "PROGRAMS TO EXECUTE FOR INTERFACE ", bind1 END-IF *language-independent lower casing for value of bind1 if (bind1 = "PC ") then MOVE "pc " TO bindlc END-IF if (bind1 = "PCO") then MOVE "pco" TO bindlc END-IF if (bind1 = "PFO") then MOVE "pfo" TO bindlc END-IF if (bind1 = "PPA") then MOVE "ppa" TO bindlc END-IF if (bind1 = "PAD") then MOVE "pad" TO bindlc END-IF if (bind1 = "MC ") then MOVE "mc " TO bindlc END-IF if (bind1 = "MCO") then MOVE "mco" TO bindlc END-IF if (bind1 = "MFO") then MOVE "mfo" TO bindlc END-IF if (bind1 = "MPA") then MOVE "mpa" TO bindlc END-IF if (bind1 = "MAD") then MOVE "mad" TO bindlc END-IF if (bind1 = "SQL") then MOVE "sql" TO bindlc END-IF if (SQLCODE NOT < 0 AND SQLCODE NOT = 100) then DISPLAY "RUN", bind1, " ", prog, ".", bindlc, " AS - " ", uidx, " ", tpnote END-IF GO TO P310 . P311. DISPLAY " " * EXEC SQL CLOSE RUNALL_BAS; CALL "SUB65" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *========================================================= *========================================================= *Print tests to delete from required programs. *Testing individual features (outside of profiles) is * tricky, because the programs were not structured for this. *TEd format may be input to TEd after cut and paste. *========================================================= * EXEC SQL DECLARE DELETE_TESTNO CURSOR FOR * SELECT DISTINCT TESTCASE.TESTNO, TESTCASE.PROG * FROM TESTCASE, TESTPROG * WHERE TESTCASE.PROG = TESTPROG.PROG * AND TESTCASE.PROG IN * (SELECT PROG FROM T_REQ) * AND TESTCASE.TESTNO NOT IN * (SELECT TESTNO FROM T_REQ) * ORDER BY TESTNO END-EXEC * EXEC SQL OPEN DELETE_TESTNO; CALL "SUB66" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD if (SQLCODE < 0) then DISPLAY "Problem #14 OPEN DELETE_TESTNO, SQLCODE = ", SQL-COD END-IF MOVE 0 TO iii . P410. * EXEC SQL FETCH DELETE_TESTNO INTO :testno, :prog; CALL "SUB67" USING SQLCODE SQLSTATE testno prog MOVE SQLCODE TO SQL-COD if (SQLCODE = 100) then GO TO P411 END-IF if (iii = 0) then DISPLAY "DELETE the following tests from these programs:" END-IF COMPUTE iii = iii + 1 DISPLAY "del ", prog, ".* /BEGIN TEST", testno, "/END TEST", testno, "/" GO TO P410 . P411. * EXEC SQL CLOSE DELETE_TESTNO; CALL "SUB68" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB69" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD *========================================================= *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 *The following routines list entire table contents for debugging PFREQ. * EXEC SQL DECLARE F_REQ_CURSOR CURSOR FOR * SELECT * FROM F_REQ ORDER BY C1, P1, F1 END-EXEC * EXEC SQL OPEN F_REQ_CURSOR; CALL "SUB70" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY " " DISPLAY "F_REQ Listing" MOVE 0 TO SQLCODE MOVE 0 TO iii . P210. * EXEC SQL FETCH F_REQ_CURSOR INTO :feat1, :feat2, :feat3, * :lvl; CALL "SUB71" USING SQLCODE SQLSTATE feat1 feat2 feat3 lvl MOVE SQLCODE TO SQL-COD if (SQLCODE NOT < 0 AND SQLCODE NOT = 100) then COMPUTE iii = iii + 1 DISPLAY "C1=", feat1, ", P1=", feat2, ", F1=", feat3, ", - " LVL=", lvl GO TO P210 END-IF * EXEC SQL CLOSE F_REQ_CURSOR; CALL "SUB72" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB73" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY iii, " rows selected" DISPLAY " ". PFTEMP. * EXEC SQL DECLARE F_TEMP_CURSOR CURSOR FOR * SELECT * FROM F_TEMP ORDER BY C1, P1, F1 END-EXEC * EXEC SQL OPEN F_TEMP_CURSOR; CALL "SUB74" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY " " DISPLAY "F_TEMP Listing" MOVE 0 TO SQLCODE MOVE 0 TO iii . P220. * EXEC SQL FETCH F_TEMP_CURSOR INTO :feat1, :feat2, :feat3, * :lvl; CALL "SUB75" USING SQLCODE SQLSTATE feat1 feat2 feat3 lvl MOVE SQLCODE TO SQL-COD if (SQLCODE NOT < 0 AND SQLCODE NOT = 100) then COMPUTE iii = iii + 1 DISPLAY "C1=", feat1, ", P1=", feat2, ", F1=", feat3, ", - " LVL=", lvl GO TO P220 END-IF * EXEC SQL CLOSE F_TEMP_CURSOR; CALL "SUB76" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB77" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY iii, " rows selected" DISPLAY " ". PRSTR. * EXEC SQL DECLARE R_STRUCTURE_CURSOR CURSOR FOR * SELECT * FROM R_STRUCTURE ORDER BY C1, P1, TESTNO * END-EXEC * EXEC SQL OPEN R_STRUCTURE_CURSOR; CALL "SUB78" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY " " DISPLAY "R_STRUCTURE Listing" MOVE 0 TO SQLCODE MOVE 0 TO iii . P230. * EXEC SQL FETCH R_STRUCTURE_CURSOR INTO :feat1, :feat2, * :feat3, :lvl; CALL "SUB79" USING SQLCODE SQLSTATE feat1 feat2 feat3 lvl MOVE SQLCODE TO SQL-COD if (SQLCODE NOT < 0 AND SQLCODE NOT = 100) then COMPUTE iii = iii + 1 DISPLAY "C1=", feat1, ", P1=", feat2, ", TESTNO=", feat3, ", LVL=", lvl GO TO P230 END-IF * EXEC SQL CLOSE R_STRUCTURE_CURSOR; CALL "SUB80" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB81" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY iii, " rows selected" DISPLAY " ". PTREQ. * EXEC SQL DECLARE T_REQ_CURSOR CURSOR FOR * SELECT * FROM T_REQ ORDER BY BINDING1, PROG, TESTNO * END-EXEC * EXEC SQL OPEN T_REQ_CURSOR; CALL "SUB82" USING SQLCODE, SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY " " DISPLAY "T_REQ Listing" MOVE 0 TO SQLCODE MOVE 0 TO iii . P240. * EXEC SQL FETCH T_REQ_CURSOR INTO :testno, :prog, :bind1, * :reqopt, :result; CALL "SUB83" USING SQLCODE SQLSTATE testno prog bind1 reqopt result MOVE SQLCODE TO SQL-COD if (SQLCODE NOT < 0 AND SQLCODE NOT = 100) then COMPUTE iii = iii + 1 DISPLAY "TESTNO=", testno, ",PROG=", prog, " ", bind1, " - " ", reqopt, " ", result GO TO P240 END-IF * EXEC SQL CLOSE T_REQ_CURSOR; CALL "SUB84" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD * EXEC SQL COMMIT WORK; CALL "SUB85" USING SQLCODE SQLSTATE MOVE SQLCODE TO SQL-COD DISPLAY iii, " rows selected" DISPLAY " ". P50. DISPLAY " ***************************************" DISPLAY " **** Do not run the REPORT program. ***" DISPLAY " **** Correct ", errcnt, " errors and rerun! - " ****" DISPLAY " ***************************************" ADD 1 TO iii . ¤ Dauer der Verarbeitung: 0.25 Sekunden (vorverarbeitet) ¤*© Formatika GbR, Deutschland |
|
2026-03-28