Quelle dml078.cob Sprache: Cobol

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

      * EMBEDDED COBOL (file "DML078.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.
      *
      *  DML078.PCO
      *  WRITTEN BY: S Hurwitz
      *
      *  This routine tests how the SQL language handles
      *  the length of several COBOL alphanumeric character strings.
      *
      *  Examples:
      *    01  xyz4    PIC X(256).
      *    01  xyz5    PIC X(512).
      *    01  xyz6    PIC X(1024).
      *
      *  REFERENCES
      *         AMERICAN NATIONAL STANDARD database language - SQL
      *         X3.135-1989
      *              SECTION 5.5  <data type> Syntax Rule 5).
      *         X3.168-1989 <embedded SQL COBOL program>
      *              SECTION 9.5  Snytax Rule 4)c).
      ***************************************************************

           EXEC SQL BEGIN DECLARE SECTION END-EXEC.

       01  IN256       PIC  X(256).
       01  IN512       PIC  X(512).
       01  IN1024      PIC  X(1024).
       01  OUT256      PIC  X(256).
       01  OUT512      PIC  X(512).
       01  OU1024     PIC  X(1024).

       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  XYZ5.
           02 FILLER PIC X(128) value is   "aracter handling facilities,
      -              " and support for national character sets. Annexes
      -            " to this standard specify embedded syntax for incl".
           02 FILLER PIC X(128) value is                          "uding
      -                              " SQL data manipulation language st
      -              "atements in an otherwise standard application prog
      -              "ram. Such embedded syntax is defined t".
       01  XYZ6.
           02 FILLER PIC X(128) value is      "o be a shorthand notation
      -                " for a standard application program in which the
      -       " embedded SQL statements have been replaced with explic".
           02 FILLER PIC X(128)  value is
                                 "it of database procedures that
      -             " contain the SQL statements. This standard applies
      -                       " to implementations that exist in an en".
       01  XYZ7.
           02 FILLER PIC  X(128) value is                     "vironment
      -            " that may include application programming languages,
      -            " end-user query languages, report generator systems,
      -              " data dictionar".
           02 FILLER PIC X(128)     value is
                                    "y ststems, program library systems,
      -              " and distributed communication systems, as well as
      -                     " various tools for database design,..... ".

       01  T256.
           05  aa256       PIC  X(80).
           05  bb256       PIC  X(52).
           05  cc256       PIC  X(108).
           05  dd256       PIC  X(16).

       01  T512.
           05  aa512       PIC  X(80).
           05  bb512       PIC  X(52).
           05  cc512       PIC  X(108).
           05  dd512       PIC  X(16).
           05  ee512       PIC  X(256).

       01  T1024.
           05  aa1024      PIC  X(80).
           05  bb1024      PIC  X(52).
           05  cc1024      PIC  X(108).
           05  dd1024      PIC  X(16).
           05  ee1024      PIC  X(256).
           05  ff1024      PIC  X(256).
           05  gg1024      PIC  X(256).


      * 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, dml078.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-1989 SECTION 5.5 ".
           display " syntax rule 5). ".
           display " reference X3.168-1989 SECTION 9.5 SR 4) C) ".

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

           move XYZ1 to aa256
                        aa512 aa1024.
           move XYZ2 to bb256 bb512
                        bb1024.
           move XYZ3 to cc256 cc512 cc1024.
           move XYZ4 to dd256 dd512 dd1024.
           move XYZ5 to ee512 ee1024.
           move XYZ6 to ff1024.
           move XYZ7 to gg1024.
           move T256 to IN256.
           move T512 to IN512.
           move T1024 to IN1024.

      ********************** BEGIN TEST0189 ********************
           display " ".
           display " OPTIONAL TEST0189 ".
           display " CHAR (256) ".
           display " ".
           EXEC SQL DELETE
             FROM TEXT256
           END-EXEC.

           EXEC SQL INSERT
             INTO TEXT256(TEXXT)
                VALUES (:IN256)
           END-EXEC.

           EXEC SQL SELECT
             TEXXT INTO :OUT256 FROM TEXT256
           END-EXEC.

           display " OUT256= "  OUT256.

           if OUT256 = T256
              display " "
              display  " *** pass **** "
              display " "
              display "=============================================="
              EXEC SQL INSERT INTO TESTREPORT
                VALUES('0189','pass','PCO') END-EXEC
            else
              display " "
              display " dml078.pco *** fail *** "
              display " "
              display "============================================="
              EXEC SQL INSERT INTO TESTREPORT
                VALUES('0189','fail','PCO') END-EXEC
             ADD 1 TO errcnt
            END-IF
           EXEC SQL COMMIT WORK END-EXEC.

      ******************** END TEST0189 *********************
      ******************** BEGIN TEST0190 ********************
           display " ".
           display " OPTIONAL TEST0190 ".
           display " CHAR (512) ".
           display " ".
           EXEC SQL DELETE
             FROM TEXT512
           END-EXEC.

           EXEC SQL INSERT
            INTO TEXT512(TEXXT)
                VALUES (:IN512)
           END-EXEC.

           EXEC SQL SELECT
             TEXXT INTO :OUT512 FROM TEXT512
           END-EXEC.

           display " OUT512= " OUT512.

           if OUT512 = T512
              display " "
              display " *** pass *** "
              display " "
              display "=============================================="

              EXEC SQL INSERT INTO TESTREPORT
                VALUES('0190','pass','PCO') END-EXEC
            else
              display " "
              display " dml078.pco *** fail *** "
              display " "
              display "==============================================="

              EXEC SQL INSERT INTO TESTREPORT
                VALUES('0190','fail','PCO') END-EXEC
             ADD 1 TO errcnt
             END-IF
           EXEC SQL COMMIT WORK END-EXEC.

      ******************** END TEST0190 *********************
      ******************** BEGIN TEST0191 ********************
           display " ".
           display " OPTIONAL TEST0191 ".
           display " CHAR (1024) ".
           display " ".

           EXEC SQL DELETE
            FROM TEXT1024
           END-EXEC.

           EXEC SQL INSERT
            INTO TEXT1024(TEXXT)
                VALUES (:IN1024)
           END-EXEC.

           EXEC SQL SELECT
            TEXXT INTO :OU1024 FROM TEXT1024
           END-EXEC.

           display " OUT1024= " OU1024.

           if OU1024 = T1024
              display " "
              display " *** pass *** "
              display " "
              display "============================================="

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

      ******************** END TEST0191 *********************
      *********************************************************

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

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

quality98%

¤ Dauer der Verarbeitung: 0.7 Sekunden ¤

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.