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.

      * EMBEDDED COBOL (file "COB002.PCO")

      **************************************************************
      *
      *                  COMMENT SECTION
      *
      *  DATE  1988/06/26 EMBEDDED 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.PCO
      *  WRITTEN BY: S Hurwitz
      *
      *  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).

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

       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
           EXEC SQL SELECT
                 USER INTO :uidx FROM HU.ECCO END-EXEC
           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, Embedded COBOL, cob002.pco"
           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.

           EXEC SQL INSERT
             INTO TEXT80(TEXXT)
                VALUES (:IN80)
           END-EXEC.

           EXEC SQL SELECT
             TEXXT INTO :OUT80 FROM TEXT80
           END-EXEC.

           display " OUT80= "  OUT80.

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

              EXEC SQL INSERT INTO TESTREPORT
                     VALUES('0186','pass','PCO') END-EXEC
            else
             display " "
             display " cob002.pco *** fail *** "
             display " "
             display "============================================"
             EXEC SQL INSERT INTO TESTREPORT
                  VALUES('0186','fail','PCO') END-EXEC
             ADD 1 TO errcnt
            END-IF

           EXEC SQL COMMIT WORK END-EXEC.

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

           EXEC SQL INSERT
            INTO TEXT132(TEXXT)
                VALUES (:IN132)
           END-EXEC.

           EXEC SQL SELECT
             TEXXT INTO :OUT132 FROM TEXT132
           END-EXEC.

           display " OUT132= " OUT132.

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

              EXEC SQL INSERT INTO TESTREPORT
                   VALUES ('0187','pass','PCO') END-EXEC
            else
              display " "
              display " cob002.pco *** fail *** "
              display " "
              display "==============================================="
              EXEC SQL INSERT INTO TESTREPORT
                   VALUES ('0187','fail','PCO') END-EXEC
             ADD 1 TO errcnt
            END-IF

           EXEC SQL COMMIT WORK END-EXEC.

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

           EXEC SQL DELETE
            FROM TEXT240
           END-EXEC.

           EXEC SQL INSERT
             INTO TEXT240(TEXXT)
                VALUES (:IN240)
           END-EXEC.

           EXEC SQL SELECT
             TEXXT INTO :OUT240 FROM TEXT240
           END-EXEC.

           display " OUT240= " OUT240.

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

              EXEC SQL INSERT INTO TESTREPORT
                   VALUES('0188','pass','PCO') END-EXEC
            else
              display " "
              display " cob002.pco *** fail *** "
              display " "
              display "=============================================="
              EXEC SQL INSERT INTO TESTREPORT
                   VALUES ('0188','fail','PCO') END-EXEC
             ADD 1 TO errcnt
             END-IF

           EXEC SQL COMMIT WORK END-EXEC.

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

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

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

quality100%

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