Date
Name
Plattform
Language
Kurzbeschreibung
Owner
Link
17.11.2001
DB2TERM.PLI
OS/390
PL/I
DB2/PLI Call Attachment Facility für DB2 Commands
Gernot Ruban
DB2 ist ein Produkt der
IBM Corporation. Bitte Copyright- und Trademark-Hinweise beachten!
/* DB2TERM - DB2 COMMAND INTERFACE */00010000
/*********************************************************************/00020000
/* */00030000
/* APPLICATION: FOR DB2 DBA NEEDS */00040000
/* */00050000
/* FUNCTION : EXECUTES ANY LEGAL DB2 COMMAND (EXCEPT '-STO DB2') */00060000
/* AND REDUCES ELAPSED AND CPU TIME CONSUMPTION CMP'ED */00070000
/* TO DB2 DSN COMMAND PROCESSOR. */00080000
/* */00090000
/* INVOCATION : A) BATCH VIA MVS/ESA JCL: */00100000
/* //CI EXEC PGM=DB2TERM,PARM='/SSID,-CMD' */00110000
/* //STEPLIB DD DSN=YOUR.STEPLIB,DISP=SHR */00120000
/* B) UNDER TSO/E VIA REXX */00130000
/* ADDRESS ATTACH "DB2TERM" "/SSID,-CMD" */00140000
/* */00150000
/* CALLS : DSNALI - DB2 CAF */00160000
/* DSNWLI - DB2 IFI */00170000
/* */00180000
/* ARGUMENTS : SSID - DB2 SUBSYSTEM ID 4 BYTES */00190000
/* CMD - DB2 COMMAND 80 BYTES */00200000
/* */00210000
/* COMMENTS : THIS PROGRAM NEEDS NO DB2 PLAN AND NEEDS NOT TO BE */00220000
/* PRECOMPILED! COMMUNICATION AREAS ARE 'PRODUCT */00230000
/* SENSITIVE' AREAS AND HAVE TO BE EXAMINDED WITH */00240000
/* RELEASE CHANGES. */00250000
/* */00260000
/* LINK EDIT THE OBJECT MODULE WITH 'RENT,REUS'! */00270000
/* */00280000
/* SQLCA - DB2 COMMAND AND UTILITY REFERENCE */00290000
/* ECB'S - MVS/ESA DATA AREAS OR SYS1.MACLIB */00300000
/* CAF/IFI - DB2 APPL. PGM'ING AND SQL REFERENCE */00310000
/* IFI CALL- DB2 ADMINISTRATION GUIDE */00320000
/* */00330000
/* PROGRAMM OUTPUT MESSAGE ARE PREFIXED WITH '>>>'. */00340000
/* */00350000
/*********************************************************************/00360000
/* HISTORY : 21.12.94 G.RUBAN V1R2 */00370000
/* 30.03.97/GR: PROBLEM WITH "STOP DB2" VERFICATION FIXED V1R3 */00371002
/*********************************************************************/00380000
00390000
DB2TERM: PROC ( ARGS ) /* ARGUMENTS PASSED */00400000
OPTIONS ( MAIN ) 00410000
REORDER; 00420000
00430000
/*********************************************************************/00440000
/* PARAMETERS */00450000
/*********************************************************************/00460000
DCL ARGS CHAR (100) VARYING; /* ARGUMENTS PASSED AS STRING */00470000
DCL SSID CHAR (004); /* SUBSYSTEM ID */00480000
DCL CMD CHAR (080) VARYING; /* DB2 COMMAND */00490000
00500000
/*********************************************************************/00510000
/* EXTERNAL FILES */00520000
/*********************************************************************/00530000
DCL SYSPRINT FILE STREAM OUTPUT EXTERNAL; 00540000
00550000
/*********************************************************************/00560000
/* EXTERNAL ENTRY POINT */00570000
/*********************************************************************/00580000
DCL DSNALI EXTERNAL ENTRY OPTIONS(ASM,INTER,RETCODE); 00590000
DCL DSNWLI EXTERNAL ENTRY OPTIONS(ASM,INTER,RETCODE); 00600000
00610000
/*********************************************************************/00620000
/* PARAMETERS USED AND SET IN DSNALI */00630000
/*********************************************************************/00640000
DCL PTR_SECB POINTER; /* STARTUP EVENT CTRL BLOCK */00650000
DCL PTR_TECB POINTER; /* TERMINATION EVENT CTRL BLOCK*/00660000
DCL PTR_RIB POINTER; /* RELEASE INFORMATION BLOCK */00670000
DCL 1 RIB BASED(PTR_RIB), /* V2R3: LENGTH 44 BYTES */00680000
2 CODE BIN FIXED(15,0), /* BLOCK IDENTIFIER */00690000
2 TLEN BIN FIXED(15,0), /* BLOCK LENGTH */00700000
2 EYEC CHAR(04), /* EYECATCHER */00710000
2 CID, /* COMPONENT IDENTIFIER */00720000
3 ECODE CHAR(04), /* ENVIRONMENT CODE */00730000
3 PCODE CHAR(03), /* PRODUCT CODE */00740000
3 FCODE CHAR(02), /* FEATURE CODE */00750000
2 REL CHAR(03), /* RELEASE IDENTIFIER */00760000
2 CPTR POINTER, /* CHANGE INFORMATION -> CINFO */00770000
2 CNUMB BIN FIXED(31), /* # ELEMENTS IN CINFO (8 BITS)*/00780000
2 RSRV2 CHAR(16), /* RESERVED */00790000
2 CINFO CHAR(00), /* CHANGE LEVEL ARRAY (EMPTY) */00800000
2 END CHAR(00); /* RIB END */00810000
00820000
DCL ALI_RETCODE BIN FIXED(31,0); 00830000
DCL ALI_REACODE POINTER; 00840000
00850000
/*********************************************************************/00860000
/* PARAMETERS USED AND SET IN DSNWLI */00870000
/*********************************************************************/00880000
DCL 1 IFCA, /* INSTRUMENTATION FACILITY CA: */00890000
2 LEN BIN FIXED(15,0), /* LENGTH */00900000
2 RSRV1 BIN FIXED(15,0), /* RESERVED */00910000
2 ID CHAR(04), /* BLOCK ID */00920000
2 OWNR CHAR(04), /* OWNER ID */00930000
2 RETCODE BIN FIXED(31,0), /* RETURN CODE */00940000
2 REACODE BIN FIXED(31,0), /* REASON CODE */00950000
2 RETLEN BIN FIXED(31,0), /* BYTES MOVED TO RETURN AREA */00960000
2 BUFLEN BIN FIXED(31,0), /* BYTES NOT MOVED TO RETAREA */00970000
2 OPWS BIN FIXED(31,0), /* OPEN WRITER SEQUENCE NUMBER */00980000
2 RLC BIN FIXED(31,0), /* RECORDS LOST FROM ACT BUFFER */00990000
2 ANY CHAR(60), /* AREA TO CONTAIN 8 OPN NAMES */01000000
2 DDLEN BIN FIXED(15,0), /* LENGTH OF DIAGNOSTIC DATA */01010000
2 RSRV2 BIN FIXED(15,0), /* RESERVED */01020000
2 DD CHAR(80); /* DIAGNOSTIC DATA */01030000
01040000
DCL 1 DB2CMD, /* DB2 COMMAND: */01050000
2 LEN BIN FIXED(15,0), /* LENGTH OF TOTAL CMD AREA */01060000
2 CMD CHAR(80) VARYING; /* PREFIXED BY LL, IGNORED IN IF*/01070000
01080000
DCL 1 RETAREA, /* OUTPUT FROM DB2 COMMAND: */01090000
2 LEN BIN FIXED(31,0), /* LENGTH BUFFERED */01100000
2 DATA(32764) CHAR(01); /* 32K OUTPUT */01110000
01120000
DCL PTR_RETSTR POINTER; 01130000
DCL 1 RETSTR BASED(PTR_RETSTR), /* VARYING STRINGS IN RETAREA */01140000
2 LEN BIN FIXED(15,0), /* LENGTH OF ONE STRING */01150000
2 RSRV2 CHAR(02), /* RESERVED */01160000
2 STRING(RSI REFER(RETSTR.LEN)) CHAR(01),/* VARYING STRING */01170000
2 DELIM CHAR(01); /* CONTAINS X'15' */01180000
DCL RSI BIN FIXED(15) INIT(80);/* INITIAL STRING LENGTH */01190000
01200000
/*********************************************************************/01210000
/* SQL COMMUNICATION AREA */01220000
/*********************************************************************/01230000
DCL 1 SQLCA, 01240000
2 ANY1 CHAR (12), 01250000
2 SQLCODE BIN FIXED (31,0), 01260000
2 SQLERRM CHAR (70) VAR, 01270000
2 ANY2 CHAR (936); 01280000
01290000
/*********************************************************************/01300000
/* OTHER WORK FIELDS */01310000
/*********************************************************************/01320000
DCL (I,J) BIN FIXED (31,0); 01330000
01340000
/*********************************************************************/01350000
/* BUILTIN FUNCTIONS */01360000
/*********************************************************************/01370000
DCL ADDR BUILTIN; 01380000
DCL INDEX BUILTIN; 01390000
DCL LENGTH BUILTIN; 01400000
DCL MAX BUILTIN; 01410000
DCL NULL BUILTIN; 01420000
DCL PLIRETC BUILTIN; 01430000
DCL STORAGE BUILTIN; 01440000
DCL SUBSTR BUILTIN; 01450000
DCL VERIFY BUILTIN; 01460000
01470000
01480000
/*********************************************************************/01490000
/* PROCESSING START */01500000
/*********************************************************************/01510000
01520000
/******************************************************************/01530000
/* CHECK ARGUMENT STRING */01540000
/******************************************************************/01550000
IF LENGTH(ARGS) < 9 01560000
THEN 01570000
DO; 01580000
PUT SKIP LIST ('>>> PARAMETER SHORTER THAN REQUIRED'); 01590000
STOP; 01600000
END; 01610000
01620000
I = INDEX(ARGS,','); 01630000
IF I = 0 01640000
THEN 01650000
DO; 01660000
PUT SKIP LIST ('>>> INVALID SYNTAX (REQ.: SSID,CMD'); 01670000
STOP; 01680000
END; 01690000
IF I ^= 5 01700000
THEN 01710000
DO; 01720000
PUT SKIP LIST ('>>> SUBSYSTEM ID IS NOT A VALID ID'); 01730000
STOP; 01740000
END; 01750000
01760000
/******************************************************************/01770000
/* EXTRACT ARGUMENTS FROM ARGUMENT STRING */01780000
/******************************************************************/01790000
SSID = SUBSTR(ARGS,1,4); 01800000
CMD = SUBSTR(ARGS,6); 01810000
01820000
/******************************************************************/01830000
/* CHECK THE ILLEGAL COMMAND '-STOP DB2' */01840000
/******************************************************************/01850000
/* IF INDEX(CMD,'-STO') V1R3 */ 01860001
/* & INDEX(CMD,'DB2' ) V1R3 */ 01870001
IF INDEX(CMD,'-STOP DB2') 01871001
! INDEX(CMD,'-STO DB2') 01872001
THEN 01880000
DO; 01890000
PUT SKIP LIST ('>>> INVALID DB2 COMMAND (-STOP DB2)'); 01900000
STOP; 01910000
END; 01920000
01930000
DB2CMD.LEN = LENGTH(CMD) + 4; 01940000
DB2CMD.CMD = CMD; 01950000
01960000
/******************************************************************/01970000
/* DYNAMICALLY LOAD DSNALI AT RUNTIME */01980000
/******************************************************************/01990000
02000000
/******************************************************************/02010000
/* CONNECT TO THE REQUESTED SUBSYSTEM */02020000
/******************************************************************/02030000
PTR_TECB = NULL; 02040000
PTR_SECB = NULL; 02050000
PTR_RIB = NULL; 02060000
CALL DSNALI ('CONNECT ', 02070000
SSID, 02080000
PTR_TECB, 02090000
PTR_SECB, 02100000
PTR_RIB, 02110000
ALI_RETCODE, 02120000
ALI_REACODE); 02130000
CALL CHECK_FOR_ERROR(ALI_RETCODE,ADDR(ALI_REACODE)); 02140000
02150000
/******************************************************************/02160000
/* INITIALIZE COMMUNICATION AREA, COMMAND STRING, */02170000
/******************************************************************/02180000
IFCA = ''; 02190000
IFCA.LEN = STORAGE(IFCA); 02200000
IFCA.ID = 'IFCA'; 02210000
RETAREA.LEN = STORAGE(RETAREA); 02220000
02230000
/******************************************************************/02240000
/* DYNAMICALLY LOAD DSNWLI AT RUNTIME */02250000
/******************************************************************/02260000
02270000
/******************************************************************/02280000
/* ISSUE IFI CALL, A DB2 COMMAND */02290000
/******************************************************************/02300000
CALL DSNWLI ('COMMAND ', 02310000
IFCA, 02320000
RETAREA, 02330000
DB2CMD); 02340000
CALL CHECK_FOR_ERROR(IFCA.RETCODE,ADDR(IFCA.REACODE)); 02350000
02360000
/******************************************************************/02370000
/* HEADING LINES FOR DB2 COMMAND OUTPUT */02380000
/******************************************************************/02390000
CALL WRITE_HEADER; 02400000
02410000
/******************************************************************/02420000
/* WRITE OUTPUT DATA FROM RETURN AREA TO SYSPRINT */02430000
/******************************************************************/02440000
ALLOC RETSTR; 02450000
I = 1; 02460000
PTR_RETSTR = ADDR(RETAREA.DATA(I)); 02470000
DO WHILE (RETSTR.LEN > 0); 02480000
PUT SKIP; 02490000
DO J=1 TO RETSTR.LEN-5; 02500000
PUT EDIT(RETSTR.STRING(J)) (A(1)); 02510000
END; 02520000
I = I + RETSTR.LEN; 02530000
PTR_RETSTR = ADDR(RETAREA.DATA(I)); 02540000
END; 02550000
02560000
/******************************************************************/02570000
/* RETURN AREA OVERFLOW (UNUSUAL WITH DB2 COMMANDS) */02580000
/******************************************************************/02590000
IF IFCA.BUFLEN > 0 02600000
THEN PUT SKIP LIST(' '!! STRIP(IFCA.BUFLEN) !! 02610000
' BYTES REMAINED IN BUFFER'); 02620000
02630000
/******************************************************************/02640000
/* DISCONNECT FROM THE REQUESTED SUBSYSTEM */02650000
/******************************************************************/02660000
CALL DSNALI ('DISCONNECT '); 02670000
02680000
02690000
/*********************************************************************/02700000
/* CHECK_FOR_ERROR: CHECK RETURN CODE AFTER CAF/IFI CALL */02710000
/*********************************************************************/02720000
CHECK_FOR_ERROR: PROCEDURE (RC,PTR_REA); 02730000
02740000
/******************************************************************/02750000
/* PROCEDURE-INTERAL DECLARATIONS */02760000
/******************************************************************/02770000
DCL RC BIN FIXED(31,0); 02780000
DCL REA_C CHAR(04) BASED (PTR_REA); 02790000
DCL REA_I BIN FIXED(31,0) BASED (PTR_REA); 02800000
DCL PTR_REA POINTER; 02810000
02820000
/******************************************************************/02830000
/* CHECK RETURN AND REASON CODE VARIATIONS */02840000
/******************************************************************/02850000
SELECT; 02860000
02870000
WHEN (RC = 0); 02880000
02890000
/**************************************************************/02900000
/* TROUBLE WITH CAF (AT CONNECT) */02910000
/**************************************************************/02920000
WHEN (RC = 4 & (PTR_REA = NULL ! REA_C = '00C10823'X)) 02930000
DO; 02940000
/**********************************************************/02950000
/* WRITE REPORT HEADER LINES */02960000
/**********************************************************/02970000
CALL WRITE_HEADER; 02980000
/**********************************************************/02990000
/* DISCONNECT FROM THE REQUESTED SUBSYSTEM */03000000
/**********************************************************/03010000
PUT SKIP LIST ('>>> PROBLEM WITH CALL OF CAF - HALT'); 03020000
PUT SKIP LIST ('>>> CHECK LINK-EDIT LIST AND/OR PGM'); 03030000
CALL WRITE_DD; 03040000
/**********************************************************/03050000
/* DISCONNECT FROM THE REQUESTED SUBSYSTEM */03060000
/**********************************************************/03070000
CALL DSNALI ('DISCONNECT '); 03080000
STOP; 03090000
END; 03100000
03110000
/**************************************************************/03120000
/* TROUBLE WITH IFI (FEEBACK AREA OVERFLOW) */03130000
/**************************************************************/03140000
WHEN (RC = 8 & PTR_REA ^= NULL & REA_C = '00E60820'X ) 03150000
DO; 03160000
PUT SKIP LIST ('>>> COMMAND DID NOT COMPLETE NORMALLY'); 03170000
CALL WRITE_DD; 03180000
END; 03190000
03200000
/**************************************************************/03210000
/* OTHERWISE */03220000
/**************************************************************/03230000
OTHERWISE 03240000
DO; 03250000
/**********************************************************/03260000
/* WRITE REPORT HEADER LINES */03270000
/**********************************************************/03280000
CALL WRITE_HEADER; 03290000
/**********************************************************/03300000
/* DISCONNECT FROM THE REQUESTED SUBSYSTEM */03310000
/**********************************************************/03320000
CALL DSNALI ('TRANSLATE ', 03330000
SQLCA); 03340000
PUT SKIP LIST ('>>> CAF/IFI RETURN CODE=' !! RC); 03350000
IF PTR_REA ^= NULL 03360000
THEN PUT SKIP LIST ('>>> CAF/IFI REASON CODE=' !! REA_I !! 03370000
' X''' !! C2X(REA_C) !! ''''); 03380000
PUT SKIP LIST ('>>> TRANSLATED SQL CODE=' !! SQLCODE); 03390000
PUT SKIP LIST ('>>> SQL MESSAGE=' !! SQLERRM); 03400000
CALL WRITE_DD; 03410000
/**********************************************************/03420000
/* DISCONNECT FROM THE REQUESTED SUBSYSTEM */03430000
/**********************************************************/03440000
CALL DSNALI ('DISCONNECT '); 03450000
STOP; 03460000
END; /*OTHER*/ 03470000
03480000
END; /*SELECT*/ 03490000
03500000
END CHECK_FOR_ERROR; 03510000
03520000
/*********************************************************************/03530000
/* WRITE_HEADER: WRITE PROGRAMM OUTPUT HEADER MESSAGES */03540000
/*********************************************************************/03550000
WRITE_HEADER: PROCEDURE; 03560000
03570000
/******************************************************************/03580000
/* WRITE HEADER LINES IF NOT ALREADY WRITTEN */03590000
/******************************************************************/03600000
IF PTR_RIB ^= NULL 03610000
THEN PUT SKIP EDIT ('>>> PRODUCT=', 03620000
RIB.CID.ECODE,RIB.CID.PCODE,RIB.CID.FCODE, 03630000
' DB2/VR=',RIB.REL,', ', 03640000
STRIP(IFCA.RETLEN), 03650000
' BYTES RETURNED FROM DB2') 03660000
(A,A,A,A,A,A,A,A,A); 03670000
PUT SKIP EDIT ('>>> SSID=',SSID,' COMMAND=',DB2CMD.CMD, 03680000
' LL=',STRIP(DB2CMD.LEN-4)) 03690000
(A,A,A,A,A,A); 03700000
03710000
END WRITE_HEADER; 03720000
03730000
03740000
/*********************************************************************/03750000
/* WRITE_DD: WRITE IFCA DIAGNOSTIC DATA */03760000
/*********************************************************************/03770000
WRITE_DD: PROCEDURE; 03780000
03790000
/******************************************************************/03800000
/* CHECK RETURN AND REASON CODE VARIATIONS */03810000
/******************************************************************/03820000
PUT SKIP EDIT ('>>> DIAGNOSTIC DATA LL=',STRIP(IFCA.DDLEN)) (A,A); 03830000
IF IFCA.DDLEN > 0 03840000
THEN 03850000
DO I=1 TO IFCA.DDLEN BY 75; 03860000
PUT SKIP EDIT (SUBSTR(IFCA.DD,I)) (X(4),A(75)); 03870000
END; 03880000
03890000
END WRITE_DD; 03900000
03910000
03920000
/*********************************************************************/03930000
/* C2X: CONVERTS CHARACTER TO HEXADECIMAL STRING */03940000
/*********************************************************************/03950000
C2X: PROCEDURE (B) 03960000
RETURNS (CHAR(08)); 03970000
03980000
/******************************************************************/03990000
/* FUNCTION-INTERAL DECLARATIONS */04000000
/******************************************************************/04010000
DCL LL BIN FIXED(15,0); 04020000
DCL B CHAR(04); 04030000
DCL BV(8) BIT (04) BASED (ADDR(B)); 04040000
DCL X CHAR(08); 04050000
DCL XV(8) CHAR(01) BASED (ADDR(X)); 04060000
DCL BVT(16) BIT(04) INIT ('0000'B, '0001'B, '0010'B, '0011'B, 04070000
'0100'B, '0101'B, '0110'B, '0111'B, 04080000
'1000'B, '1001'B, '1010'B, '1011'B, 04090000
'1100'B, '1101'B, '1110'B, '1111'B); 04100000
DCL XVT(16) CHAR(1) INIT ('0','1','2','3','4','5','6','7', 04110000
'8','9','A','B','C','D','E','F'); 04120000
04130000
/******************************************************************/04140000
/* CONVERT BIT TO CHAR HALF-BYTE-WISE */04150000
/******************************************************************/04160000
XV(*) = '0'; 04170000
DO I=1 TO 8; 04180000
DO J=1 TO 16 UNTIL(BV(I) = BVT(J)); END; 04190000
XV(I) = XVT(J); 04200000
END; 04210000
RETURN(X); 04220000
04230000
END C2X; 04240000
04250000
/*********************************************************************/04260000
/* STRIP: REMOVE LEADING BLANKS FROM NUMERIC STRING */04270000
/*********************************************************************/04280000
STRIP: PROCEDURE (LL) 04290000
RETURNS (CHAR(9) VARYING); 04300000
04310000
/******************************************************************/04320000
/* FUNCTION-INTERAL DECLARATIONS */04330000
/******************************************************************/04340000
DCL LL BIN FIXED(31,0); 04350000
DCL LL_P PIC 'Z.ZZZ.ZZ9'; 04360000
DCL LL_C CHAR(09) BASED (ADDR(LL_P)); 04370000
04380000
/******************************************************************/04390000
/* MOVE BINARY TO PICTURE, CUT-OFF BLANKS, RETURN NUMERIC STRING */04400000
/******************************************************************/04410000
LL_P = LL; 04420000
I = VERIFY(LL_C,' '); 04430000
I = MAX(1,I); 04440000
RETURN (SUBSTR(LL_C,I)); 04450000
04460000
END STRIP; 04470000
04480000
/*********************************************************************/04490000
/* END OF PROGRAMM */04500000
/*********************************************************************/04510000
END DB2TERM; 04520000
© Gernot Ruban