Quelle xop701.cob Sprache: Cobol

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

      * Embedded SQL COBOL (file "XOP701.PCO")

      *   Copyright 1994, 1995 X/Open Company Limited

      *   All rights reserved.

      *   DISCLAIMER:
      *   This program was reviewed by employees of NIST for
      *   conformance to the SQL standards.
      *   NIST assumes no responsibility for any party's use of
      *   this program.

      *   X/Open and the 'X' symbol are registered trademarks of X/Open Company
      *   Limited in the UK and other countries.

      ****************************************************************
      *
      *                 COMMENT SECTION
      *
      * DATE 1994/05/03 EMBEDDED C LANGUAGE
      * X/Open SQL VALIDATION TEST SUITE V6.0
      *
      * XOP701.PCO
      * WRITTEN BY: Colin O'Driscoll
      *
      * WHENEVER SQLWARNING and Scoping of 'C' Labels as targets
      * for WHENEVER
      *
      * REFERENCES
      *       X/OPEN CAE SQL Specification
      *       Section 4.6
      *
      *                <embedded SQL C program>
      *
      * DATE PROGRAM LAST CHANGED   1/11/94
      *
      ****************************************************************

           EXEC SQL BEGIN DECLARE SECTION END-EXEC
       01  SQLSTATE PIC  X(5).
       01  testchar PIC  X(3).
       01  testint PIC S9(9) DISPLAY SIGN LEADING SEPARATE.
       01  uid PIC  X(18).
       01  uidx PIC  X(18).
             EXEC SQL END DECLARE SECTION END-EXEC

             EXEC SQL INCLUDE SQLCA END-EXEC.

       01  errcnt PIC S9(4) DISPLAY SIGN LEADING SEPARATE.
      *date_time declaration
       01  TO-DAY PIC 9(6).
       01  THE-TIME PIC 9(8).

       01  errflg PIC S9(9) DISPLAY SIGN LEADING SEPARATE.

       01  SQL-COD PIC S9(9) DISPLAY SIGN LEADING SEPARATE.

       PROCEDURE DIVISION.
       P0.

             MOVE "XOPEN1" TO uid
             CALL "AUTHID" USING uid
             MOVE "not logged in, not" TO uidx
             EXEC SQL SELECT USER INTO :uidx FROM XOPEN1.ECCO END-EXEC
             MOVE SQLCODE TO SQL-COD
             if (uid  NOT  =   uidx) then
               DISPLAY "ERROR: User ", uid " expected. User ", uidx "
      -    " connected"
             STOP RUN
             END-IF
             MOVE 0 TO errcnt
           DISPLAY    "X/OPEN Extensions SQL Test Suite, V6.0, Embedded
      -            "COBOL, xop701.pco"
             DISPLAY
           "59-byte ID"
             DISPLAY "TEd Version #"
      *date_time print
           ACCEPT TO-DAY FROM DATE
           ACCEPT THE-TIME FROM TIME
           DISPLAY "Date run YYMMDD: " TO-DAY " at hhmmssff: " THE-TIME

      ******************** BEGIN TEST0701 *******************

           DISPLAY " TEST0701 "
           DISPLAY " X/O,WHENEVER SQLWARNING and scoping of 'C' labels"
           DISPLAY " X/Open CAE SQL Sec 4.6"
           DISPLAY " - - - - - - - - - - - - - - - - - - -"
           DISPLAY "### WHENEVER SQLWARNING GOTO P100;"
           DISPLAY "### SELECT SUM(TESTINT) INTO :testint "
           DISPLAY "### FROM WARNING;"
           DISPLAY "### WHENEVER SQLWARNING GO TO P101;"
           DISPLAY "### SELECT TESTCHAR INTO :testchar FROM
      -    " WARNING"
           DISPLAY "### WHERE TESTINT = 1;"
           DISPLAY "### WHENEVER SQLWARNING GOTO P102;"
           DISPLAY "### WHENEVER SQLWARNING CONTINUE;"
           DISPLAY "### SELECT SUM(TESTINT) INTO :testint"
           DISPLAY "### FROM WARNING;"
           DISPLAY "### WHENEVER SQLWARNING GO TO P104;"
           DISPLAY "### SELECT AVG(TESTINT) INTO :testint"
           DISPLAY "### FROM WARNING;"
           DISPLAY "================================================="

             MOVE 0 TO errflg
      *Load values into WARNING table

             EXEC SQL INSERT INTO WARNING
               VALUES ('AAAAAA', 1) END-EXEC
             MOVE SQLCODE TO SQL-COD

             EXEC SQL INSERT INTO WARNING
               VALUES ('BBBBBB', 2) END-EXEC
             MOVE SQLCODE TO SQL-COD

             EXEC SQL INSERT INTO WARNING
               VALUES ('CCCCCC', NULL) END-EXEC
             MOVE SQLCODE TO SQL-COD

      *Start new block

             EXEC SQL WHENEVER SQLWARNING GOTO P100 END-EXEC
             MOVE SQLCODE TO SQL-COD

      *Generate warning

             EXEC SQL SELECT SUM(TESTINT) INTO :testint
               FROM WARNING END-EXEC
             MOVE SQLCODE TO SQL-COD
             DISPLAY "================================================="

             DISPLAY "Program should jump around this code"
             DISPLAY "*** Problem found (TEST STEP NUMBER 1 ) ! *** "
             COMPUTE errflg = errflg + 1

            DISPLAY "=================================================".

       P100.

             EXEC SQL WHENEVER SQLWARNING GO TO P101 END-EXEC
             MOVE SQLCODE TO SQL-COD

      *Generate  warning

             EXEC SQL SELECT TESTCHAR INTO :testchar
               FROM WARNING
               WHERE TESTINT = 1 END-EXEC
             MOVE SQLCODE TO SQL-COD

             DISPLAY "================================================="

             DISPLAY "Program should jump around this code"
             DISPLAY "*** Problem found (TEST STEP NUMBER 2) ! *** "
             COMPUTE errflg = errflg + 1

            DISPLAY "=================================================".

       P101.

             EXEC SQL WHENEVER SQLWARNING GOTO P102 END-EXEC
             MOVE SQLCODE TO SQL-COD
             EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC
             MOVE SQLCODE TO SQL-COD

      *Generate warning (which shouldn't cause a jump to P102:)

             EXEC SQL SELECT SUM(TESTINT) INTO :testint
               FROM WARNING END-EXEC
             MOVE SQLCODE TO SQL-COD

             GO TO P103.

       P102.

             DISPLAY "================================================="

             DISPLAY "Program should jump around this code"
             DISPLAY "*** Problem found (TEST STEP NUMBER 3) ! *** "
             COMPUTE errflg = errflg + 1

            DISPLAY "=================================================".

       P103.

             EXEC SQL WHENEVER SQLWARNING GO TO P104 END-EXEC
             MOVE SQLCODE TO SQL-COD

             EXEC SQL SELECT AVG(TESTINT) INTO :testint
               FROM WARNING END-EXEC
             MOVE SQLCODE TO SQL-COD

      *Shouldn't get here

             DISPLAY "================================================="

             DISPLAY "Program should jump around this code"
             DISPLAY "*** Problem found (TEST STEP NUMBER 4) ! *** "
             COMPUTE errflg = errflg + 1

            DISPLAY "=================================================".
       P104.

             EXEC SQL WHENEVER SQLWARNING CONTINUE END-EXEC
             MOVE SQLCODE TO SQL-COD
             EXEC SQL ROLLBACK WORK END-EXEC
             MOVE SQLCODE TO SQL-COD
             EXEC SQL DELETE FROM WARNING END-EXEC
             MOVE SQLCODE TO SQL-COD

             DISPLAY "number of errors detected = ", errflg " "
             DISPLAY "### maximum number of errors is 4 ###"

             if (errflg  =  0) then
               EXEC SQL INSERT INTO XOPEN1.TESTREPORT
             VALUES('0701','pass','PCO') END-EXEC
               MOVE SQLCODE TO SQL-COD
               DISPLAY " xop701.pco *** pass *** "
             else
               EXEC SQL INSERT INTO XOPEN1.TESTREPORT
             VALUES('0701','fail','PCO') END-EXEC
               MOVE SQLCODE TO SQL-COD
               COMPUTE errcnt = errcnt + 1
               DISPLAY " xop701.pco *** fail *** "
             END-IF

             DISPLAY "================================================="
             DISPLAY  " "

             EXEC SQL COMMIT WORK END-EXEC
             MOVE SQLCODE TO SQL-COD

      ******************** END TEST0701 *******************

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

      *    ****  Procedures for PERFORM statements

quality97%

¤ 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.