345 lines
14 KiB
HTML
345 lines
14 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 in ILE COBOL: List Object API" />
|
||
|
|
<meta name="abstract" content="The example program prints a report that shows all objects that adopt owner authority." />
|
||
|
|
<meta name="description" content="The example program prints a report that shows all objects that adopt owner authority." />
|
||
|
|
<meta name="DC.Relation" scheme="URI" content="listOverview.htm" />
|
||
|
|
<meta name="DC.Relation" scheme="URI" content="listRPG.htm" />
|
||
|
|
<meta name="DC.Relation" scheme="URI" content="listRPG.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="listCOBOL" />
|
||
|
|
<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 in ILE COBOL: List Object API</title>
|
||
|
|
</head>
|
||
|
|
<body id="listCOBOL"><a name="listCOBOL"><!-- --></a>
|
||
|
|
<!-- Java sync-link --><script language="Javascript" src="../rzahg/synch.js" type="text/javascript"></script>
|
||
|
|
<h1 class="topictitle1">Example in ILE COBOL: List Object API</h1>
|
||
|
|
<div><p>The example program prints a report that shows all objects that
|
||
|
|
adopt owner authority.</p>
|
||
|
|
<div class="section"><div class="note"><span class="notetitle">Note:</span> Read the <a href="codedisclaimer.htm">Code license and disclaimer information</a> for important
|
||
|
|
legal information.</div>
|
||
|
|
<p>Refer to Example in RPG: List Object
|
||
|
|
API for the original example. The following program also works for OPM COBOL.</p>
|
||
|
|
<pre> IDENTIFICATION DIVISION.
|
||
|
|
***************************************************************
|
||
|
|
***************************************************************
|
||
|
|
*
|
||
|
|
* Program: List objects that adopt owner authority
|
||
|
|
*
|
||
|
|
* Language: COBOL
|
||
|
|
*
|
||
|
|
* Description: This program prints a report showing all objects
|
||
|
|
* that adopt owner authority. The two parameters
|
||
|
|
* passed to the program are the profile to be
|
||
|
|
* checked and the type of objects to be listed.
|
||
|
|
* The parameter values are the same as those
|
||
|
|
* accepted by the QSYLOBJP API.
|
||
|
|
*
|
||
|
|
* APIs Used: QSYLOBJP - List Objects that Adopt Owner Authority
|
||
|
|
* QUSCRTUS - Create User Space
|
||
|
|
* QUSPTRUS - Retrieve Pointer to User Space
|
||
|
|
* QUSROBJD - Retrieve Object Description
|
||
|
|
*
|
||
|
|
***************************************************************
|
||
|
|
***************************************************************
|
||
|
|
*
|
||
|
|
PROGRAM-ID. LISTADOPT.
|
||
|
|
ENVIRONMENT DIVISION.
|
||
|
|
CONFIGURATION SECTION.
|
||
|
|
SOURCE-COMPUTER. IBM-AS400.
|
||
|
|
OBJECT-COMPUTER. IBM-AS400.
|
||
|
|
INPUT-OUTPUT SECTION.
|
||
|
|
FILE-CONTROL.
|
||
|
|
SELECT LISTING ASSIGN TO PRINTER-QPRINT
|
||
|
|
ORGANIZATION IS SEQUENTIAL.
|
||
|
|
DATA DIVISION.
|
||
|
|
FILE SECTION.
|
||
|
|
FD LISTING RECORD CONTAINS 132 CHARACTERS
|
||
|
|
LABEL RECORDS ARE STANDARD
|
||
|
|
DATA RECORD IS LIST-LINE.
|
||
|
|
01 LIST-LINE PIC X(132).
|
||
|
|
*
|
||
|
|
WORKING-STORAGE SECTION.
|
||
|
|
*
|
||
|
|
* Error Code parameter include. As this sample program
|
||
|
|
* uses COPY to include the error code structure, only the first
|
||
|
|
* 16 bytes of the error code structure are available. If the
|
||
|
|
* application program needs to access the variable length
|
||
|
|
* exception data for the error, the developer should physically
|
||
|
|
* copy the QSYSINC include and modify the copied include to
|
||
|
|
* define additional storage for the exception data.
|
||
|
|
*
|
||
|
|
COPY QUSEC OF QSYSINC-QLBLSRC.
|
||
|
|
*
|
||
|
|
* Listing text
|
||
|
|
*
|
||
|
|
01 OBJ-ENTRY.
|
||
|
|
05 OBJECT.
|
||
|
|
09 TEXT1 PIC X(08) VALUE "Object: ".
|
||
|
|
09 NAME PIC X(10).
|
||
|
|
09 TEXT2 PIC X(10) VALUE " Library: ".
|
||
|
|
09 LIBRARY PIC X(10).
|
||
|
|
05 TEXT3 PIC X(07) VALUE " Type: ".
|
||
|
|
05 OBJECT-TYPE PIC X(10).
|
||
|
|
05 TEXT4 PIC X(07) VALUE " Text: ".
|
||
|
|
05 OBJECT-TEXT PIC X(50).
|
||
|
|
01 END-LIST.
|
||
|
|
05 TEXT1 PIC X(15) VALUE "*** End of List".
|
||
|
|
*
|
||
|
|
01 MISC.
|
||
|
|
05 SPC-NAME PIC X(20) VALUE "ADOPTS QTEMP ".
|
||
|
|
05 SPC-SIZE PIC S9(09) VALUE 1 BINARY.
|
||
|
|
05 SPC-INIT PIC X(01) VALUE X"00".
|
||
|
|
05 SPCPTR POINTER.
|
||
|
|
05 RCVVAR PIC X(08).
|
||
|
|
05 RCVVARSIZ PIC S9(09) VALUE 8 BINARY.
|
||
|
|
05 LST-STATUS PIC X(01).
|
||
|
|
05 MBR-LIST PIC X(08) VALUE "OBJP0200".
|
||
|
|
05 CONTIN-HDL PIC X(20).
|
||
|
|
05 APINAM PIC X(10).
|
||
|
|
05 ROBJD-FMT PIC X(08) VALUE "OBJD0100".
|
||
|
|
05 SPC-TYPE PIC X(10) VALUE "*USRSPC".
|
||
|
|
05 EXT-ATTR PIC X(10) VALUE "QSYLOBJP".
|
||
|
|
05 SPC-AUT PIC X(10) VALUE "*ALL".
|
||
|
|
05 SPC-TEXT PIC X(50).
|
||
|
|
05 SPC-REPLAC PIC X(10) VALUE "*YES".
|
||
|
|
05 SPC-DOMAIN PIC X(10) VALUE "*USER".
|
||
|
|
*
|
||
|
|
LINKAGE SECTION.
|
||
|
|
*
|
||
|
|
* Input parameters.
|
||
|
|
*
|
||
|
|
01 USR-PRF PIC X(10).
|
||
|
|
01 OBJ-TYPE PIC X(10).
|
||
|
|
*
|
||
|
|
* String to map User Space offsets into
|
||
|
|
*
|
||
|
|
01 STRING-SPACE PIC X(32000).
|
||
|
|
*
|
||
|
|
* User Space Generic Header include. These includes will be
|
||
|
|
* mapped over a User Space.
|
||
|
|
*
|
||
|
|
COPY QUSGEN OF QSYSINC-QLBLSRC.
|
||
|
|
*
|
||
|
|
* List Objects that Adopt API include. These includes will be
|
||
|
|
* mapped over a User Space.
|
||
|
|
*
|
||
|
|
COPY QSYLOBJP OF QSYSINC-QLBLSRC.
|
||
|
|
*
|
||
|
|
* Beginning of mainline
|
||
|
|
*
|
||
|
|
PROCEDURE DIVISION USING USR-PRF, OBJ-TYPE.
|
||
|
|
MAIN-LINE.
|
||
|
|
PERFORM INIT.
|
||
|
|
PERFORM PROCES.
|
||
|
|
PERFORM DONE.
|
||
|
|
*
|
||
|
|
* Start of subroutines
|
||
|
|
*
|
||
|
|
*****************************************************************
|
||
|
|
PROCES.
|
||
|
|
*
|
||
|
|
* Do until the list is complete
|
||
|
|
*
|
||
|
|
MOVE INFORMATION-STATUS OF QUS-GENERIC-HEADER-0100 TO
|
||
|
|
LST-STATUS.
|
||
|
|
*
|
||
|
|
PERFORM PROCES1 WITH TEST AFTER UNTIL LST-STATUS = "C".
|
||
|
|
*
|
||
|
|
PROCES1.
|
||
|
|
*
|
||
|
|
* This subroutine processes each entry returned by QSYLOBJP
|
||
|
|
*
|
||
|
|
*
|
||
|
|
* If valid information was returned
|
||
|
|
*
|
||
|
|
IF (INFORMATION-STATUS OF QUS-GENERIC-HEADER-0100 = "C"
|
||
|
|
OR INFORMATION-STATUS OF QUS-GENERIC-HEADER-0100 = "P")
|
||
|
|
IF NUMBER-LIST-ENTRIES OF QUS-GENERIC-HEADER-0100 > 0
|
||
|
|
*
|
||
|
|
* increment to the first list entry
|
||
|
|
*
|
||
|
|
SET ADDRESS OF QSY-OBJP0200-LIST TO
|
||
|
|
ADDRESS OF STRING-SPACE(
|
||
|
|
(OFFSET-LIST-DATA OF QUS-GENERIC-HEADER-0100 + 1):1), <span class="uicontrol">(5)</span>
|
||
|
|
SET ADDRESS OF STRING-SPACE TO ADDRESS OF
|
||
|
|
QSY-OBJP0200-LIST,
|
||
|
|
*
|
||
|
|
* and process all of the entries
|
||
|
|
*
|
||
|
|
PERFORM PROCES2
|
||
|
|
NUMBER-LIST-ENTRIES OF QUS-GENERIC-HEADER-0100 TIMES, <span class="uicontrol">(6)</span>
|
||
|
|
*
|
||
|
|
* If all entries in this User Space have been processed, check
|
||
|
|
* if more entries exist than can fit in one User Space
|
||
|
|
*
|
||
|
|
IF INFORMATION-STATUS OF QUS-GENERIC-HEADER-0100 = "P"
|
||
|
|
*
|
||
|
|
* by addressing the input parameter header
|
||
|
|
*
|
||
|
|
SET ADDRESS OF STRING-SPACE TO SPCPTR,
|
||
|
|
SET ADDRESS OF QSY-OBJP-INPUT TO
|
||
|
|
ADDRESS OF STRING-SPACE((OFFSET-INPUT-PARAMETER
|
||
|
|
OF QUS-GENERIC-HEADER-0100 + 1):1),
|
||
|
|
*
|
||
|
|
* If the continuation handle in the Input Parameter Header is
|
||
|
|
* blank, then set the List status to Complete
|
||
|
|
*
|
||
|
|
IF CONTINUATION-HANDLE OF QSY-OBJP-INPUT = SPACES
|
||
|
|
MOVE "C" TO LST-STATUS
|
||
|
|
ELSE
|
||
|
|
*
|
||
|
|
* Else, call QSYLOBJP reusing the User Space to get more
|
||
|
|
* List entries
|
||
|
|
*
|
||
|
|
MOVE CONTINUATION-HANDLE OF QSY-OBJP-INPUT
|
||
|
|
TO CONTIN-HDL OF MISC, <span class="uicontrol">(2)</span>
|
||
|
|
PERFORM GETLST,
|
||
|
|
MOVE INFORMATION-STATUS OF QUS-GENERIC-HEADER-0100
|
||
|
|
TO LST-STATUS,
|
||
|
|
END-IF,
|
||
|
|
END-IF,
|
||
|
|
END-IF,
|
||
|
|
ELSE
|
||
|
|
*
|
||
|
|
* And if an unexpected status, log an error (not shown) and exit
|
||
|
|
*
|
||
|
|
PERFORM DONE,
|
||
|
|
END-IF.
|
||
|
|
*
|
||
|
|
PROCES2.
|
||
|
|
MOVE CORRESPONDING QSY-OBJP0200-LIST TO OBJ-ENTRY.
|
||
|
|
WRITE LIST-LINE FROM OBJ-ENTRY.
|
||
|
|
*
|
||
|
|
* after each entry, increment to the next entry
|
||
|
|
*
|
||
|
|
SET ADDRESS OF QSY-OBJP0200-LIST TO ADDRESS OF
|
||
|
|
STRING-SPACE(
|
||
|
|
(SIZE-EACH-ENTRY OF QUS-GENERIC-HEADER-0100 + 1):1). <span class="uicontrol">(7)</span>
|
||
|
|
SET ADDRESS OF STRING-SPACE TO ADDRESS OF QSY-OBJP0200-LIST.
|
||
|
|
*****************************************************************
|
||
|
|
GETLST.
|
||
|
|
*
|
||
|
|
* Call QSYLOBJP to generate a list
|
||
|
|
* The continuation handle is set by the caller of this
|
||
|
|
* subroutine.
|
||
|
|
MOVE "OBJP0200" TO MBR-LIST.
|
||
|
|
*
|
||
|
|
CALL "QSYLOBJP" USING SPC-NAME, MBR-LIST, USR-PRF,
|
||
|
|
OBJ-TYPE, CONTIN-HDL, QUS-EC. <span class="uicontrol">(3)</span>
|
||
|
|
*
|
||
|
|
* Check for errors on QSYLOBJP
|
||
|
|
*
|
||
|
|
IF BYTES-AVAILABLE OF QUS-EC > 0
|
||
|
|
MOVE "QSYLOBJP" TO APINAM,
|
||
|
|
PERFORM APIERR.
|
||
|
|
*****************************************************************
|
||
|
|
INIT.
|
||
|
|
*
|
||
|
|
* One time initialization code for this program
|
||
|
|
*
|
||
|
|
* Open LISTING file
|
||
|
|
*
|
||
|
|
OPEN OUTPUT LISTING.
|
||
|
|
*
|
||
|
|
* Set Error Code structure to not use exceptions
|
||
|
|
*
|
||
|
|
MOVE LENGTH OF QUS-EC TO BYTES-PROVIDED OF QUS-EC.
|
||
|
|
*
|
||
|
|
* Check to see if the User Space was previously created in
|
||
|
|
* QTEMP. If it was, simply reuse it.
|
||
|
|
*
|
||
|
|
CALL "QUSROBJD" USING RCVVAR, RCVVARSIZ, ROBJD-FMT,
|
||
|
|
SPC-NAME, SPC-TYPE, QUS-EC.
|
||
|
|
*
|
||
|
|
* Check for errors on QUSROBJD
|
||
|
|
*
|
||
|
|
IF BYTES-AVAILABLE OF QUS-EC > 0
|
||
|
|
*
|
||
|
|
* If CPF9801, then User Space was not found
|
||
|
|
*
|
||
|
|
IF EXCEPTION-ID OF QUS-EC = "CPF9801"
|
||
|
|
*
|
||
|
|
* So create a User Space for the List generated by QSYLOBJP
|
||
|
|
*
|
||
|
|
CALL "QUSCRTUS" USING SPC-NAME, EXT-ATTR, SPC-SIZE,
|
||
|
|
SPC-INIT, SPC-AUT, SPC-TEXT,
|
||
|
|
SPC-REPLAC, QUS-EC, SPC-DOMAIN
|
||
|
|
*
|
||
|
|
* Check for errors on QUSCRTUS
|
||
|
|
*
|
||
|
|
IF BYTES-AVAILABLE OF QUS-EC > 0
|
||
|
|
MOVE "QUSCRTUS" TO APINAM,
|
||
|
|
PERFORM APIERR,
|
||
|
|
ELSE
|
||
|
|
CONTINUE,
|
||
|
|
ELSE
|
||
|
|
*
|
||
|
|
* Else, an error occurred accessing the User Space
|
||
|
|
*
|
||
|
|
MOVE "QUSROBJD" TO APINAM,
|
||
|
|
PERFORM APIERR.
|
||
|
|
*
|
||
|
|
* Set QSYLOBJP (via GETLST) to start a new list
|
||
|
|
*
|
||
|
|
MOVE SPACES TO CONTIN-HDL.
|
||
|
|
PERFORM GETLST.
|
||
|
|
*
|
||
|
|
* Get a resolved pointer to the User Space for performance
|
||
|
|
*
|
||
|
|
CALL "QUSPTRUS" USING SPC-NAME, SPCPTR, QUS-EC.
|
||
|
|
*
|
||
|
|
* Check for errors on QUSPTRUS
|
||
|
|
*
|
||
|
|
IF BYTES-AVAILABLE OF QUS-EC > 0
|
||
|
|
MOVE "QUSPTRUS" TO APINAM,
|
||
|
|
PERFORM APIERR.
|
||
|
|
*
|
||
|
|
* If no error, then set addressability to User Space
|
||
|
|
*
|
||
|
|
SET ADDRESS OF QUS-GENERIC-HEADER-0100 TO SPCPTR.
|
||
|
|
SET ADDRESS OF STRING-SPACE TO SPCPTR.
|
||
|
|
*
|
||
|
|
*****************************************************************
|
||
|
|
APIERR.
|
||
|
|
*
|
||
|
|
* Log any error encountered, and exit the program
|
||
|
|
*
|
||
|
|
DISPLAY APINAM.
|
||
|
|
DISPLAY EXCEPTION-ID OF QUS-EC.
|
||
|
|
PERFORM DONE.
|
||
|
|
*****************************************************************
|
||
|
|
DONE.
|
||
|
|
*
|
||
|
|
* Exit the program
|
||
|
|
*
|
||
|
|
WRITE LIST-LINE FROM END-LIST.
|
||
|
|
STOP RUN.</pre>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
<div>
|
||
|
|
<div class="familylinks">
|
||
|
|
<div class="parentlink"><strong>Parent topic:</strong> <a href="listOverview.htm" title="List APIs return a list unique to a given API. The section discusses the characteristics of a list API and provides information that you should be aware of when you use list APIs.">List APIs overview</a></div>
|
||
|
|
</div>
|
||
|
|
<div class="relref"><strong>Related reference</strong><br />
|
||
|
|
<div><a href="listRPG.htm" title="This example program prints a report that shows all objects that adopt owner authority.">Example in RPG: List Object API</a></div>
|
||
|
|
</div>
|
||
|
|
</div>
|
||
|
|
</body>
|
||
|
|
</html>
|