DSN8CC
FUNCTION = THIS MODULE IS AN EXAMPLE OF A COBOL INTERFACE TO THE CALL ATTACH FACILITY.
IDENTIFICATION DIVISION.
*------------------------
PROGRAM-ID. DSNCC.
******* DSNCC - SAMPLE CAF COBOL INTERFACE *********************
* *
* MODULE NAME = DSNCC *
* *
* DESCRIPTIVE *
* NAME = DB2 SAMPLE APPLICATION *
* CALL ATTACH FACILITY COBOL INTERFACE *
* ISPF/TSO *
* COBOL *
* *
*LICENSED MATERIALS - PROPERTY OF IBM *
*5695-DB2 *
*(C) COPYRIGHT 1982, 1995 IBM CORP. ALL RIGHTS RESERVED. *
* *
*STATUS = VERSION 4 *
* *
* FUNCTION = THIS MODULE IS AN EXAMPLE OF A COBOL *
* INTERFACE TO THE CALL ATTACH FACILITY. *
* *
* THE FOLLOWING SERVICE REQUESTS WILL BE MADE *
* TO THE CALL ATTACH FACILITY. ISPF VARIABLES *
* ARE USED TO CONTAIN POINTERS TO ECBS AND *
* CONTROL BLOCKS. *
* *
* - CONNECT *
* *
* ESTABLISH A CONNECTION BETWEEN AN *
* APPLICATION'S ADDRESS SPACE AND A *
* SPECIFIED DB2 SUBSYSTEM. *
* *
* - OPEN *
* *
* ESTABLISH THE SPECIFIED PLAN AS A USER OF *
* DB2 SERVICES AND ALLOCATE RESOURCES FOR *
* SQL CALLS. THIS CAN BE CALLED 'CREATING A *
* THREAD'. *
* *
* - CLOSE *
* *
* TERMINATE THE CURRENT THREAD USING THE *
* SPECIFIED TERMINATION OPTION. *
* *
* - DISCONNECT *
* *
* TERMINATE THE CONNECTION TO DB2. *
* *
* - TRANSLATE *
* *
* CLARIFIES A RESOURCE UNAVAILABLE CONDITION.*
* IT IS PERFORMED AFTER AN OPEN FAILURE. *
* *
* NOTES = NONE *
* *
* MODULE TYPE = *
* PROCESSOR = DB2 PREPROCESSOR, COBOL COMPILER *
* MODULE SIZE = SEE LINKEDIT *
* ATTRIBUTES = REUSABLE *
* *
* ENTRY POINT = DSN8CC *
* PURPOSE = SEE FUNCTION *
* LINKAGE = ISPF *
* *
* INPUT = ISPF SERVICES ARE USED TO OBTAIN INFORMATION *
* FROM THE MAIN PANEL AND THE CONNECTION *
* MANAGER. THE FOLLOWING INFORMATION IS *
* RETRIEVED: *
* *
* FUNCTION (12 CHARACTERS) *
* *
* CONNECT: *
* *
* SUBSYSTEM ID (4 CHARACTERS) *
* *
* OPEN: *
* *
* SUBSYSTEM ID (4 CHARACTERS) *
* PROGRAM NAME (8 CHARACTERS) *
* PLAN NAME (8 CHARACTERS) *
* *
* CLOSE: *
* *
* TERM-OPTION (4 CHARACTERS) *
* *
* DISCONNECT: *
* *
* NO PARAMETERS *
* *
* TRANSLATE: *
* *
* SQLCA (136 BYTES ) *
* *
* OUTPUT = PARAMETERS EXPLICITLY RETURNED: *
* *
* RETC-NAME *
* ISPF VARIABLE NAME: DSN8RETC *
* REAS-NAME *
* ISPF VARIABLE NAME: DSN8REAS *
* *
* EXIT-NORMAL = THE REQUESTED FUNCTION WAS PERFORMED *
* SUCCESSFULLY *
* *
* *
* EXIT-ERROR = THE REQUESTED FUNCTION WAS NOT PERFORMED *
* *
* RETURN CODE = NONE *
* *
* ABEND CODES = NONE *
* *
* ERROR *
* MESSAGES = NONE *
* *
* EXTERNAL *
* REFERENCES = *
* ROUTINES/ *
* SERVICES = ISPLINK - ISPF SERVICES *
* DSNALI - CALL ATTACH LANGUAGE INTERFACE *
* *
* DATA-AREAS = NONE *
* *
* CONTROL *
* BLOCKS = NONE *
* *
* TABLES = NONE *
* *
* CHANGE *
* ACTIVITY = NONE *
* *
* *
* *PSEUDOCODE* *
* *
* SELECT(FUNCTION) *
* WHEN('CONNECT ') *
* DO *
* SET UP PARMS *
* ISSUE CONNECT CALL *
* END *
* WHEN('OPEN ') *
* DO *
* SET UP PARMS *
* ISSUE OPEN CALL *
* END *
* WHEN('CLOSE ') *
* DO *
* SET UP PARMS *
* ISSUE CLOSE CALL *
* END *
* WHEN('DISCONNECT ') *
* DO *
* SET UP PARMS *
* ISSUE DISCONNECT CALL *
* END *
* WHEN('TRANSLATE ') *
* DO *
* SET UP PARMS *
* ISSUE TRANSLATE CALL *
* END *
* IF RETURN CODE ^= 0 THEN *
* CONVERT REASON CODE TO PRINTABLE CHARACTERS *
* EXIT *
* *
* CHANGE-ACTIVITY: *
* 10-25-93 CHANGED STOP RUN TO GOBACK IN @71 KEF0871 *
* ORDER TO PREVENT ABEND OC4 (PN47976) @71 KEF0871 *
****************************************************************
/
ENVIRONMENT DIVISION.
*------------------------
INPUT-OUTPUT SECTION.
FILE-CONTROL.
DATA DIVISION.
*------------------------
FILE SECTION.
WORKING-STORAGE SECTION.
77 COIBM PIC X(54) VALUE
'COPYRIGHT = 5740-XYR (C) COPYRIGHT IBM CORP 1982, 1987'.
****************************************************************
* ISPF DIALOG VARIABLES LENGTH DECLARATIONS *
****************************************************************
77 SSID-LEN PIC 9(06) VALUE 4 COMP.
77 PROG-LEN PIC 9(06) VALUE 8 COMP.
77 PLAN-LEN PIC 9(06) VALUE 8 COMP.
77 RETC-LEN PIC 9(06) VALUE 8 COMP.
77 REAS-LEN PIC 9(06) VALUE 8 COMP.
77 SQCA-LEN PIC 9(06) VALUE 136 COMP.
77 TECB-LEN PIC 9(06) VALUE 4 COMP.
77 SECB-LEN PIC 9(06) VALUE 4 COMP.
77 TERM-LEN PIC 9(06) VALUE 4 COMP.
77 ACTN-LEN PIC 9(06) VALUE 12 COMP.
77 SERV-LEN PIC 9(06) VALUE 12 COMP.
****************************************************************
* ISPF DIALOG VARIABLE NAMES *
****************************************************************
77 SSID-NAME PIC X(08) VALUE 'DSN8SSID'.
77 PROG-NAME PIC X(08) VALUE 'DSN8PROG'.
77 PLAN-NAME PIC X(08) VALUE 'DSN8PLAN'.
77 RETC-NAME PIC X(08) VALUE 'DSN8RETC'.
77 REAS-NAME PIC X(08) VALUE 'DSN8REAS'.
77 SQCA-NAME PIC X(08) VALUE 'DSN8SQCA'.
77 TECB-NAME PIC X(08) VALUE 'DSN8TECB'.
77 SECB-NAME PIC X(08) VALUE 'DSN8SECB'.
77 TERM-NAME PIC X(08) VALUE 'DSN8TERM'.
77 ACTN-NAME PIC X(08) VALUE 'DSN8ACTN'.
77 SERV-NAME PIC X(08) VALUE 'DSN8SERV'.
/
****************************************************************
* CAF SERVICES DECLARATIONS *
****************************************************************
* CAF FUNCTIONS
77 CONN-FUNCTION PIC X(12) VALUE 'CONNECT '.
77 OPEN-FUNCTION PIC X(12) VALUE 'OPEN '.
77 CLOS-FUNCTION PIC X(12) VALUE 'CLOSE '.
77 DISC-FUNCTION PIC X(12) VALUE 'DISCONNECT '.
77 XLAT-FUNCTION PIC X(12) VALUE 'TRANSLATE '.
* CODE FOR UNRECOGNIZED FUNCTION REQUEST
77 BAD-FUNCTION PIC 9(06) VALUE 11.
****************************************************************
* ISPF DIALOG SERVICES DECLARATIONS *
****************************************************************
* DEFINE MODIFIERS FOR ISPF CALLS
77 I-CHAR PIC X(08) VALUE 'CHAR '.
77 I-FIXED PIC X(08) VALUE 'FIXED '.
* ISPF DIALOG SERVICE TYPES DECLARATIONS
77 I-VDEFINE PIC X(08) VALUE 'VDEFINE '.
77 I-VDELETE PIC X(08) VALUE 'VDELETE '.
77 I-VGET PIC X(08) VALUE 'VGET '.
77 I-VPUT PIC X(08) VALUE 'VPUT '.
/
****************************************************************
* LOCAL VARIABLES *
****************************************************************
01 SSID PIC X(04) VALUE SPACES.
01 FUNC PIC X(01) VALUE SPACES.
01 PROG PIC X(08) VALUE SPACES.
01 PLAN PIC X(08) VALUE SPACES.
01 REAS PIC 9(06) VALUE 0 COMP.
01 RETC PIC 9(06) VALUE 0 COMP.
01 TECB PIC 9(06) VALUE 0 COMP.
01 SECB PIC 9(06) VALUE 0 COMP.
01 RIBPTR PIC 9(06) VALUE 0 COMP.
01 TERM PIC X(04) VALUE SPACES.
01 ACTN PIC X(12) VALUE SPACES.
****************************************************************
* SQLCA DECLARATION *
****************************************************************
EXEC SQL INCLUDE SQLCA END-EXEC.
****************************************************************
* VARIABLES FOR NUMERIC-TO-CHARACTER CONVERSION *
****************************************************************
01 DIVIDEND PIC 9(18) VALUE 0 COMP.
01 QUOTIENT PIC 9(18) VALUE 0 COMP.
01 DIGITS-IN-EBCDIC PIC X(16) VALUE '0123456789ABCDEF'.
01 NUM-TO-CHAR-TABLE REDEFINES DIGITS-IN-EBCDIC.
05 HEX-TO-EBCDIC PIC X(01) OCCURS 16 TIMES
INDEXED BY HEX-EBCDIC-INDEX.
01 EBCDIC-REAS PIC X(08) VALUE SPACES.
01 EBCDIC-BYTES REDEFINES EBCDIC-REAS.
05 EBCDIC-BYTE PIC X(01) OCCURS 8 TIMES
INDEXED BY EBCDIC-INDEX.
01 EBCDIC-REAS-LEN PIC 9(06) VALUE 8 COMP.
01 HEX-BYTE PIC 9(02) VALUE 0 COMP.
01 BYTE-DEST PIC 9(02) VALUE 0 COMP.
01 BYTES-TO-SHIFT PIC 9(02) VALUE 0 COMP.
01 COUNTER PIC 9(02) VALUE 0 COMP.
01 EBCDIC-ZERO PIC X(01) VALUE '0'.
/
****************************************************************
* LINKAGE SECTION *
****************************************************************
LINKAGE SECTION.
PROCEDURE DIVISION.
*---------------------
/
****************************************************************
* DEFINE DIALOG VARIABLES USED IN THIS APPLICATION PROGRAM *
****************************************************************
CALL 'ISPLINK' USING I-VDEFINE ACTN-NAME ACTN I-CHAR
ACTN-LEN.
CALL 'ISPLINK' USING I-VDEFINE SSID-NAME SSID I-CHAR
SSID-LEN.
CALL 'ISPLINK' USING I-VDEFINE TECB-NAME TECB I-FIXED
TECB-LEN.
CALL 'ISPLINK' USING I-VDEFINE SECB-NAME SECB I-FIXED
SECB-LEN.
CALL 'ISPLINK' USING I-VDEFINE PLAN-NAME PLAN I-CHAR
PLAN-LEN.
CALL 'ISPLINK' USING I-VDEFINE TERM-NAME TERM I-CHAR
TERM-LEN.
CALL 'ISPLINK' USING I-VDEFINE SQCA-NAME SQLCA I-CHAR
SQCA-LEN.
CALL 'ISPLINK' USING I-VDEFINE SERV-NAME ACTN I-CHAR
SERV-LEN.
CALL 'ISPLINK' USING I-VDEFINE RETC-NAME RETC I-FIXED
RETC-LEN.
CALL 'ISPLINK' USING I-VDEFINE REAS-NAME EBCDIC-REAS I-CHAR
REAS-LEN.
****************************************************************
* RETRIEVE THE SERVICE REQUEST *
****************************************************************
CALL 'ISPLINK' USING I-VGET ACTN-NAME.
****************************************************************
* PERFORM THE REQUESTED SERVICE *
****************************************************************
ACTN-PERFORM.
IF ACTN = CONN-FUNCTION THEN
CALL 'ISPLINK' USING I-VGET SSID-NAME
CALL 'ISPLINK' USING I-VGET TECB-NAME
CALL 'ISPLINK' USING I-VGET SECB-NAME
CALL 'DSNALI' USING ACTN SSID TECB SECB RIBPTR RETC REAS
ELSE IF ACTN = OPEN-FUNCTION THEN
CALL 'ISPLINK' USING I-VGET SSID-NAME
CALL 'ISPLINK' USING I-VGET PLAN-NAME
CALL 'DSNALI' USING ACTN SSID PLAN RETC REAS
ELSE IF ACTN = CLOS-FUNCTION THEN
CALL 'ISPLINK' USING I-VGET TERM-NAME
CALL 'DSNALI' USING ACTN TERM RETC REAS
ELSE IF ACTN = DISC-FUNCTION THEN
CALL 'DSNALI' USING ACTN RETC REAS
ELSE IF ACTN = XLAT-FUNCTION THEN
CALL 'ISPLINK' USING I-VGET SQCA-NAME
CALL 'DSNALI' USING ACTN SQLCA RETC REAS
CALL 'ISPLINK' USING I-VPUT SQCA-NAME
ELSE
CALL 'ISPLINK' USING I-VPUT SERV-NAME
MOVE BAD-FUNCTION TO RETC
CALL 'ISPLINK' USING I-VPUT RETC-NAME.
CALL 'ISPLINK' USING I-VPUT RETC-NAME.
PERFORM REASON-CONVERT.
CALL 'ISPLINK' USING I-VPUT REAS-NAME.
CALL 'ISPLINK' USING I-VDELETE ACTN-NAME.
CALL 'ISPLINK' USING I-VDELETE SSID-NAME.
CALL 'ISPLINK' USING I-VDELETE TECB-NAME.
CALL 'ISPLINK' USING I-VDELETE SECB-NAME.
CALL 'ISPLINK' USING I-VDELETE PLAN-NAME.
CALL 'ISPLINK' USING I-VDELETE TERM-NAME.
CALL 'ISPLINK' USING I-VDELETE SQCA-NAME.
CALL 'ISPLINK' USING I-VDELETE SERV-NAME.
CALL 'ISPLINK' USING I-VDELETE RETC-NAME.
CALL 'ISPLINK' USING I-VDELETE REAS-NAME.
* **@71
GOBACK.
/
****************************************************************
* CONVERT BINARY REASON CODE TO PRINTABLE FORM *
****************************************************************
REASON-CONVERT.
* **SET REASON CODE TO
* **EBCDIC ZEROES
PERFORM REAS-ZERO-FILL VARYING EBCDIC-INDEX
FROM 1 BY 1 UNTIL EBCDIC-INDEX > EBCDIC-REAS-LEN.
* **POINT TO LOW-ORDER BYTE
* **OF EBCDIC REASON CODE
SET EBCDIC-INDEX TO EBCDIC-REAS-LEN.
* **THIS BYTE IS REMAINDER
* **WHEN DECIMAL REASON CODE
* **IS DIVIDED BY SIXTEEN
MOVE REAS TO DIVIDEND.
DIVIDE 16 INTO DIVIDEND GIVING QUOTIENT
REMAINDER HEX-BYTE.
* **GET EBCDIC REPRESENTATION
* **BY LOOKING IN TABLE
ADD 1 HEX-BYTE GIVING HEX-BYTE.
SET HEX-EBCDIC-INDEX TO HEX-BYTE.
MOVE HEX-TO-EBCDIC (HEX-EBCDIC-INDEX) TO
EBCDIC-BYTE (EBCDIC-INDEX).
* **FILL IN THE REST OF THE
* **DIGITS IN THE SAME WAY
PERFORM CONVERT-TO-EBCDIC UNTIL
QUOTIENT = 0.
* **CALCULATE A HEX DIGIT
CONVERT-TO-EBCDIC.
* **POINT TO NEXT BYTE
* **IN TARGET STRING
SET COUNTER TO EBCDIC-INDEX.
SUBTRACT 1 FROM COUNTER.
SET EBCDIC-INDEX TO COUNTER.
* **QUOTIENT FROM PREVIOUS
* **DIVISION IS DIVIDEND
* **FOR CURRENT DIVISION
MOVE QUOTIENT TO DIVIDEND.
* **GET CURRENT HEX DIGIT
DIVIDE 16 INTO DIVIDEND GIVING QUOTIENT REMAINDER
HEX-BYTE.
* **GET EBCDIC VALUE BY
* **LOOKING IN TABLE
ADD 1 HEX-BYTE GIVING HEX-BYTE.
SET HEX-EBCDIC-INDEX TO HEX-BYTE.
MOVE HEX-TO-EBCDIC (HEX-EBCDIC-INDEX) TO
EBCDIC-BYTE (EBCDIC-INDEX).
* **MAKE REASON CODE ZEROES
REAS-ZERO-FILL.
MOVE EBCDIC-ZERO TO EBCDIC-BYTE (EBCDIC-INDEX).