Quelle  cicscall.cbl   Sprache: Cobol

       IDENTIFICATION DIVISION.                                         
      PROGRAM-ID.  OSCICS8C.                                            
      DATE-WRITTEN. 09/17/96.                                           
      DATE-COMPILED.                                                    
      ******************************************************************
      **                                                                
      **       (c) 1995 by Sybase, Inc. All Rights Reserved             
      **                                                                
      ******************************************************************
                                                                        
      ******************************************************************
      ** PROGRAM:    OSCICS8C  TRAN:SY8C....                            
      **                                                                
      ** THIS PROGRAM IS A THE OPEN SERVER VERSION OF RSP8C.  RECEIVES  
      ** A TEXT INPUT STRING(10,000 BYTES) AND RETURNS IT IN A 50 BYTE  
      ** COLUMN ONE ROW AT A TIME...                                    
      ** Example: exec sy8c 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'     
      ******************************************************************
                                                                        
      ENVIRONMENT DIVISION.                                             
                                                                        
      DATA DIVISION.                                                    
                                                                        
      WORKING-STORAGE SECTION.                                          
                                                                        
      ******************************************************************
      * COPY IN THE OS SERVER LIBRARYS                                  
      ******************************************************************
      *  COPY SYGWCOB.                                                  
      ******************************************************************
      *OPEN SERVER WORK VARIBLES FOR OS CALL TO USE ...                 
      ******************************************************************
      01  WS-GWL-WORK-VARIBLES.                                         
          05  GWL-PROC                POINTER.                          
          05  GWL-INIT-HANDLE         POINTER.                          
          05  GWL-RC                  PIC S9(9) COMP.                   
          05  GWL-INFPRM-ID           PIC S9(9) COMP.                   
          05  GWL-INFPRM-TYPE         PIC S9(9) COMP.                   
          05  GWL-INFPRM-DATA-L       PIC S9(9) COMP.                   
          05  GWL-INFPRM-MAX-DATA-L   PIC S9(9) COMP.                   
          05  GWL-INFPRM-STATUS       PIC S9(9) COMP.                   
          05  GWL-INFPRM-NAME         PIC X(30).                        
          05  GWL-INFPRM-NAME-L       PIC S9(9) COMP.                   
          05  GWL-INFPRM-USER-DATA    PIC S9(9) COMP.                   
          05  GWL-INFUDT-USER-TYPE    PIC S9(9) COMP.                   
          05  GWL-STATUS-NR           PIC S9(9) COMP.                   
          05  GWL-STATUS-DONE         PIC S9(9) COMP.                   
          05  GWL-STATUS-COUNT        PIC S9(9) COMP.                   
          05  GWL-STATUS-COMM         PIC S9(9) COMP.                   
          05  GWL-COMM-STATE          PIC S9(9) COMP.                   
          05  GWL-STATUS-RETURN-CODE  PIC S9(9) COMP.                   
          05  GWL-STATUS-SUBCODE      PIC S9(9) COMP.                   
          05  GWL-NUMPRM-PARMS        PIC S9(9) COMP.                   
          05  GWL-RCVPRM-DATA-L       PIC S9(9) COMP.                   
          05  GWL-SETPRM-ID           PIC S9(9) COMP.                   
          05  GWL-SETPRM-TYPE         PIC S9(9) COMP.                   
          05  GWL-SETPRM-DATA-L       PIC S9(9) COMP.                   
          05  GWL-SETPRM-USER-DATA    PIC S9(9) COMP.                   
          05  GWL-CONVRT-SCALE        PIC S9(9) COMP VALUE 2.           
          05  GWL-SETBCD-SCALE        PIC S9(9) COMP VALUE 0.           
          05  GWL-INFBCD-LENGTH       PIC S9(9) COMP.                   
          05  GWL-INFBCD-SCALE        PIC S9(9) COMP.                   
          05  GWL-RETURN-ROWS         PIC S9(9) COMP VALUE +0.          
          05  SNA-CONN-NAME           PIC X(8)  VALUE SPACES.           
          05  SNA-SUBC                PIC S9(9) COMP.                   
          05  WRK-DONE-STATUS         PIC S9(9) COMP.                   
          05  GWL-ACTUAL-LEN          PIC S9(9) COMP.                   
          05  GWL-TRAN-LEN            PIC S9(9) COMP.                   
          05  GWL-MSG-LEN             PIC S9(9) COMP.                   
          05  GWL-REQUEST-TYP         PIC S9(9) COMP.                   
          05  GWL-RPC-NAME            PIC X(30) VALUE SPACES.           
          05  GWL-COMM-STATE          PIC S9(9) COMP.                   
          05  I                       PIC S9(9) COMP VALUE +0.          
          05  J                       PIC S9(4) COMP VALUE +0.          
                                                                        
      01  DESCRIPTION-FIELDS.                                           
          05 COLUMN-NUMBER          PIC S9(09) COMP VALUE +0.           
          05 HOST-TYPE              PIC S9(09) COMP VALUE +0.           
          05 HOST-LEN               PIC S9(09) COMP VALUE +0.           
          05 COLUMN-LEN             PIC S9(09) COMP VALUE +0.           
          05 COLUMN-NAME-LEN        PIC S9(09) COMP VALUE +0.           
                                                                        
      01  WS-MSG-WORK-VARS.                                             
          05 MSG-NR                   PIC S9(9) COMP VALUE +9999.       
                                                                        
      01  WS-INPUT-LEN                PIC s9(9) COMP VALUE +10000.      
      01  WS-INPUT-DATA-HDR.                                            
          03  WS-INPUT-DATA           PIC X(10000)   VALUE SPACES.      
          03  WS-INPUT-REDEFINE REDEFINES WS-INPUT-DATA.                
              05  WS-INPUT-TABLE OCCURS 10000 TIMES.                    
                  10  WS-INPUT-CHAR    PIC X.                           
                                                                        
                                                                        
      01  WS-OUTPUT-DATA-HDR.                                           
          03  WS-OUTPUT-DATA           PIC X(50)   VALUE SPACES.        
          03  WS-OUTPUT-REDEFINE REDEFINES WS-OUTPUT-DATA.              
              05  WS-OUTPUT-TABLE OCCURS 50 TIMES.                      
                  10  WS-OUTPUT-CHAR    PIC X.                          
                                                                        
      01  WS-OUTPUT-COL-NAME          PIC X(13)                         
          VALUE 'OUTPUT_COLUMN'.                                        
                                                                        
      ******************************************************************
      * MESSAGES                                                       *
      ******************************************************************
                                                                        
      01  WS-MSG.                                                       
          05  FILLER                    PIC  X(17)                      
              VALUE 'ERROR IN OS CALL '.                                
          05  WS-MSG-FUNC               PIC  X(10).                     
          05  FILLER                    PIC  X(04)                      
              VALUE 'RC='.                                              
          05  WS-MSG-RC                 PIC  9(9).                      
          05  FILLER                    PIC  X(18)                      
              VALUE ' SUBCODE ERROR = '.                                
          05  MSG-SUBC                  PIC  9(9) VALUE 0.              
          05  WS-MSG-TEXT               PIC X(50) VALUE SPACES.         
                                                                        
                                                                        
      01  WORK-SRVIN-INFO.                                              
          05  WK-INFO-TBL-ID        PIC S9(8) COMP.                     
          05  WK-INFO-TBL-NAME      PIC  X(30).                         
          05  WK-INFO-TBL-VALUE     PIC  X(10).                         
                                                                        
                                                                        
      LINKAGE SECTION.                                                  
      **************************************************************    
      * THE LINKAGE SECTION DEFINES MASKS FOR DATA AREAS THAT ARE       
      * PASSED BETWEEN THIS PROGRAM.                                    
      **************************************************************    
                                                                        
      01  DFHCOMMAREA                PIC  X(1).                         
                                                                        
                                                                        
      PROCEDURE DIVISION.                                               
                                                                        
      000-MAIN-PROCESSING.                                              
                                                                        
          PERFORM 100-INITIALIZE            THRU 100-EXIT.              
                                                                        
          PERFORM 200-PROCESS-INPUT         THRU 200-EXIT.              
                                                                        
          PERFORM 300-PROCESS-OUTPUT        THRU 300-EXIT.              
                                                                        
          PERFORM 900-ALL-DONE              THRU 900-EXIT.              
                                                                        
          GOBACK.                                                       
                                                                        
      000-EXIT.                                                         
          EXIT.                                                         
                                                                        
      100-INITIALIZE.                                                   
                                                                        
      ******************************************************            
      * INTIALIZED THE TDS CONNECTION AND RECEIVE THE                   
      * RPC PARM........                                                
      ******************************************************            
                                                                        
      *==> ESTABLISH GATEWAY ENVIRONMENT <===*                          
                                                                        
          CALL 'TDINIT' USING DFHEIBLK, GWL-RC, GWL-INIT-HANDLE.        
          IF GWL-RC NOT = TDS-OK THEN                                   
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT                     
          END-IF.                                                       
                                                                        
      *==> ACCEPT CLIENT REQUEST <===*                                  
                                                                        
          CALL 'TDACCEPT' USING GWL-PROC, GWL-RC, GWL-INIT-HANDLE,      
                                SNA-CONN-NAME, SNA-SUBC.                
          IF GWL-RC NOT = TDS-OK THEN                                   
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT                     
          END-IF.                                                       
                                                                        
      *==> TO MAKE SURE WE WERE STARTED BY RPC REQUEST... <===*         
                                                                        
          CALL 'TDINFRPC' USING GWL-PROC,        GWL-RC,                
                                GWL-REQUEST-TYP, GWL-RPC-NAME,          
                                GWL-COMM-STATE.                         
          IF GWL-RC          NOT = TDS-OK    OR                         
             GWL-REQUEST-TYP NOT = TDS-RPC-EVENT                        
             THEN                                                       
                MOVE GWL-RC         TO WS-MSG-RC                        
                MOVE 'TDINFRPC'     TO WS-MSG-FUNC                      
                PERFORM 920-SEND-MESSAGE THRU 920-EXIT                  
                PERFORM 910-ERR-PROCESS  THRU 910-EXIT                  
          END-IF.                                                       
                                                                        
      100-EXIT.                                                         
          EXIT.                                                         
                                                                        
                                                                        
                                                                        
      200-PROCESS-INPUT.                                                
      ****************************************************************  
      * RECEIVE THE INPUT PARAMETER INTO HOST VARIBLE                   
      ****************************************************************  
                                                                        
      *---> Find out how many parms are being passed <---*              
                                                                        
          CALL 'TDNUMPRM' USING GWL-PROC, GWL-NUMPRM-PARMS.             
                                                                        
      *---> More than one pump back a message        <---*              
                                                                        
          IF GWL-NUMPRM-PARMS not = +1 THEN                             
             MOVE 'Invalid Number of Parameters'                        
                                 TO WS-MSG-TEXT                         
             MOVE GWL-RC         TO WS-MSG-RC                           
             MOVE 'TDNUMPRM'     TO WS-MSG-FUNC                         
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT                     
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT                     
          END-IF                                                        
                                                                        
      *---> Get that parm into into the host varible <---*              
                                                                        
          IF GWL-NUMPRM-PARMS = +1 THEN                                 
             CALL 'TDRCVPRM' USING GWL-PROC, GWL-RC,                    
                                   GWL-NUMPRM-PARMS,                    
                                   WS-INPUT-DATA,                       
                                   TDSLONGVARCHAR,                      
                                   WS-INPUT-LEN,                        
                                   GWL-ACTUAL-LEN                       
             IF GWL-RC NOT = TDS-OK THEN                                
                MOVE GWL-RC         TO WS-MSG-RC                        
                MOVE 'TDRCVPRM'     TO WS-MSG-FUNC                      
                PERFORM 920-SEND-MESSAGE THRU 920-EXIT                  
                PERFORM 910-ERR-PROCESS  THRU 910-EXIT                  
             END-IF                                                     
          END-IF.                                                       
      200-EXIT.                                                         
          EXIT.                                                         
      300-PROCESS-OUTPUT.                                               
      ****************************************************************  
      * BREAK UP THE 10K INPUT FIELDS INTO A 50 BYTE COLUMN AND SEND    
      ****************************************************************  
                                                                        
          MOVE +1                                TO COLUMN-NUMBER.      
          MOVE LENGTH OF WS-OUTPUT-DATA          TO HOST-LEN            
                                                    COLUMN-LEN.         
          MOVE LENGTH OF WS-OUTPUT-COL-NAME      TO COLUMN-NAME-LEN.    
          CALL 'TDESCRIB' USING GWL-PROC,                               
                                GWL-RC,                                 
                                COLUMN-NUMBER,                          
                                TDSCHAR,                                
                                HOST-LEN,                               
                                WS-OUTPUT-DATA,                         
                                TDS-ZERO,                               
                                TDS-FALSE,                              
                                TDSCHAR,                                
                                COLUMN-LEN,                             
                                WS-OUTPUT-COL-NAME,                     
                                COLUMN-NAME-LEN.                        
                                                                        
          IF GWL-RC NOT = TDS-OK THEN                                   
             MOVE GWL-RC         TO WS-MSG-RC                           
             MOVE 'TDESCRIB'     TO WS-MSG-FUNC                         
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT                     
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT                     
          END-IF.                                                       
                                                                        
                                                                        
          PERFORM VARYING I FROM 1 BY 1 UNTIL I > GWL-ACTUAL-LEN        
             COMPUTE J = J + 1                                          
             MOVE WS-INPUT-CHAR(I)      TO WS-OUTPUT-CHAR(J)            
             IF J = 50                                                  
             THEN                                                       
                PERFORM 310-SEND-ROW     THRU 310-EXIT                  
                MOVE ZERO                TO   J                         
                MOVE SPACES              TO   WS-OUTPUT-DATA            
             END-IF                                                     
          END-PERFORM.                                                  
          IF J > ZERO                                                   
             THEN PERFORM 310-SEND-ROW     THRU 310-EXIT.               
                                                                        
      300-EXIT.                                                         
          EXIT.                                                         
      310-SEND-ROW.                                                     
      ****************************************************************  
      * SEND ROW OF DATA TO CLIENT....                                  
      ***************************************************************** 
                                                                        
          CALL 'TDSNDROW' USING GWL-PROC, GWL-RC                        
          IF GWL-RC NOT = TDS-OK                                        
          THEN                                                          
             MOVE GWL-RC         TO WS-MSG-RC                           
             MOVE 'TDSNDROW'     TO WS-MSG-FUNC                         
             PERFORM 920-SEND-MESSAGE THRU 920-EXIT                     
             PERFORM 910-ERR-PROCESS  THRU 910-EXIT                     
          END-IF.                                                       
                                                                        
      310-EXIT.                                                         
          EXIT.                                                         
          EJECT                                                         
      900-ALL-DONE.                                                     
      ******************************************************************
      * CLOSE CONNECTION TO CLIENT AND RETURN TO CICS...               *
      ******************************************************************
                                                                        
          CALL 'TDSNDDON' USING GWL-PROC, GWL-RC, WRK-DONE-STATUS,      
                                GWL-RETURN-ROWS, TDS-ZERO, TDS-ENDRPC.  
          IF GWL-RC NOT = TDS-OK THEN                                   
             PERFORM 980-CICS-DUMP    THRU 980-EXIT                     
             PERFORM 990-CICS-RETURN  THRU 990-EXIT                     
          END-IF.                                                       
                                                                        
          CALL 'TDFREE' USING GWL-PROC, GWL-RC.                         
          PERFORM 990-CICS-RETURN     THRU 990-EXIT.                    
                                                                        
      900-EXIT.                                                         
          EXIT.                                                         
                                                                        
      910-ERR-PROCESS.                                                  
      ******************************************************************
      * PERFORM ALL-DONE IN A ERROR STATE                              *
      ******************************************************************
                                                                        
          MOVE ZERO             TO  GWL-RETURN-ROWS.                    
          MOVE TDS-DONE-ERROR   TO  WRK-DONE-STATUS.                    
          PERFORM 900-ALL-DONE  THRU 900-EXIT.                          
                                                                        
      910-EXIT.                                                         
          EXIT.                                                         
                                                                        
      920-SEND-MESSAGE.                                                 
      ******************************************************************
      * SEND ERROR MESSAGE DOWN TO CLIENT                              *
      ******************************************************************
          CALL 'TDSTATUS' USING GWL-PROC, GWL-RC, GWL-STATUS-NR,        
                                GWL-STATUS-DONE, GWL-STATUS-COUNT,      
                                GWL-STATUS-COMM,                        
                                GWL-STATUS-RETURN-CODE,                 
                                GWL-STATUS-SUBCODE.                     
                                                                        
      *==> ENSURE THAT WE ARE IN THE CORRECT STATE TO SEND A MESSAGE <=* 
          IF GWL-RC NOT = TDS-OK THEN                                   
             PERFORM 980-CICS-DUMP       THRU 980-EXIT                  
             PERFORM 990-CICS-RETURN     THRU 990-EXIT                  
          END-IF.                                                       
                                                                        
          IF GWL-STATUS-COMM = TDS-RECEIVE THEN                         
             CALL 'TDCANCEL' USING GWL-PROC, GWL-RC.                    
                                                                        
                                                                        
          MOVE LENGTH OF EIBTRNID TO GWL-TRAN-LEN.                      
          MOVE LENGTH OF WS-MSG   TO GWL-MSG-LEN.                       
          CALL 'TDSNDMSG' USING GWL-PROC, GWL-RC, TDS-ERROR-MSG,        
                               MSG-NR, TDS-ERROR-SEV, TDS-ZERO,         
                               TDS-ZERO, EIBTRNID, GWL-TRAN-LEN,        
                               WS-MSG, GWL-MSG-LEN.                     
                                                                        
      920-EXIT.                                                         
          EXIT.                                                         
                                                                        
      980-CICS-DUMP.                                                    
      ******************************************************************
      * CAUSE A CICS TRANSACTION DUMP USUALLY BECAUSE SOMETHING IS BAD *
      ******************************************************************
          EXEC CICS                                                     
               DUMP DUMPCODE('SY8C') NOHANDLE                           
          END-EXEC.                                                     
                                                                        
      980-EXIT.                                                         
          EXIT.                                                         
                                                                        
      990-CICS-RETURN.                                                  
      ******************************************************************
      * RETURN TO CICS...                                              *
      ******************************************************************
                                                                        
          EXEC CICS                                                     
               RETURN                                                   
          END-EXEC.                                                     
                                                                        
      990-EXIT.                                                         
          EXIT.