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.

      * Standard COBOL (file "DML078.SCO") calling SQL
      * procedures in file "DML078.MCO".
      * STANDARD COBOL (file "DML078.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.
      *
      *  DML078.SCO
      *  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).
      *              SECTION 7.3 SR 8)a)iii)
      *
      ***************************************************************

      * 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;
           CALL "SUB1" USING SQLCODE uidx
           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, dml078.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-1989 SECTION 5.5 ".
           display " syntax rule 5). ".
           display " SECTION 7.3 SR 8)a)iii) ".

           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
      * ;
           CALL "SUB2" USING SQLCODE

      * EXEC SQL INSERT
      *  INTO TEXT256(TEXXT)
      *     VALUES (:IN256)
      * ;
           CALL "SUB3" USING SQLCODE IN256

      * EXEC SQL SELECT
      *  TEXXT INTO :OUT256 FROM TEXT256
      * ;
           CALL "SUB4" USING SQLCODE OUT256

           display " OUT256= "  OUT256.

           if OUT256 = T256
              display " "
              display  " *** pass **** "
              display " "
              display "=============================================="
      *   EXEC SQL INSERT INTO TESTREPORT
      *     VALUES('0189','pass','MCO');
              CALL "SUB5" USING SQLCODE
            else
              display " "
              display " dml078.sco *** fail *** "
              display " "
              display "============================================="
      *   EXEC SQL INSERT INTO TESTREPORT
      *     VALUES('0189','fail','MCO');
              CALL "SUB6" USING SQLCODE
             ADD 1 TO errcnt
            END-IF
      * EXEC SQL COMMIT WORK;
           CALL "SUB7" USING SQLCODE

      ******************** END TEST0189 *********************
      ******************** BEGIN TEST0190 ********************
           display " ".
           display " OPTIONAL TEST0190 ".
           display " CHAR (512) ".
           display " ".
      * EXEC SQL DELETE
      *  FROM TEXT512
      * ;
           CALL "SUB8" USING SQLCODE

      * EXEC SQL INSERT
      * INTO TEXT512(TEXXT)
      *     VALUES (:IN512)
      * ;
           CALL "SUB9" USING SQLCODE IN512

      * EXEC SQL SELECT
      *  TEXXT INTO :OUT512 FROM TEXT512
      * ;
           CALL "SUB10" USING SQLCODE OUT512

           display " OUT512= " OUT512.

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

      *   EXEC SQL INSERT INTO TESTREPORT
      *     VALUES('0190','pass','MCO');
              CALL "SUB11" USING SQLCODE
            else
              display " "
              display " dml078.sco *** fail *** "
              display " "
              display "==============================================="

      *   EXEC SQL INSERT INTO TESTREPORT
      *     VALUES('0190','fail','MCO');
              CALL "SUB12" USING SQLCODE
             ADD 1 TO errcnt
             END-IF
      * EXEC SQL COMMIT WORK;
           CALL "SUB13" USING SQLCODE

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

      * EXEC SQL DELETE
      * FROM TEXT1024
      * ;
           CALL "SUB14" USING SQLCODE

      * EXEC SQL INSERT
      * INTO TEXT1024(TEXXT)
      *     VALUES (:IN1024)
      * ;
           CALL "SUB15" USING SQLCODE IN1024

      * EXEC SQL SELECT
      * TEXXT INTO :OU1024 FROM TEXT1024
      * ;
           CALL "SUB16" USING SQLCODE OU1024

           display " OUT1024= " OU1024.

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

      *   EXEC SQL INSERT INTO TESTREPORT
      *     VALUES('0191','pass','MCO');
              CALL "SUB17" USING SQLCODE
             else
              display " "
              display " dml078.sco *** fail *** "
              display " "
              display "=============================================="
      *     EXEC SQL INSERT INTO TESTREPORT
      *         VALUES('0191','fail','MCO');
                CALL "SUB18" USING SQLCODE
             ADD 1 TO errcnt
             END-IF
              display " ".
      * EXEC SQL COMMIT WORK;
           CALL "SUB19" USING SQLCODE

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

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

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

quality100%

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