Quelle cob002.cob Sprache: Cobol

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

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

      **************************************************************
      *
      *                  COMMENT SECTION
      *
      * DATE  1988/06/26 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.
      *
      * COB002.SCO
      * WRITTEN BY: S Hurwitz
      * TRANSLATED AUTOMATICALLY FROM EMBEDDED COBOL BY CHRIS SCHANZLE
      *
      *  This routine tests how the SQL language handles
      *  the length of several COBOL alphanumeric character strings.
      *
      *  Examples:
      *    01  xyz1    PIC X(80).
      *    01  xyz2    PIC X(132).
      *    01  xyz3    PIC X(240).
      *
      *  REFERENCES
      *         AMERICAN NATIONAL STANDARD database language - SQL
      *                   X3.135-1989
      *         SECTION 5.5  <data type> Syntax Rule 5).
      *         SECTION ANNEX C. <embedded SQL COBOL program>
      *                 Snytax Rule 4)c).
      ***************************************************************

      * EXEC SQL BEGIN DECLARE SECTION END-EXEC.

       01  IN80        PIC  X(80).
       01  IN132       PIC  X(132).
       01  IN240       PIC  X(240).
       01  OUT80       PIC  X(80).
       01  OUT132      PIC  X(132).
       01  OUT240      PIC  X(240).

      * EXEC SQL END DECLARE SECTION END-EXEC.

       01  SQL-COD PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  SQLCODE PIC S9(9) COMP.
       01  errcnt PIC S9(4) DISPLAY SIGN LEADING SEPARATE.
       01  uid        PIC  X(18).
       01  uidx       PIC  X(18).

       01  XYZ1    PIC  X(80) value is            "NOTE: Additional SQL
      -                  " language is planned for later addenda to this
      -                                                 " standard. M".
       01  XYZ2    PIC  X(52) value is         "ajor topics under consid
      -                                  "eration for such addenda inc".
       01  XYZ3    PIC  X(108) value is     "lude referential integrity,
      -                 " enhanced transaction management, specification
      -                            " of certain implementor-defined ru".
       01  XYZ4    PIC  X(16)  value is              "les, enhanced ch".

       01  T80.
           05  aa80        PIC  X(80).

       01  T132.
           05  aa132       PIC  X(80).
           05  bb132       PIC  X(52).

       01  T240.
           05  aa240       PIC  X(80).
           05  bb240       PIC  X(52).
           05  cc240       PIC  X(108).

      * date_time declaration *
       01  TO-DAY PIC 9(6).
       01  THE-TIME PIC 9(8).

       PROCEDURE DIVISION.
       P0.

      *log into database
           move "HU" to uid.
           CALL "AUTHID" USING uid.
           MOVE "not logged in, not" TO uidx
           CALL "AUTHCK" USING SQLCODE uidx
           MOVE SQLCODE TO SQL-COD
           if (uid NOT = uidx) then
            DISPLAY "ERROR: User " uid " expected."
            DISPLAY "User " uidx " connected."
            DISPLAY " "
            STOP RUN
           END-IF

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

           display " Testing COBOL character string lengths ".
           display " reference X3. 135-1986 SECTION 5.5 ".
           display " syntax rule 5). ".
           display " reference SECTION ANNEX C. syntax rule 4)c). ".

           display " - - - - - - - - - - - - - - - - - - - - - ".

           move XYZ1 to aa80 aa132 aa240.
           move XYZ2 to bb132 bb240.
           move XYZ3 to cc240.
           move T80 to IN80.
           move T132 to IN132.
           move T240 to IN240.

      ******************** BEGIN TEST0186 ********************
           display " ".
           display " TEST0186 ".
           display " *** Testing character string length 80 ***".
           display " ".

      * EXEC SQL DELETE FROM TEXT80
      * END-EXEC.
           CALL "SUB1" USING SQLCODE

      * EXEC SQL INSERT
      *  INTO TEXT80(TEXXT)
      *     VALUES (:IN80)
      * END-EXEC.
           CALL "SUB2" USING SQLCODE IN80

      * EXEC SQL SELECT
      *  TEXXT INTO :OUT80 FROM TEXT80
      * END-EXEC.
           CALL "SUB3" USING SQLCODE OUT80

           display " OUT80= "  OUT80.

           if OUT80 = T80
              display " "
              display " *** pass *** "
              display " "
              display "=========================================="

      *   EXEC SQL INSERT INTO TESTREPORT
      *          VALUES('0186','pass','MCO') END-EXEC
              CALL "SUB4" USING SQLCODE
            else
             display " "
             display " cob002.sco *** fail *** "
             display " "
             display "============================================"
      *  EXEC SQL INSERT INTO TESTREPORT
      *       VALUES('0186','fail','MCO') END-EXEC
             ADD 1 TO errcnt
             CALL "SUB5" USING SQLCODE
            END-IF

      * EXEC SQL COMMIT WORK;
           CALL "SUB6" USING SQLCODE

      ******************** END TEST0186 *********************
      ******************** BEGIN TEST0187 ********************
           display " ".
           display " TEST0187 ".
           display " **** Testing character string length 132 *** ".
           display " ".
      * EXEC SQL DELETE
      *   FROM TEXT132
      * END-EXEC.
           CALL "SUB7" USING SQLCODE

      * EXEC SQL INSERT
      * INTO TEXT132(TEXXT)
      *     VALUES (:IN132)
      * END-EXEC.
           CALL "SUB8" USING SQLCODE IN132

      * EXEC SQL SELECT
      *  TEXXT INTO :OUT132 FROM TEXT132
      * END-EXEC.
           CALL "SUB9" USING SQLCODE OUT132

           display " OUT132= " OUT132.

           if OUT132 = T132
              display " "
              display " *** pass *** "
              display " "
              display "=============================================="

      *   EXEC SQL INSERT INTO TESTREPORT
      *        VALUES ('0187','pass','MCO') END-EXEC
              CALL "SUB10" USING SQLCODE
            else
              display " "
              display " cob002.sco *** fail *** "
              display " "
              display "==============================================="
      *   EXEC SQL INSERT INTO TESTREPORT
      *        VALUES ('0187','fail','MCO') END-EXEC
             ADD 1 TO errcnt
              CALL "SUB11" USING SQLCODE
            END-IF

      * EXEC SQL COMMIT WORK;
           CALL "SUB12" USING SQLCODE

      ******************** END TEST0187 *********************
      ******************** BEGIN TEST0188 ********************
           display " ".
           display " TEST0188 ".
           display " *** Testing character string length 240 ***".
           display " ".

      * EXEC SQL DELETE
      * FROM TEXT240
      * END-EXEC.
           CALL "SUB13" USING SQLCODE

      * EXEC SQL INSERT
      *  INTO TEXT240(TEXXT)
      *     VALUES (:IN240)
      * END-EXEC.
           CALL "SUB14" USING SQLCODE IN240

      * EXEC SQL SELECT
      *  TEXXT INTO :OUT240 FROM TEXT240
      * END-EXEC.
           CALL "SUB15" USING SQLCODE OUT240

           display " OUT240= " OUT240.

           if OUT240 = T240
              display " "
              display " *** pass *** "
              display " "
              display "=============================================="

      *   EXEC SQL INSERT INTO TESTREPORT
      *        VALUES('0188','pass','MCO') END-EXEC
              CALL "SUB16" USING SQLCODE
            else
              display " "
              display " cob002.sco *** fail *** "
              display " "
              display "=============================================="
      *   EXEC SQL INSERT INTO TESTREPORT
      *        VALUES ('0188','fail','MCO') END-EXEC
             ADD 1 TO errcnt
              CALL "SUB17" USING SQLCODE
             END-IF

      * EXEC SQL COMMIT WORK;
           CALL "SUB18" USING SQLCODE

      ******************** END TEST0188 *********************
      *********************************************************

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

      *********************************************************

quality100%

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