|
Topics: |
These examples illustrate how to set up a COBOL2 application that sends requests for data to a server through the Extender for Db2. The examples are:
|
Topics: |
The sample COBOL2 program, XTDCOB, performs the following:
XTDCOB can be run in the following modes:
You can enter the following commands in SYSIN DD for a Prepared SQL statement or an Execute Immediate statement.
+------------------------------------------+ | Available Commands: | | | | Prepared SQL statement Syntax: | | SQL <sql statement> | | END | | | | Execute Immediate Syntax: | | IMM <sql statement> | | END | | | | Type EXIT to exit this program. | +-----------------------------------------+
XTDCOB contains DEBUG and BATCH options for XTDPRM DD.
DEBUG=Y|N
where:
Displays COBOL debugging messages.
Does not display the debugging messages. This is the default value.
BATCH=Y|N
where:
Echoes input commands back to SYSOUT DD.
Does not echo input commands (interactive mode). This is the default value.
Note: The sample program can retrieve numeric and alpha columns, but it does not convert numeric columns into a displayable format. Therefore, the output of a numeric column appears in its internal binary representation. For example, the number 12 could be represented as 000C (undisplayable).
A sample XTDCOB program is provided at qualif.HOME.DATA(XTDCOB) follows:
IDENTIFICATION DIVISION. 00370099
PROGRAM-ID. XTDCOB. 00380099
AUTHOR. YANKO CASELLA. 00390099
ENVIRONMENT DIVISION. 00400099
CONFIGURATION SECTION. 00410099
SOURCE-COMPUTER. IBM-370. 00420099
OBJECT-COMPUTER. IBM-370. 00430099
INPUT-OUTPUT SECTION. 00440099
FILE-CONTROL. 00450099
SELECT XTDPRM 00460099
ASSIGN TO XTDPRM. 00470099
SELECT DBGOUT 00471099
ASSIGN TO DBGOUT. 00472099
DATA DIVISION. 00473099
FILE SECTION. 00474099
FD XTDPRM 00475099
RECORD CONTAINS 80 CHARACTERS 00476099
BLOCK CONTAINS 0 RECORDS 00477099
LABEL RECORDS ARE OMITTED 00478099
RECORDING MODE IS F. 00479099
01 PRMREC PIC X(80). 00480099
00490099
FD DBGOUT 00500099
RECORD CONTAINS 132 CHARACTERS 00510099
BLOCK CONTAINS 0 RECORDS 00520099
LABEL RECORDS ARE OMITTED 00530099
RECORDING MODE IS F. 00540099
01 MSGREC PIC X(132). 00550099
00550199
WORKING-STORAGE SECTION. 00570099
01 MSGERR PIC X(132). 00580099
77 MSGNUM PIC -ZZZ,ZZZ,ZZ9. 00590099
77 MSGBLK PIC X(132) VALUE SPACES. 00600099
77 MSGLEN PIC 9(4) VALUE 132. 00610099
00610199
01 SLCT-STMT. 00610799
49 SLCT-LENGTH PIC S9(04) COMP-5. 00610899
49 SLCT-STRING PIC X(32700). 00610999
00611099
01 SYSIN-STRING. 00611499
05 SYSIN-CMD PIC X(04). 00611599
05 SYSIN-LINE PIC X(76). 00611699
0061179901 REXX-PARMS. 00612099
05 FILLER PIC X(6) VALUE "DEBUG=". 00613099
05 DEBUG-YES PIC X. 00614099
05 FILLER PIC X(7) VALUE ",BATCH=". 00615099
05 BATCH-YES PIC X. 00616099
05 FILLER PIC X(65). 00617099
******************************************************** 00618099
* STRUCTURE FOR INPUT * 00619099
******************************************************** 00620099
01 IOAREA. 00630099
02 TNAME PIC X(72). 00640099
02 FILLER PIC X(08). 00650099
00660099
*********************************************************** 00670099
* VARIABLES FOR ERROR-MESSAGE FORMATTING * 00680099
*********************************************************** 00690099
01 ERROR-MESSAGE. 00700099
02 ERROR-LEN PIC S9(4) COMP VALUE +960. 00710099
02 ERROR-TEXT PIC X(120) OCCURS 8 TIMES 00720099
INDEXED BY ERROR-INDEX. 00730099
77 ERROR-TEXT-LEN PIC S9(8) COMP VALUE +120. 00740099
*********************************************************** 00750099
* SQLDA * 00760099
*********************************************************** 00770099
01 SQLDA. 00780099
02 SQLDAID PIC X(08) VALUE "SQLDA ". 00790099
02 SQLDABC PIC S9(08) COMP VALUE 33016. 00800099
02 SQLN PIC S9(04) COMP VALUE 750. 00810099
02 SQLD PIC S9(04) COMP VALUE 0. 00820099
02 SQLVAR OCCURS 1 TO 750 TIMES 00830099
DEPENDING ON SQLN. 00840099
03 SQLTYPE PIC S9(04) COMP. 00850099
03 SQLLEN PIC S9(04) COMP. 00860099
03 SQLDATA POINTER. 00870099
03 SQLIND POINTER. 00880099
03 SQLNAME. 00890099
49 SQLNAMEL PIC S9(04) COMP. 00900099
49 SQLNAMEC PIC X(30). 00910099
00920099
77 VARCTYPE PIC S9(4) COMP VALUE +448. 00930099
77 CHARTYPE PIC S9(4) COMP VALUE +452. 00940099
77 VARLTYPE PIC S9(4) COMP VALUE +456. 00950099
77 VARGTYPE PIC S9(4) COMP VALUE +464. 00960099
77 GTYPE PIC S9(4) COMP VALUE +468. 00970099
77 LVARGTYP PIC S9(4) COMP VALUE +472. 00980099
77 FLOATYPE PIC S9(4) COMP VALUE +480. 00990099
77 DECTYPE PIC S9(4) COMP VALUE +484. 01000099
77 INTTYPE PIC S9(4) COMP VALUE +496. 01010099
77 HWTYPE PIC S9(4) COMP VALUE +500. 01020099
77 DATETYP PIC S9(4) COMP VALUE +384. 01030099
77 MDTTIMTP PIC S9(4) COMP VALUE +397. 01040099
01050099
01 TITLE-REC. 01060099
02 TITLE-LEN PIC S9(4) COMP. 01070099
02 TITLE-LINE PIC X(132). 01080099
02 TITLE-SEP PIC X(132) VALUE ALL "_". 01080199
01081099
01 SQLDATA-REC. 01091099
02 REC1-LEN PIC S9(8) COMP. 01092099
02 REC1-CHAR PIC X(1) OCCURS 1 TO 32700 TIMES 01093299
DEPENDING ON REC1-LEN. 01094099
01 SQLDATA-IND. 01100099
02 IND PIC S9(04) COMP OCCURS 750 TIMES. 01110099
01120099
01 RECPTR POINTER. 01130099
01 RECNUM REDEFINES RECPTR PIC S9(9) COMP. 01140099
01 I PIC S9(4) COMP. 01150099
01 DUMMY PIC S9(4) COMP. 01160099
01 MYTYPE PIC S9(4) COMP. 01170099
01 COLUMN-IND PIC S9(4) COMP. 01180099
01 COLUMN-LEN PIC S9(4) COMP. 01190099
01 COLUMN-PREC PIC S9(4) COMP. 01200099
01 COLUMN-SCALE PIC S9(4) COMP. 01210099
01 INDCOUNT PIC S9(4) COMP. 01220099
01 ROWCOUNT PIC S9(9) COMP. 01230099
01 WORKAREA2. 01240099
02 WORKINDPTR POINTER OCCURS 750 TIMES. 01250099
01260099
EXEC SQL 01270099
DECLARE SLCT-CSR CURSOR FOR SLCT-CSR-STMT 01280099
END-EXEC. 01290099
01300099
EXEC SQL 01310099
DECLARE SLCT-CSR-STMT STATEMENT 01320099
END-EXEC. 01330099
01340099
EXEC SQL INCLUDE SQLCA END-EXEC. 01350099
01360099
77 ONE PIC S9(4) COMP VALUE +1. 01380099
77 TWO PIC S9(4) COMP VALUE +2. 01390099
77 FOUR PIC S9(4) COMP VALUE +4. 01400099
77 QMARK PIC X VALUE "?". 01401099
77 LAST-CMD PIC X(4). 01410099
01420099LINKAGE SECTION. 01430099
01 SQLDATA-BLANK. 01440099
02 INDREC PIC X(1). 01450099
01460099
PROCEDURE DIVISION. 01470099
01480099
***************************************************** 01490099
* SQL RETURN CODE HANDLING * 01500099
***************************************************** 01510099
EXEC SQL WHENEVER SQLERROR GOTO DBERROR END-EXEC. 01520099
EXEC SQL WHENEVER NOT FOUND CONTINUE END-EXEC. 01540099
01550099
OPEN INPUT XTDPRM. 01560099
READ XTDPRM INTO REXX-PARMS. 01570099
CLOSE XTDPRM. 01580099
01590099
IF DEBUG-YES = 'Y' THEN 01600099
OPEN OUTPUT DBGOUT. 01610099
01620099
DISPLAY "+---------------------------------+". 01630099
DISPLAY "| Available Commands: |". 01640099
DISPLAY "| |". 01650099
DISPLAY "| Prepared SQL statement Syntax: |". 01660099
DISPLAY "| SQL <sql statement> |". 01670099
DISPLAY "| END |". 01680099
DISPLAY "| |". 01690099
DISPLAY "| Execute Immediate Syntax: |". 01700099
DISPLAY "| IMM <sql statement> |". 01710099
DISPLAY "| END |". 01720099
DISPLAY "| |". 01730099
DISPLAY "| Type EXIT to exit this program. |". 01740099
DISPLAY "+---------------------------------+". 01750099
DISPLAY " ". 01760099
MOVE ONE TO SLCT-LENGTH. 01770099
01780099
MAIN-LOOP. 01790099
01800099
DISPLAY "Type Command To Be Processed:". 01810099
DISPLAY " ". 01820099
MOVE SPACES TO LAST-CMD. 01830099
01840099
READ-SQL. 01850099
ACCEPT SYSIN-STRING FROM SYSIN. 01860099
IF BATCH-YES = 'Y' THEN 01870099
DISPLAY SYSIN-STRING. 01880099
01890099
EVALUATE FUNCTION UPPER-CASE (SYSIN-CMD) 01900099
WHEN "SQL " 01910099
MOVE "SQL " TO LAST-CMD 01920099
MOVE ONE TO SLCT-LENGTH 01930099
STRING SYSIN-LINE DELIMITED BY SIZE 01940099
INTO SLCT-STRING WITH POINTER SLCT-LENGTH 01950099
GO TO READ-SQL 01960099
01970099
WHEN "IMM " 01980099
MOVE "IMM " TO LAST-CMD 01990099
MOVE ONE TO SLCT-LENGTH 02000099
STRING SYSIN-LINE DELIMITED BY SIZE 02010099
INTO SLCT-STRING WITH POINTER SLCT-LENGTH 02020099
GO TO READ-SQL 02030099
02040099
WHEN "EXIT" 02050099
GO TO PROG-END 02060099
02070099
WHEN "END " 02080099
SUBTRACT ONE FROM SLCT-LENGTH 02090099
02100099
IF DEBUG-YES = 'Y' THEN 02110099
STRING "LAST-CMD = ", LAST-CMD, MSGBLK 02120099
DELIMITED BY MSGLEN INTO MSGERR 02130099
WRITE MSGREC FROM MSGERR 02140099
MOVE SLCT-LENGTH TO MSGNUM 02150099
STRING "IN READ-SQL SLCT-LENGTH = ", MSGNUM, MSGBLK0 02160099
DELIMITED BY MSGLEN INTO MSGERR 02170099
WRITE MSGREC FROM MSGERR 02180099
STRING "IN READ-SQL SLCT-STRING = ", SLCT-STRING, 02190099
MSGBLK DELIMITED BY MSGLEN INTO MSGERR 02200099
WRITE MSGREC FROM MSGERR 02210099
END-IF 02220099
02230099
EVALUATE LAST-CMD 02240099
02250099
WHEN "SQL " 02260099
PERFORM PROCESS-INPUT THROUGH IND-RESULT 02270099
WHEN "IMM " 02280099
PERFORM IMMED-SQL THROUGH PRINT-ROWS 02290099
END-EVALUATE 02300099
GO TO MAIN-LOOP 02310099
02320099
WHEN OTHER 02330099
STRING SYSIN-STRING DELIMITED BY SIZE 02340099
INTO SLCT-STRING WITH POINTER SLCT-LENGTH 02350099
GO TO READ-SQL 02360099
END-EVALUATE. 02370099
02380099 PROG-END. 02390099
IF DEBUG-YES = 'Y' THEN 02400099
CLOSE DBGOUT. 02410099
GOBACK. 02420099
*********************************************************** 02430099
* PREPARE * 02440099
*********************************************************** 02450099
PROCESS-INPUT. 02460099
EXEC SQL 02470099
PREPARE SLCT-CSR-STMT 02480099
INTO :SQLDA 02490099
FROM :SLCT-STMT 02500099
END-EXEC. 02510099
**************************************************************** 02520099
* SET UP ADDRESSES IN THE SQLDA FOR DATA * 02530099
**************************************************************** 02540099
IF DEBUG-YES = 'Y' THEN 02550099
MOVE SQLD TO MSGNUM 02560099
STRING "IN PROCESS-INPUT SQLD = ", MSGNUM, MSGBLK 02570099
DELIMITED BY MSGLEN INTO MSGERR 02580099
WRITE MSGREC FROM MSGERR 02590099
MOVE SQLN TO MSGNUM 02600099
STRING "IN PROCESS-INPUT SQLN = ", MSGNUM, MSGBLK 02610099
DELIMITED BY MSGLEN INTO MSGERR 02620099
WRITE MSGREC FROM MSGERR. 02630099
**************************************************************** 02640099
* IF STATEMENT IS NOT SELECT, EXECUTE STMT * 02650099
**************************************************************** 02660099
IF SQLD = ZERO THEN 02670099
GO TO NOT-A-SELECT. 02680099
02690099
DISPLAY " " 02700099
MOVE ZERO TO ROWCOUNT. 02710099
MOVE ZERO TO REC1-LEN. 02720099
SET RECPTR TO ADDRESS OF REC1-CHAR(1). 02730099
MOVE ONE TO I. 02740099
INITIALIZE TITLE-LINE. 02740199
MOVE ONE TO TITLE-LEN. 02741099
PERFORM COLADDR UNTIL I > SQLD. 02750099
MOVE SPACES TO SQLDATA-REC(5:REC1-LEN). 02750199
DISPLAY TITLE-LINE. 02750299
DISPLAY TITLE-SEP. 02751099************************************************************ 02760099
* SET LENGTH OF OUTPUT RECORD. * 02770099
* OPEN CURSOR * 02780099
************************************************************ 02790099
02800099
EXEC SQL OPEN SLCT-CSR END-EXEC. 02810099
02820099
*********************************************************** 02830099
* FETCH * 02840099
*********************************************************** 02850099
IF DEBUG-YES = 'Y' THEN 02860099
STRING "AT FETCH.....", MSGBLK DELIMITED BY MSGLEN 02870099
INTO MSGERR 02880099
WRITE MSGREC FROM MSGERR. 02890099
02900099
EXEC SQL 02910099
FETCH SLCT-CSR 02920099
USING DESCRIPTOR :SQLDA 02930099
END-EXEC. 02940099
02950099
IF SQLCODE = ZERO THEN 02960099
PERFORM WRITE-AND-FETCH 02970099
UNTIL SQLCODE IS NOT EQUAL TO ZERO. 02980099
02990099
MOVE ROWCOUNT TO MSGNUM 03000099
DISPLAY " " 03010099
DISPLAY "***** NUMBER OF RECORDS IN TABLE=" MSGNUM " *****" 03020099
DISPLAY " " 03030099
03040099
IF DEBUG-YES = 'Y' THEN 03050099
STRING "LEAVING FETCH.....", MSGBLK 03060099
DELIMITED BY MSGLEN INTO MSGERR 03070099
WRITE MSGREC FROM MSGERR. 03080099
03090099
CLOSEDT. 03100099
IF DEBUG-YES = 'Y' THEN 03110099
STRING "AT CLOSEDT.....", MSGBLK 03120099
DELIMITED BY MSGLEN INTO MSGERR 03130099
WRITE MSGREC FROM MSGERR. 03140099
03150099
EXEC SQL CLOSE SLCT-CSR END-EXEC. 03160099
03170099
IND-RESULT. 03180099
IF DEBUG-YES = 'Y' THEN 03190099
STRING "AT IND-RESULT. RETURNING TO MAIN LOOP.", MSGBLK 03200099
DELIMITED BY MSGLEN INTO MSGERR 03210099
WRITE MSGREC FROM MSGERR. 03220099
03230099WRITE-AND-FETCH. 03240099
IF DEBUG-YES = 'Y' THEN 03250099
STRING "AT WRITE-AND-FETCH.....", MSGBLK 03260099
DELIMITED BY MSGLEN INTO MSGERR 03270099
WRITE MSGREC FROM MSGERR. 03280099
03290099
MOVE ONE TO INDCOUNT. 03300099
PERFORM NULLCHK UNTIL INDCOUNT > SQLD. 03310099
03320099
IF DEBUG-YES = 'Y' THEN 03330099
STRING "SQLDATA-REC = ", SQLDATA-REC, MSGBLK 03340099
DELIMITED BY MSGLEN INTO MSGERR 03350099
WRITE MSGREC FROM MSGERR. 03360099
03370099
DISPLAY SQLDATA-REC(5:REC1-LEN). 03380099
MOVE SPACES TO SQLDATA-REC(5:REC1-LEN). 03390099
ADD ONE TO ROWCOUNT. 03420099
03430099
EXEC SQL 03440099
FETCH SLCT-CSR 03450099
USING DESCRIPTOR :SQLDA 03460099
END-EXEC. 03470099
03480099
IF DEBUG-YES = 'Y' THEN 03490099
STRING "IN WRITE-AND-FETCH SQLDA = ", SQLDA, MSGBLK 03500099
DELIMITED BY MSGLEN INTO MSGERR 03510099
WRITE MSGREC FROM MSGERR 03520099
03530099
STRING "LEAVING WRITE-AND-FETCH.....", MSGBLK 03540099
DELIMITED BY MSGLEN INTO MSGERR 03550099
ITE MSGREC FROM MSGERR. 03560099
NULLCHK. 03570099
IF DEBUG-YES = 'Y' THEN 03580099
STRING "AT NULLCHK.....", MSGBLK 03590099
DELIMITED BY MSGLEN INTO MSGERR 03600099
WRITE MSGREC FROM MSGERR 03610099
03620099
MOVE IND(INDCOUNT) TO MSGNUM 03630099
STRING "IN NULLCHK IND(INDCOUNT) = ", MSGNUM, MSGBLK 03640099
DELIMITED BY MSGLEN INTO MSGERR 03650099
WRITE MSGREC FROM MSGERR. 03660099
03690199
IF IND(INDCOUNT) < 0 THEN 03691099
SET ADDRESS OF SQLDATA-BLANK TO WORKINDPTR(INDCOUNT) 03692099
MOVE QMARK TO INDREC. 03700099
03710099IF DEBUG-YES = 'Y' THEN 03720099
MOVE INDCOUNT TO MSGNUM 03730099
STRING "IN NULLCHK AFTER IF - INDCOUNT = ", MSGNUM, MSGBLK 03740099
DELIMITED BY MSGLEN INTO MSGERR 03750099
WRITE MSGREC FROM MSGERR. 03760099
03770099
ADD ONE TO INDCOUNT. 03780099
03790099
IF DEBUG-YES = 'Y' THEN 03800099
STRING "LEAVING NULLCHK....", MSGBLK 03810099
DELIMITED BY MSGLEN INTO MSGERR 03820099
WRITE MSGREC FROM MSGERR. 03830099
03850699
COLADDR. 03851099
IF DEBUG-YES = 'Y' THEN 03860099
STRING "AT COLADDR.....", MSGBLK 03870099
DELIMITED BY MSGLEN INTO MSGERR 03880099
WRITE MSGREC FROM MSGERR. 03890099
03900099
SET SQLDATA(I) TO RECPTR. 03940099
**************************************************************** 03950099
* DETERMINE LENGTH OF COLUMN (COLUMN-LEN) * 03960099
**************************************************************** 03970099
MOVE SQLLEN(I) TO COLUMN-LEN. 03980099
**************************************************************** 03990099
* COLUMN-IND IS 0 FOR NO NULLS AND 1 FOR NULLS * 04000099
**************************************************************** 04010099
DIVIDE SQLTYPE(I) BY TWO GIVING DUMMY REMAINDER COLUMN-IND. 04020099
**************************************************************** 04030099
* MYTYPE IS JUST THE SQLTYPE WITHOUT THE NULL BIT * 04040099
**************************************************************** 04050099
MOVE SQLTYPE(I) TO MYTYPE. 04060099
04070099
IF DEBUG-YES = 'Y' THEN 04080099
MOVE SQLTYPE(I) TO MSGNUM 04090099
STRING "IN COLADDR SQLTYPE(I) = ", MSGNUM, MSGBLK 04100099
DELIMITED BY MSGLEN INTO MSGERR 04110099
WRITE MSGREC FROM MSGERR. 04120099
04130099
SUBTRACT COLUMN-IND FROM MYTYPE. 04140099**************************************************************** 04150099
* SET THE COLUMN LENGTH, DEPENDENT UPON DATA TYPE * 04160099
**************************************************************** 04170099
EVALUATE MYTYPE 04180099
WHEN CHARTYPE CONTINUE, 04190099
WHEN DATETYP THROUGH MDTTIMTP CONTINUE, 04200099
WHEN FLOATYPE CONTINUE, 04210099
WHEN VARCTYPE 04220099
ADD TWO TO COLUMN-LEN, 04230099
WHEN VARLTYPE 04240099
ADD TWO TO COLUMN-LEN, 04250099
WHEN GTYPE 04260099
MULTIPLY COLUMN-LEN BY TWO GIVING COLUMN-LEN, 04270099
WHEN VARGTYPE 04280099
PERFORM CALC-VARG-LEN, 04290099
WHEN LVARGTYP 04300099
PERFORM CALC-VARG-LEN, 04310099
WHEN HWTYPE 04320099
MOVE TWO TO COLUMN-LEN, 04330099
WHEN INTTYPE 04340099
MOVE FOUR TO COLUMN-LEN, 04350099
WHEN DECTYPE 04360099
PERFORM CALC-DECIMAL-LEN, 04370099
WHEN OTHER 04380099
PERFORM UNRECOGNIZED-ERROR, 04390099
END-EVALUATE. 04400099
04410099
IF DEBUG-YES = 'Y' THEN 04420099
MOVE COLUMN-LEN TO MSGNUM 04430099
STRING "IN COLADDR COLUMN-LEN = ", MSGNUM, MSGBLK 04440099
DELIMITED BY MSGLEN INTO MSGERR 04450099
WRITE MSGREC FROM MSGERR. 04460099
04470099
ADD COLUMN-LEN TO RECNUM. 04480099
ADD COLUMN-LEN TO REC1-LEN. 04490099
04490199
STRING SQLNAMEC(I) DELIMITED BY SPACE 04491099
INTO TITLE-LINE POINTER TITLE-LEN. 04491199
STRING SPACE DELIMITED BY SIZE 04491299
INTO TITLE-LINE POINTER TITLE-LEN. 04491399************************************************************* 04500099
*IF THIS COLUMN CAN BE NULL, AN INDICATOR VARIABLE IS NEEDED* 04510099
************************************************************* 04520099
MOVE ZERO TO IND(I) 04530099
IF COLUMN-IND = ONE THEN 04540099
SET SQLIND(I) TO ADDRESS OF IND(I) 04550099
SET WORKINDPTR(I) TO RECPTR 04560099
ADD ONE TO RECNUM 04570099
ADD ONE TO REC1-LEN. 04580099
04583099
ADD ONE TO I. 04590099
04600099
IF DEBUG-YES = 'Y' THEN 04610099
STRING "LEAVING COLADDR....", MSGBLK 04620099
DELIMITED BY MSGLEN INTO MSGERR 04630099
WRITE MSGREC FROM MSGERR. 04640099
************************************************************* 04650099
*CALCULATE COLUMN LENGTH FOR A DECIMAL DATA TYPE COLUMN. * 04660099
************************************************************* 04670099
CALC-DECIMAL-LEN. 04680099
IF DEBUG-YES = 'Y' THEN 04690099
STRING "AT CALC-DECIMAL-LEN....", MSGBLK 04700099
DELIMITED BY MSGLEN INTO MSGERR 04710099
WRITE MSGREC FROM MSGERR. 04720099
04730099
DIVIDE COLUMN-LEN BY 256 GIVING COLUMN-PREC 04740099
REMAINDER COLUMN-SCALE. 04750099
MOVE COLUMN-PREC TO COLUMN-LEN. 04760099
ADD ONE TO COLUMN-LEN. 04770099
DIVIDE COLUMN-LEN BY TWO GIVING COLUMN-LEN. 04780099
04790099
IF DEBUG-YES = 'Y' THEN 04800099
MOVE COLUMN-LEN TO MSGNUM 04810099
STRING "IN CALC-DECIMAL-LEN COLUMN-LEN= ", MSGNUM, MSGBLK 04820099
DELIMITED BY MSGLEN INTO MSGERR 04830099
WRITE MSGREC FROM MSGERR 04840099
04850099
STRING "LEAVING CALC-DECIMAL-LEN....", MSGBLK 04860099
DELIMITED BY MSGLEN INTO MSGERR 04870099
WRITE MSGREC FROM MSGERR. 04880099************************************************************* 04890099
*PERFORM PARAGRAPH TO CALCULATE COLUMN LENGTH * 04900099
*FOR A VARGRAPHIC DATA TYPE COLUMN. * 04910099
************************************************************* 04920099
CALC-VARG-LEN. 04930099
IF DEBUG-YES = 'Y' THEN 04940099
STRING "AT CALC-VARG-LEN.....", MSGBLK 04950099
DELIMITED BY MSGLEN INTO MSGERR 04960099
WRITE MSGREC FROM MSGERR. 04970099
04980099
MULTIPLY COLUMN-LEN BY TWO GIVING COLUMN-LEN. 04990099
ADD TWO TO COLUMN-LEN. 05000099
05010099
IF DEBUG-YES = 'Y' THEN 05020099
STRING "LEAVING CALC-VARG-LEN.....", MSGBLK 05030099
DELIMITED BY MSGLEN INTO MSGERR 05040099
WRITE MSGREC FROM MSGERR. 05050099
************************************************************* 05060099
*PERFORM PARAGRAPH TO NOTE AN UNRECOGNIZED DATA TYPE COLUMN.* 05070099
************************************************************* 05080099
UNRECOGNIZED-ERROR. 05090099
MOVE MYTYPE TO MSGNUM 05100099
DISPLAY "UNRECOGNIZED DATA TYPE = " MSGNUM 05110099
MOVE COLUMN-LEN TO MSGNUM 05120099
DISPLAY " COLUMN-LEN = " MSGNUM 05130099
05140099
GO TO IND-RESULT. 05150099
05160099
NOT-A-SELECT. 05170099
IF DEBUG-YES = 'Y' THEN 05180099
STRING "AT NOT-A-SELECT....", MSGBLK 05190099
DELIMITED BY MSGLEN INTO MSGERR 05200099
WRITE MSGREC FROM MSGERR. 05210099
05220099
EXEC SQL 05230099
EXECUTE SLCT-CSR-STMT USING DESCRIPTOR :SQLDA 05240099
END-EXEC. 05250099
05260099
PERFORM PRINT-ROWS. 05270099
05280099
GO TO IND-RESULT. 05290099
05300099IMMED-SQL. 05310099
IF DEBUG-YES = 'Y' THEN 05320099
STRING "AT IMMED-SQL....", MSGBLK 05330099
DELIMITED BY MSGLEN INTO MSGERR 05340099
WRITE MSGREC FROM MSGERR. 05350099
05360099
EXEC SQL 05370099
EXECUTE IMMEDIATE :SLCT-STMT 05380099
END-EXEC. 05390099
05400099
PRINT-ROWS. 05410099
MOVE SQLERRD(3) TO MSGNUM 05420099
DISPLAY " " 05430099
DISPLAY "***** NUMBER OF ROWS AFFECTED BY REQUEST=" MSGNUM 05440099
" *****" 05450099
DISPLAY " " 05451099
IF DEBUG-YES = 'Y' THEN 05451199
STRING "LEAVING PRINT-ROWS....", MSGBLK 05451299
DELIMITED BY MSGLEN INTO MSGERR 05451399
WRITE MSGREC FROM MSGERR. 05451499
05451599
DBERROR. 05451699
IF DEBUG-YES = 'Y' THEN 05451799
STRING "AT DBERROR.....", MSGBLK 05451899
DELIMITED BY MSGLEN INTO MSGERR 05451999
WRITE MSGREC FROM MSGERR 05452099
MOVE SQLCODE TO MSGNUM 05456099
STRING "SQL ERROR OCCURRED, SQLCODE = ", MSGNUM, 05457099
MSGBLK DELIMITED BY MSGLEN INTO MSGERR 05458099
WRITE MSGREC FROM MSGERR. 05459099
05460099
CALL "DSNTIAR" USING SQLCA ERROR-MESSAGE ERROR-TEXT-LEN. 05470099
05480099
IF RETURN-CODE = ZERO 05490099
PERFORM ERROR-PRINT VARYING ERROR-INDEX 05500099
FROM 1 BY 1 UNTIL ERROR-INDEX GREATER THAN 8 05510099
ELSE 05520099
IF DEBUG-YES = 'Y' THEN 05530099
STRING "DSNT497I RETURN CODE FROM MSG ROUTINE DSNTIAR",05540099
MSGBLK DELIMITED BY MSGLEN INTO MSGERR 05550099
WRITE MSGREC FROM MSGERR 05560099
END-IF 05570099
END-IF. 05580099
05590099
IF DEBUG-YES = 'Y' THEN 05600099
STRING "LEAVING DBERROR....", MSGBLK 05610099
DELIMITED BY MSGLEN INTO MSGERR 05620099
WRITE MSGREC FROM MSGERR. 05630099
05640099
IF LAST-CMD = "SQL " THEN 05650099
GO TO IND-RESULT 05660099
ELSE 05661099
GO TO PRINT-ROWS. 05662099
05663099
ERROR-PRINT. 05664099
IF DEBUG-YES = 'Y' THEN 05665099
STRING "AT ERROR-PRINT....", MSGBLK 05666099
DELIMITED BY MSGLEN INTO MSGERR 05667099
WRITE MSGREC FROM MSGERR. 05668099
05669099
DISPLAY ERROR-TEXT (ERROR-INDEX). 05670099
05680099
IF DEBUG-YES = 'Y' THEN 05690099
STRING "LEAVING ERROR-PRINT....", MSGBLK 05700099
DELIMITED BY MSGLEN INTO MSGERR 05710099
WRITE MSGREC FROM MSGERR. 05720099|
Topics: |
This JCL sample, XTDCLG, precompiles, compiles, link-edits and executes COBOL2 programs containing dynamic SQL with the Extender for Db2. XTDCLG does the following.
The syntax for SYSIN DD is:
+------------------------------------------+ | Available Commands: | | | | Prepared SQL statement Syntax: | | SQL <sql statement> | | END | | | | Execute Immediate Syntax: | | IMM <sql statement> | | END | | | | Type EXIT to exit this program. | +-----------------------------------------+
To link-edit your JCL, perform the following steps.
Note: If an application only processes servers (no local Db2 access), it is not necessary to bind and grant the customer application plan. The server default plan (dynamic plan) is used instead.
//* Job Card Goes Here //* //* Note: DSNELI could be used instead, DSNALI was used * //* arbitrarily. * //* * //*Substitutions: * //* qualif - High level qualifier for DB2 Extender datasets * //* db2hlq - High level qualifier for DB2 libraries. * //* user - High level qualifier for user libraries. * //* dbss - DB2 Subsytem name. * //* hostn - Server's Host name or Server's IP address. * //* portn - TCP/IP Port number server is listening on. * //************************************************************ // SET DB2REL=db2hlq //************************************************************ //* PC XDTCOB //************************************************************ //PC EXEC PGM=DSNHPC, // PARM='HOST(COB2),QUOTE,APOSTSQL,ATTACH(CAF)' //STEPLIB DD DISP=SHR,DSN=&DB2REL..SDSNEXIT // DD DISP=SHR,DSN=&DB2REL..SDSNLOAD //SYSIN DD DISP=SHR,DSN=user.COBOL.SOURCE(XTDCOB) //DBRMLIB DD DISP=SHR,DSN=user.DBRMLIB.DATA(XTDCOB) //SYSCIN DD DSN=&&DSNHOUT,DISP=(MOD,PASS),UNIT=SYSDA, // SPACE=(800,(500,500)) //SYSPRINT DD SYSOUT=* //SYSTERM DD SYSOUT=* //SYSUT1 DD UNIT=SYSDA,SPACE=(800,(500,500),,,ROUND) //SYSUT2 DD UNIT=SYSDA,SPACE=(800,(500,500),,,ROUND) //SYSUT3 DD UNIT=SYSDA,SPACE=(800,(500,500),,,ROUND) //SYSUT4 DD UNIT=SYSDA,SPACE=(800,(500,500),,,ROUND) //SYSUT5 DD UNIT=SYSDA,SPACE=(800,(500,500),,,ROUND)
//********************************************************* //* C O M P I L E //********************************************************* //COB EXEC PGM=IGYCRCTL,COND=(4,LT), // PARM='QUOTE,OBJECT,MAP,LIST,RENT,NODYNAM' //SYSIN DD DSN=&&DSNHOUT,DISP=(OLD,DELETE) //SYSLIN DD DSN=&&LOADSET,DISP=(MOD,PASS),UNIT=SYSDA, // SPACE=(800,(500,500)) //SYSPRINT DD SYSOUT=* //SYSUT1 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) //SYSUT2 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) //SYSUT3 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) //SYSUT4 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) //SYSUT5 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) //SYSUT6 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) //SYSUT7 DD UNIT=SYSDA,SPACE=(CYL,(1,1)) //******************************************************** //* LINKEDIT STEP FOR XTDCOB //******************************************************** //LKEDXTD EXEC PGM=IEWL,PARM='XREF',COND=(4,LT) //SYSLIB DD DISP=SHR,DSN=qualif.HOMEEXT.LOAD // DD DISP=SHR,DSN=&DB2REL..SDSNLOAD // DD DISP=SHR,DSN=CEE.SCEELKED //SYSLMOD DD DISP=SHR,DSN=user.COBOL.LOAD //OBJECT DD DSN=&&LOADSET,DISP=(OLD,DELETE,DELETE) //SYSPRINT DD SYSOUT=* //SYSUT1 DD UNIT=SYSDA,SPACE=(CYL,(10,5)) //SYSLIN DD * INCLUDE SYSLIB(DSNALI) INCLUDE SYSLIB(DSNTIAR) INCLUDE OBJECT MODE AMODE(31),RMODE(ANY) ENTRY XTDCOB NAME XTDCOB(R) /*
//****************************************************
//* BIND STEP FOR XTDCOB
//* (only required to use DB2 directly (NATIVELY))
//****************************************************
//BIND EXEC PGM=IKJEFT01,DYNAMNBR=20,COND=(4,LT)
//STEPLIB DD DSN=&DB2REL..SDSNLOAD,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//DBRMLIB DD DISP=SHR,DSN=user.DBRMLIB.DATA(XTDCOB)
//SYSTSIN DD *
DSN SYSTEM(dbss)
BIND PLAN (XTDCOB) -
MEMBER (XTDCOB) -
LIBRARY ('user.DBRMLIB.DATA') -
ACTION (REPLACE) -
ISOLATION (CS) -
ACQUIRE (USE) -
RELEASE (COMMIT) -
EXPLAIN (YES)
END
/*
//****************************************************
//* GRANT STEP FOR XTDCOB
//* (only required to use DB2 directly (NATIVELY))
//****************************************************
//GRANT EXEC PGM=IKJEFT01,DYNAMNBR=20,COND=(4,LT)
//STEPLIB DD DSN=&DB2REL..SDSNLOAD,DISP=SHR
//SYSPRINT DD SYSOUT=*
//SYSTSPRT DD SYSOUT=*
//SYSTSIN DD *
RUN PROGRAM (DSNTIAD) PLAN (DSNTIA81) -
LIB ('DSN810.RUNLIB.LOAD')
END
/*
//SYSIN DD *
GRANT EXECUTE ON PLAN XTDCOB TO PUBLIC;
/*//********************************************************************
//* RUN STEP for XTDCOB
//********************************************************************
//RUNXTD EXEC PGM=XTDCOB,COND=((4,LT),EVEN)
//STEPLIB DD DISP=SHR,DSN=user.COBOL.LOAD
// DD DISP=SHR,DSN=qualif.HOMEEXT.LOAD
// DD DISP=SHR,DSN=qualif.HOME.LOAD
// DD DISP=SHR,DSN=&DB2REL..SDSNEXIT
// DD DISP=SHR,DSN=&DB2REL..SDSNLOAD
//EDACS3 DD *
NAME = Client Odin File
NODE = EDASERVE
BEGIN
PROTOCOL = TCP
CLASS = CLIENT
HOST = hostn ;Server's Host name or IP address
PORT = portn ;Port # server is listening on
; TRACE = 31
END
/*
//EDAENV DD *
FSTRACE=DD:FSTRACE
EDACONF=/PDS
/*
//EDADPDS DD DUMMY
//*EDAPARMS DD DISP=SHR,DSN=user.EDAPARMS
//IBITRACE DD *
SET TRACEON=ALL
/*
//FSTRACE DD SYSOUT=*,DCB=(LRECL=132,RECFM=FB,BLKSIZE=132)
//SYSOUT DD SYSOUT=*
//DBGOUT DD SYSOUT=*
//XTDPRM DD *
DEBUG=N,BATCH=Y
/*
//SYSIN DD *
SQL
SELECT COUNTRY,CAR,MODEL,BODYTYPE FROM EDASERVE.ANYNAME.CAR
END
SQL
SELECT LAST_NAME,FIRST_NAME FROM EDASERVE.ANYNAME.EMPLOYEE
END
EXIT
/*| WebFOCUS | |
|
Feedback |