230 lines
11 KiB
HTML
230 lines
11 KiB
HTML
|
<?xml version="1.0" encoding="UTF-8"?>
|
||
|
|
<!DOCTYPE html
|
||
|
|
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
|
||
|
|
<html lang="en-us" xml:lang="en-us">
|
||
|
|
<head>
|
||
|
|
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
|
||
|
|
<meta name="security" content="public" />
|
||
|
|
<meta name="Robots" content="index,follow" />
|
||
|
|
<meta http-equiv="PICS-Label" content='(PICS-1.1 "http://www.icra.org/ratingsv02.html" l gen true r (cz 1 lz 1 nz 1 oz 1 vz 1) "http://www.rsac.org/ratingsv01.html" l gen true r (n 0 s 0 v 0 l 0) "http://www.classify.org/safesurf/" l gen true r (SS~~000 1))' />
|
||
|
|
<meta name="DC.Type" content="reference" />
|
||
|
|
<meta name="DC.Title" content="Example: Using COBOL program to call APIs" />
|
||
|
|
<meta name="abstract" content="This example illustrates using COBOL programs to call APIs." />
|
||
|
|
<meta name="description" content="This example illustrates using COBOL programs to call APIs." />
|
||
|
|
<meta name="DC.Relation" scheme="URI" content="apiexmp.htm" />
|
||
|
|
<meta name="copyright" content="(C) Copyright IBM Corporation 1998, 2006" />
|
||
|
|
<meta name="DC.Rights.Owner" content="(C) Copyright IBM Corporation 1998, 2006" />
|
||
|
|
<meta name="DC.Format" content="XHTML" />
|
||
|
|
<meta name="DC.Identifier" content="apiexusapi" />
|
||
|
|
<meta name="DC.Language" content="en-us" />
|
||
|
|
<!-- All rights reserved. Licensed Materials Property of IBM -->
|
||
|
|
<!-- US Government Users Restricted Rights -->
|
||
|
|
<!-- Use, duplication or disclosure restricted by -->
|
||
|
|
<!-- GSA ADP Schedule Contract with IBM Corp. -->
|
||
|
|
<link rel="stylesheet" type="text/css" href="./ibmdita.css" />
|
||
|
|
<link rel="stylesheet" type="text/css" href="./ic.css" />
|
||
|
|
<title>Example: Using COBOL program to call APIs</title>
|
||
|
|
</head>
|
||
|
|
<body id="apiexusapi"><a name="apiexusapi"><!-- --></a>
|
||
|
|
<!-- Java sync-link --><script language="Javascript" src="../rzahg/synch.js" type="text/javascript"></script>
|
||
|
|
<h1 class="topictitle1">Example: Using COBOL program to call APIs</h1>
|
||
|
|
<div><p>This example illustrates using COBOL programs to call APIs.</p>
|
||
|
|
<div class="section"><p>This example COBOL program uses the example error handler in <a href="#apiexusapi__HDRCOBSM2">Error handler for example COBOL program</a>.</p>
|
||
|
|
<div class="note"><span class="notetitle">Note:</span> <ul><li>In order for this example to run successfully, the error program, ACERRF24
|
||
|
|
(shown in <a href="#apiexusapi__HDRCOBSM2">Error handler for example COBOL program</a>), must exist in a library
|
||
|
|
called UTCBL.</li>
|
||
|
|
<li>Read the <a href="codedisclaimer.htm">Code license and disclaimer information</a> for important legal
|
||
|
|
information.</li>
|
||
|
|
</ul>
|
||
|
|
</div>
|
||
|
|
<pre> IDENTIFICATION DIVISION.
|
||
|
|
PROGRAM-ID. ACF24.
|
||
|
|
**************************************************************
|
||
|
|
**************************************************************
|
||
|
|
*
|
||
|
|
* FUNCTION: SHOWS HOW TO CALL THE VARIOUS APIs, WHILE
|
||
|
|
* TESTING THAT THEY WORK PROPERLY.
|
||
|
|
*
|
||
|
|
* LANGUAGE: COBOL
|
||
|
|
*
|
||
|
|
* APIs USED: QLRRTVCE, QLRCHGCM, QLRSETCE
|
||
|
|
*
|
||
|
|
**************************************************************
|
||
|
|
**************************************************************
|
||
|
|
ENVIRONMENT DIVISION.
|
||
|
|
CONFIGURATION SECTION.
|
||
|
|
SOURCE-COMPUTER. IBM-AS400.
|
||
|
|
OBJECT-COMPUTER. IBM-AS400.
|
||
|
|
DATA DIVISION.
|
||
|
|
WORKING-STORAGE SECTION.
|
||
|
|
01 old.
|
||
|
|
05 oldname PIC X(10).
|
||
|
|
05 oldlibr PIC X(10).
|
||
|
|
77 scope PIC X VALUE "P".
|
||
|
|
01 errparm.
|
||
|
|
05 input-l PIC S9(6) BINARY VALUE ZERO.
|
||
|
|
05 output-l PIC S9(6) BINARY VALUE ZERO.
|
||
|
|
05 exception-id PIC X(7).
|
||
|
|
05 reserved PIC X(1).
|
||
|
|
05 exception-data PIC X(50).
|
||
|
|
01 new.
|
||
|
|
05 newname PIC X(10) VALUE "ACERRF24".
|
||
|
|
05 newlibr PIC X(10) VALUE "UTCBL".
|
||
|
|
77 newlib PIC X(10).
|
||
|
|
PROCEDURE DIVISION.
|
||
|
|
main-proc.
|
||
|
|
DISPLAY "in ACF24".
|
||
|
|
PERFORM variation-01 THRU end-variation.
|
||
|
|
STOP RUN.
|
||
|
|
variation-01.
|
||
|
|
**************************************************************
|
||
|
|
* *
|
||
|
|
* This variation addresses the situation where there is no *
|
||
|
|
* pending COBOL main, so no pending error handler can exist. *
|
||
|
|
* *
|
||
|
|
**************************************************************
|
||
|
|
DISPLAY "no pending so expect nothing but error LBE7052".
|
||
|
|
MOVE SPACES TO old exception-id.
|
||
|
|
**************************************************************
|
||
|
|
* By setting error parm > 8, expect escape message *
|
||
|
|
* LBE7052 to be returned in error parameter. *
|
||
|
|
**************************************************************
|
||
|
|
MOVE LENGTH OF errparm TO input-l.
|
||
|
|
CALL "QLRRTVCE" USING old scope errparm.
|
||
|
|
IF exception-id IS NOT = "LBE7052" THEN
|
||
|
|
DISPLAY "** error - expected LBE7052"
|
||
|
|
ELSE
|
||
|
|
DISPLAY "LBE7052 was found"
|
||
|
|
END-IF.
|
||
|
|
**************************************************************
|
||
|
|
* Reset input-l to ZERO, thus any further errors will cause *
|
||
|
|
* COBOL program to stop. *
|
||
|
|
**************************************************************
|
||
|
|
MOVE 0 TO input-l.
|
||
|
|
MOVE SPACES TO old exception-id.
|
||
|
|
variation-02.
|
||
|
|
**************************************************************
|
||
|
|
* *
|
||
|
|
* This variation creates a pending run unit. It then makes *
|
||
|
|
* sure that no pending error handler has been set. *
|
||
|
|
* *
|
||
|
|
**************************************************************
|
||
|
|
DISPLAY "create pending run unit".
|
||
|
|
CALL "QLRCHGCM" USING errparm.
|
||
|
|
**************************************************************
|
||
|
|
* *
|
||
|
|
* No pending error handler exists so *NONE should be *
|
||
|
|
* returned. *
|
||
|
|
* *
|
||
|
|
**************************************************************</pre>
|
||
|
|
<pre> CALL "QLRRTVCE" USING old scope errparm.
|
||
|
|
DISPLAY "Retrieved Error Handler is=" old.
|
||
|
|
IF oldname IS NOT = "*NONE" THEN
|
||
|
|
DISPLAY "** error - expected *NONE for error handler"
|
||
|
|
END-IF.
|
||
|
|
MOVE 0 TO input-l.
|
||
|
|
MOVE SPACES TO old exception-id.
|
||
|
|
variation-03.
|
||
|
|
**************************************************************
|
||
|
|
* *
|
||
|
|
* This variation sets an error handler for the pending *
|
||
|
|
* run unit and then does another check to make sure it *
|
||
|
|
* was really set. *
|
||
|
|
* *
|
||
|
|
**************************************************************
|
||
|
|
CALL "QLRSETCE" USING new scope newlib old errparm.
|
||
|
|
IF oldname IS NOT = "*NONE"
|
||
|
|
DISPLAY "** error in oldname "
|
||
|
|
END-IF.
|
||
|
|
IF newlib IS NOT = "UTCBL"
|
||
|
|
DISPLAY "** error in new library "
|
||
|
|
END-IF.
|
||
|
|
**************************************************************
|
||
|
|
* Call the retrieve API to check to make sure that the *
|
||
|
|
* set API worked. *
|
||
|
|
**************************************************************
|
||
|
|
MOVE SPACES TO old exception-id.
|
||
|
|
CALL "QLRRTVCE" USING old scope errparm.
|
||
|
|
DISPLAY "Retrieved Error Handler is=" old.
|
||
|
|
IF oldname IS NOT = "ACERRF24" OR oldlibr IS NOT = "UTCBL"
|
||
|
|
DISPLAY "** error - expected ACERRF24 error handler"
|
||
|
|
END-IF.
|
||
|
|
end-variation.</pre>
|
||
|
|
</div>
|
||
|
|
<div class="section" id="apiexusapi__HDRCOBSM2"><a name="apiexusapi__HDRCOBSM2"><!-- --></a><h4 class="sectiontitle">Error handler for example COBOL program</h4><p>This
|
||
|
|
example error handler works with <a href="#apiexusapi">Example: Using COBOL program to call APIs</a>.</p>
|
||
|
|
<pre> IDENTIFICATION DIVISION.
|
||
|
|
PROGRAM-ID. ACERRF24.
|
||
|
|
**************************************************************
|
||
|
|
**************************************************************
|
||
|
|
*
|
||
|
|
* FUNCTION: Error handler for preceding example COBOL program
|
||
|
|
*
|
||
|
|
* LANGUAGE: COBOL
|
||
|
|
*
|
||
|
|
* APIs USED: None
|
||
|
|
*
|
||
|
|
**************************************************************
|
||
|
|
**************************************************************
|
||
|
|
ENVIRONMENT DIVISION.
|
||
|
|
CONFIGURATION SECTION.
|
||
|
|
SOURCE-COMPUTER. IBM-AS400.
|
||
|
|
OBJECT-COMPUTER. IBM-AS400.
|
||
|
|
SPECIAL-NAMES. SYSTEM-CONSOLE IS SYSCON.
|
||
|
|
DATA DIVISION.
|
||
|
|
WORKING-STORAGE SECTION.
|
||
|
|
77 scope PIC X VALUE "P".
|
||
|
|
01 errparm.
|
||
|
|
05 FILLER PIC X(30).
|
||
|
|
LINKAGE SECTION.
|
||
|
|
77 cobol-id PIC X(7).
|
||
|
|
77 valid-responses PIC X(6).
|
||
|
|
01 progr.
|
||
|
|
05 progname PIC X(10).
|
||
|
|
05 proglibr PIC X(10).
|
||
|
|
77 system-id PIC X(7).
|
||
|
|
77 len-text PIC S9(9) COMP-4.
|
||
|
|
01 subtext.
|
||
|
|
03 subchars PIC X OCCURS 1 TO 230 TIMES
|
||
|
|
DEPENDING ON len-text.
|
||
|
|
77 retcode PIC X(1).
|
||
|
|
PROCEDURE DIVISION USING cobol-id, valid-responses,
|
||
|
|
progr, system-id, subtext, len-text, retcode.
|
||
|
|
main-proc.
|
||
|
|
**********************************************************
|
||
|
|
* check for typical messages and take appropriate action *
|
||
|
|
**********************************************************
|
||
|
|
EVALUATE cobol-id
|
||
|
|
WHEN "LBE7604"
|
||
|
|
**********************************************************
|
||
|
|
* stop literal, let the user see the message *
|
||
|
|
**********************************************************
|
||
|
|
MOVE SPACE TO retcode
|
||
|
|
WHEN "LBE7208"
|
||
|
|
**********************************************************
|
||
|
|
* accept/display, recoverable problem answer G to continue
|
||
|
|
**********************************************************
|
||
|
|
MOVE "G" TO retcode
|
||
|
|
WHEN OTHER
|
||
|
|
**********************************************************
|
||
|
|
* for all other messages signal system operator and *
|
||
|
|
* end the current run unit *
|
||
|
|
**********************************************************
|
||
|
|
DISPLAY "COBOL Error Handler ACERRF24 "
|
||
|
|
"Found message " cobol-id
|
||
|
|
" Issued from program " progr
|
||
|
|
UPON syscon
|
||
|
|
DISPLAY " Ended current run unit"
|
||
|
|
UPON syscon
|
||
|
|
MOVE "C" TO retcode
|
||
|
|
END-EVALUATE.
|
||
|
|
GOBACK.</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div>
|
||
|
|
<div class="familylinks">
|
||
|
|
<div class="parentlink"><strong>Parent topic:</strong> <a href="apiexmp.htm" title="Contains example programs that use APIs and exit programs.">Examples: APIs</a></div>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
</body>
|
||
|
|
</html>
|