SYCTSAX4: PROC OPTIONS(MAIN REENTRANT);
/* @(#) syctsax4.pli 1.1 4/18/96 */
/****** SYCTSAX4 - Open Server, Open Client - PL/1 - CICS ***********/
/* */
/* TRANID: SYX4 */
/* PROGRAM: SYCTSAX4 */
/* TABLE: SYBASE.SAMPLETB */
/* */
/* The purpose of the program is primarily to demonstrate 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" */
/* */
/* Make sure that the server you wish to access has an entry */
/* in the Connection Router Table for that Server and the */
/* MCG(s) that you wish to use. */
/* */
/* 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: */
/* */
/* CSBCTXDROP drop a context */
/* 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 */
/* Oct3095 99999 Rewrite and add front end to the program */
/* */
/* */
/********************************************************************/
/*------------------------------------------------------------------*/
/* CLIENT LIBRARY PL/1 COPY BOOK */
/*------------------------------------------------------------------*/
%INCLUDE CTPUBLIC;
/*------------------------------------------------------------------*/
/* SERVER LIBRARY PL/1 COPY BOOK */
/*------------------------------------------------------------------*/
%INCLUDE SYGWPLI;
/*------------------------------------------------------------------*/
/* CICS Standard Attention Identifiers PL/1 Copy Book */
/*------------------------------------------------------------------*/
%INCLUDE DFHAID;
/*------------------------------------------------------------------*/
/* SERVER LIBRARY ROUTINE DECLARATIONS */
/*------------------------------------------------------------------*/
DCL
TDACCEPT ENTRY OPTIONS(INTER ASSEMBLER),
TDESCRIB ENTRY OPTIONS(INTER ASSEMBLER),
TDFREE ENTRY OPTIONS(INTER ASSEMBLER),
TDINFPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDINIT ENTRY OPTIONS(INTER ASSEMBLER),
TDNUMPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDRCVPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDSNDDON ENTRY OPTIONS(INTER ASSEMBLER),
TDSNDMSG ENTRY OPTIONS(INTER ASSEMBLER),
TDSNDROW ENTRY OPTIONS(INTER ASSEMBLER);
/********************************************************************/
/* CLIENT LIBRARY ROUTINE DECLARATIONS */
/********************************************************************/
DCL
CSBCTXDR ENTRY OPTIONS(INTER ASSEMBLER),
CTBBIND ENTRY OPTIONS(INTER ASSEMBLER),
CTBCLOSE ENTRY OPTIONS(INTER ASSEMBLER),
CTBCMDALLOC ENTRY OPTIONS(INTER ASSEMBLER),
CTBCMDDROP ENTRY OPTIONS(INTER ASSEMBLER),
CTBCOMMAND ENTRY OPTIONS(INTER ASSEMBLER),
CTBCONALLOC ENTRY OPTIONS(INTER ASSEMBLER),
CTBCONDROP ENTRY OPTIONS(INTER ASSEMBLER),
CTBCONPROPS ENTRY OPTIONS(INTER ASSEMBLER),
CTBCONNECT ENTRY OPTIONS(INTER ASSEMBLER),
CTBDIAG ENTRY OPTIONS(INTER ASSEMBLER),
CTBEXIT ENTRY OPTIONS(INTER ASSEMBLER),
CTBFETCH ENTRY OPTIONS(INTER ASSEMBLER),
CTBINIT ENTRY OPTIONS(INTER ASSEMBLER),
CTBRESULTS ENTRY OPTIONS(INTER ASSEMBLER),
CTBSEND ENTRY OPTIONS(INTER ASSEMBLER);
/********************************************************************/
/* BUILT-IN FUNCTION DECLARATIONS */
/********************************************************************/
DCL
ADDR BUILTIN,
LENGTH BUILTIN,
STG BUILTIN,
SUBSTR BUILTIN;
/********************************************************************/
/* WORK AREAS SERVER LIBRARY */
/********************************************************************/
DCL
01 GW_LIB_MISC_FIELDS,
05 GWL_TDPROC PTR,
05 GWL_RC FIXED BIN(31);
DCL
01 PARM_FIELDS,
05 PF_PARM_ID FIXED BIN(31),
05 PF_DATATYPE FIXED BIN(31),
05 PF_ACTUAL_DATA_LENGTH FIXED BIN(31),
05 PF_MAX_DATA_LENGTH FIXED BIN(31),
05 PF_PARM_STATUS FIXED BIN(31),
05 PF_PARM_NAME CHAR(30),
05 PF_PARM_NAME_LENGTH FIXED BIN(31),
05 PF_USER_DATATYPE FIXED BIN(31),
05 PF_NUM_OF_PARMS FIXED BIN(31);
DCL
01 SNA_FIELDS,
05 SNA_SUBC FIXED BIN(31),
05 SNA_CONNECTION_NAME CHAR(08) INIT(' ');
DCL
01 WORK_FIELDS,
05 WRK_DONE_STATUS FIXED BIN(31);
DCL
01 DESCRIBE_FIELDS,
05 DF_COLUMN_NUMBER FIXED BIN(31),
05 DF_HOST_VARIABLE_TYPE FIXED BIN(31),
05 DF_HOST_VARIABLE_MAXLEN FIXED BIN(31),
05 DF_HOST_VARIABLE_NAME PTR,
05 DF_NULL_INDICATOR_VAR FIXED BIN(15),
05 DF_NULLS_ALLOWED FIXED BIN(31),
05 DF_COLUMN_TYPE FIXED BIN(31),
05 DF_COLUMN_MAXLEN FIXED BIN(31),
05 DF_COLUMN_NAME CHAR(30),
05 DF_COLUMN_NAME_LEN FIXED BIN(31);
DCL
01 SNDMSG_FIELDS,
05 SF_MESSAGE_TYPE FIXED BIN(31),
05 SF_MESSAGE_NUMBER FIXED BIN(31),
05 SF_SEVERITY FIXED BIN(31),
05 SF_ERROR_STATE FIXED BIN(31),
05 SF_LINE_ID FIXED BIN(31),
05 SF_TRANSACTION_ID CHAR(4) INIT('SYX4'),
05 SF_TRANSACTION_ID_LEN FIXED BIN(31),
05 SF_MESSAGE_TEXT CHAR(80),
05 SF_MESSAGE_LENGTH FIXED BIN(31);
/*------------------------------------------------------------------*//
/* WORK AREAS OPEN CLIENT */
/*------------------------------------------------------------------*/
DCL
01 CS_LIB_MISC_FIELDS,
05 CSL_CMD_HANDLE FIXED BIN(31) INIT(0),
05 CSL_CON_HANDLE FIXED BIN(31) INIT(0),
05 CSL_CTX_HANDLE FIXED BIN(31) INIT(0),
05 CSL_RC FIXED BIN(31);
DCL
01 PROPS_FIELDS,
05 PF_SERVER CHAR(30),
05 PF_SERVER_LEN FIXED BIN(31),
05 PF_USER CHAR(08),
05 PF_USER_LEN FIXED BIN(31),
05 PF_PWD CHAR(30),
05 PF_PWD_LEN FIXED BIN(31),
05 PF_OUTLEN FIXED BIN(31),
05 PF_STRLEN FIXED BIN(31),
05 PF_MSGLIMIT FIXED BIN(31);
DCL
01 QUERY_FIELDS,
05 QF_LEN FIXED BIN(15) INIT(1),
05 QF_MAXLEN FIXED BIN(15) INIT(1),
05 QF_ANSWER CHAR(01) INIT(' ');
DCL
01 FETCH_FIELDS,
05 FF_ROWS_READ FIXED BIN(31),
05 FF_ROW_NUM FIXED BIN(31) INIT(0);
DCL
01 COLUMN_FIELDS,
05 CF_COL_FIRSTNME CHAR(12) VAR,
05 CF_COL_NUMBER FIXED BIN(31) INIT(0),
05 CF_COL_INDICATOR FIXED BIN(31) INIT(0),
05 CF_COL_OUTLEN FIXED BIN(31);
DCL
01 LANG_FIELDS STATIC,
05 LF_LANG CHAR(36)
INIT ('SELECT FIRSTNME FROM SYBASE.SAMPLETB');
DCL
01 ERROR_MSG,
05 ERROR_TEXT CHAR(50) INIT(' '),
05 ERROR_LITERAL CHAR(03) INIT('RC='),
05 ERROR_RC PIC '----9';
DCL
01 ERROR_MSG_STR CHAR(58)
DEFINED ERROR_MSG;
DCL
01 OUTPUT_MSG,
05 MESG CHAR(27) INIT(' '),
05 NUM_COLS_OR_ROWS PIC '99999';
DCL
01 OUTPUT_MSG_STR CHAR(32)
DEFINED OUTPUT_MSG;
DCL
01 INFO_MSG_STR CHAR(80) INIT(' ');
DCL
01 RESULTS_FIELDS,
05 RF_TYPE FIXED BIN(31);
DCL
01 DATAFMT,
05 DF_NAME CHAR(132),
05 DF_NAMELEN FIXED BIN(31),
05 DF_DATATYPE FIXED BIN(31),
05 DF_FORMAT FIXED BIN(31),
05 DF_MAXLENGTH FIXED BIN(31),
05 DF_SCALE FIXED BIN(31),
05 DF_PRECISION FIXED BIN(31),
05 DF_STATUS FIXED BIN(31),
05 DF_COUNT FIXED BIN(31),
05 DF_USERTYPE FIXED BIN(31),
05 DF_LOCALE CHAR(68);
/*------------------------------------------------------------------*/
/* COMMON WORK AREAS */
/*------------------------------------------------------------------*/
DCL
01 MSG_FIELDS STATIC,
05 MSG_END_MSG CHAR(25)
INIT ('All done processing rows.'),
05 MSG_NOT_RPC CHAR(35)
INIT ('SYX4 must be begun via rpc request.'),
05 MSG_WRONG_NR_PARMS CHAR(50)
INIT ('Number of parameters must be 2 or 3.'),
05 MSG_NOT_CHAR_PARM CHAR(50)
INIT ('Parameter must be a CHARACTER type.'),
05 MSG_NOT_INT4_PARM CHAR(50)
INIT ('Parameter must be a INTEGER type.'),
05 MSG_CANCELED CHAR(17)
INIT ('Cancel requested.'),
05 MSG_TDRCVPRM_FAIL CHAR(16)
INIT ('TDRCVPRM failed.');
DCL
01 CICS_FIELDS,
05 CICS_RESPONSE FIXED BIN(31);
DCL
01 MISC_FIELDS,
05 BLANK CHAR(01) INIT(' '),
05 BLANK_13 CHAR(13) INIT(' '),
05 DIAG_MSGS_INIT BIT(1) INIT('1'B),
05 FALSE BIT(1) INIT('0'B),
05 LCV FIXED BIN(31),
05 TMP_TIME CHAR(08) INIT(' '),
05 TMP_DATE CHAR(08) INIT(' '),
05 TRUE BIT(1) INIT('1'B),
05 UTIME FIXED DEC(15) INIT(0);
DCL
01 DIAG_FIELDS,
05 DF_MSGNO FIXED BIN(31) INIT(1),
05 DF_NUM_OF_MSGS FIXED BIN(31) INIT(0);
DCL
01 DISP_MSG,
05 TEST_CASE CHAR(09) INIT('SYCTSAX4 '),
05 MSG,
10 SAMP_LIT CHAR(05) INIT('rc = '),
10 SAMP_RC PIC'99',
10 REST_LIT CHAR(15)
INIT(' Result Type: '),
10 REST_TYPE PIC'9999',
10 FILLER CHAR(03) INIT(' '),
10 MSGSTR CHAR(40) INIT(' ');
DCL
01 DISP_DATE_HEADER,
05 DATE_HDR CHAR(06) INIT(' DATE '),
05 DATE_DATA CHAR(08),
05 X4_HDR CHAR(54) ;
DCL
01 DISP_TIME_HEADER,
05 TIME_HDR CHAR(06) INIT(' TIME '),
05 TIME_DATA CHAR(08);
DCL
01 DISP_SERVER,
05 SERVER_HDR CHAR(09) INIT(' SERVER: '),
05 SERVER_DATA CHAR(30),
05 USER_HDR CHAR(10) INIT(' USER-ID: '),
05 USER_DATA CHAR(08);
/*------------------------------------------------------------------*/
/* Client Message Structure */
/*------------------------------------------------------------------*/
DCL
01 CLIENT_MSG,
05 CM_SEVERITY FIXED BIN(31),
05 CM_MSGNO FIXED BIN(31),
05 CM_TEXT CHAR(256),
05 CM_TEXT_LEN FIXED BIN(31),
05 CM_OS_MSGNO FIXED BIN(31),
05 CM_OS_MSGTXT CHAR(256),
05 CM_OS_MSGTEXT_LEN FIXED BIN(31),
05 CM_STATUS FIXED BIN(31);
DCL
01 DISP_CLIENT_MSG_1,
05 CM_SEVERITY_HDR CHAR(13)
INIT(' Severity: '),
05 CM_SEVERITY_DATA PIC'ZZZ9',
05 CM_STATUS_HDR CHAR(12)
INIT(', Status: '),
05 CM_STATUS_DATA PIC'ZZZ9' ;
DCL
01 DISP_CLIENT_MSG_2,
05 CM_OC_MSGNO_HDR CHAR(13)
INIT(' OC MsgNo: '),
05 CM_OC_MSGNO_DATA PIC'ZZZZZZZ9' ;
DCL
01 DISP_CLIENT_MSG_3,
05 CM_OC_MSG_HDR CHAR(13)
INIT(' OC MsgTx: '),
05 CM_OC_MSG_DATA CHAR(66);
DCL
01 DISP_CLIENT_MSG_3A,
05 CM_OC_MSG_DATA_1 CHAR(66),
05 CM_OC_MSG_DATA_2 CHAR(66),
05 CM_OC_MSG_DATA_3 CHAR(66),
05 CM_OC_MSG_DATA_4 CHAR(58);
DCL
01 DISP_CLIENT_MSG_3B,
05 FILLER CHAR(13) INIT(' '),
05 CM_OC_MSG_DATA_X CHAR(66);
DCL
01 DISP_CLIENT_MSG_4,
05 CM_OS_MSG_HDR CHAR(13)
INIT(' OS MsgNo: '),
05 CM_OS_MSGNO_DATA PIC'ZZZZZZZ9' ;
DCL
01 DISP_CLIENT_MSG_5,
05 CM_OS_MSG_HDR_5 CHAR(13)
INIT(' OS MsgTx: '),
05 CM_OS_MSG_DATA CHAR(66);
/*------------------------------------------------------------------*/
/* Server Message Structure */
/*------------------------------------------------------------------*/
DCL
01 SERVER_MSG,
05 SM_MSGNO FIXED BIN(31),
05 SM_STATE FIXED BIN(31),
05 SM_SEV FIXED BIN(31),
05 SM_TEXT CHAR(256),
05 SM_TEXT_LEN FIXED BIN(31),
05 SM_SVRNAME CHAR(256),
05 SM_SVRNAME_LEN FIXED BIN(31),
05 SM_PROC CHAR(256),
05 SM_PROC_LEN FIXED BIN(31),
05 SM_LINE FIXED BIN(31),
05 SM_STATUS FIXED BIN(31);
DCL
01 DISP_SERVER_MSG_1,
05 SM_MSG_NO_HDR CHAR(13)
INIT(' Message#: '),
05 SM_MSG_NO_DATA PIC'ZZZZZZZ9',
05 SM_SEVERITY_HDR CHAR(14)
INIT(', Severity: '),
05 SM_SEVERITY_DATA PIC'ZZZ9',
05 SM_STATE_HDR CHAR(14)
INIT(', State No: '),
05 SM_STATE_DATA PIC'ZZZ9' ;
DCL
01 DISP_SERVER_MSG_2,
05 SM_LINE_NO_HDR CHAR(13)
INIT(' Line No: '),
05 SM_LINE_NO_DATA PIC'ZZZ9',
05 SM_STATUS_HDR CHAR(14)
INIT(', Status : '),
05 SM_STATUS_DATA PIC'ZZZ9' ;
DCL
01 DISP_SERVER_MSG_3,
05 SM_SVRNAME_HDR CHAR(13)
INIT(' Serv Nam: '),
05 SM_SVRNAME_DATA CHAR(66) ;
DCL
01 DISP_SERVER_MSG_4,
05 SM_PROC_ID_HDR CHAR(13)
INIT(' Proc ID: '),
05 SM_PROC_ID_DATA CHAR(66);
DCL
01 DISP_SERVER_MSG_5,
05 SM_MSG_HDR CHAR(13)
INIT(' Message : '),
05 SM_MSG_DATA CHAR(66);
DCL
01 DISP_SERVER_MSG_5X,
05 FILLER CHAR(13) INIT(' '),
05 SM_MSG_DATA_X CHAR(66);
/*------------------------------------------------------------------*/
/* Begin program here */
/*------------------------------------------------------------------*/
X4_HDR = ' SYBASE PL/1 SAMPLE PROGRAM SYCTSAX4 SQL RESULT OUTPUT' ;
EXEC CICS ASKTIME ABSTIME(UTIME);
EXEC CICS FORMATTIME
ABSTIME(UTIME)
DATESEP('/')
MMDDYY(TMP_DATE)
TIME(TMP_TIME)
TIMESEP ;
/*------------------------------------------------------------------*/
/* intialize the TDS environment for a client */
/*------------------------------------------------------------------*/
CALL TDINIT( DFHEIBLK,
GWL_RC,
CSL_CTX_HANDLE);
IF GWL_RC ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDINIT failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
/*----------------------------------------*/
/* accept a request from a remote client */
/*----------------------------------------*/
CALL TDACCEPT( GWL_TDPROC,
GWL_RC,
CSL_CTX_HANDLE,
SNA_CONNECTION_NAME,
SNA_SUBC);
IF GWL_RC ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDACCEPT failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
/*------------------------------------------*/
/* display program heading information */
/*------------------------------------------*/
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = DATE_HDR || TMP_DATE || X4_HDR ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = TIME_HDR || TMP_TIME ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
/*------------------------------------------------*/
/* determine how many parameters were sent with */
/* the current RPC by the remote client or server */
/* .. better be two */
/*------------------------------------------------*/
CALL TDNUMPRM( GWL_TDPROC,
PF_NUM_OF_PARMS);
IF PF_NUM_OF_PARMS = 2 | PF_NUM_OF_PARMS = 3
THEN ;
ELSE DO;
INFO_MSG_STR = MSG_WRONG_NR_PARMS;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR =
'syntax is: SYX4 server-nm, user-id OR' ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR =
' SYX4 server-nm, user-id, password' ;
CALL SEND_INFO_MESSAGE;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* retrieves parameter type, datatype, and length information */
/* about the 1st RPC parameter( server-name parameter ) */
/*------------------------------------------------------------*/
PF_PARM_ID = 1;
CALL TDINFPRM( 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 ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDINFPRM for server-name parameter failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
IF PF_DATATYPE ^= TDSCHAR & PF_DATATYPE ^= TDSVARYCHAR THEN
DO;
INFO_MSG_STR = 'server-name datatype must be TDSCHAR';
CALL SEND_INFO_MESSAGE;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* retrieves the data from an RPC parameter sent by a remote */
/* client */
/*------------------------------------------------------------*/
CALL TDRCVPRM( GWL_TDPROC,
GWL_RC,
PF_PARM_ID,
PF_SERVER,
TDSCHAR,
STG(PF_SERVER),
PF_ACTUAL_DATA_LENGTH);
IF GWL_RC ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDRCVPRM failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
PF_SERVER_LEN = PF_ACTUAL_DATA_LENGTH ;
/*------------------------------------------------------------*/
/* retrieves parameter type, datatype, and length information */
/* about the 2nd RPC parameter( user-id parameter ) */
/*------------------------------------------------------------*/
PF_PARM_ID = 2;
CALL TDINFPRM( 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 ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDINFPRM for user-id parameter failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
IF PF_DATATYPE ^= TDSCHAR & PF_DATATYPE ^= TDSVARYCHAR THEN
DO;
INFO_MSG_STR = 'user-id datatype must be TDSCHAR';
CALL SEND_INFO_MESSAGE;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* retrieves the data from an RPC parameter sent by a remote */
/* client */
/*------------------------------------------------------------*/
CALL TDRCVPRM( GWL_TDPROC,
GWL_RC,
PF_PARM_ID,
PF_USER,
TDSCHAR,
STG(PF_USER),
PF_ACTUAL_DATA_LENGTH);
IF GWL_RC ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDRCVPRM for user-id failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
PF_USER_LEN = PF_ACTUAL_DATA_LENGTH ;
/*------------------------------------------------------------*/
/* retrieves parameter type, datatype, and length information */
/* about the 3rd RPC parameter( password parameter ) */
/*------------------------------------------------------------*/
IF PF_NUM_OF_PARMS = 3 THEN
DO ;
PF_PARM_ID = 3;
CALL TDINFPRM( 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 ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDINFPRM for password parameter failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
IF PF_DATATYPE ^= TDSCHAR & PF_DATATYPE ^= TDSVARYCHAR THEN
DO;
INFO_MSG_STR = 'password datatype must be TDSCHAR';
CALL SEND_INFO_MESSAGE;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* retrieves the data from an RPC parameter sent by a remote */
/* client */
/*------------------------------------------------------------*/
CALL TDRCVPRM( GWL_TDPROC,
GWL_RC,
PF_PARM_ID,
PF_PWD,
TDSCHAR,
STG(PF_PWD),
PF_ACTUAL_DATA_LENGTH);
IF GWL_RC ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDRCVPRM for password failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
PF_PWD_LEN = PF_ACTUAL_DATA_LENGTH ;
END ;
ELSE DO ;
PF_PWD = BLANK ;
PF_PWD_LEN = 0 ;
END ;
/*---------------------------------------*/
/* display server and user-id heading */
/*---------------------------------------*/
INFO_MSG_STR = SERVER_HDR || PF_SERVER ||
USER_HDR || PF_USER ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
/*-----------------------------------------------------------*/
/* describe the 1st column in a result row and the mainframe */
/* server program variable where it is stored */
/*-----------------------------------------------------------*/
DF_COLUMN_NUMBER = 1;
DF_HOST_VARIABLE_TYPE = TDSVARYCHAR;
DF_HOST_VARIABLE_MAXLEN = STG(CF_COL_FIRSTNME) - 2;
DF_HOST_VARIABLE_NAME = ADDR(CF_COL_FIRSTNME);
DF_NULL_INDICATOR_VAR = TDS_ZERO; /* not null */
DF_NULLS_ALLOWED = TDS_FALSE;
DF_COLUMN_TYPE = TDSVARYCHAR;
DF_COLUMN_MAXLEN = STG(CF_COL_FIRSTNME) - 2;
DF_COLUMN_NAME = 'FIRST NAME';
DF_COLUMN_NAME_LEN = 10; /* length of 'FIRST NAME' */
CALL TDESCRIB( 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 ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDESCRIB failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* Open Client calls */
/*------------------------------------------------------------*/
CALL OC_INIT;
CALL OC_CONNECT;
CALL OC_SEND_LANG;
CALL OC_PROCESS_RESULTS;
CALL OC_ALL_DONE;
ALL_DONE:
/*------------------------------------------------------------*/
/* send a results completion indication to the client */
/*------------------------------------------------------------*/
CALL TDSNDDON( GWL_TDPROC,
GWL_RC,
TDS_DONE_FINAL,
TDS_NULL,
TDS_ZERO,
TDS_ENDRPC);
IF GWL_RC ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDSNDDON failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
END;
/*------------------------------------------------------------*/
/* free up a previously allocated GWL_TDPROC structure after */
/* returning results to a client */
/*------------------------------------------------------------*/
CALL TDFREE( GWL_TDPROC,
GWL_RC);
IF GWL_RC ^= TDS_OK THEN
DO;
ERROR_TEXT = 'TDFREE failed.';
ERROR_RC = GWL_RC;
CALL SEND_ERROR_MESSAGE;
END;
EXEC CICS RETURN;
/*------------------------------------------------------------------*/
/* Subroutine to initialize the Client-Library */
/*------------------------------------------------------------------*/
OC_INIT: PROC;
/*------------------------------------------------------------------*/
/* initialize the Client-Library */
/*------------------------------------------------------------------*/
CALL CTBINIT( CSL_CTX_HANDLE,
CSL_RC,
CS_VERSION_46);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBINIT failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
END OC_INIT;
/*------------------------------------------------------------------*/
/* 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: PROC;
/*------------------------------------------------------------*/
/* allocate a connection to the server */
/*------------------------------------------------------------*/
CALL CTBCONALLOC( CSL_CTX_HANDLE,
CSL_RC,
CSL_CON_HANDLE);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCONALLOC failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* alter properties of the connection for user-id */
/*------------------------------------------------------------*/
PF_STRLEN = STG(PF_USER);
CALL CTBCONPROPS( CSL_CON_HANDLE,
CSL_RC,
CS_SET,
CS_USERNAME,
PF_USER,
PF_USER_LEN,
CS_FALSE,
CS_UNUSED);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCONPROPS for user-id failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
PF_STRLEN = 0;
/*------------------------------------------------------------*/
/* alter properties of the connection for password */
/*------------------------------------------------------------*/
CALL CTBCONPROPS( CSL_CON_HANDLE,
CSL_RC,
CS_SET,
CS_PASSWORD,
PF_PWD,
PF_PWD_LEN,
CS_FALSE,
CS_UNUSED);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCONPROPS for password failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* setup retrieval of All Messages */
/*------------------------------------------------------------*/
CALL CTBDIAG( CSL_CON_HANDLE,
CSL_RC,
CS_UNUSED,
CS_INIT,
CS_ALLMSG_TYPE,
CS_UNUSED,
CS_UNUSED ) ;
IF CSL_RC ^= CS_SUCCEED THEN
DO ;
MSGSTR = 'CTBDIAG CS_INIT failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END ;
/*------------------------------------------------------------*/
/* set the upper limit of number of messages */
/*------------------------------------------------------------*/
PF_MSGLIMIT = 5 ;
CALL CTBDIAG( CSL_CON_HANDLE,
CSL_RC,
CS_UNUSED,
CS_MSGLIMIT,
CS_ALLMSG_TYPE,
CS_UNUSED,
PF_MSGLIMIT ) ;
IF CSL_RC ^= CS_SUCCEED THEN
DO ;
MSGSTR = 'CTBDIAG CS_MSGLIMIT failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END ;
/*------------------------------------------------------------*/
/* open connection to the server */
/*------------------------------------------------------------*/
CALL CTBCONNECT( CSL_CON_HANDLE,
CSL_RC,
PF_SERVER,
PF_SERVER_LEN,
CS_FALSE);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCONNECT failed' ;
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
END OC_CONNECT;
/*------------------------------------------------------------------*/
/* Subroutine to allocate command handler, prepare and send the */
/* language request */
/*------------------------------------------------------------------*/
OC_SEND_LANG: PROC;
/*------------------------------------------------------------*/
/* allocate a command handle */
/*------------------------------------------------------------*/
CALL CTBCMDALLOC( CSL_CON_HANDLE,
CSL_RC,
CSL_CMD_HANDLE);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCMDALLOC failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* prepare the language request */
/*------------------------------------------------------------*/
PF_STRLEN = STG(LF_LANG);
CALL CTBCOMMAND( CSL_CMD_HANDLE,
CSL_RC,
CS_LANG_CMD,
LF_LANG,
PF_STRLEN,
CS_UNUSED);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCOMMAND failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* send the language request */
/*------------------------------------------------------------*/
CALL CTBSEND( CSL_CMD_HANDLE,
CSL_RC);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBSEND failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
END OC_SEND_LANG;
/*------------------------------------------------------------------*/
/* Subroutine to process the result */
/*------------------------------------------------------------------*/
OC_PROCESS_RESULTS: PROC;
DORESULTS: DO WHILE(1=1);
/*------------------------------------------------------------*/
/* set up the results data */
/*------------------------------------------------------------*/
CALL CTBRESULTS( CSL_CMD_HANDLE,
CSL_RC,
RF_TYPE);
IF CSL_RC ^= CS_SUCCEED
THEN
LEAVE DORESULTS;
/*--------------------------------------------------------*/
/* We need to bind the data to program variables. */
/* We don't care about the indicator variable */
/* so we'll pass NULL for that parameter in CTBBIND(). */
/*--------------------------------------------------------*/
IF RF_TYPE = CS_ROW_RESULT THEN
DO;
/*---------------------------------*/
/* bind the first column, FIRSTNME */
/* defined as VARCHAR(12) */
/*---------------------------------*/
DF_DATATYPE = CS_VARCHAR_TYPE;
DF_FORMAT = CS_FMT_UNUSED;
DF_MAXLENGTH = STG(CF_COL_FIRSTNME) - 2;
DF_COUNT = 1; /* rows per fetch */
/*-----------------------*/
/* bind the first column */
/*-----------------------*/
CF_COL_NUMBER = 1;
CALL CTBBIND( 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 ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBBIND first name failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
/*-------------------------------------------*/
/* loop to fetch all rows in this result set */
/*-------------------------------------------*/
DOFETCHROW: DO WHILE(1=1);
CALL CTBFETCH( CSL_CMD_HANDLE,
CSL_RC,
CS_UNUSED, /* type */
CS_UNUSED, /* offset */
CS_UNUSED, /* option */
FF_ROWS_READ);
IF CSL_RC ^= CS_SUCCEED
THEN
LEAVE DOFETCHROW;
FF_ROW_NUM = FF_ROW_NUM + 1;
/*-------------------------------------------*/
/* send a row of data back to the requesting */
/* client */
/*-------------------------------------------*/
CALL TDSNDROW( GWL_TDPROC,
GWL_RC);
IF GWL_RC ^= TDS_OK THEN
DO;
INFO_MSG_STR = MSG_CANCELED;
CALL SEND_INFO_MESSAGE;
END;
END; /* end of DOFETCHROW */
/*----------------------------------------------------*/
/* We're done processing rows. Let's check the final */
/* return value of ctbfetch. */
/*----------------------------------------------------*/
IF CSL_RC = CS_CANCELLED THEN
DO;
ERROR_TEXT = MSG_CANCELED;
ERROR_RC = 0;
CALL SEND_ERROR_MESSAGE;
END;
ELSE IF CSL_RC = CS_END_DATA THEN
DO;
INFO_MSG_STR = BLANK;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = MSG_END_MSG;
CALL SEND_INFO_MESSAGE;
END;
ELSE IF CSL_RC = CS_SUCCEED THEN
DO;
ERROR_TEXT = 'CTBFETCH unexpected return code';
ERROR_RC = CSL_RC;
CALL SEND_ERROR_MESSAGE;
END;
ELSE DO;
ERROR_TEXT = 'CTBFETCH failed.';
ERROR_RC = CSL_RC;
CALL SEND_ERROR_MESSAGE;
END;
END; /* end rftype = cs_row_result */
/*--------------------------------------------------------*/
/* don't care about status */
/*--------------------------------------------------------*/
ELSE IF RF_TYPE = CS_STATUS_RESULT THEN
DO;
CALL CTBFETCH( CSL_CMD_HANDLE,
CSL_RC,
CS_UNUSED, /* type */
CS_UNUSED, /* offset */
CS_UNUSED, /* option */
FF_ROWS_READ);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBFETCH status failed.';
CALL ERROR_OUT;
END;
END;
/*------------------------------------------------------------*/
/* print an error message if the server encountered an error */
/* while executing the request */
/*------------------------------------------------------------*/
ELSE IF RF_TYPE = CS_CMD_FAIL THEN
DO;
MSGSTR = 'CTBRESUL returned CS_CMD-FAIL restype' ;
CALL ERROR_OUT;
INFO_MSG_STR = 'bad user-id or password' ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
END;
/*--------------------------------------------------------*/
/* this means no rows were returned */
/*--------------------------------------------------------*/
ELSE IF RF_TYPE = CS_SUCCEED THEN
DO;
END;
/*--------------------------------------------------------*/
/* done with one result set, let's go on to the next */
/*--------------------------------------------------------*/
ELSE IF RF_TYPE = CS_CMD_DONE THEN
DO;
END;
/*--------------------------------------------------------*/
/* the server encountered an error while processing our */
/* command */
/*--------------------------------------------------------*/
ELSE IF RF_TYPE = CS_CMD_FAIL THEN
DO;
END;
/*--------------------------------------------------------*/
/* we got something unexpected */
/*--------------------------------------------------------*/
ELSE
DO;
END;
END; /* end of DORESULTS */
/*-------------------------------------------------------------*/
/* We're done processing results. Let's check the return value */
/* of CTBRESULTS() to see if everything went ok. */
/*-------------------------------------------------------------*/
IF CSL_RC = CS_END_RESULTS THEN
DO;
END;
/*------------------------------------------------------------*/
/* something terrible happened */
/*------------------------------------------------------------*/
ELSE IF CSL_RC = CS_FAIL THEN
DO;
MSGSTR = 'CTBRESULTS failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
/*------------------------------------------------------------*/
/* we got an unexpected return value */
/*------------------------------------------------------------*/
ELSE
DO;
MSGSTR = 'CTBRESULTS failed.';
CALL ERROR_OUT;
GO TO ALL_DONE;
END;
END OC_PROCESS_RESULTS;
/*------------------------------------------------------------------*/
/* Subroutine to drop the command handler, to close the server */
/* connection, to drop the connection handler and exit */
/*------------------------------------------------------------------*/
OC_ALL_DONE: PROC;
/*------------------------------------------------------------------*/
/* drop the command handle */
/*------------------------------------------------------------------*/
CALL CTBCMDDROP( CSL_CMD_HANDLE,
CSL_RC);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCMDDROP failed.';
CALL ERROR_OUT;
END;
/*------------------------------------------------------------------*/
/* close the server connection */
/*------------------------------------------------------------------*/
CALL CTBCLOSE( CSL_CON_HANDLE,
CSL_RC,
CS_UNUSED);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCLOSE failed.';
CALL ERROR_OUT;
END;
/*------------------------------------------------------------------*/
/* de-allocate the connection handler */
/*------------------------------------------------------------------*/
CALL CTBCONDROP( CSL_CON_HANDLE,
CSL_RC);
IF CSL_RC ^= CS_SUCCEED THEN
DO;
MSGSTR = 'CTBCONDROP failed.';
CALL ERROR_OUT;
END;
END OC_ALL_DONE;
/*------------------------------------------------------------------*/
/* Subroutine to send an error message to the client */
/*------------------------------------------------------------------*/
SEND_ERROR_MESSAGE: PROC;
SF_MESSAGE_TYPE = TDS_ERROR_MSG;
SF_MESSAGE_NUMBER = 0;
SF_SEVERITY = 10; /* TDS_ERROR_SEV */
SF_ERROR_STATE = 0;
SF_LINE_ID = 0;
SF_TRANSACTION_ID_LEN = STG(SF_TRANSACTION_ID);
SF_MESSAGE_TEXT = ERROR_MSG_STR;
SF_MESSAGE_LENGTH = STG(SF_MESSAGE_TEXT);
CALL TDSNDMSG( GWL_TDPROC,
GWL_RC,
SF_MESSAGE_TYPE, /* msg type */
SF_MESSAGE_NUMBER, /* return_code */
SF_SEVERITY, /* TDS_ERROR_SEV */
SF_ERROR_STATE, /* error state */
SF_LINE_ID, /* line # */
SF_TRANSACTION_ID, /* transaction id*/
SF_TRANSACTION_ID_LEN, /* tid len */
SF_MESSAGE_TEXT, /* msg */
SF_MESSAGE_LENGTH); /* msg len */
END SEND_ERROR_MESSAGE;
/*------------------------------------------------------------------*/
/* Subroutine to send an information message to the client */
/*------------------------------------------------------------------*/
SEND_INFO_MESSAGE: PROC;
SF_MESSAGE_TYPE = TDS_INFO_MSG;
SF_MESSAGE_NUMBER = 0;
SF_SEVERITY = 0; /* TDS_INFO_SEV */
SF_ERROR_STATE = 0;
SF_LINE_ID = 0;
SF_TRANSACTION_ID_LEN = STG(SF_TRANSACTION_ID);
SF_MESSAGE_TEXT = INFO_MSG_STR;
SF_MESSAGE_LENGTH = STG(SF_MESSAGE_TEXT);
CALL TDSNDMSG( GWL_TDPROC,
GWL_RC,
SF_MESSAGE_TYPE, /* msg type */
SF_MESSAGE_NUMBER, /* return_code */
SF_SEVERITY, /* TDS_ERROR_SEV */
SF_ERROR_STATE, /* error state */
SF_LINE_ID, /* line # */
SF_TRANSACTION_ID, /* transaction id*/
SF_TRANSACTION_ID_LEN, /* tid len */
SF_MESSAGE_TEXT, /* msg */
SF_MESSAGE_LENGTH); /* msg len */
END SEND_INFO_MESSAGE;
/*------------------------------------------------------------------*/
/* */
/* Subroutine to print output messages. */
/* */
/*------------------------------------------------------------------*/
ERROR_OUT: PROC;
IF DIAG_MSGS_INIT
THEN
CALL GET_DIAG_MESSAGES ;
/*------------------------------------------------------------------*/
/* display error messages */
/*------------------------------------------------------------------*/
SAMP_RC = CSL_RC;
REST_TYPE = RF_TYPE ;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = TEST_CASE || SAMP_LIT || SAMP_RC ||
REST_LIT || REST_TYPE || ' ' ||
MSGSTR ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
SAMP_RC = 0;
REST_TYPE = 0 ;
END ERROR_OUT;
/*------------------------------------------------------------------*/
/* */
/* Subroutine to retrieve any diagnostic messages */
/* */
/*------------------------------------------------------------------*/
GET_DIAG_MESSAGES: PROC ;
DCL CNT FIXED BIN(15) ;
/*------------------------------------------------------------------*/
/* Disable calls to this subroutine */
/*------------------------------------------------------------------*/
DIAG_MSGS_INIT = FALSE ;
/*------------------------------------------------------------------*/
/* First, get client messages */
/*------------------------------------------------------------------*/
CALL CTBDIAG( CSL_CON_HANDLE,
CSL_RC,
CS_UNUSED,
CS_STATUS,
CS_CLIENTMSG_TYPE,
CS_UNUSED,
DF_NUM_OF_MSGS ) ;
IF CSL_RC ^= CS_SUCCEED THEN
DO ;
ERROR_TEXT = 'CTBDIAG CS_STATUS CLIENTMSG_TYPE failed';
ERROR_RC = CSL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END ;
ELSE DO ;
IF DF_NUM_OF_MSGS > 0 THEN
DO ;
DO CNT = 1 TO DF_NUM_OF_MSGS ;
CALL RETRIEVE_CLIENT_MSGS ;
END ;
END ;
END ;
/*------------------------------------------------------------------*/
/* Then, get server messages */
/*------------------------------------------------------------------*/
CALL CTBDIAG( CSL_CON_HANDLE,
CSL_RC,
CS_UNUSED,
CS_STATUS,
CS_SERVERMSG_TYPE,
CS_UNUSED,
DF_NUM_OF_MSGS ) ;
IF CSL_RC ^= CS_SUCCEED THEN
DO ;
ERROR_TEXT = 'CTBDIAG CS_STATUS SERVERMSG_TYPE failed' ;
ERROR_RC = CSL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END ;
ELSE DO ;
IF DF_NUM_OF_MSGS > 0 THEN
DO ;
DO CNT = 1 TO DF_NUM_OF_MSGS ;
CALL RETRIEVE_SERVER_MSGS ;
END ;
END ;
END ;
END GET_DIAG_MESSAGES ;
/*------------------------------------------------------------------*/
/* */
/* Subroutine to retrieve diagnostic messages from client */
/* */
/*------------------------------------------------------------------*/
RETRIEVE_CLIENT_MSGS: PROC ;
CALL CTBDIAG( CSL_CON_HANDLE,
CSL_RC,
CS_UNUSED,
CS_GET,
CS_CLIENTMSG_TYPE,
DF_MSGNO,
CLIENT_MSG ) ;
IF CSL_RC ^= CS_SUCCEED THEN
DO ;
ERROR_TEXT = 'CTBDIAG CS_GET CS_CLIENTMSG_TYPE FAILED' ;
ERROR_RC = CSL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END ;
/*------------------------------------------------------------------*/
/* display message text */
/*------------------------------------------------------------------*/
INFO_MSG_STR = 'Client Message:' ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
CM_SEVERITY_DATA = CM_SEVERITY ;
CM_STATUS_DATA = CM_STATUS ;
INFO_MSG_STR = CM_SEVERITY_HDR || CM_SEVERITY_DATA ||
CM_STATUS_HDR || CM_STATUS_DATA ;
CALL SEND_INFO_MESSAGE;
CM_OC_MSGNO_DATA = CM_MSGNO ;
INFO_MSG_STR = CM_OC_MSGNO_HDR || CM_OC_MSGNO_DATA ;
CALL SEND_INFO_MESSAGE;
IF CM_MSGNO ^= 0 THEN
DO ;
CM_OC_MSG_DATA = SUBSTR( CM_TEXT, 1, 66 ) ;
INFO_MSG_STR = CM_OC_MSG_HDR || CM_OC_MSG_DATA ;
CALL SEND_INFO_MESSAGE;
IF CM_TEXT_LEN > 66 THEN
DO ;
CM_OC_MSG_DATA_X = SUBSTR( CM_TEXT, 67, 66 ) ;
INFO_MSG_STR = BLANK_13 || CM_OC_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
IF CM_TEXT_LEN > 132 THEN
DO ;
CM_OC_MSG_DATA_X = SUBSTR( CM_TEXT, 133, 66 ) ;
INFO_MSG_STR = BLANK_13 ||
CM_OC_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
IF CM_TEXT_LEN > 198 THEN
DO ;
CM_OC_MSG_DATA_X = SUBSTR( CM_TEXT, 199 ) ;
INFO_MSG_STR = BLANK_13 ||
CM_OC_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
END ;
END ;
END ;
END ;
ELSE DO ;
INFO_MSG_STR = ' OC MsgTx: No Message' ;
CALL SEND_INFO_MESSAGE;
END ;
CM_OS_MSGNO_DATA = CM_OS_MSGNO ;
INFO_MSG_STR = ' OS MsgNo: ' || CM_OS_MSGNO_DATA ;
CALL SEND_INFO_MESSAGE;
IF CM_OS_MSGNO ^= 0 THEN
DO ;
CM_OS_MSG_DATA = SUBSTR( CM_OS_MSGTXT, 1, 66 ) ;
INFO_MSG_STR = CM_OS_MSG_HDR_5 ||
CM_OS_MSG_DATA ;
CALL SEND_INFO_MESSAGE;
IF CM_OS_MSGTEXT_LEN > 66 THEN
DO ;
CM_OC_MSG_DATA_X = SUBSTR( CM_OS_MSGTXT, 67, 66 ) ;
INFO_MSG_STR = BLANK_13 || CM_OC_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
IF CM_OS_MSGTEXT_LEN > 132 THEN
DO ;
CM_OC_MSG_DATA_X = SUBSTR( CM_OS_MSGTXT,133,66 );
INFO_MSG_STR = BLANK_13 || CM_OC_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
IF CM_OS_MSGTEXT_LEN > 198 THEN
DO ;
CM_OC_MSG_DATA_X = SUBSTR( CM_OS_MSGTXT,199 );
INFO_MSG_STR = BLANK_13 ||
CM_OC_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
END ;
END ;
END ;
END ;
ELSE DO ;
INFO_MSG_STR = ' OS MsgTx: No Message!' ;
CALL SEND_INFO_MESSAGE;
END ;
END RETRIEVE_CLIENT_MSGS ;
/*------------------------------------------------------------------*/
/* */
/* Subroutine to retrieve diagnostic messages from server */
/* */
/*------------------------------------------------------------------*/
RETRIEVE_SERVER_MSGS: PROC ;
CALL CTBDIAG( CSL_CON_HANDLE,
CSL_RC,
CS_UNUSED,
CS_GET,
CS_SERVERMSG_TYPE,
DF_MSGNO,
SERVER_MSG ) ;
IF CSL_RC ^= CS_SUCCEED THEN
DO ;
ERROR_TEXT = 'CTBDIAG CS_GET CS_SERVERMSG_TYPE failed' ;
ERROR_RC = CSL_RC;
CALL SEND_ERROR_MESSAGE;
GO TO ALL_DONE;
END ;
/*------------------------------------------------------------------*/
/* display message text */
/*------------------------------------------------------------------*/
SM_MSG_NO_DATA = SM_MSGNO ;
SM_SEVERITY_DATA = SM_SEV ;
SM_STATE_DATA = SM_STATE ;
SM_LINE_NO_DATA = SM_LINE ;
SM_STATUS_DATA = SM_STATUS ;
IF SM_SVRNAME_LEN > 66
THEN
SM_SVRNAME_DATA = SUBSTR( SM_SVRNAME, 1, 63 ) || '...' ;
ELSE
SM_SVRNAME_DATA = SUBSTR( SM_SVRNAME, 1, 66 ) ;
IF SM_PROC_LEN > 66
THEN
SM_PROC_ID_DATA = SUBSTR( SM_PROC, 1, 63 ) || '...' ;
ELSE
SM_PROC_ID_DATA = SUBSTR( SM_PROC, 1, 66 ) ;
SM_MSG_DATA = SUBSTR( SM_TEXT, 1, 66 ) ;
INFO_MSG_STR = 'Server Message:' ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = BLANK ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = SM_MSG_NO_HDR || SM_MSG_NO_DATA ||
SM_SEVERITY_HDR || SM_SEVERITY_DATA ||
SM_STATE_HDR || SM_STATE_DATA ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = SM_LINE_NO_HDR || SM_LINE_NO_DATA ||
SM_STATUS_HDR || SM_STATUS_DATA ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = SM_SVRNAME_HDR || SM_SVRNAME_DATA ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = SM_PROC_ID_HDR || SM_PROC_ID_DATA ;
CALL SEND_INFO_MESSAGE;
INFO_MSG_STR = SM_MSG_HDR || SM_MSG_DATA ;
CALL SEND_INFO_MESSAGE;
IF SM_TEXT_LEN > 66 THEN
DO ;
SM_MSG_DATA_X = SUBSTR( SM_TEXT, 67, 66 ) ;
INFO_MSG_STR = BLANK_13 || SM_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
IF SM_TEXT_LEN > 132 THEN
DO ;
SM_MSG_DATA_X = SUBSTR( SM_TEXT, 133, 66 ) ;
INFO_MSG_STR = BLANK_13 || SM_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
IF SM_TEXT_LEN > 198 THEN
DO ;
SM_MSG_DATA_X = SUBSTR( SM_TEXT, 198 ) ;
INFO_MSG_STR = BLANK_13 || SM_MSG_DATA_X ;
CALL SEND_INFO_MESSAGE;
END ;
END ;
END ;
END RETRIEVE_SERVER_MSGS ;
END SYCTSAX4;
*@(#) syctsax5.cobol 1.2 4/18/96
