This program accesses the sample DB2 table, SYBASE.SAMPLETB and selects columns from all rows with a department number that matches the number supplied in a passed parameter. It returns the selected rows to the client. The number of rows is returned in a return parameter.
After each row is sent, this program examines the TDSNDROW return code. If it receives a cancel request, it stops sending rows.
If the program completes successfully, it sends a confirmation message to the client; otherwise, it sends an error message.
SYSAMP1: PROC OPTIONS(MAIN REENTRANT);
/* @(#) sycpsar1.pli 11.1 2/17/95 */
/****** SYCPSAR1 - RPC REQUEST APPLICATION - PL/I - CICS ************/
/* */
/* TRANID: SYR1 */
/* PROGRAM: SYCPSAR1 */
/* PLAN NAME: SYR1PLAN */
/* FILES: none */
/* TABLES: SYBASE.SAMPLETB */
/* */
/* This program is executed via a client RPC request from sample */
/* dblib program 'SYR1'. The purpose of the program is primarily */
/* to demonstrate Server Library calls, especially those which */
/* would be used in a server application designed to handle */
/* RPC requests. */
/* */
/* Server Library calls: */
/* TDACCEPT accept request from client */
/* TDCONVRT convert data from host to DBlib datatype */
/* TDESCRIB describe a column */
/* TDFREE free TDPROC structure */
/* TDGETUSR get user login information from the client */
/* TDINFBCD get BCD information for a described column */
/* TDINFPRM get information about one rpc parameter */
/* TDINFUDT get user column datatype */
/* TDINIT establish environment */
/* TDLOCPRM return id of one rpc parameter based on name */
/* TDNUMPRM get total nr of rpc parameters */
/* TDRCVPRM retrieve rpc parameter from client */
/* TDRESULT describe next communication */
/* TDSETBCD set scaling for a described column */
/* TDSETLEN set length of a described column */
/* TDSETPRM set return parameter */
/* TDSETUDT set user column datatype */
/* TDSNDDON send results-completion to client */
/* TDSNDMSG send message to client */
/* TDSNDROW send row to client */
/* TDSTATUS get status information */
/* */
/* */
/* The program selects columns from the DB2 sample table */
/* SYBASE.SAMPLETB of all rows with a department number equal */
/* to that supplied in a passed parameter. */
/* */
/* The number of rows is returned in a return parameter. */
/* */
/* After each row is sent, TDSNDROW's return code is examined. */
/* If a cancel request was received, then no more rows are sent. */
/* */
/* A confirmation message is sent to the client if all is */
/* well, otherwise an error message is sent. */
/* */
/* CHANGE ACTIVITY: */
/* 06/90 - Created, MPM */
/* 10/93 - Added INCLUDE for table definition, TC */
/* */
/********************************************************************/
/*------------------------------------------------------------------*/
/* DB2 SQLCA */
/*------------------------------------------------------------------*/
EXEC SQL INCLUDE SQLCA;
/*------------------------------------------------------------------*/
/* TABLE DEFINITION FOR SYBASE.SAMPLETB */
/*------------------------------------------------------------------*/
EXEC SQL INCLUDE SYCPSMPT;
/********************************************************************/
/* SERVER LIBRARY PL/I COPY BOOK */
/********************************************************************/
%INCLUDE SYGWPLI;
/*------------------------------------------------------------------*/
/* SERVER LIB ROUTINES DECLARATIONS */
/*------------------------------------------------------------------*/
DCL
TDACCEPT ENTRY OPTIONS(INTER ASSEMBLER),
TDCONVRT ENTRY OPTIONS(INTER ASSEMBLER),
TDESCRIB ENTRY OPTIONS(INTER ASSEMBLER),
TDFREE ENTRY OPTIONS(INTER ASSEMBLER),
TDGETUSR ENTRY OPTIONS(INTER ASSEMBLER),
TDINFBCD ENTRY OPTIONS(INTER ASSEMBLER),
TDINFPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDINFUDT ENTRY OPTIONS(INTER ASSEMBLER),
TDINIT ENTRY OPTIONS(INTER ASSEMBLER),
TDLOCPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDNUMPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDRCVPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDRESULT ENTRY OPTIONS(INTER ASSEMBLER),
TDSETBCD ENTRY OPTIONS(INTER ASSEMBLER),
TDSETLEN ENTRY OPTIONS(INTER ASSEMBLER),
TDSETPRM ENTRY OPTIONS(INTER ASSEMBLER),
TDSETUDT ENTRY OPTIONS(INTER ASSEMBLER),
TDSNDDON ENTRY OPTIONS(INTER ASSEMBLER),
TDSNDMSG ENTRY OPTIONS(INTER ASSEMBLER),
TDSNDROW ENTRY OPTIONS(INTER ASSEMBLER),
TDSTATUS ENTRY OPTIONS(INTER ASSEMBLER);
/*------------------------------------------------------------------*/
/* BUILT IN FUNCTIONS DECLARATIONS */
/*------------------------------------------------------------------*/
DCL
ADDR BUILTIN,
INDEX BUILTIN,
LENGTH BUILTIN,
NULL BUILTIN,
STG BUILTIN,
STRING BUILTIN;
/*------------------------------------------------------------------*/
/* WORK AREAS */
/*------------------------------------------------------------------*/
DCL
01 GW_LIB_MISC_FIELDS,
05 GWL_PROC PTR,
05 GWL_INIT_HANDLE PTR,
05 GWL_RC FIXED BIN(31),
05 GWL_INFPRM_ID FIXED BIN(31),
05 GWL_INFPRM_TYPE FIXED BIN(31),
05 GWL_INFPRM_DATA_L FIXED BIN(31),
05 GWL_INFPRM_MAX_DATA_L FIXED BIN(31),
05 GWL_INFPRM_STATUS FIXED BIN(31),
05 GWL_INFPRM_NAME CHAR(30),
05 GWL_INFPRM_NAME_L FIXED BIN(31),
05 GWL_INFPRM_USER_DATA FIXED BIN(31),
05 GWL_INFUDT_USER_TYPE FIXED BIN(31),
05 GWL_STATUS_NR FIXED BIN(31),
05 GWL_STATUS_DONE FIXED BIN(31),
05 GWL_STATUS_COUNT FIXED BIN(31),
05 GWL_STATUS_COMM FIXED BIN(31),
05 GWL_STATUS_RETURN_CODE FIXED BIN(31),
05 GWL_STATUS_SUBCODE FIXED BIN(31),
05 GWL_NUMPRM_PARMS FIXED BIN(31),
05 GWL_RCVPRM_DATA_L FIXED BIN(31),
05 GWL_SETPRM_ID FIXED BIN(31),
05 GWL_SETPRM_TYPE FIXED BIN(31),
05 GWL_SETPRM_DATA_L FIXED BIN(31),
05 GWL_SETPRM_USER_DATA FIXED BIN(31),
05 GWL_CONVRT_SCALE FIXED BIN(31) INIT(02),
05 GWL_SETBCD_SCALE FIXED BIN(31) INIT(0),
05 GWL_INFBCD_LENGTH FIXED BIN(31),
05 GWL_INFBCD_SCALE FIXED BIN(31);
DCL
01 PARM_FIELDS,
05 PARM_DEPT CHAR(3) VAR,
05 PARM_RETURN_ROWS FIXED BIN(31) INIT(0);
DCL
01 SNA_FIELDS,
05 SNA_SUBC FIXED BIN(31),
05 SNA_CONNECTION_NAME CHAR(08) INIT(' ');
DCL
01 EMPLOYEE_FIELDS,
05 EMPLOYEE_FNM CHAR(12) VAR,
05 EMPLOYEE_LNM CHAR(15) VAR,
05 EMPLOYEE_ED FIXED BIN(15),
05 EMPLOYEE_JC FIXED DEC(3),
05 EMPLOYEE_SAL FIXED DEC(8,2);
DCL
01 COLUMN_NAME_FIELDS,
05 CN_FNM CHAR(10) INIT('FIRST_NAME'),
05 CN_LNM CHAR(09) INIT('LAST_NAME'),
05 CN_ED CHAR(09) INIT('EDUCATION'),
05 CN_JC CHAR(07) INIT('JOBCODE'),
05 CN_SAL CHAR(06) INIT('SALARY');
DCL
01 DESCRIBE_BIND_FIELDS,
05 DB_HOST_TYPE FIXED BIN(31),
05 DB_CLIENT_TYPE FIXED BIN(31),
05 DB_DESCRIBE_HV_PTR PTR,
05 DB_COLUMN_NAME_HV_PTR PTR,
05 DB_NULL_INDICATOR FIXED BIN(15) INIT(0);
DCL
01 TDGETUSR_FIELDS,
05 GU_ACCESS_CODE CHAR(32),
05 GU_USER_ID CHAR(32),
05 GU_PASSWORD CHAR(32),
05 GU_SERVER_NAME CHAR(32),
05 GU_CLIENT_CHARSET CHAR(32),
05 GU_NATIONAL_LANG CHAR(32),
05 GU_SERVER_CHARSET CHAR(32),
05 GU_SERVER_DBCS CHAR(32),
05 GU_APP_ID CHAR(32);
DCL
01 DB_DESCRIBE_HV
BASED(DB_DESCRIBE_HV_PTR);
DCL
01 DB_COLUMN_NAME_HV
BASED(DB_COLUMN_NAME_HV_PTR);
DCL
01 COUNTER_FIELDS,
05 CTR_COLUMN FIXED BIN(31) INIT(0);
DCL
01 WORK_FIELDS,
05 WRKLEN1 FIXED BIN(31),
05 WRKLEN2 FIXED BIN(31),
05 WRK_DONE_STATUS FIXED BIN(31),
05 WRK_EMPLOYEE_SAL CHAR(08),
05 WRK_BLANKS_SS FIXED BIN(31);
DCL
01 MESSAGE_FIELDS,
05 MSG_TYPE FIXED BIN(31),
05 MSG_SEVERITY FIXED BIN(31),
05 MSG_SEVERITY_OK FIXED BIN(31) INIT(9),
05 MSG_SEVERITY_ERROR FIXED BIN(31) INIT(11),
05 MSG_NR FIXED BIN(31),
05 MSG_NR_OK FIXED BIN(31) INIT(1),
05 MSG_NR_ERROR FIXED BIN(31) INIT(2),
05 MSG_RPC CHAR(04) INIT('SYR1'),
05 MSG_RPC_L FIXED BIN(31)
INIT(STG(MSG_RPC)),
05 MSG_TEXT CHAR(100),
05 MSG_TEXT_L FIXED BIN(31),
05 MSG_NOT_RPC CHAR(30) INIT
('SYR1 not begun via rpc request'),
05 MSG_NOT_AUTH CHAR(19) INIT
('User not authorized'),
05 MSG_WRONG_NR_PARMS CHAR(30) INIT
('Number of parameters was not 2'),
05 MSG_NOT_RETURN_PARM CHAR(42) INIT
('First parameter must be a RETURN parameter'),
05 MSG_NOT_CHAR_PARM CHAR(41) INIT
('Second parameter must be a CHARACTER type'),
05 MSG_BAD_CURSOR CHAR(27) INIT
('ERROR - can not open cursor'),
05 MSG_BAD_FETCH CHAR(24) INIT
('ERROR - fetch row failed'),
05 MSG_SQL_ERROR,
10 FILLER1 CHAR(10) INIT
('Sqlcode = '),
10 MSG_SQL_ERROR_C PIC '---9',
10 FILLER2 CHAR(16) INIT
(', Error Tokens: '),
10 MSG_SQL_ERROR_K CHAR(70),
05 MSG_SQL_ERROR_SS FIXED BIN(15);
DCL
01 MSG_SQLERRM CHAR(70);
DCL
01 MSG_SQLERRM_CHARS(70) DEFINED MSG_SQLERRM
CHAR(01);
DCL
01 CICS_FIELDS,
05 CICS_RESPONSE FIXED BIN(31);
DCL
01 SWITCHES,
05 ALL_DONE BIT(01) INIT('0'B),
05 ALL_DONE_YES BIT(01) INIT('1'B),
05 SEND_DONE BIT(01) INIT('1'B),
05 SEND_DONE_ERROR BIT(01) INIT('0'B),
05 SEND_DONE_OK BIT(01) INIT('1'B);
/*------------------------------------------------------------------*/
/* DECLARE CURSOR */
/*------------------------------------------------------------------*/
EXEC SQL
DECLARE ECURSOR CURSOR
FOR SELECT FIRSTNME, LASTNAME,
EDUCLVL, JOBCODE, SALARY
FROM SYBASE.SAMPLETB
WHERE WORKDEPT = :PARM_DEPT;
/*------------------------------------------------------------------*/
INITIALIZE_PROGRAM:
/*------------------------------------------------------------------*/
/* ------------------------------------------------------------*/
/* reset db2 error handlers */
/* ------------------------------------------------------------*/
EXEC SQL WHENEVER SQLWARNING CONTINUE;
EXEC SQL WHENEVER SQLERROR CONTINUE;
EXEC SQL WHENEVER NOT FOUND CONTINUE;
/* ------------------------------------------------------------*/
/* establish gateway environment */
/* ------------------------------------------------------------*/
CALL TDINIT (DFHEIBLK, GWL_RC, GWL_INIT_HANDLE);
/* ------------------------------------------------------------*/
/* accept client request */
/* ------------------------------------------------------------*/
CALL TDACCEPT (GWL_PROC, GWL_RC, GWL_INIT_HANDLE,
SNA_CONNECTION_NAME,
SNA_SUBC);
/* ------------------------------------------------------------*/
/* TDRESULT to validate kicked off via rpc request */
/* ------------------------------------------------------------*/
CALL TDRESULT (GWL_PROC, GWL_RC);
IF GWL_RC ^= TDS_PARM_PRESENT THEN
DO;
CALL TDRESULT_ERROR;
GO TO END_PROGRAM;
END;
/* ------------------------------------------------------------*/
/* verify user login information */
/* ------------------------------------------------------------*/
GU_ACCESS_CODE = 'TOP SECRET';
CALL TDGETUSR (GWL_PROC, GWL_RC,
GU_ACCESS_CODE,
GU_USER_ID,
GU_PASSWORD,
GU_SERVER_NAME,
GU_CLIENT_CHARSET,
GU_NATIONAL_LANG,
GU_SERVER_CHARSET,
GU_SERVER_DBCS,
GU_APP_ID);
IF GWL_RC ^= TDS_OK THEN
DO;
CALL TDGETUSR_ERROR;
GO TO END_PROGRAM;
END;
/*------------------------------------------------------------------*/
GET_NR_OF_PARMS:
/*------------------------------------------------------------------*/
/* ------------------------------------------------------------*/
/* get nr of parms .. better be two */
/* ------------------------------------------------------------*/
CALL TDNUMPRM (GWL_PROC, GWL_NUMPRM_PARMS);
IF GWL_NUMPRM_PARMS ^= 2 THEN
DO;
CALL TDNUMPRM_ERROR;
GO TO END_PROGRAM;
END;
/*------------------------------------------------------------------*/
GET_PARMS:
/*------------------------------------------------------------------*/
/* ------------------------------------------------------------*/
/* get return parameter information */
/* ------------------------------------------------------------*/
GWL_INFPRM_ID = 1;
CALL GET_PARM_INFO;
(IF GWL_INFPRM_STATUS ^= TDS_RETURN_VALUE AND
IF GWL_INFPRM_STATUS ^= TDS_RETURN_VALUE_NULLABLE) THEN
DO;
CALL TDINFPRM_NOT_RETURN_PARM_ERROR;
GO TO END_PROGRAM;
END;
GWL_SETPRM_USER_DATA = GWL_INFPRM_USER_DATA;
GWL_SETPRM_ID = GWL_INFPRM_ID;
GWL_SETPRM_DATA_L = GWL_INFPRM_DATA_L;
GWL_SETPRM_TYPE = GWL_INFPRM_TYPE;
/* ------------------------------------------------------------*/
/* get department id parameter number from known name */
/* ------------------------------------------------------------*/
GWL_INFPRM_NAME = '@parm2';
GWL_INFPRM_NAME_L = 6;
CALL TDLOCPRM (GWL_PROC,
GWL_INFPRM_ID,
GWL_INFPRM_NAME,
GWL_INFPRM_NAME_L);
/* ------------------------------------------------------------*/
/* get department parameter information */
/* ------------------------------------------------------------*/
CALL GET_PARM_INFO;
IF GWL_INFPRM_TYPE ^= TDSVARYCHAR THEN
DO;
CALL TDINFPRM_NOT_CHAR_PARM_ERROR;
GO TO END_PROGRAM;
END;
/* ------------------------------------------------------------*/
/* get department parameter data */
/* ------------------------------------------------------------*/
CALL TDRCVPRM (GWL_PROC, GWL_RC,
GWL_INFPRM_ID,
PARM_DEPT,
GWL_INFPRM_TYPE,
GWL_INFPRM_MAX_DATA_L,
GWL_RCVPRM_DATA_L);
/*------------------------------------------------------------------*/
OPEN_DB2_CURSOR:
/*------------------------------------------------------------------*/
EXEC SQL OPEN ECURSOR;
IF SQLCODE ^= 0 THEN
DO;
CALL OPEN_ERROR;
GO TO END_PROGRAM;
END;
/*------------------------------------------------------------------*/
SETUP_REPLY_COLUMNS:
/*------------------------------------------------------------------*/
DB_DESCRIBE_HV_PTR = ADDR(EMPLOYEE_FNM);
DB_COLUMN_NAME_HV_PTR = ADDR(CN_FNM);
WRKLEN1 = STG(EMPLOYEE_FNM)-2;
WRKLEN2 = STG(CN_FNM);
DB_HOST_TYPE = TDSVARYCHAR;
DB_CLIENT_TYPE = TDSVARYCHAR;
CALL DESCRIBE_COLUMN;
/* ------------------------------------------------------------*/
/* Here we let TDESCRIB convert from DB2 varchar (TDSVARYCHAR) */
/* to DBCHAR. */
/* ------------------------------------------------------------*/
DB_DESCRIBE_HV_PTR = ADDR(EMPLOYEE_LNM);
DB_COLUMN_NAME_HV_PTR = ADDR(CN_LNM);
WRKLEN1 = STG(EMPLOYEE_LNM)-2;
WRKLEN2 = STG(CN_LNM);
DB_HOST_TYPE = TDSVARYCHAR;
DB_CLIENT_TYPE = TDSCHAR;
CALL DESCRIBE_COLUMN;
DB_DESCRIBE_HV_PTR = ADDR(EMPLOYEE_ED);
DB_COLUMN_NAME_HV_PTR = ADDR(CN_ED);
WRKLEN1 = STG(EMPLOYEE_ED);
WRKLEN2 = STG(CN_ED);
DB_HOST_TYPE = TDSINT2;
DB_CLIENT_TYPE = TDSINT2;
CALL DESCRIBE_COLUMN;
/* ------------------------------------------------------------*/
/* Get the user defined datatype of EMPLOYEE_ED column. */
/* ------------------------------------------------------------*/
CALL TDINFUDT (GWL_PROC, GWL_RC,
CTR_COLUMN,
GWL_INFUDT_USER_TYPE);
/* ------------------------------------------------------------*/
/* Set the user defined datatype of EMPLOYEE_ED column. */
/* ------------------------------------------------------------*/
CALL TDSETUDT (GWL_PROC, GWL_RC,
CTR_COLUMN,
GWL_INFUDT_USER_TYPE);
/* ------------------------------------------------------------*/
/* Here we let TDESCRIB convert from TDSDECIMAL to TDSFLT8. */
/* ------------------------------------------------------------*/
DB_DESCRIBE_HV_PTR = ADDR(EMPLOYEE_JC);
DB_COLUMN_NAME_HV_PTR = ADDR(CN_JC);
WRKLEN1 = STG(EMPLOYEE_JC);
WRKLEN2 = STG(CN_JC);
DB_HOST_TYPE = TDSDECIMAL;
DB_CLIENT_TYPE = TDSFLT8;
CALL DESCRIBE_COLUMN;
/* ------------------------------------------------------------*/
/* We must inform the Server Library how many decimal places */
/* are in the EMPLOYEE_JC column. */
/* ------------------------------------------------------------*/
CALL TDSETBCD (GWL_PROC, GWL_RC,
TDS_OBJECT_COL,
CTR_COLUMN,
TDS_DEFAULT_LENGTH,
GWL_SETBCD_SCALE);
/* ------------------------------------------------------------*/
/* Demonstrate getting decimal column information. */
/* ------------------------------------------------------------*/
CALL TDINFBCD (GWL_PROC, GWL_RC,
TDS_OBJECT_COL,
CTR_COLUMN,
GWL_INFBCD_LENGTH,
GWL_INFBCD_SCALE);
/* ------------------------------------------------------------*/
/* Here we intend to use TDCONVRT to convert from TDSDECIMAL to*/
/* TDSMONEY, so we point TDESCRIB to the output of TDCONVRT, */
/* rather than the original input. */
/* ------------------------------------------------------------*/
DB_DESCRIBE_HV_PTR = ADDR(WRK_EMPLOYEE_SAL);
DB_COLUMN_NAME_HV_PTR = ADDR(CN_SAL);
WRKLEN1 = STG(WRK_EMPLOYEE_SAL);
WRKLEN2 = STG(CN_SAL);
DB_HOST_TYPE = TDSMONEY;
DB_CLIENT_TYPE = TDSMONEY;
CALL DESCRIBE_COLUMN;
/*------------------------------------------------------------------*/
SEND_ROWS:
/*------------------------------------------------------------------*/
DO WHILE(^ ALL_DONE);
CALL FETCH_AND_SEND_ROWS;
END;
/*------------------------------------------------------------------*/
END_OF_QUERY:
/*------------------------------------------------------------------*/
/* ------------------------------------------------------------*/
/* close cursor */
/* ------------------------------------------------------------*/
EXEC SQL CLOSE ECURSOR;
/* ------------------------------------------------------------*/
/* update return parameter with nr of rows fetched */
/* ------------------------------------------------------------*/
CALL TDSETPRM (GWL_PROC, GWL_RC,
GWL_SETPRM_ID,
GWL_SETPRM_TYPE,
GWL_SETPRM_DATA_L,
PARM_RETURN_ROWS,
GWL_SETPRM_USER_DATA);
GO TO END_PROGRAM;
/*------------------------------------------------------------------*/
FETCH_AND_SEND_ROWS: PROC;
/*------------------------------------------------------------------*/
EXEC SQL FETCH ECURSOR INTO :EMPLOYEE_FIELDS;
IF SQLCODE = 0 THEN
DO;
/* --------------------------------------------------------*/
/* Convert from DB2 decimal (TDSDECIMAL) to dblib MONEY. */
/* --------------------------------------------------------*/
WRKLEN1 = STG(EMPLOYEE_SAL);
WRKLEN2 = STG(WRK_EMPLOYEE_SAL);
CALL TDCONVRT (GWL_PROC, GWL_RC,
GWL_CONVRT_SCALE,
TDSDECIMAL,
WRKLEN1,
EMPLOYEE_SAL,
TDSMONEY,
WRKLEN2,
WRK_EMPLOYEE_SAL);
/* --------------------------------------------------------*/
/* Do not send trailing blanks of EMPLOYEE_LNM */
/* --------------------------------------------------------*/
WRKLEN1 = LENGTH(EMPLOYEE_LNM);
CTR_COLUMN = 2;
WRK_BLANKS_SS = 1;
LOOP: DO WHILE(WRK_BLANKS_SS <= WRKLEN1);
IF SUBSTR(EMPLOYEE_LNM, WRK_BLANKS_SS, 1) = ' ' THEN DO;
LEAVE LOOP;
END;
WRK_BLANKS_SS = WRK_BLANKS_SS + 1;
END LOOP;
IF (WRK_BLANKS_SS <= WRKLEN1) THEN DO;
CALL TDSETLEN (GWL_PROC, GWL_RC,
CTR_COLUMN,
WRK_BLANKS_SS - 1);
END;
/* --------------------------------------------------------*/
/* send a row to the client */
/* --------------------------------------------------------*/
CALL TDSNDROW (GWL_PROC, GWL_RC);
PARM_RETURN_ROWS = PARM_RETURN_ROWS + 1;
IF GWL_RC = TDS_CANCEL_RECEIVED THEN
DO;
ALL_DONE = ALL_DONE_YES;
END;
END;
ELSE IF SQLCODE = +100 THEN
DO;
ALL_DONE = ALL_DONE_YES;
END;
ELSE IF SQLCODE < 0 THEN
DO;
ALL_DONE = ALL_DONE_YES;
CALL FETCH_ERROR;
END;
RETURN;
END FETCH_AND_SEND_ROWS;
/*------------------------------------------------------------------*/
GET_PARM_INFO: PROC;
/*------------------------------------------------------------------*/
CALL TDINFPRM (GWL_PROC, GWL_RC,
GWL_INFPRM_ID,
GWL_INFPRM_TYPE,
GWL_INFPRM_DATA_L,
GWL_INFPRM_MAX_DATA_L,
GWL_INFPRM_STATUS,
GWL_INFPRM_NAME,
GWL_INFPRM_NAME_L,
GWL_INFPRM_USER_DATA);
RETURN;
END GET_PARM_INFO;
/*------------------------------------------------------------------*/
DESCRIBE_COLUMN: PROC;
/*------------------------------------------------------------------*/
CTR_COLUMN = CTR_COLUMN +1;
CALL TDESCRIB (GWL_PROC, GWL_RC,
CTR_COLUMN,
DB_HOST_TYPE,
WRKLEN1,
DB_DESCRIBE_HV,
DB_NULL_INDICATOR,
TDS_FALSE,
DB_CLIENT_TYPE,
WRKLEN1,
DB_COLUMN_NAME_HV,
WRKLEN2);
RETURN;
END DESCRIBE_COLUMN;
/*------------------------------------------------------------------*/
TDGETUSR_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_TEXT = MSG_NOT_AUTH;
MSG_TEXT_L = STG(MSG_NOT_AUTH);
CALL SEND_ERROR_MESSAGE;
RETURN;
END TDGETUSR_ERROR;
/*------------------------------------------------------------------*/
TDRESULT_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_TEXT = MSG_NOT_RPC;
MSG_TEXT_L = STG(MSG_NOT_RPC);
CALL SEND_ERROR_MESSAGE;
RETURN;
END TDRESULT_ERROR;
/*------------------------------------------------------------------*/
TDNUMPRM_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_TEXT = MSG_WRONG_NR_PARMS;
MSG_TEXT_L = STG(MSG_WRONG_NR_PARMS);
CALL SEND_ERROR_MESSAGE;
RETURN;
END TDNUMPRM_ERROR;
/*------------------------------------------------------------------*/
TDINFPRM_NOT_RETURN_PARM_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_TEXT = MSG_NOT_RETURN_PARM;
MSG_TEXT_L = STG(MSG_NOT_RETURN_PARM);
CALL SEND_ERROR_MESSAGE;
RETURN;
END TDINFPRM_NOT_RETURN_PARM_ERROR;
/*------------------------------------------------------------------*/
TDINFPRM_NOT_CHAR_PARM_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_TEXT = MSG_NOT_CHAR_PARM;
MSG_TEXT_L = STG(MSG_NOT_CHAR_PARM);
CALL SEND_ERROR_MESSAGE;
RETURN;
END TDINFPRM_NOT_CHAR_PARM_ERROR;
/*------------------------------------------------------------------*/
OPEN_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_TEXT = MSG_BAD_CURSOR;
MSG_TEXT_L = STG(MSG_BAD_CURSOR);
CALL SEND_ERROR_MESSAGE;
CALL SEND_SQL_ERROR;
RETURN;
END OPEN_ERROR;
/*------------------------------------------------------------------*/
FETCH_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_TEXT = MSG_BAD_FETCH;
MSG_TEXT_L = STG(MSG_BAD_FETCH);
CALL SEND_ERROR_MESSAGE;
CALL SEND_SQL_ERROR;
RETURN;
END FETCH_ERROR;
/*------------------------------------------------------------------*/
SEND_SQL_ERROR: PROC;
/*------------------------------------------------------------------*/
MSG_SQL_ERROR_C = SQLCODE;
MSG_SQLERRM = SQLERRM;
/* ------------------------------------------------------------*/
/* ensure possible non-printables translated to spaces */
/* ------------------------------------------------------------*/
DO MSG_SQL_ERROR_SS = 1 TO LENGTH(SQLERRM);
IF MSG_SQLERRM_CHARS(MSG_SQL_ERROR_SS) < ' ' |
MSG_SQLERRM_CHARS(MSG_SQL_ERROR_SS) > '9' THEN
DO;
MSG_SQLERRM_CHARS(MSG_SQL_ERROR_SS) = ' ';
END;
END;
MSG_SQL_ERROR_K = MSG_SQLERRM;
MSG_TEXT = STRING(MSG_SQL_ERROR);
MSG_TEXT_L = STG(MSG_SQL_ERROR);
CALL SEND_ERROR_MESSAGE;
RETURN;
END SEND_SQL_ERROR;
/*------------------------------------------------------------------*/
SEND_ERROR_MESSAGE: PROC;
/*------------------------------------------------------------------*/
SEND_DONE = SEND_DONE_ERROR;
MSG_SEVERITY = MSG_SEVERITY_ERROR;
MSG_NR = MSG_NR_ERROR;
MSG_TYPE = TDS_ERROR_MSG;
CALL SEND_MESSAGE;
RETURN;
END SEND_ERROR_MESSAGE;
/*------------------------------------------------------------------*/
SEND_MESSAGE: PROC;
/*------------------------------------------------------------------*/
/* ------------------------------------------------------------*/
/* ensure we're in right state to send a message */
/* ------------------------------------------------------------*/
CALL TDSTATUS (GWL_PROC, GWL_RC,
GWL_STATUS_NR,
GWL_STATUS_DONE,
GWL_STATUS_COUNT,
GWL_STATUS_COMM,
GWL_STATUS_RETURN_CODE,
GWL_STATUS_SUBCODE);
IF GWL_RC = TDS_OK THEN
DO;
IF GWL_STATUS_COMM = TDS_RECEIVE THEN
CALL TDSNDMSG (GWL_PROC, GWL_RC,
MSG_TYPE, MSG_NR,
MSG_SEVERITY,
TDS_ZERO,
TDS_ZERO,
MSG_RPC, MSG_RPC_L,
MSG_TEXT, MSG_TEXT_L);
END;
RETURN;
END SEND_MESSAGE;
/*------------------------------------------------------------------*/
END_PROGRAM:
/*------------------------------------------------------------------*/
IF SEND_DONE = SEND_DONE_OK THEN
WRK_DONE_STATUS = TDS_DONE_COUNT;
ELSE
DO;
WRK_DONE_STATUS = TDS_DONE_ERROR;
PARM_RETURN_ROWS = 0;
END;
CALL TDSNDDON (GWL_PROC, GWL_RC,
WRK_DONE_STATUS,
PARM_RETURN_ROWS,
TDS_ZERO,
TDS_ENDRPC);
CALL TDFREE (GWL_PROC, GWL_RC);
EXEC CICS RETURN;
END SYSAMP1;
