Quelle hpsample.pli Sprache: Pl1

S027:

   PROCEDURE OPTIONS (MAIN);

DCL
  1 RECEIVE_AREA,
    2 KEY   CHAR(9) INIT((9)' '),
    2 NAME  CHAR(21) INIT((21)' ');

DCL
  1 SEND_AREA,
    2 KEY   CHAR(9) INIT((9)' '),
    2 NAME  CHAR(21) INIT((21)' '),
    2 DATA  CHAR(50) INIT((50)' ');

/***  error codes ***/
DCL NOT_FOUND    CHAR(4) INIT('0001');
DCL INVALID_NAME CHAR(4) INIT('0002');
DCL MISC_ERROR   CHAR(4) INIT('0003');

DCL ADDR        BUILTIN;
DCL CSTG        BUILTIN;
DCL HIGH        BUILTIN;
DCL LOW         BUILTIN;
DCL SUBSTR      BUILTIN;
DCL STG         BUILTIN;
DCL VERIFY      BUILTIN;

DCL CONV_GONE     BIT(1)  INIT('0'B);
DCL CONFIRM_REQ   BIT(1)  INIT('0'B);
DCL DATA_COMPLETE BIT(1)  INIT('0'B);
DCL INLEN   FIXED BIN(31) INIT(30);
DCL RSC     CHAR(6)       INIT('TPFILE');
DCL SYNC    FIXED BIN(15) INIT(0);

/***   Begin MAIN   ***/

   EXEC CICS HANDLE CONDITION NOTFND(L_NFD)
                           ERROR(L_ERR);

/* Receive attach from HP 3000.  Equivalent to MCGetAllocate. */

   EXEC CICS EXTRACT PROCESS SYNCLEVEL(SYNC);

RCV_LOOP:
   DO WHILE ((CONV_GONE = '0'B) &
             (CONFIRM_REQ = '0'B));

/* Until the partner TP deallocates the conversation or */
/* the partner TP issues MCConfirm to request confirmation, */
/* receive another 30-byte record with 9-digit key and 21-character name. */

   EXEC CICS RECEIVE INTO(RECEIVE_AREA) LENGTH(INLEN);

/* If the partner TP deallocated, exit the receive loop. */

   IF DFHEIBLK.EIBFREE = HIGH(1) THEN
     DO;
     CONV_GONE = '1'B;
     LEAVE RCV_LOOP;
     END;

/* If the partner TP called MCConfirm, exit the receive loop. */

   IF DFHEIBLK.EIBCONF = HIGH(1) THEN
     DO;
     CONFIRM_REQ = '1'B;
     LEAVE RCV_LOOP;
     END;

/* If End-Of-Chain & DATA_COMPLETE & partner TP called MCPrepToRcv */

   IF ( (DFHEIBLK.EIBEOC   = HIGH(1)) &
        (DFHEIBLK.EIBCOMPL = HIGH(1)) &
        (DFHEIBLK.EIBRECV  = LOW(1)) )  THEN
     DO;

       IF VERIFY(RECEIVE_AREA.KEY,'0123456789') = 0 THEN
       DO;

/* Query the database for the key received from the remote TP. */

         EXEC CICS ENQ RESOURCE(RSC) LENGTH(6);
         EXEC CICS READ DATASET('TPFILE') INTO(SEND_AREA)
                        RIDFLD(RECEIVE_AREA.KEY);
         EXEC CICS DEQ RESOURCE(RSC) LENGTH(6);

   IF RECEIVE_AREA.NAME ¬ = SEND_AREA.NAME THEN

/* The above line contains a logicalnot or (NOT EQUAL) sign. */
/* If the name in the database doesn't match the name from the remote TP, */
/* issue an error code and call McPrepToRcv (INVITE WAIT). */

         DO;
           EXEC CICS SEND FROM(INVALID_NAME) INVITE WAIT;
         END;

/* If names match, send the data record and call MCPrepToRcv (INVITE WAIT). */

         ELSE DO;
           EXEC CICS SEND FROM(SEND_AREA) INVITE WAIT;
         END;
       END;

/* Otherwise, report a misc. error and call MCPrepToRcv (INVITE WAIT). */

       ELSE DO;
         EXEC CICS DEQ RESOURCE(RSC) LENGTH(6);
L_ERR:   EXEC CICS SEND FROM(MISC_ERROR) INVITE WAIT;
       END;
     END;
END RCV_LOOP;

/* If the partner TP called MCConfirm, */
/* respond with MCConfirmed (EXEC CICS ISSUE CONFIRMATION). */

L_BYE:
   IF ((SYNC = 1) & (CONFIRM_REQ = '1'B)) THEN
     DO;
       EXEC CICS ISSUE CONFIRMATION;
       CONFIRM_REQ = '0'B;
     END;

/* If the remote TP deallocated, deallocate the local conversation. */

   IF DFHEIBLK.EIBFREE = HIGH(1) THEN
     DO;
       EXEC CICS RETURN;
     END;

/* If the key sent by the remote TP is not in the database, */
/* report an error, call MCPrepToRcv (INVITE WAIT), and */
/* return to the receive loop to receive another record. */

L_NFD:
     DO;
       EXEC CICS DEQ RESOURCE(RSC) LENGTH(6);
       EXEC CICS SEND FROM(NOT_FOUND)  INVITE WAIT;
       GOTO RCV_LOOP;
     END;

END S027;

quality37%

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