*******************************************************************
*
* Confidential property of Sybase, Inc.
* (c) Copyright Sybase, Inc. 1985 TO ???.
* All rights reserved.
********************************************************************
****** SYCTSAX5 - Open Server Open Client - COBOL -CICS ************ * *
* *
* TRANID: SYX5 *
* *
* PROGRAM: SYCTSAX5 *
* *
* *
* TABLE: SYBASE.SAMPLETB *
* *
* PURPOSE: Demonstrates Open Server/Open Client CALLs. *
* *
* FUNCTION: Illustrates the ability to act as a server and a *
* client within one program. *
* *
* This program is invoked via an RPC request and will *
* in turn execute a language request against a server *
* and return the results back to the client. *
* *
* It will issue the following SQL statement: *
* "SELECT FIRSTNME FROM SYBASE.SAMPLETB" *
* *
* *
* PREREQS: Before running SYCTSAX5, make sure that the server *
* you wish to access has an entry in the Connection *
* Router Table for that Server and the MCC(s) that *
* you wish to use. *
* *
* INPUT: On the input, make sure to enter the Server name, *
* user id, and password for the target server that *
* executes the RPC - SYX5. *
* *
* Open Server Library calls: *
* *
* TDACCEPT accept request from client *
* TDESCRIB describe a column in the result row *
* TDFREE free TDPROC structure *
* TDINFPRM get information about one rpc parameter *
* TDINIT establish environment *
* TDNUMPRM get total nr of rpc parameters *
* TDRCVPRM retrieve rpc parameter from client *
* TDSNDDON send results-completion to client *
* TDSNDMSG send error messages back to the client *
* TDSNDROW send a row of data back to the client *
* *
* Open Client calls: *
* *
* CTBBIND bind a column variable *
* CTBCLOSE close a server connection *
* CTBCMDALLOC allocate a command *
* CTBCMDDROP drop a command *
* CTBCOMMAND initiate remote procedure call *
* CTBCONALLOC allocate a connection *
* CTBCONDROP drop a connection *
* CTBCONPROPS alter properties of a connection *
* CTBCONNECT open a server connection *
* CTBDIAG retrieve SQLCODE messages *
* CTBEXIT exit client library *
* CTBFETCH fetch result data *
* CTBINIT init client library *
* CTBRESULTS sets up result data *
* CTBSEND send a request to the server *
* *
* History: *
* *
* Date BTS# Descrition *
* ======= ====== =============================================== *
* Feb1795 Create *
* Nov1595 99999 Rewrite and add front end to the program *
* *
********************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. SYCTSAX5.
ENVIRONMENT DIVISION.
DATA DIVISION.
WORKING-STORAGE SECTION.
*-----------------------------------------------------------------
* Client Library Cobol Copy Book
*-----------------------------------------------------------------
COPY CTPUBLIC.
*-----------------------------------------------------------------
* Server Library Cobol Copy Book
*-----------------------------------------------------------------
COPY SYGWCOB.
*-----------------------------------------------------------------
* Standard CICS Attribute and Print Control Chararcter List
*-----------------------------------------------------------------
COPY DFHBMSCA.
*-----------------------------------------------------------------
* CICS Standard Attention Identifiers Cobol Copy Book
*-----------------------------------------------------------------
COPY DFHAID.
*-----------------------------------------------------------------
* Work Area
*-----------------------------------------------------------------
01 GW-LIB-MISC-FIELDS.
05 GWL-TDPROC POINTER.
05 GWL-RC PIC S9(9) COMP SYNC VALUE 0.
01 INTERNAL-FIELDS.
05 CF-FOUR PIC S9(9) COMP VALUE 4.
01 SWITCHES.
05 SW-RESULTS PIC X(01) value 'Y'.
88 NO-MORE-RESULTS VALUE 'N'.
05 SW-FETCH PIC X(01) value 'Y'.
88 NO-MORE-ROWS VALUE 'N'.
05 SW-DIAG PIC X(01) VALUE 'N'.
88 DIAG-MSGS-INITIALIZED VALUE 'Y'.
01 PARM-FIELDS.
05 PF-PARM-ID PIC S9(9) COMP SYNC.
05 PF-DATATYPE PIC S9(9) COMP SYNC.
05 PF-ACTUAL-DATA-LENGTH PIC S9(9) COMP SYNC.
05 PF-MAX-DATA-LENGTH PIC S9(9) COMP SYNC.
05 PF-PARM-STATUS PIC S9(9) COMP SYNC.
05 PF-PARM-NAME PIC X(30).
05 PF-PARM-NAME-LENGTH PIC S9(9) COMP SYNC.
05 PF-USER-DATATYPE PIC S9(9) COMP SYNC.
05 PF-NUM-OF-PARMS PIC S9(9) COMP SYNC.
05 PF-MSGLIMIT PIC S9(9) COMP.
01 SNA-FIELDS.
05 SNA-SUBC PIC S9(9) COMP SYNC.
05 SNA-CONNECTION-NAME PIC X(8) VALUE IS SPACES.
01 WORK-FIELDS.
05 WRK-DONE-STATUS PIC S9(9) COMP SYNC.
01 DESCRIBE-FIELDS.
05 DF-COLUMN-NUMBER PIC S9(9) COMP SYNC VALUE 0.
05 DF-HOST-VARIABLE-TYPE PIC S9(9) COMP SYNC VALUE 0.
05 DF-HOST-VARIABLE-MAXLEN PIC S9(9) COMP SYNC VALUE 0.
05 DF-HOST-VARIABLE-NAME POINTER.
05 DF-NULL-INDICATOR-VAR PIC S9(9) COMP SYNC VALUE 0.
05 DF-NULLS-ALLOWED PIC S9(9) COMP SYNC VALUE 0.
05 DF-COLUMN-TYPE PIC S9(9) COMP SYNC VALUE 0.
05 DF-COLUMN-MAXLEN PIC S9(9) COMP SYNC VALUE 0.
05 DF-COLUMN-NAME PIC X(30).
05 DF-COLUMN-NAME-LEN PIC S9(9) COMP SYNC VALUE 0.
01 SNDMSG-FIELDS.
05 SF-MESSAGE-TYPE PIC S9(9) COMP SYNC.
05 SF-MESSAGE-NUMBER PIC S9(9) COMP SYNC.
05 SF-SEVERITY PIC S9(9) COMP SYNC.
05 SF-ERROR-STATE PIC S9(9) COMP SYNC.
05 SF-LINE-ID PIC S9(9) COMP SYNC.
05 SF-TRANSACTION-ID PIC X(4) VALUE 'SYX5'.
05 SF-TRANSACTION-ID-LEN PIC S9(9) COMP SYNC.
05 SF-MESSAGE-TEXT PIC X(80).
05 SF-MESSAGE-LENGTH PIC S9(9) COMP SYNC.
01 CTX PIC S9(9) COMP SYNC.
01 ROW-DATA PIC X(80) VALUE IS SPACES.
*-----------------------------------------------------------------
* Work Areas Open Client
*-----------------------------------------------------------------
01 CS-LIB-MISC-FIELDS.
05 CSL-CMD-HANDLE PIC S9(9) COMP SYNC VALUE 0.
05 CSL-CON-HANDLE PIC S9(9) COMP SYNC VALUE 0.
05 CSL-CTX-HANDLE PIC S9(9) COMP SYNC VALUE 0.
05 CSL-RC PIC S9(9) COMP SYNC.
01 PROPS-FIELDS.
05 PF-SERVER PIC X(30).
05 PF-SERVER-SIZE PIC S9(9) COMP.
05 PF-USER PIC X(30).
05 PF-USER-SIZE PIC S9(9) COMP.
05 PF-PWD PIC X(30).
05 PF-PWD-SIZE PIC S9(9) COMP.
05 PF-OUTLEN PIC S9(9) COMP SYNC.
05 PF-STRLEN PIC S9(9) COMP SYNC.
01 QUERY-FIELDS.
05 QF-LEN PIC S9(9) VALUE 1.
05 QF-MAXLEN PIC S9(9) VALUE 1.
05 QF-ANSWER PIC X(01) VALUE ' '.
01 FETCH-FIELDS.
05 FF-ROWS-READ PIC S9(9) COMP SYNC VALUE 0.
05 FF-ROW-NUM PIC S9(9) COMP SYNC VALUE 0.
01 COLUMN-FIELDS.
05 CF-COL-FIRSTNME PIC X(12) VALUE SPACES.
05 CF-COL-NUMBER PIC S9(9) COMP SYNC VALUE 0.
05 CF-COL-INDICATOR PIC S9(9) COMP SYNC VALUE 0.
05 CF-COL-OUTLEN PIC S9(9) COMP SYNC VALUE 0.
01 LANG-FIELDS.
05 LF-LANG PIC X(36)
VALUE 'SELECT FIRSTNME FROM SYBASE.SAMPLETB'.
01 ERROR-MSG.
05 ERROR-TEXT PIC X(50) VALUE ' '.
05 ERROR-LITERAL PIC X(06) VALUE ' RC = '.
05 ERROR-RC PIC -ZZZ9.
01 ERROR-MSG-STR REDEFINES ERROR-MSG PIC X(61).
01 INFO-MSG-STR PIC X(80) VALUE ' '.
01 RESULTS-FIELDS.
05 RF-TYPE PIC S9(9) COMP SYNC VALUE 0.
01 DATAFMT.
05 DF-NAME PIC X(132).
05 DF-NAMELEN PIC S9(9) COMP SYNC.
05 DF-DATATYPE PIC S9(9) COMP SYNC.
05 DF-FORMAT PIC S9(9) COMP SYNC.
05 DF-MAXLENGTH PIC S9(9) COMP SYNC.
05 DF-SCALE PIC S9(9) COMP SYNC.
05 DF-PRECISION PIC S9(9) COMP SYNC.
05 DF-STATUS PIC S9(9) COMP SYNC.
05 DF-COUNT PIC S9(9) COMP SYNC.
05 DF-USERTYPE PIC S9(9) COMP SYNC.
05 DF-LOCALE PIC X(68).
*-----------------------------------------------------------------
* Common Work Areas
*-----------------------------------------------------------------
01 MSG-FIELDS.
05 MSG-END-MSG PIC X(25)
VALUE 'All done processing rows.'.
05 MSG-NOT-RPC PIC X(35)
VALUE 'SYX5 must be begun via rpc request.'.
05 MSG-WRONG-NR-PARMS PIC X(40)
VALUE 'Number of parameters must be 2 or 3.'.
05 MSG-NOT-INT4-PARM PIC X(33)
VALUE 'Parameter must be a INTEGER type.'.
05 MSG-CANCELED PIC X(17)
VALUE 'Cancel requested.'.
05 MSG-TDRCVPRM-FAIL PIC X(16)
VALUE 'TDRCVPRM failed.'.
01 CICS-FIELDS.
05 CICS-RESPONSE PIC S9(9) COMP SYNC.
01 MISC-FIELDS.
05 I PIC S9(9) COMP.
05 LCV PIC S9(9) COMP SYNC.
05 TMP-DATE PIC X(08).
05 TMP-TIME PIC X(08).
05 UTIME PIC S9(15) COMP-3.
01 X5-HEADER.
05 X5-DATE-HDR PIC X(06) VALUE ' DATE '.
05 X5-DATE-DATA PIC X(08).
05 X5-HDR PIC X(56).
01 X5-HEADER-STR REDEFINES X5-HEADER PIC X(70).
01 X5-HEADER2.
05 X5-TIME-HDR PIC X(06) VALUE ' TIME '.
05 X5-TIME-DATA PIC X(08).
01 X5-HEADER2-STR REDEFINES X5-HEADER2 PIC X(14).
01 DISP-MSG.
05 TEST-CASE PIC X(08) VALUE IS 'SYCTSAA5'.
05 FILLER PIC X(01) VALUE IS SPACES.
05 MSG.
10 SAMP-LIT PIC X(05) VALUE IS 'rc = '.
10 SAMP-RC PIC -Z9.
10 FILLER PIC X(02) VALUE IS ', '.
10 REST-LIT PIC X(12) VALUE IS
'Result Type:'.
10 REST-TYPE PIC Z(3)9.
10 FILLER PIC X(03) VALUE IS SPACES.
10 MSGSTR PIC X(40) VALUE IS SPACES.
01 DIAG-FIELDS.
05 DG-MSGNO PIC S9(9) COMP VALUE +1.
05 DG-NUM-OF-MSGS PIC S9(9) COMP VALUE +0.
01 DISP-SERVER.
05 SERVER-HDR PIC X(09) VALUE IS
' SERVER: '.
05 SERVER-DATA PIC X(20).
05 USER-HDR PIC X(10) VALUE IS
' USER-ID: '.
05 USER-DATA PIC X(30).
*-----------------------------------------------------------------
* Client Message Structure
*-----------------------------------------------------------------
01 CLIENT-MSG.
05 CM-SEVERITY PIC S9(9) COMP SYNC.
05 CM-MSGNO PIC S9(9) COMP SYNC.
05 CM-TEXT PIC X(256).
05 CM-TEXT-LEN PIC S9(9) COMP SYNC.
05 CM-OS-MSGNO PIC S9(9) COMP SYNC.
05 CM-OS-MSGTXT PIC X(256).
05 CM-OS-MSGTEXT-LEN PIC S9(9) COMP SYNC.
05 CM-STATUS PIC S9(9) COMP.
01 DISP-CLIENT-MSG-HDR.
05 CLIENT-MSG-HDR PIC X(15) VALUE IS
'Client Message:'.
01 DISP-CLIENT-MSG-1.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-SEVERITY-HDR PIC X(09) VALUE IS 'Severity:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-SEVERITY-DATA PIC Z(8)9.
05 CM-STATUS-HDR PIC X(12) VALUE IS
', Status: '.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-STATUS-DATA PIC Z(8)9.
01 DISP-CLIENT-MSG-2.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSGNO-HDR PIC X(09) VALUE IS 'OC MsgNo:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSGNO-DATA PIC Z(8)9.
01 DISP-CLIENT-MSG-3.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSG-HDR PIC X(09) VALUE IS 'OC MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSG-DATA PIC X(66).
01 DISP-CLIENT-MSG-3A.
05 CM-OC-MSG-DATA-1 PIC X(66).
05 CM-OC-MSG-DATA-2 PIC X(66).
05 CM-OC-MSG-DATA-3 PIC X(66).
05 CM-OC-MSG-DATA-4 PIC X(58).
01 DISP-CLIENT-MSG-3B.
05 FILLER PIC X(13) VALUE IS SPACES.
05 CM-OC-MSG-DATA-X PIC X(66).
01 DISP-EMPTY-CLIENT-MSG-3.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OC-MSG-HDR PIC X(09) VALUE IS 'OC MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 NO-DATA PIC X(11) VALUE IS 'No Message!'.
01 DISP-CLIENT-MSG-4.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-HDR PIC X(09) VALUE IS 'OS MsgNo:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSGNO-DATA PIC Z(8)9.
01 DISP-CLIENT-MSG-5.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-HDR PIC X(09) VALUE IS 'OS MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-DATA PIC X(66).
01 DISP-CLIENT-MSG-5A.
05 CM-OS-MSG-DATA-1 PIC X(66).
05 CM-OS-MSG-DATA-2 PIC X(66).
05 CM-OS-MSG-DATA-3 PIC X(66).
05 CM-OS-MSG-DATA-4 PIC X(58).
01 DISP-EMPTY-CLIENT-MSG-5.
05 FILLER PIC X(02) VALUE IS SPACES.
05 CM-OS-MSG-HDR PIC X(09) VALUE IS 'OS MsgTx:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 NO-DATA PIC X(11) VALUE IS 'No Message!'.
*-----------------------------------------------------------------
* Server Message Structure
*-----------------------------------------------------------------
01 SERVER-MSG.
05 SM-MSGNO PIC S9(9) COMP.
05 SM-STATE PIC S9(9) COMP.
05 SM-SEV PIC S9(9) COMP.
05 SM-TEXT PIC X(256).
05 SM-TEXT-LEN PIC S9(9) COMP.
05 SM-SVRNAME PIC X(256).
05 SM-SVRNAME-LEN PIC S9(9) COMP.
05 SM-PROC PIC X(256).
05 SM-PROC-LEN PIC S9(9) COMP.
05 SM-LINE PIC S9(9) COMP.
05 SM-STATUS PIC S9(9) COMP.
01 DISP-SERVER-MSG-HDR.
05 SERVER-MSG-HDR PIC X(15) VALUE IS
'Server Message:'.
01 DISP-SERVER-MSG-1.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-NO-HDR PIC X(09) VALUE IS
'Message#:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-NO-DATA PIC Z(8)9.
05 SM-SEVERITY-HDR PIC X(12) VALUE IS
', Severity:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-SEVERITY-DATA PIC Z(8)9.
05 SM-STATE-HDR PIC X(12) VALUE IS
', State No:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-STATE-DATA PIC Z(8)9.
01 DISP-SERVER-MSG-2.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-LINE-NO-HDR PIC X(09) VALUE IS
'Line No:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-LINE-NO-DATA PIC Z(8)9.
05 SM-STATUS-HDR PIC X(12) VALUE IS
', Status :'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-STATUS-DATA PIC Z(8)9.
01 DISP-SERVER-MSG-3.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-SVRNAME-HDR PIC X(09) VALUE IS 'Serv Nam:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-SVRNAME-DATA PIC X(66).
05 FILLER PIC X(03) VALUE IS '...'.
01 DISP-SERVER-MSG-4.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-PROC-ID-HDR PIC X(09) VALUE IS 'Proc ID:'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-PROC-ID-DATA PIC X(66).
01 DISP-SERVER-MSG-5.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-HDR PIC X(09) VALUE IS 'Message :'.
05 FILLER PIC X(02) VALUE IS SPACES.
05 SM-MSG-DATA PIC X(66).
01 DISP-SERVER-MSG-5A.
05 SM-MSG-DATA-1 PIC X(66).
05 SM-MSG-DATA-2 PIC X(66).
05 SM-MSG-DATA-3 PIC X(66).
05 SM-MSG-DATA-4 PIC X(58).
01 DISP-SERVER-MSG-5X.
05 FILLER PIC X(13) VALUE IS SPACES.
05 SM-MSG-DATA-X PIC X(66).
PROCEDURE DIVISION.
*-----------------------------------------------------------------
* Begin program here
*-----------------------------------------------------------------
MOVE LOW-VALUES TO PARM-FIELDS DATAFMT.
MOVE 'Y' TO SW-DIAG.
EXEC CICS ASKTIME
ABSTIME(UTIME)
END-EXEC.
EXEC CICS FORMATTIME
ABSTIME(UTIME)
DATESEP('/')
MMDDYY(TMP-DATE)
TIME(TMP-TIME)
TIMESEP
END-EXEC.
MOVE
' SYBASE COBOL SAMPLE PROGRAM SYCTSAX5 SQL RESULT OUTPUT '
TO X5-HDR.
MOVE TMP-DATE TO X5-DATE-DATA.
MOVE TMP-TIME TO X5-TIME-DATA.
*-----------------------------------------------------------------
* intialize the TDS environment for a client
*-----------------------------------------------------------------
CALL 'TDINIT' USING DFHEIBLK,
GWL-RC,
CSL-CTX-HANDLE.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDINIT failed' TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------------
* accept request from a remote client
*-----------------------------------------------------------------
CALL 'TDACCEPT' USING GWL-TDPROC,
GWL-RC,
CSL-CTX-HANDLE,
SNA-CONNECTION-NAME,
SNA-SUBC.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDACCEPT failed' TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------------
* display date and time
*-----------------------------------------------------------------
MOVE SPACES TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE X5-HEADER-STR TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE X5-HEADER2-STR TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE SPACES TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
*-----------------------------------------------------------------
* determine how many parameters were sent with the current RPC
* by the remote client or server
*-----------------------------------------------------------------
CALL 'TDNUMPRM' USING GWL-TDPROC,
PF-NUM-OF-PARMS.
IF PF-NUM-OF-PARMS = 2 OR PF-NUM-OF-PARMS = 3
THEN
MOVE SPACES TO INFO-MSG-STR
ELSE
MOVE MSG-WRONG-NR-PARMS TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
MOVE SPACES TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
MOVE
'syntax is: SYX5 server-nm, user-id OR'
TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
MOVE
' SYX5 server-nm, user-id, password'
TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------------
* retrieves parameter type, datatype, and length information
* about the 1st RPC parameter( server-name parameter )
*-----------------------------------------------------------------
MOVE 1 TO PF-PARM-ID.
CALL 'TDINFPRM' USING GWL-TDPROC,
GWL-RC,
PF-PARM-ID,
PF-DATATYPE,
PF-ACTUAL-DATA-LENGTH,
PF-MAX-DATA-LENGTH,
PF-PARM-STATUS,
PF-PARM-NAME,
PF-PARM-NAME-LENGTH,
TDS-NULL.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDINFPRM for server-name parameter failed'
TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
IF PF-DATATYPE NOT = TDSCHAR AND
PF-DATATYPE NOT = TDSVARYCHAR
THEN
MOVE 'server-name datatype must be TDSCHAR'
TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------------
* retrieves the data from an RPC parameter sent by a remote
* client
*-----------------------------------------------------------------
MOVE LENGTH OF PF-SERVER TO PF-STRLEN.
CALL 'TDRCVPRM' USING GWL-TDPROC,
GWL-RC,
PF-PARM-ID,
PF-SERVER,
TDSCHAR,
PF-STRLEN,
PF-ACTUAL-DATA-LENGTH.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDRCVPRM for server-name parameter failed'
TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
MOVE PF-ACTUAL-DATA-LENGTH TO PF-SERVER-SIZE.
*-----------------------------------------------------------------
* retrieves parameter type, datatype, and length information
* about the 2nd RPC parameter( user-id parameter )
*-----------------------------------------------------------------
MOVE 2 TO PF-PARM-ID.
CALL 'TDINFPRM' USING GWL-TDPROC,
GWL-RC,
PF-PARM-ID,
PF-DATATYPE,
PF-ACTUAL-DATA-LENGTH,
PF-MAX-DATA-LENGTH,
PF-PARM-STATUS,
PF-PARM-NAME,
PF-PARM-NAME-LENGTH,
TDS-NULL.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDINFPGM for user-id parameter failed'
TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
IF PF-DATATYPE NOT = TDSCHAR AND
PF-DATATYPE NOT = TDSVARYCHAR
THEN
MOVE 'user-id datatype must be TDSCHAR'
TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------------
* retrieves the data from an RPC parameter sent by a remote
* client
*-----------------------------------------------------------------
MOVE LENGTH OF PF-USER TO PF-STRLEN.
CALL 'TDRCVPRM' USING GWL-TDPROC,
GWL-RC,
PF-PARM-ID,
PF-USER,
TDSCHAR,
PF-STRLEN,
PF-ACTUAL-DATA-LENGTH.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDRCVPRM for user-id failed' TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
MOVE PF-ACTUAL-DATA-LENGTH TO PF-USER-SIZE.
IF PF-NUM-OF-PARMS = 3
THEN
*-----------------------------------------------------------------
* retrieves parameter type, datatype, and length information
* about the 3rd RPC parameter( password parameter )
*-----------------------------------------------------------------
MOVE 3 TO PF-PARM-ID
CALL 'TDINFPRM' USING GWL-TDPROC,
GWL-RC,
PF-PARM-ID,
PF-DATATYPE,
PF-ACTUAL-DATA-LENGTH,
PF-MAX-DATA-LENGTH,
PF-PARM-STATUS,
PF-PARM-NAME,
PF-PARM-NAME-LENGTH,
TDS-NULL
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDINFPRM for server-name parameter failed'
TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF
IF PF-DATATYPE NOT = TDSCHAR AND
PF-DATATYPE NOT = TDSVARYCHAR
THEN
MOVE 'server-name datatype must be TDSCHAR'
TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
PERFORM ALL-DONE
END-IF
*-----------------------------------------------------------------
* retrieves the data from an RPC parameter sent by a remote
* client
*-----------------------------------------------------------------
MOVE LENGTH OF PF-PWD TO PF-STRLEN
CALL 'TDRCVPRM' USING GWL-TDPROC,
GWL-RC,
PF-PARM-ID,
PF-PWD,
TDSCHAR,
PF-STRLEN,
PF-ACTUAL-DATA-LENGTH
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDRCVPRM for password parameter failed'
TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF
MOVE PF-ACTUAL-DATA-LENGTH TO PF-PWD-SIZE
ELSE
MOVE SPACES TO PF-PWD
MOVE 0 TO PF-PWD-SIZE
END-IF.
*-----------------------------------------------------------------
* display server and user-id heading
*-----------------------------------------------------------------
MOVE PF-SERVER TO SERVER-DATA.
MOVE PF-USER TO USER-DATA.
MOVE DISP-SERVER TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE SPACES TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
*-----------------------------------------------------------------
* describe the 1st column in a result row and the mainframe
* server program variable where it is stored
*-----------------------------------------------------------------
MOVE 1 TO DF-COLUMN-NUMBER.
MOVE TDSVARYCHAR TO DF-HOST-VARIABLE-TYPE.
MOVE LENGTH OF CF-COL-FIRSTNME TO DF-HOST-VARIABLE-MAXLEN.
MOVE TDS-ZERO TO DF-NULL-INDICATOR-VAR.
MOVE TDS-FALSE TO DF-NULLS-ALLOWED.
MOVE TDSVARYCHAR TO DF-COLUMN-TYPE.
MOVE LENGTH OF CF-COL-FIRSTNME TO DF-COLUMN-MAXLEN.
MOVE 'FIRST NAME' TO DF-COLUMN-NAME.
MOVE 10 TO DF-COLUMN-NAME-LEN.
CALL 'TDESCRIB' USING GWL-TDPROC,
GWL-RC,
DF-COLUMN-NUMBER,
DF-HOST-VARIABLE-TYPE,
DF-HOST-VARIABLE-MAXLEN,
CF-COL-FIRSTNME,
DF-NULL-INDICATOR-VAR,
DF-NULLS-ALLOWED,
DF-COLUMN-TYPE,
DF-COLUMN-MAXLEN,
DF-COLUMN-NAME,
DF-COLUMN-NAME-LEN.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDESCRIB failed' TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
PERFORM OC-INIT.
PERFORM OC-CONNECT.
PERFORM OC-SEND-LANG.
PERFORM OC-PROCESS-RESULTS.
PERFORM OC-ALL-DONE.
*========================================================
*== ==
*== Subroutine to send a results completion indication ==
*== to the client, free up a previously allocated ==
*== GWL_TDPROC structure, and return back to CICS ==
*== ==
*========================================================
ALL-DONE.
*-----------------------------------------------------------------
* send a results completion indication to the client
*-----------------------------------------------------------------
CALL 'TDSNDDON' USING GWL-TDPROC,
GWL-RC,
TDS-DONE-FINAL,
TDS-NULL,
TDS-ZERO,
TDS-ENDRPC.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDSNDDON failed' TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
END-IF.
*-----------------------------------------------------------------
* free up a previously allocated GWL_TDPROC structure after
* returning results to a client
*-----------------------------------------------------------------
CALL 'TDFREE' USING GWL-TDPROC,
GWL-RC.
IF GWL-RC NOT = TDS-OK
THEN
MOVE 'TDFREE failed' TO ERROR-TEXT
MOVE GWL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
END-IF.
*-----------------------------------------------------------------
* return back to CICS
*-----------------------------------------------------------------
EXEC CICS RETURN END-EXEC.
*========================================================
*== ==
*== Subroutine to initialize the Client-Library ==
*== ==
*========================================================
OC-INIT.
*-----------------------------------------------------------
* initialize the Client-Library
*-----------------------------------------------------------
CALL 'CTBINIT' USING CSL-CTX-HANDLE,
CSL-RC,
CS-VERSION-46.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBINIT failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*========================================================
*== ==
*== Subroutine to allocate connect handler, alter ==
*== properties for user-id and password, set up ==
*== retrieval of all Open Client messages, and open ==
*== connection to the server ==
*== ==
*========================================================
OC-CONNECT.
*-----------------------------------------------------------
* allocate a connection to the server
*----------------------------------------------------------
CALL 'CTBCONAL' USING CSL-CTX-HANDLE,
CSL-RC,
CSL-CON-HANDLE.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCONAL failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------
*alter properties of the connection
* ----------------------------------------------------------
CALL 'CTBCONPR' USING CSL-CON-HANDLE,
CSL-RC,
CS-SET,
CS-USERNAME,
PF-USER,
PF-USER-SIZE,
CS-FALSE,
CS-UNUSED.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCONPR for user-id failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
CALL 'CTBCONPR' USING CSL-CON-HANDLE,
CSL-RC,
CS-SET,
CS-PASSWORD,
PF-PWD,
PF-PWD-SIZE,
CS-FALSE,
CS-UNUSED.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCONPR for password failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*------------------------------------------------------------*
* setup retrieval of All Messages
*------------------------------------------------------------*
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-INIT,
CS-ALLMSG-TYPE,
CS-UNUSED,
CS-UNUSED.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBDIAG CS-INIT failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*------------------------------------------------------------*
* set the upper limit of number of messages
*------------------------------------------------------------*
MOVE 5 TO PF-MSGLIMIT.
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-MSGLIMIT,
CS-ALLMSG-TYPE,
CS-UNUSED,
PF-MSGLIMIT.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBDIAG CS-MSGLIMIT failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*------------------------------------------------------------*
* open connection to the server
*------------------------------------------------------------*
CALL 'CTBCONNE' USING CSL-CON-HANDLE,
CSL-RC,
PF-SERVER,
PF-SERVER-SIZE,
CS-FALSE.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCONNE failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*========================================================
*== ==
*== Subroutine to allocate command handler, prepare ==
*== and send the language request ==
*== ==
*========================================================
OC-SEND-LANG.
*-----------------------------------------------------------
* allocate a command handle
*----------------------------------------------------------
CALL 'CTBCMDAL' USING CSL-CON-HANDLE,
CSL-RC,
CSL-CMD-HANDLE.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCMDAL failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------
* prepare the language request
*-----------------------------------------------------------
MOVE LENGTH OF LF-LANG TO PF-STRLEN.
CALL 'CTBCOMMA' USING CSL-CMD-HANDLE,
CSL-RC,
CS-LANG-CMD,
LF-LANG,
PF-STRLEN,
CS-UNUSED.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCOMMA failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------
* send the language request
*----------------------------------------------------------
CALL 'CTBSEND' USING CSL-CMD-HANDLE,
CSL-RC.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBSEND failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*========================================================
*== ==
*== Subroutine to process the result ==
*== ==
*========================================================
OC-PROCESS-RESULTS.
PERFORM RESULTS-PROCESSING UNTIL NO-MORE-RESULTS.
*========================================================
*== ==
*== Subroutine to set up the results data ==
*== ==
*========================================================
RESULTS-PROCESSING.
CALL 'CTBRESUL' USING CSL-CMD-HANDLE
CSL-RC
RF-TYPE.
EVALUATE CSL-RC
WHEN CS-SUCCEED
EVALUATE RF-TYPE
WHEN CS-ROW-RESULT
PERFORM ROW-RESULT-PROCESSING
MOVE 'Y' TO SW-FETCH
PERFORM FETCH-PROCESSING UNTIL NO-MORE-ROWS
WHEN CS-STATUS-RESULT
PERFORM STATUS-PROCESSING
WHEN CS-CMD-FAIL
MOVE 'RESULTS-PROCESSING CMD-FAIL' TO MSGSTR
PERFORM ERROR-OUT
MOVE 'bad user-id or password' TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
MOVE SPACES TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
WHEN CS-CMD-DONE
MOVE 'RESULTS-PROCESSING CMD-DONE' TO INFO-MSG-STR
MOVE RF-TYPE TO ERROR-RC
WHEN OTHER
MOVE 'RESULTS-PROCESSING unknown return code'
TO MSGSTR
PERFORM ERROR-OUT
END-EVALUATE
WHEN CS-FAIL
MOVE 'N' TO SW-RESULTS
MOVE 'CTBRESULTS failed' TO MSGSTR
PERFORM ERROR-OUT
WHEN CS-END-RESULTS
MOVE 'N' TO SW-RESULTS
WHEN OTHER
MOVE 'N' TO SW-RESULTS
MOVE 'CTBRESULTS failed' TO MSGSTR
PERFORM ERROR-OUT
END-EVALUATE.
*========================================================
*== ==
*== Subroutine to process row result and bind ==
*== ==
*========================================================
ROW-RESULT-PROCESSING.
CALL 'CTBRESUL' USING CSL-CMD-HANDLE
CSL-RC
RF-TYPE.
MOVE CS-VARCHAR-TYPE TO DF-DATATYPE.
MOVE CS-FMT-UNUSED TO DF-FORMAT.
MOVE LENGTH OF CF-COL-FIRSTNME TO DF-MAXLENGTH.
MOVE 1 TO DF-COUNT.
*----------------------------------------------------------
* bind the first column
*----------------------------------------------------------
MOVE 1 TO CF-COL-NUMBER.
CALL 'CTBBIND' USING CSL-CMD-HANDLE,
CSL-RC,
CF-COL-NUMBER,
DATAFMT,
CF-COL-FIRSTNME,
CF-COL-OUTLEN,
CS-PARAM-NOTNULL,
CF-COL-INDICATOR,
CS-PARAM-NULL.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBBIND first name failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*========================================================
*== ==
*== Subroutine to fetch the result ==
*== ==
*========================================================
FETCH-PROCESSING.
CALL 'CTBFETCH' USING CSL-CMD-HANDLE,
CSL-RC,
CS-UNUSED,
CS-UNUSED,
CS-UNUSED,
FF-ROWS-READ.
EVALUATE CSL-RC
WHEN CS-SUCCEED
MOVE 'Y' TO SW-FETCH
COMPUTE FF-ROW-NUM = FF-ROW-NUM + 1
*----------------------------------------------------------
* send a row of data back to the requesting client
*----------------------------------------------------------
CALL 'TDSNDROW' USING GWL-TDPROC,
GWL-RC
MOVE SPACES TO CF-COL-FIRSTNME
IF GWL-RC NOT = TDS-OK
THEN
MOVE MSG-CANCELED TO INFO-MSG-STR
MOVE CSL-RC TO ERROR-RC
PERFORM SEND-INFO-MESSAGE
END-IF
WHEN CS-END-DATA
MOVE 'N' TO SW-FETCH
MOVE SPACES TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
MOVE MSG-END-MSG TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
MOVE SPACES TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
WHEN CS-FAIL
MOVE 'N' TO SW-FETCH
MOVE 'FETCH-PROCESSING return CS-FAIL ' TO MSGSTR
PERFORM ERROR-OUT
WHEN CS-ROW-FAIL
MOVE 'N' TO SW-FETCH
MOVE 'FETCH-PROCESSING retuen CS-ROW-FAIL'
TO MSGSTR
PERFORM ERROR-OUT
WHEN CS-CANCELLED
MOVE 'N' TO SW-FETCH
MOVE MSG-CANCELED TO MSGSTR
PERFORM ERROR-OUT
WHEN OTHER
MOVE 'N' TO SW-FETCH
MOVE 'CTBFETCH UNEXPECTED RETURN CODE'
TO MSGSTR
PERFORM ERROR-OUT
END-EVALUATE.
*========================================================
*== ==
*== dummy routine ==
*== ==
*========================================================
STATUS-PROCESSING.
*STATUS-PROCESSING-EXIT.
EXIT.
*========================================================
*== ==
*== Subroutine to drop the command handler, to close ==
*== the server connection, to drop the connection ==
*== handler and exit ==
*== ==
*========================================================
OC-ALL-DONE.
CALL 'CTBCMDDR' USING CSL-CMD-HANDLE,
CSL-RC.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCMDDR failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
CALL 'CTBCLOSE' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCLOSE failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
CALL 'CTBCONDR' USING CSL-CON-HANDLE,
CSL-RC.
IF CSL-RC NOT = CS-SUCCEED
THEN
MOVE 'CTBCCONDR failed' TO MSGSTR
PERFORM ERROR-OUT
PERFORM ALL-DONE
END-IF.
*========================================================
*== ==
*== Subroutine to send an error message to the client ==
*== ==
*========================================================
SEND-ERROR-MESSAGE.
MOVE TDS-ERROR-MSG TO SF-MESSAGE-TYPE.
MOVE 0 TO SF-MESSAGE-NUMBER.
MOVE 10 TO SF-SEVERITY.
MOVE 0 TO SF-ERROR-STATE.
MOVE 0 TO SF-LINE-ID.
MOVE LENGTH OF SF-TRANSACTION-ID TO SF-TRANSACTION-ID-LEN.
MOVE ERROR-MSG-STR TO SF-MESSAGE-TEXT.
MOVE LENGTH OF SF-MESSAGE-TEXT TO SF-MESSAGE-LENGTH.
CALL 'TDSNDMSG' USING GWL-TDPROC,
GWL-RC,
SF-MESSAGE-TYPE,
SF-MESSAGE-NUMBER,
SF-SEVERITY,
SF-ERROR-STATE,
SF-LINE-ID,
SF-TRANSACTION-ID,
SF-TRANSACTION-ID-LEN,
SF-MESSAGE-TEXT,
SF-MESSAGE-LENGTH.
*========================================================
*== ==
*== Subroutine to send an informational message to the ==
*== client ==
*== ==
*========================================================
SEND-INFO-MESSAGE.
MOVE TDS-INFO-MSG TO SF-MESSAGE-TYPE.
MOVE 0 TO SF-MESSAGE-NUMBER.
MOVE 0 TO SF-SEVERITY.
MOVE 0 TO SF-ERROR-STATE.
MOVE 0 TO SF-LINE-ID.
MOVE LENGTH OF SF-TRANSACTION-ID TO SF-TRANSACTION-ID-LEN.
MOVE INFO-MSG-STR TO SF-MESSAGE-TEXT.
MOVE LENGTH OF SF-MESSAGE-TEXT TO SF-MESSAGE-LENGTH.
CALL 'TDSNDMSG' USING GWL-TDPROC,
GWL-RC,
SF-MESSAGE-TYPE,
SF-MESSAGE-NUMBER,
SF-SEVERITY,
SF-ERROR-STATE,
SF-LINE-ID,
SF-TRANSACTION-ID,
SF-TRANSACTION-ID-LEN,
SF-MESSAGE-TEXT,
SF-MESSAGE-LENGTH.
*========================================================
*== ==
*== Subroutine to print output messages. ==
*== ==
*========================================================
ERROR-OUT.
IF DIAG-MSGS-INITIALIZED
THEN
PERFORM GET-DIAG-MESSAGES
END-IF.
*-----------------------------------------------------------------
* Display The Message
*-----------------------------------------------------------------
MOVE CSL-RC TO SAMP-RC.
MOVE RF-TYPE TO REST-TYPE.
MOVE SPACES TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE DISP-MSG TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE SPACES TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE SPACES TO MSGSTR.
MOVE ZERO TO SAMP-RC.
MOVE ZERO TO REST-TYPE.
PRINT-MSG-EXIT.
EXIT.
*====================================================
*== ==
*== Subroutine to retrieve any diagnostic messages ==
*== ==
*====================================================
GET-DIAG-MESSAGES.
************************************
* Disable calls to this subroutine *
************************************
MOVE 'N' TO SW-DIAG.
******************************
* First, get client messages *
******************************
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-STATUS,
CS-CLIENTMSG-TYPE,
CS-UNUSED,
DG-NUM-OF-MSGS.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
STRING 'CTBDIAG CS-STATUS CS-CLIENTMSG-TYP failed'
DELIMITED BY SIZE INTO ERROR-TEXT
MOVE CSL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
ELSE
IF DG-NUM-OF-MSGS > 0
THEN
PERFORM RETRIEVE-CLIENT-MSGS
VARYING I FROM 1 BY 1
UNTIL I IS GREATER THAN DG-NUM-OF-MSGS
END-IF
END-IF.
*****************************
* Then, get server messages *
*****************************
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-STATUS,
CS-SERVERMSG-TYPE,
CS-UNUSED,
DG-NUM-OF-MSGS.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
STRING 'CTBDIAG CS-STATUS CS-SERVERMSG-TYP fail'
DELIMITED BY SIZE INTO ERROR-TEXT
MOVE CSL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
ELSE
IF DG-NUM-OF-MSGS > 0
THEN
PERFORM RETRIEVE-SERVER-MSGS
VARYING I FROM 1 BY 1
UNTIL I IS GREATER THAN DG-NUM-OF-MSGS
END-IF
END-IF.
GET-DIAG-MESSAGES-EXIT.
EXIT.
*============================================================
*== ==
*== Subroutine to retrieve diagnostic messages from client ==
*== ==
*============================================================
RETRIEVE-CLIENT-MSGS.
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-GET,
CS-CLIENTMSG-TYPE,
DG-MSGNO,
CLIENT-MSG.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
STRING 'CTBDIAG CS-GET CS-CLIENTMSG-TYPE failed'
DELIMITED BY SIZE INTO ERROR-TEXT
MOVE CSL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
*-----------------------------------------------------------------
* display message text
*-----------------------------------------------------------------
MOVE DISP-CLIENT-MSG-HDR TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE SPACES TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE CM-SEVERITY TO CM-SEVERITY-DATA.
MOVE CM-STATUS TO CM-STATUS-DATA.
MOVE DISP-CLIENT-MSG-1 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE CM-MSGNO TO CM-OC-MSGNO-DATA.
MOVE DISP-CLIENT-MSG-2 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
IF CM-MSGNO NOT EQUAL 0
THEN
MOVE SPACES TO CM-OC-MSG-DATA
MOVE CM-TEXT TO CM-OC-MSG-DATA
MOVE CM-TEXT TO DISP-CLIENT-MSG-3A
MOVE DISP-CLIENT-MSG-3 TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF CM-TEXT-LEN > 66
THEN
MOVE CM-OC-MSG-DATA-2 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF CM-TEXT-LEN > 132
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OC-MSG-DATA-3 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF CM-TEXT-LEN > 198
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OC-MSG-DATA-4 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
END-IF
END-IF
END-IF
ELSE
MOVE DISP-EMPTY-CLIENT-MSG-3 TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
END-IF.
MOVE CM-OS-MSGNO TO CM-OS-MSGNO-DATA.
MOVE DISP-CLIENT-MSG-4 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
IF CM-OS-MSGNO NOT EQUAL 0
THEN
MOVE SPACES TO CM-OS-MSG-DATA
MOVE CM-OS-MSGTXT TO CM-OS-MSG-DATA
MOVE SPACES TO DISP-CLIENT-MSG-5A
MOVE CM-OS-MSGTXT TO DISP-CLIENT-MSG-5A
MOVE DISP-CLIENT-MSG-5 TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF CM-OS-MSGTEXT-LEN > 66
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OS-MSG-DATA-2 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF CM-OS-MSGTEXT-LEN > 132
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OS-MSG-DATA-3 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF CM-OS-MSGTEXT-LEN > 198
THEN
MOVE SPACES TO CM-OC-MSG-DATA-X
MOVE CM-OS-MSG-DATA-4 TO CM-OC-MSG-DATA-X
MOVE DISP-CLIENT-MSG-3B TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
END-IF
END-IF
END-IF
ELSE
MOVE DISP-EMPTY-CLIENT-MSG-5 TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
END-IF.
RETRIEVE-CLIENT-MSGS-EXIT.
EXIT.
*============================================================
*== ==
*== Subroutine to retrieve diagnostic messages from server ==
*== ==
*============================================================
RETRIEVE-SERVER-MSGS.
CALL 'CTBDIAG' USING CSL-CON-HANDLE,
CSL-RC,
CS-UNUSED,
CS-GET,
CS-SERVERMSG-TYPE,
DG-MSGNO,
SERVER-MSG.
IF CSL-RC NOT EQUAL CS-SUCCEED
THEN
STRING 'CTBDIAG CS-GET CS-SERVERMSG-TYPE failed'
DELIMITED BY SIZE INTO ERROR-TEXT
MOVE CSL-RC TO ERROR-RC
PERFORM SEND-ERROR-MESSAGE
PERFORM ALL-DONE
END-IF.
*----------------------------------------------------------------
* display message text
*----------------------------------------------------------------
MOVE SM-MSGNO TO SM-MSG-NO-DATA.
MOVE SM-SEV TO SM-SEVERITY-DATA.
MOVE SM-STATE TO SM-STATE-DATA.
MOVE SM-LINE TO SM-LINE-NO-DATA.
MOVE SM-STATUS TO SM-STATUS-DATA.
MOVE SPACES TO SM-SVRNAME-DATA.
MOVE SM-SVRNAME TO SM-SVRNAME-DATA.
MOVE SPACES TO SM-PROC-ID-DATA.
MOVE SM-PROC TO SM-PROC-ID-DATA.
MOVE SPACES TO SM-MSG-DATA.
MOVE SM-TEXT TO SM-MSG-DATA.
MOVE SPACES TO DISP-SERVER-MSG-5A.
MOVE SM-TEXT TO DISP-SERVER-MSG-5A.
MOVE DISP-SERVER-MSG-HDR TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE DISP-SERVER-MSG-1 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE DISP-SERVER-MSG-2 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE DISP-SERVER-MSG-3 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE DISP-SERVER-MSG-4 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
MOVE DISP-SERVER-MSG-5 TO INFO-MSG-STR.
PERFORM SEND-INFO-MESSAGE.
IF SM-TEXT-LEN > 66
THEN
MOVE SPACES TO SM-MSG-DATA-X
MOVE SM-MSG-DATA-2 TO SM-MSG-DATA-X
MOVE DISP-SERVER-MSG-5X TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF SM-TEXT-LEN > 132
THEN
MOVE SPACES TO SM-MSG-DATA-X
MOVE SM-MSG-DATA-3 TO SM-MSG-DATA-X
MOVE DISP-SERVER-MSG-5X TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
IF SM-TEXT-LEN > 198
THEN
MOVE SPACES TO SM-MSG-DATA-X
MOVE SM-MSG-DATA-4 TO SM-MSG-DATA-X
MOVE DISP-SERVER-MSG-5X TO INFO-MSG-STR
PERFORM SEND-INFO-MESSAGE
END-IF
END-IF
END-IF.
RETRIEVE-SERVER-MSGS-EXIT.
EXIT.
