home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / o22516d1.zip / DSDEMO.@IP / DSSERVER.CBL < prev    next >
Text File  |  1992-07-29  |  8KB  |  212 lines
  1.       $SET MF
  2.        IDENTIFICATION DIVISION.
  3.        ENVIRONMENT DIVISION.
  4.        CONFIGURATION SECTION.
  5.        SPECIAL-NAMES.
  6.        CALL-CONVENTION 3 IS API.
  7.  
  8.        WORKING-STORAGE SECTION.
  9.        01  LOCALS.
  10.            05  INFO1                   PIC X(80).
  11.            05  MAX-LENGTH              PIC X(4)    COMP-5.
  12.            05  WS-LENGTH               PIC X(4)    COMP-5.
  13.            05  SERVER-NAME             PIC X(8)    VALUE "CCIECI".
  14.            05  SESSION-ID              PIC X(4)    COMP-5 VALUE 0.
  15.            05  HANDLE1                 PIC X(4)    COMP-5 VALUE 0.
  16.  
  17.        COPY CCISIGNA.
  18.  
  19.        COPY 'FAAECIW.CBL'.
  20.  
  21.        01  CICS-ENTRY-POINT            PROCEDURE-POINTER.
  22.  
  23.        01  ECI-ERR-MSG-LINE.
  24.            05  ECI-ERR-MSG-CODE        PIC 9(4).
  25.            05  ECI-ERR-MSG-DATA        PIC X(30).
  26.  
  27.        COPY COMMAREA.
  28.  
  29.        LINKAGE SECTION.
  30.        COPY CCITABLE.
  31.  
  32.        PROCEDURE DIVISION.
  33.            PERFORM 100-START
  34.            PERFORM 200-CALL-ECI UNTIL COMM-REQUEST EQUAL 4
  35.            PERFORM 300-CLOSE
  36.            PERFORM MAIN-EXIT
  37.            .
  38.       ****************************************************************
  39.        100-START SECTION.
  40.            INITIALIZE COMM-AREA
  41.                       ECI-PARMS
  42.                       ECI-ERROR-ID
  43.       * THE FOLLOWING LINE
  44.       * CAUSES THE DLL FILE FAACICS.DLL TO BE PRELOADED BY THE
  45.       * COBOL RUNTIME SYSTEM. IF THIS IS NOT DONE THEN THE
  46.       * FOLLOWING CALL TO '_FAAECI' WILL GENERATE A FILE NOT FOUND
  47.       * MESSAGE, DURING ANIMATION. THIS ERROR WILL NOT OCCUR IF
  48.       * THE PROGRAM IS COMPILED TO OBJ THEN LINKED AS AN EXE.
  49.       *
  50.            SET CICS-ENTRY-POINT TO ENTRY "FAACICS.DLL".
  51.  
  52.       *
  53.       * JUST CALLING THIS TO PRE-LOAD CUSTIO SINCE YOU WILL PROBABLY
  54.       * MARK IT AS RESIDENT IN THE PPT AND ALSO TO MAKE SURE CICS OS/2
  55.       * IS FUNCTIONAL.
  56.       *
  57.            MOVE 'CUSTIO'            TO ECI-PROGRAM-NAME
  58.            MOVE 'SYSAD'             TO ECI-USERID
  59.            MOVE 'SYSAD'             TO ECI-PASSWORD
  60.            SET ECI-COMMAREA         TO ADDRESS OF COMM-AREA
  61.            MOVE LENGTH OF COMM-AREA TO ECI-COMMAREA-LENGTH
  62.                                        WS-LENGTH
  63.                                        MAX-LENGTH
  64.            CALL '_FAAECI' USING ECI-PARMS
  65.            END-CALL
  66.            PERFORM CHECK-ECI-RETURN
  67.  
  68.            CALL API "CCINAMP" USING BY REFERENCE SIGNATURE-BLOCK
  69.            IF CCITYPE NOT = "NAMP"
  70.                DISPLAY 'ERROR IN CCI SIGNATURE'
  71.                GO TO MAIN-EXIT
  72.            END-IF
  73.  
  74.            SET ADDRESS OF CALTAB TO CCICALTAB
  75.            CALL API CCI-INITSERVER USING BY REFERENCE SERVER-NAME
  76.                                          BY REFERENCE HANDLE1
  77.                                          BY VALUE 0 SIZE 4
  78.            IF RETURN-CODE NOT = 0
  79.                PERFORM GET-CCI-ERROR
  80.                DISPLAY INFO1 AT LINE NUMBER 15 COLUMN 1
  81.                DISPLAY "Error on return from CCI-INITSERVER"
  82.                        AT LINE NUMBER 15 COLUMN 1
  83.                GO TO MAIN-EXIT
  84.            END-IF
  85.            .
  86.       ****************************************************************
  87.        200-CALL-ECI SECTION.
  88.            CALL API CCI-RECEIVEALL USING  BY VALUE HANDLE1
  89.                                           BY REFERENCE SESSION-ID
  90.                                           BY REFERENCE COMM-AREA
  91.                                           BY VALUE MAX-LENGTH
  92.                                           BY REFERENCE WS-LENGTH
  93.                                           BY VALUE 0 SIZE 4
  94.                                           BY VALUE 0 SIZE 4
  95.            IF RETURN-CODE NOT = 0
  96.                PERFORM GET-CCI-ERROR
  97.                DISPLAY INFO1 AT LINE NUMBER 15 COLUMN 1
  98.                DISPLAY "Error on return from CCI-RECEIVEALL"
  99.                        AT LINE NUMBER 15 COLUMN 1
  100.            END-IF
  101.  
  102.            IF COMM-REQUEST EQUAL 2
  103.                MOVE LENGTH OF COMM-AREA TO ECI-COMMAREA-LENGTH
  104.                CALL '_FAAECI' USING ECI-PARMS
  105.                END-CALL
  106.                PERFORM CHECK-ECI-RETURN
  107.            END-IF
  108.  
  109.            CALL API CCI-SEND USING BY VALUE     SESSION-ID
  110.                                    BY REFERENCE COMM-AREA
  111.                                    BY VALUE     WS-LENGTH
  112.                                    BY VALUE     0 SIZE 4
  113.                                    BY VALUE     0 SIZE 4
  114.  
  115.            CALL API CCI-SUSPENDSERVER USING BY VALUE SESSION-ID
  116.            IF RETURN-CODE NOT = 0
  117.                PERFORM GET-CCI-ERROR
  118.                DISPLAY INFO1 AT LINE NUMBER 15 COLUMN 1
  119.                DISPLAY "Error on return from CCI-SUSPENDSERVER"
  120.                         AT LINE NUMBER 15 COLUMN 1
  121.                GO TO MAIN-EXIT
  122.            END-IF
  123.  
  124.            IF COMM-REQUEST EQUAL 3 OR 4
  125.                CALL API CCI-HANGUP USING BY VALUE SESSION-ID
  126.                IF RETURN-CODE NOT = 0
  127.                    PERFORM GET-CCI-ERROR
  128.                    DISPLAY INFO1 AT LINE NUMBER 15 COLUMN 1
  129.                    DISPLAY "Error on return from CCI-HANGUP"
  130.                             AT LINE NUMBER 15 COLUMN 1
  131.                    GO TO MAIN-EXIT
  132.                END-IF
  133.            END-IF
  134.            .
  135.       *---------------------------------------------------------------*
  136.  
  137.        CHECK-ECI-RETURN SECTION.
  138.            EVALUATE TRUE
  139.               WHEN ECI-NO-ERROR
  140.                    NEXT SENTENCE
  141.               WHEN ECI-ERR-INVALID-DATA-LENGTH
  142.                    MOVE '  ECI-ERR-INVALID-DATA-LENGTH' TO
  143.                            ECI-ERR-MSG-DATA
  144.                WHEN ECI-ERR-INVALID-EXTEND-MODE
  145.                    MOVE '  ECI-ERR-INVALID-EXTEND-MODE' TO
  146.                            ECI-ERR-MSG-DATA
  147.                WHEN ECI-ERR-NO-CICS
  148.                    MOVE '  ECI-ERR-NO-CICS' TO
  149.                            ECI-ERR-MSG-DATA
  150.                WHEN ECI-ERR-CICS-DIED
  151.                    MOVE '  ECI-ERR-CICS-DIED' TO
  152.                            ECI-ERR-MSG-DATA
  153.                WHEN ECI-ERR-REQUEST-TIMEOUT
  154.                    MOVE '  ECI-ERR-REQUEST-TIMEOUT' TO
  155.                            ECI-ERR-MSG-DATA
  156.                WHEN ECI-ERR-RESPONSE-TIMEOUT
  157.                    MOVE '  ECI-ERR-RESPONSE-TIMEOUT' TO
  158.                            ECI-ERR-MSG-DATA
  159.                WHEN ECI-ERR-TRANSACTION-ABEND
  160.                    MOVE '  ECI-ERR-TRANSACTION-ABEND' TO
  161.                            ECI-ERR-MSG-DATA
  162.                WHEN ECI-ERR-EXEC-NOT-RESIDENT
  163.                    MOVE '  ECI-ERR-EXEC-NOT-RESIDENT' TO
  164.                            ECI-ERR-MSG-DATA
  165.                WHEN ECI-ERR-SYSTEM-ERROR
  166.                    MOVE '  ECI-ERR-SYSTEM-ERROR' TO
  167.                            ECI-ERR-MSG-DATA
  168.                WHEN ECI-ERR-NULL-WIN-HANDLE
  169.                    MOVE '  ECI-ERR-NULL-WIN-HANDLE' TO
  170.                            ECI-ERR-MSG-DATA
  171.                WHEN ECI-ERR-NULL-MESSAGE-ID
  172.                    MOVE '  ECI-ERR-NULL-MESSAGE-ID' TO
  173.                            ECI-ERR-MSG-DATA
  174.                WHEN ECI-ERR-THREAD-CREATE-ERROR
  175.                    MOVE '  ECI-ERR-THREAD-CREATE-ERROR' TO
  176.                            ECI-ERR-MSG-DATA
  177.            END-EVALUATE
  178.  
  179.            IF  ECI-ERROR-ID NOT = 0
  180.                MOVE ECI-ERROR-ID TO ECI-ERR-MSG-CODE
  181.                DISPLAY SPACES
  182.                DISPLAY 'CICS/OS2 E.C.I. failed with an error code of;'
  183.                DISPLAY ECI-ERR-MSG-LINE
  184.                GO TO MAIN-EXIT
  185.            END-IF
  186.            .
  187.  
  188.        300-CLOSE SECTION.
  189.            DISPLAY "Closing down server"
  190.  
  191.            CALL API CCI-CLOSESERVER USING BY VALUE HANDLE1
  192.  
  193.            IF RETURN-CODE NOT = 0
  194.                PERFORM GET-CCI-ERROR
  195.  
  196.                DISPLAY INFO1
  197.                DISPLAY "Error on return from CCI-CLOSESERVER"
  198.            END-IF
  199.            .
  200.  
  201.        MAIN-EXIT SECTION.
  202.            EXIT PROGRAM
  203.            GOBACK
  204.            .
  205.       ****************************************************************
  206.        GET-CCI-ERROR SECTION.
  207.            MOVE LENGTH OF INFO1 TO MAX-LENGTH
  208.            CALL API CCI-GETERROR USING BY REFERENCE INFO1
  209.                                        BY VALUE MAX-LENGTH
  210.                                        BY REFERENCE WS-LENGTH
  211.            .
  212.