Add APIs
This commit is contained in:
SJLennon
@@ -0,0 +1,175 @@
|
||||
**FREE
|
||||
/TITLE GETJOBTR Get Active Job Type: Interactive, Batch, whatever
|
||||
// -------------------------------------------------------------------
|
||||
// This program is passed job name, user and job number and if the
|
||||
// job is active, it returns the job type, otherwise returns ' '.
|
||||
// Initially written to be called from GETOBJUR.
|
||||
//=== Parameters =================================================
|
||||
// Input Parm:
|
||||
// Job name - 10 char job name + 10 char user + 6 char job number,
|
||||
// or * for job program is running in.
|
||||
// Out Parm:
|
||||
// Type - 1 character as returned by the QUSLJOB API.
|
||||
// I=Interactive, B=Batch, blank is job not active.
|
||||
// A=Autostart, M=subsystem monitor, R=spooled reader,
|
||||
// S=system job, W=spooled writer, X=SCPF system job.
|
||||
//Compile: CRTBNDRPG PGM(GETJOBTR) SRCFILE(...) DBGVIEW(*LIST)
|
||||
// -------------------------------------------------------------------
|
||||
// 12/00/97 LENNON Original Writing
|
||||
// 07/--/2021 Lennon Converted to **FREE and Linear module.
|
||||
// It was origially a standalone program. Perhaps it should
|
||||
// be a service program and perhaps some of the diract API
|
||||
// call should be in a service program.
|
||||
// -------------------------------------------------------------------
|
||||
ctl-opt debug option(*nodebugio: *srcstmt)
|
||||
dftactgrp(*no) actgrp(*caller)
|
||||
main(Main);
|
||||
/copy USPHDR
|
||||
//=== CRTUSRSPC (QUSCTRUS) Parameters ================================
|
||||
dcl-s CusName char(20) inz('GETJOBTR QTEMP');
|
||||
dcl-s CusAttr char(10) inz('GETJOBTR ');
|
||||
dcl-s CusIntSize bindec(9);
|
||||
dcl-s CusIntVal char(1) inz(x'00');
|
||||
dcl-s CusAut char(10) inz('*CHANGE');
|
||||
dcl-s CusText char(50) inz('GETJOBTR ');
|
||||
dcl-s CusReplace char(10) inz('*NO');
|
||||
dcl-s CusDomain char(10) inz('*DEFAULT');
|
||||
//=== List Job (QUSLJOB) Parameters ==================================
|
||||
dcl-s LJBFormat char(8) inz('JOBL0100');
|
||||
dcl-s LJBQJobName char(26);
|
||||
dcl-s LJBStatus char(10) inz('*ACTIVE');
|
||||
//=== List Job Entry Layout ==========================================
|
||||
dcl-ds LJLEntry based(ljptr);
|
||||
LJJobName char(10);
|
||||
LJJobUser char(10);
|
||||
LJJobNum char(6);
|
||||
LJJobIdent char(16);
|
||||
LJJobStus char(10);
|
||||
LJJobType char(1);
|
||||
LJJobSubT char(1);
|
||||
LJReserved char(2);
|
||||
end-ds;
|
||||
dcl-s LJPtr pointer inz(*null);
|
||||
//=== Send Pgm Message (QMHSNDPM) Parameters =========================
|
||||
dcl-s MSNMsgId char(7);
|
||||
dcl-s MSNFile char(20) inz('QCPFMSG *LIBL ');
|
||||
dcl-s MSNData char(1);
|
||||
dcl-s MSNLength bindec(9);
|
||||
dcl-s MSNType char(10) inz('*ESCAPE');
|
||||
dcl-s MSNStackE char(10) inz('*CTLBDY');
|
||||
dcl-s MSNStackC bindec(9) inz(1);
|
||||
dcl-s MSNMsgKey char(4);
|
||||
//=== API Error Code Structure =======================================
|
||||
dcl-ds APIError len(272);
|
||||
APIEProv int(10) inz(0) pos(1);
|
||||
APIEAvail int(10) inz(0) pos(5);
|
||||
APIErrId char(7) pos(9);
|
||||
APIErrRsv char(1);
|
||||
APIEData char(256);
|
||||
end-ds;
|
||||
dcl-pr p_qusdltus extpgm('QUSDLTUS');
|
||||
*n char(20); // CusName
|
||||
*n char(272); // APIError
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr p_qmhsndpm extpgm('QMHSNDPM');
|
||||
*n char(7); // MSNMsgId
|
||||
*n char(20); // MSNFile
|
||||
*n char(256); // APIEData
|
||||
*n bindec(9); // MSNLength
|
||||
*n char(10); // MSNType
|
||||
*n char(10); // MSNStackE
|
||||
*n bindec(9); // MSNStackC
|
||||
*n char(4); // MSNMsgKey
|
||||
*n char(272); // APIError
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr p_quscrtus extpgm('QUSCRTUS');
|
||||
*n char(20); // CusName
|
||||
*n char(10); // CusAttr
|
||||
*n bindec(9); // CusIntSize
|
||||
*n char(1); // CusIntVal
|
||||
*n char(10); // CusAut
|
||||
*n char(50); // Custext
|
||||
*n char(10); // CusReplace
|
||||
*n char(272); // APIError
|
||||
*n char(10); // CusDomain
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr p_qusptrus extpgm('QUSPTRUS');
|
||||
*n char(20); // CusName
|
||||
*n pointer; // UspPtr
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr p_qusljob extpgm('QUSLJOB');
|
||||
*n char(20); // CusName
|
||||
*n char(8); // LJBFormat
|
||||
*n char(26); // LJBQJobName
|
||||
*n char(10); // LJBStatus
|
||||
end-pr;
|
||||
//=== Main ===========================================================
|
||||
dcl-proc Main;
|
||||
// -----------------------------------
|
||||
dcl-pi *n extpgm('GETJOBTR');
|
||||
pQJob char(26);
|
||||
pType char(1);
|
||||
end-pi;
|
||||
//=== Delete the User Space ======================================
|
||||
APIEProv=%LEN(APIError);
|
||||
p_QUSDLTUS(
|
||||
CusName:
|
||||
APIError);
|
||||
// If user space doesn't exist, accept message CPF2105, else
|
||||
// something nasty wrong - pass errors back
|
||||
if APIEAvail <> 0 and APIErrId <> 'CPF2105';
|
||||
APIEProv=0;
|
||||
MSNMsgId=APIErrId;
|
||||
MSNLength=APIEAvail-16;
|
||||
p_QMHSNDPM(
|
||||
MSNMsgId:
|
||||
MSNFile:
|
||||
APIEData:
|
||||
MSNLength:
|
||||
MSNType:
|
||||
MSNStackE:
|
||||
MSNStackC:
|
||||
MSNMsgKey:
|
||||
APIError);
|
||||
endif;
|
||||
// === Create User Space =========================================
|
||||
// We only expect one entry back since job is fully qualified, but
|
||||
// allocate enough for 10 entries in case entry size expands.
|
||||
CusIntSize=%size(UspHdr) + (%size(LJLentry)*10);
|
||||
LJBQJobname=pQJob;
|
||||
// === Create the User Space =====================================
|
||||
APIEProv = 0;
|
||||
p_QUSCRTUS(
|
||||
CusName:
|
||||
CusAttr:
|
||||
CusIntSize:
|
||||
CusIntVal:
|
||||
CusAut:
|
||||
Custext:
|
||||
CusReplace:
|
||||
APIError:
|
||||
CusDomain);
|
||||
// === Get Pointer to User Space =================================
|
||||
p_QUSPTRUS(CusName: UspPtr);
|
||||
// === Get Job Info ==============================================
|
||||
p_QUSLJOB(
|
||||
CusName:
|
||||
LJBFormat:
|
||||
LJBQJobName:
|
||||
LJBStatus);
|
||||
if UspLst#Ent>0;
|
||||
LJPtr=UspPtr+UspLstOfs;
|
||||
// All that code just to execute this one instruction...
|
||||
pType=LJJobType;
|
||||
else;
|
||||
pType=' ';
|
||||
endif;
|
||||
// === Return to Caller ==========================================
|
||||
// Leave LR Off - this isn't very big.
|
||||
return;
|
||||
//
|
||||
end-proc;
|
||||
@@ -0,0 +1,86 @@
|
||||
GETOBJUC: +
|
||||
PGM PARM(&OBJECT &TYPE &MEMBER &RETMSG &RETMSGFLD &RETFILE)
|
||||
|
||||
/* -----------------------------------------------------------------*/
|
||||
/* This program finds all the jobs which are using an object. */
|
||||
/* It returns a message suitable for display to the operator */
|
||||
/* and/or file QTEMP/GETOBJUP listing all jobs. This file */
|
||||
/* could be used to send a message to all users of the object. */
|
||||
/* -----------------------------------------------------------------*/
|
||||
/* Use the GETOBJUSR command to invoke this program */
|
||||
/* -----------------------------------------------------------------*/
|
||||
/* 11/24/97 LENNON Original writing */
|
||||
/* -----------------------------------------------------------------*/
|
||||
/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
|
||||
/* RTVOBJD to get real library name to put in the */
|
||||
/* message fails. If this occurs, just continue and */
|
||||
/* *LIBL may appear in the message. */
|
||||
/* -----------------------------------------------------------------*/
|
||||
|
||||
/* Input parameters */
|
||||
DCL VAR(&OBJECT) TYPE(*CHAR) LEN(20) /* Obj & lib */
|
||||
DCL VAR(&TYPE) TYPE(*CHAR) LEN(10) /* Obj type */
|
||||
DCL VAR(&MEMBER) TYPE(*CHAR) LEN(10) /* if *FILE */
|
||||
DCL VAR(&RETMSG) TYPE(*CHAR) LEN(4) /* Return a msg? */
|
||||
DCL VAR(&RETMSGFLD) TYPE(*CHAR) LEN(200) /* Fld for msg */
|
||||
DCL VAR(&RETFILE) TYPE(*CHAR) LEN(4) /* Return a file? */
|
||||
|
||||
/* Variables used in this program */
|
||||
DCL VAR(&OBJNAM) TYPE(*CHAR) LEN(10) /* Obj name */
|
||||
DCL VAR(&OBJLIB) TYPE(*CHAR) LEN(10) /* Obj lib */
|
||||
DCL VAR(&FRMOBJLIB) TYPE(*CHAR) LEN(10) /* For duping file */
|
||||
DCL VAR(&FAKMSGFLD) TYPE(*CHAR) LEN(1) /* No msg fld passed */
|
||||
|
||||
/* Error Handling Variables */
|
||||
DCL VAR(&E_MSGID) TYPE(*CHAR) LEN(7)
|
||||
DCL VAR(&E_MSGF) TYPE(*CHAR) LEN(10)
|
||||
DCL VAR(&E_MSGFLIB) TYPE(*CHAR) LEN(10)
|
||||
DCL VAR(&E_MSGDTA) TYPE(*CHAR) LEN(100)
|
||||
|
||||
/* Catch unmonitored errors */
|
||||
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
|
||||
|
||||
/* Convert *LIBL/*CURLIB into a real name, if possible */
|
||||
CHGVAR VAR(&OBJNAM) VALUE(%SST(&OBJECT 1 10))
|
||||
CHGVAR VAR(&OBJLIB) VALUE(%SST(&OBJECT 11 10))
|
||||
RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
|
||||
MONMSG MSGID(CPF9803) EXEC(DO) /*Cannot Allocate*/
|
||||
GOTO CMDLBL(PASTLIBGET)
|
||||
ENDDO
|
||||
CHGVAR VAR(%SST(&OBJECT 11 10)) VALUE(&OBJLIB)
|
||||
PASTLIBGET: +
|
||||
|
||||
/* If output file requested, create empty file in QTEMP */
|
||||
IF COND(&RETFILE = '*YES') THEN(DO)
|
||||
DLTF FILE(QTEMP/GETOBJUP)
|
||||
MONMSG MSGID(CPF2105) /* not found */
|
||||
RTVOBJD OBJ(*LIBL/GETOBJUP) OBJTYPE(*FILE) RTNLIB(&FRMOBJLIB)
|
||||
CRTDUPOBJ OBJ(GETOBJUP) FROMLIB(&FRMOBJLIB) OBJTYPE(*FILE) +
|
||||
TOLIB(QTEMP)
|
||||
ADDPFM FILE(QTEMP/GETOBJUP) MBR(GETOBJUP)
|
||||
OVRDBF FILE(GETOBJUP) TOFILE(QTEMP/GETOBJUP) SECURE(*YES)
|
||||
ENDDO
|
||||
|
||||
/* Call RPG program to find the users */
|
||||
IF COND(&RETMSG = '*YES') THEN(DO)
|
||||
CALL PGM(GETOBJUR) PARM(&OBJECT &TYPE &MEMBER &RETMSG +
|
||||
&RETMSGFLD &RETFILE)
|
||||
ENDDO
|
||||
ELSE CMD(DO)
|
||||
CALL PGM(GETOBJUR) PARM(&OBJECT &TYPE &MEMBER &RETMSG +
|
||||
&FAKMSGFLD &RETFILE)
|
||||
ENDDO
|
||||
|
||||
/* End of program */
|
||||
GOTO CMDLBL(ENDPGM)
|
||||
|
||||
/* Error handler - resend any trapped escape message */
|
||||
ERROR: +
|
||||
RCVMSG MSGTYPE(*LAST) MSGDTA(&E_MSGDTA) MSGID(&E_MSGID) +
|
||||
MSGF(&E_MSGF) MSGFLIB(&E_MSGFLIB)
|
||||
MONMSG MSGID(CPF0000) /* Just in case */
|
||||
SNDPGMMSG MSGID(&E_MSGID) MSGF(&E_MSGFLIB/&E_MSGF) +
|
||||
MSGDTA(&E_MSGDTA) MSGTYPE(*ESCAPE)
|
||||
MONMSG MSGID(CPF0000) /* Just in case */
|
||||
ENDPGM: +
|
||||
ENDPGM
|
||||
@@ -0,0 +1,17 @@
|
||||
|
||||
*================================================================
|
||||
* File of Jobs using an object, returned by GETOBJUSR Command.
|
||||
*
|
||||
* =====> Create with MBR(*NONE). Dupe into QTEMP to use.
|
||||
*
|
||||
* 12/00/97 LENNON Initial Coding
|
||||
*================================================================
|
||||
A R GETOBJU
|
||||
A OUJOBNAME 10 TEXT('Job Name')
|
||||
A COLHDG('Job' 'Name')
|
||||
A OUJOBUSER 10A TEXT('Job User')
|
||||
A COLHDG('Job' 'User')
|
||||
A OUJOBNUM 6A TEXT('Job Number')
|
||||
A COLHDG('Job' 'Number')
|
||||
A OUJOBTYPE 1A TEXT('I=interact, other=non inter')
|
||||
A COLHDG('Type')
|
||||
@@ -0,0 +1,369 @@
|
||||
**FREE
|
||||
/TITLE GETOBJUR - Get users of an object
|
||||
//--------------------------------------------------------------------
|
||||
// Given an object and type, this program finds all jobs that have
|
||||
// locks on the object. It returns a message suitable for sending
|
||||
// to the system operator and/or a file, QTEMP/GETOBJUP, which
|
||||
// could be used to send messages to all interactive users of the
|
||||
// object, or for some other use.
|
||||
// This program is called from CL program GETOBJUC.
|
||||
// It calls the QWCLOBJL (List Object Locks) API.
|
||||
// Message looks like this:
|
||||
// QIWS/QCUSTCDT *FILE is in use by QPAD165916/LENNONS/167740.
|
||||
// Or this:
|
||||
// QIWS/QCUSTCDT *FILE is in use by CUSTLST/LENNONS/167922,
|
||||
// DAILYORD/LENNONS/167924, INV_UPD/LENNONS/167923,
|
||||
// QPAD165916/LENNONS/167740 plus 1 more.
|
||||
// Compile: CRTBNDRPG PGM(GETOBJUR) SRCFILE(...) DBGVIEW(*LIST)
|
||||
//--------------------------------------------------------------------
|
||||
// 12/00/97 LENNON Original Writing
|
||||
// 07/--/2021 Converted to **FREE and Linear module.
|
||||
// There are SQL services now that can provide similar
|
||||
// infomations, but as far as I know there is no SQL
|
||||
// interface to QWCLOBJL. And there certainly was not in
|
||||
// 1997. This code probably performs better than existing
|
||||
// SQL interfaces. For most use cases performance may not
|
||||
// be a consideration.
|
||||
//--------------------------------------------------------------------
|
||||
ctl-opt debug option(*nodebugio: *srcstmt)
|
||||
dftactgrp(*no) actgrp(*caller)
|
||||
main(Main);
|
||||
dcl-f GETOBJUP usage(*output) usropn block(*yes);
|
||||
/copy USPHDR
|
||||
//=== CRTUSRSPC (QUSCTRUS) Parameters ================================
|
||||
dcl-ds *n;
|
||||
CusQName char(20);
|
||||
CusName char(10) overlay(cusqname) inz('GETOBJUSR');
|
||||
CusLib char(10) overlay(cusqname:11) inz('QTEMP');
|
||||
end-ds;
|
||||
dcl-s CusAttr char(10) inz('GETOBJUSR ');
|
||||
dcl-s CusIntSize int(10);
|
||||
dcl-s CusIntVal char(1) inz(x'00');
|
||||
dcl-s CusAut char(10) inz('*CHANGE');
|
||||
dcl-s CusText char(50) inz('GETOBJUSR Command');
|
||||
//=== Send Pgm Message (QMHSNDPM) Parameters =========================
|
||||
dcl-s MSNMsgId char(7);
|
||||
dcl-s MSNFile char(20) inz('QCPFMSG *LIBL ');
|
||||
dcl-s MSNData char(1);
|
||||
dcl-s MSNLength int(10);
|
||||
dcl-s MSNType char(10) inz('*ESCAPE');
|
||||
dcl-s MSNStackE char(10) inz('*CTLBDY');
|
||||
dcl-s MSNStackC int(10) inz(1);
|
||||
dcl-s MSNMsgKey char(4);
|
||||
//=== List Object Locks List Entry Layout ============================
|
||||
dcl-ds LOLEntry based(loptr);
|
||||
LOJobName char(10);
|
||||
LOJobUser char(10);
|
||||
LOJobNum char(6);
|
||||
LOLckState char(10);
|
||||
LOLckStus int(10);
|
||||
LOLckType int(10);
|
||||
LOMemName char(10);
|
||||
LOShare char(1);
|
||||
LOReserved char(1);
|
||||
end-ds;
|
||||
dcl-s LOPtr pointer inz(*null);
|
||||
dcl-s LOEndPtr pointer inz(*null);
|
||||
//=== API Error Code Structure =======================================
|
||||
dcl-ds APIError len(272);
|
||||
APIEProv int(10) inz(216) pos(1);
|
||||
APIEAvail int(10) inz(0) pos(5);
|
||||
APIErrID char(7) pos(9);
|
||||
APIErrRsv char(1);
|
||||
APIEData char(256);
|
||||
end-ds;
|
||||
//=== Misc Field Definitions =========================================
|
||||
dcl-s LolFmt char(8) inz('OBJL0100');
|
||||
dcl-s ObjMEM char(10);
|
||||
dcl-s NumJobs packed(5);
|
||||
dcl-c MaxJobs const(4); //Maximum jobs for detailed reporting.
|
||||
// If you increase MaxJobs, increase the message parameter by 30 bytes
|
||||
// for each additional job.
|
||||
dcl-ds JobName26;
|
||||
SavJobName like(lojobname);
|
||||
SavJobUser like(lojobuser);
|
||||
SavJobNum like(lojobnum);
|
||||
end-ds;
|
||||
dcl-s Jobname28 char(28);
|
||||
dcl-s JobType char(1);
|
||||
//=== Parameters for SRTUSRSPC =======================================
|
||||
// SKeyStart - Array of key starting positions
|
||||
// SKeyLgth - Array of key lengths
|
||||
// SKeyAorD - Array of ascending/descending sequences
|
||||
// SKeyType - Array of key field data types.
|
||||
dcl-s SKeyStart packed(5) dim(10); // start position
|
||||
dcl-s SKeyLgth packed(5) dim(10); // lengths
|
||||
dcl-s SKeyAorD char(1) dim(10); // ascend/descend
|
||||
dcl-s SKeyType char(1) dim(10); // data type
|
||||
dcl-s S#Keys packed(3) inz(3);
|
||||
dcl-s SError char(1);
|
||||
//=== Program Entry and Parameters ===================================
|
||||
dcl-proc Main ;
|
||||
// Input Parameters
|
||||
// pObject is object name (10c) + object library (10c)
|
||||
// pObjType is *FILE, *DTAARA, etc., standard OS/400 type
|
||||
// pObjMem is the member for files, or *NONE if just want users
|
||||
// of the file.
|
||||
// pMsgYN is *YES to create a message.
|
||||
// pFileYN is *YES if file GETOBJUP is to be created in QTEMP
|
||||
// Output Parameter
|
||||
// PMsgFld is where the message gets created.
|
||||
// ---------------------------------------------------------
|
||||
dcl-pi *n extpgm('GETOBJUR');
|
||||
pObject char(20);
|
||||
pObjType char(10);
|
||||
pObjMem char(10);
|
||||
pMsgYN char(4);
|
||||
pMsgFld char(200);
|
||||
pFileYN char(4);
|
||||
end-pi;
|
||||
//------------------------------------------------------
|
||||
dcl-pr ListObjLck extpgm('QWCLOBJL');
|
||||
*n char(20); // CusQName
|
||||
*n char(8); // LolFmt
|
||||
*n char(20); // pObject
|
||||
*n char(10); // pObjType
|
||||
*n char(10); // ObjMem
|
||||
*n char(272); // APIError
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
// Gets job type entry for this job.
|
||||
// Returns: JobType has the job type. I=interactive, B=batch, etc.
|
||||
dcl-pr GetJobType extpgm('GETJOBTR');
|
||||
*n char(26); // JobName26
|
||||
*n char(1); // JobType
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr p_srtusrspc extpgm('SRTUSRSPC');
|
||||
*n char(10); // CusName
|
||||
*n char(10); // CusLib
|
||||
*n packed(3); // S#keys
|
||||
*n packed(5) dim(10); // KeyStart
|
||||
*n packed(5) dim(10); // KeyLgth
|
||||
*n char(1) dim(10); // Key A or D
|
||||
*n char(1) dim(10); // SKeyType
|
||||
*n char(1); // SError
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr SendMsg extpgm('QMHSNDPM');
|
||||
*n char(7); // MSNMsgId
|
||||
*n char(20); // MSNFile
|
||||
*n char(256); // APIEData
|
||||
*n int(10); // MSNLength
|
||||
*n char(10); // MSNType
|
||||
*n char(10); // MSNStackE
|
||||
*n int(10); // MSNStackC
|
||||
*n char(4); // MSNMsgKey
|
||||
*n char(272); // APIError
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr UsrSpcCrt extpgm('QUSCRTUS');
|
||||
*n char(20); // CusQName
|
||||
*n char(10); // CusAttr
|
||||
*n int(10); // CusIntSize
|
||||
*n char(1); // CusIntVal
|
||||
*n char(10); // CusAut
|
||||
*n char(50); // Custext
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr UsrSpcDlt extpgm('QUSDLTUS');
|
||||
*n char(20); // CusQName
|
||||
*n char(272); // APIError
|
||||
end-pr;
|
||||
//------------------------------------------------------
|
||||
dcl-pr UsrSpcPointer extpgm('QUSPTRUS');
|
||||
*n char(20); // CusQName
|
||||
*n pointer; // UspPtr
|
||||
end-pr;
|
||||
|
||||
//=== Code starts here ===========================================
|
||||
exsr Initialize;
|
||||
//=== List the Object Locks ======================================
|
||||
// Object type should be *NONE if not a file.
|
||||
if pObjType='*FILE';
|
||||
ObjMem=pObjMem;
|
||||
else;
|
||||
ObjMem='*NONE';
|
||||
endif;
|
||||
APIEProv=0;
|
||||
ListObjLck(
|
||||
CusQName:
|
||||
LolFmt:
|
||||
pObject:
|
||||
pObjType:
|
||||
ObjMem:
|
||||
APIError);
|
||||
exsr srtusrspc;
|
||||
// === Main Program Loop =========================================
|
||||
// Loop through the entries in the list
|
||||
exsr NxtJob;
|
||||
dow LOPtr <> *NULL;
|
||||
if pFileYN='*YES';
|
||||
GetJobType(JobName26: JobType);
|
||||
exsr WriteRec;
|
||||
endif;
|
||||
if pMsgYN='*YES';
|
||||
exsr BldMsg;
|
||||
endif;
|
||||
exsr NxtJob;
|
||||
enddo;
|
||||
// === End of Program ============================================
|
||||
if pFileYN='*YES';
|
||||
close GETOBJUP;
|
||||
endif;
|
||||
if pMsgYN='*YES';
|
||||
select;
|
||||
when NumJobs >= 1 and NumJobs <=MaxJobs;
|
||||
pMsgfld=%trimr(pMsgFld) + '.';
|
||||
when NumJobs > MaxJobs;
|
||||
pMsgfld=%trimr(pMsgFld) + ' plus ' +
|
||||
%trim(%editc(NumJobs-MaxJobs:'J')) +
|
||||
' more.';
|
||||
other;
|
||||
endsl;
|
||||
endif;
|
||||
*inlr=*on;
|
||||
// === NxtJob ====================================================
|
||||
// A job can have more than one lock on an object. We just want a
|
||||
// job once.
|
||||
// Sets LOPtr to the first entry, or to the next different entry.
|
||||
// LOPtr assumed to be *NULL on first call.
|
||||
// Returns: LOPtr=*NULL if no more entries.
|
||||
// NumJobs=number of unique jobs so far
|
||||
begsr NxtJob;
|
||||
select;
|
||||
when LOPtr=*NULL;
|
||||
if UspLst#Ent > 0;
|
||||
LOPtr=UspPtr+UspLstOfs;
|
||||
LOEndPtr=LOPtr+(UspLst#Ent*UspLstEntSz);
|
||||
NumJobs=0;
|
||||
exsr SavJobInf;
|
||||
endif;
|
||||
other;
|
||||
LOPtr=LOPtr+UspLstEntSz;
|
||||
dow LOPtr < LOEndPtr
|
||||
and SavJobName=LOJobName
|
||||
and SavJobUser=LOJobUser
|
||||
and SavJobNum=LOJobNum ;
|
||||
LOPtr=LOPtr+UspLstEntSz;
|
||||
enddo;
|
||||
if LOPtr < LOEndPtr;
|
||||
exsr SavJobInf;
|
||||
else;
|
||||
LOPtr=*NULL;
|
||||
endif;
|
||||
endsl;
|
||||
endsr;
|
||||
// === BldMsg ====================================================
|
||||
|
||||
// Adds current job to the message until MaxJobs have been added.
|
||||
begsr BldMsg;
|
||||
JobName28=%trimr(SavJobName) + '/' +
|
||||
%trimr(SavJobUser) + '/' +
|
||||
SavJobNum;
|
||||
select;
|
||||
when NumJobs=1;
|
||||
pMsgFld=
|
||||
%trimr(%subst(pObject:11:10)) +'/' +
|
||||
%trimr(%subst(pObject:1:10)) + ' ' +
|
||||
%trimr(pObjType) +
|
||||
' is in use by ' +
|
||||
JobName28;
|
||||
when NumJobs >= 2 and NumJobs <=MaxJobs;
|
||||
pMsgFld=%trimr(pMsgfld) + ', ' +
|
||||
JobName28;
|
||||
endsl;
|
||||
endsr;
|
||||
// === SavJobInf =================================================
|
||||
// Saves current job indentification information and counts
|
||||
// number of unique jobs found.
|
||||
// LOPtr must be initialized.
|
||||
begsr SavJobInf;
|
||||
NumJobs=NumJobs+1;
|
||||
SavJobName=LOJobName;
|
||||
SavJobUser=LOJobUser;
|
||||
SavJobNum=LOJobNum;
|
||||
endsr;
|
||||
// === WriteRec ==================================================
|
||||
|
||||
// Builds and writes a record to the file GETOBJUP
|
||||
// LOPtr must be initialized.
|
||||
begsr WriteRec;
|
||||
OUJOBNAME=LOJobname;
|
||||
OUJOBUSER=LOJobUser;
|
||||
OUJOBNUM=LOJobNum;
|
||||
OUJOBTYPE=JobType;
|
||||
write GETOBJU;
|
||||
endsr;
|
||||
// === Sort User Space ===========================================
|
||||
|
||||
begsr SrtUsrSpc;
|
||||
p_SRTUSRSPC(
|
||||
CusName:
|
||||
CusLib:
|
||||
S#keys:
|
||||
SKeyStart:
|
||||
SKeyLgth:
|
||||
SKeyAorD:
|
||||
SKeyType:
|
||||
SError);
|
||||
endsr;
|
||||
// ===============================================================
|
||||
// === Initialization ============================================
|
||||
begsr Initialize;
|
||||
// === Delete the User Space =================================
|
||||
APIEProv=%LEN(APIError);
|
||||
UsrSpcDlt(CusQName: APIError);
|
||||
// If user space doesn't exist, accept message CPF2105, else
|
||||
// something nasty is wrong - pass escape message back.
|
||||
if APIEAvail <> 0
|
||||
and APIErrId <> 'CPF2105';
|
||||
APIEProv=0;
|
||||
MSNMsgId=APIErrId;
|
||||
MSNLength=APIEAvail-16;
|
||||
SendMsg(
|
||||
MSNMsgId:
|
||||
MSNFile:
|
||||
APIEData:
|
||||
MSNLength:
|
||||
MSNType:
|
||||
MSNStackE:
|
||||
MSNStackC:
|
||||
MSNMsgKey:
|
||||
APIError);
|
||||
endif;
|
||||
// === Create User Space =====================================
|
||||
// Allow for 100,000 entries, which should be more than enough
|
||||
APIEProv = 0;
|
||||
CusIntSize=%size(UspHdr) + (%size(LOLentry)*100000);
|
||||
UsrSpcCrt(
|
||||
CusQName:
|
||||
CusAttr:
|
||||
CusIntSize:
|
||||
CusIntVal:
|
||||
CusAut:
|
||||
Custext);
|
||||
// === Get Pointer to User Space =============================
|
||||
UsrSpcPointer(CusQName: UspPtr);
|
||||
// === Initialize requested outputs ==========================
|
||||
if pFileYN='*YES';
|
||||
open GETOBJUP;
|
||||
endif;
|
||||
if pMsgYN='*YES';
|
||||
clear pMsgFld;
|
||||
endif;
|
||||
// === Set SRTUSRSPC paremeters ==============================
|
||||
SKeyStart(1)=1;
|
||||
SKeyStart(2)=11;
|
||||
SKeyStart(3)=21;
|
||||
SKeyLgth(1)=10;
|
||||
SKeyLgth(2)=10;
|
||||
SKeyLgth(3)=6;
|
||||
SKeyAorD(1)='A';
|
||||
SKeyAorD(2)='A';
|
||||
SKeyAorD(3)='A';
|
||||
SKeyType(1)='C';
|
||||
SKeyType(2)='C';
|
||||
SKeyType(3)='C';
|
||||
endsr;
|
||||
end-proc;
|
||||
@@ -0,0 +1,50 @@
|
||||
GETOBJUSR: CMD PROMPT('Get Users of an Object')
|
||||
/*-----------------------------------------------------------------*/
|
||||
/* CPP is GETOBJUC */
|
||||
/* Compile: */
|
||||
/* CRTCMD CMD(GETOBJUSR) PGM(GETOBJUC) */
|
||||
/* ALLOW(*BPGM *IPGM *BMOD *IMOD) */
|
||||
/*-----------------------------------------------------------------*/
|
||||
/* 12/00/97 LENNON Original writting */
|
||||
/*-----------------------------------------------------------------*/
|
||||
PARM KWD(OBJECT) TYPE(Q1) MIN(1) PROMPT('Object +
|
||||
Name')
|
||||
|
||||
PARM KWD(TYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) +
|
||||
VALUES(*ALRTBL *AUTL *BNDDIR *CFGL +
|
||||
*CHTFMT *CLD *CLS *CMD *CNNL *COSD *CRQD +
|
||||
*CSI *CSPMAP *CSPTBL *CTLD *DEVD *DOC +
|
||||
*DTAARA *DTADCT *DTAQ *EDTD *EXITRG *FCT +
|
||||
*FILE *FLR *FNTRSC *FNTTBL *FORMDF *FTR +
|
||||
*GSS *IPXD *JOBD *JOBQ *JOBSCD *JRN +
|
||||
*JRNRCV *LIB *LIND *LOCALE *MENU *MODD +
|
||||
*MODULE *MSGF *MSGQ *M36 *M36CFG *NODL +
|
||||
*NTBD *NWID *NWSD *OUTQ *OVL *PAGDFN +
|
||||
*PAGSEG *PDG *PGM *PNLGRP *PRDAVL *PRDDFN +
|
||||
*PRDLOD *PSFCFG *QMFORM *QMQRY *QRYDFN +
|
||||
*SBSD *SCHIDX *SPADCT *SQLPKG *SRVPGM +
|
||||
*SSND *S36 *TBL *USRIDX *USRPRF *USRQ +
|
||||
*USRSPC *WSCST) MIN(1) PROMPT('Object Type')
|
||||
|
||||
PARM KWD(MEMBER) TYPE(*NAME) LEN(10) DFT(*ALL) +
|
||||
SPCVAL((*ALL) (*FIRST) (*NONE)) +
|
||||
PMTCTL(ISFILE) PROMPT('Member')
|
||||
|
||||
PARM KWD(RETMSG) TYPE(*CHAR) LEN(4) RSTD(*YES) +
|
||||
DFT(*YES) VALUES(*YES *NO) PROMPT('Return +
|
||||
a message?')
|
||||
|
||||
PARM KWD(MSGFLD) TYPE(*CHAR) LEN(200) +
|
||||
RTNVAL(*YES) PMTCTL(RETMSGY) +
|
||||
PROMPT('Return Message Field')
|
||||
|
||||
PARM KWD(RETFILE) TYPE(*CHAR) LEN(4) RSTD(*YES) +
|
||||
DFT(*NO) VALUES(*YES *NO) PROMPT('Return +
|
||||
file QTEMP/GETOBJUSRP?')
|
||||
|
||||
Q1: QUAL TYPE(*NAME) LEN(10) MIN(1)
|
||||
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
|
||||
SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library')
|
||||
|
||||
RETMSGY: PMTCTL CTL(RETMSG) COND((*EQ *YES))
|
||||
ISFILE: PMTCTL CTL(TYPE) COND((*EQ *FILE))
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 34 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 9.0 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 18 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 42 KiB |
@@ -0,0 +1,75 @@
|
||||
# APIs, including QWCLOBJL (List Object Locks), QUSLJOB(List Job) QUSCRTUS, QUSDLTUS, QUSPTRUS (User Spaces)
|
||||
|
||||
User commands that use RPG and CL to call IBM i APIs.
|
||||
|
||||
## QWCLOBJL (List Object Locks) API
|
||||
|
||||
In the late 90s the Fortune 500 company where I worked had contending overnight batch jobs from different project teams that required exclusive control of some files. Jobs kept breaking to the operator console when more than one tried running simultaneously. The night shift operator then had to do a WRKOBJLCK command to attempt to resolve the contention.
|
||||
|
||||
The code provided here is a command we could put in the driving CL program and when the ALCOBJ command failed it provided information on who had the object locked.
|
||||
|
||||
The company is long gone, but I recently found the code on my PC and resurrected it.
|
||||
|
||||
Now (2021) you can get similar information with SQL - see [Work Management Services](https://www.ibm.com/docs/en/i/7.4?topic=services-work-management) on the IBM site. However, I have not found an SQL interface to QWCLOBJL. I also suspect that this code if faster than SQL, but probably in most use cases speed may not be a factor.
|
||||
|
||||
### GETOBJUSR Command
|
||||
|
||||
This is the top level interface. Prompted, it looks like this:
|
||||
|
||||
|
||||
You specify the object and type and the command returns information on the locks on the object. You can return a file of objects and/or a message.
|
||||
|
||||
The file would be GETOBJUP in QTEMP.
|
||||
|
||||
The message would be suitable for sending to the operator and look something like one of these:
|
||||
|
||||
|
||||
|
||||
It shows the details of up to 4 jobs and lists how many additional jobs, if any, have locks.
|
||||
|
||||
### GETOBJUC
|
||||
|
||||
This the command processing program for the GETOBJUSR command. It calls GETOBJUR to get the lock information.
|
||||
|
||||
### GETOBJUR
|
||||
|
||||
This RPG program creates a user space in QTEMP, then calls the QWCLOBJL (List Object Locks) API to populate the user spaces, calls SRTUSRSPC to sort by job, returns the requested message and/or file, then deletes the user space.
|
||||
|
||||
The code was originally in fexed form RPG/400, but I converted it to **FREE (using [Craig Rutledge's JCRCMDS](https://www.jcrcmds.com/)).
|
||||
|
||||
## GETOBJUP
|
||||
|
||||
DDS for the file created, if requested, in QTEMP. Resulting file contents look something like this:
|
||||
|
||||
|
||||
### SRTUSRSPC
|
||||
|
||||
This program sorts a user space. I believe I downloaded the code from the Old News 3X/400 site. It is fixed form RPG/400 that I haven't bothered to convert. Old, educational, and it works.
|
||||
|
||||
## QUSLJOB (List Job) API
|
||||
|
||||
### GETJOBTR
|
||||
|
||||
This is a standalone program that returns the job type. GETOBJUR needed it, but I coded it separately in case it was useful elsewhere.
|
||||
|
||||
You pass it two parameters:
|
||||
|
||||
1. Input: The 26 char job name, user name and job number (or * for the current job)
|
||||
|
||||
2. Output: 1-character field to return the job type, as below.
|
||||
|
||||
Type|Description
|
||||
----|-----------------------------------
|
||||
A|The job is an autostart job.
|
||||
B|The job is a batch job.
|
||||
I|The job is an interactive job.
|
||||
M|he job is a subsystem monitor job.
|
||||
R|The job is a spooled reader job.
|
||||
S|he job is a system job.
|
||||
W|The job is a spooled writer job.
|
||||
X|The job is the SCPF system job.
|
||||
|
||||
Notes:
|
||||
|
||||
1. The code was originally fixed format but I converted it to **FREE (using [Craig Rutledge's JCRCMDS](https://www.jcrcmds.com/)). If needed for general use it should probably be a service program. I'm not sure service programs were a thing in 1997, but if they were I was not familar with them then.
|
||||
2. On more current OS releases you can get similar information in SQL with the [GET_JOB_INFO table function](https://www.ibm.com/docs/en/i/7.4?topic=services-get-job-info-table-function).
|
||||
@@ -0,0 +1,405 @@
|
||||
*******************************************************************
|
||||
* From "Sort Those API Lists," NEWS/400, May 1996.
|
||||
* Author: Greg LaForge
|
||||
* COPYRIGHT (c) 1996 Duke Communications International,
|
||||
* ALL RIGHTS RESERVED.
|
||||
*
|
||||
*
|
||||
* Program: SRTUSRSPC
|
||||
* Description: This program sorts in a user space lists
|
||||
* created by system API commands.
|
||||
*
|
||||
**************************************************************************
|
||||
* Indicators used.
|
||||
*
|
||||
* 01 - Error on CALLs. Triggers abnormal termination of program and
|
||||
* sets return parameter EXITER to *ON.
|
||||
*
|
||||
**************************************************************************
|
||||
* Arrays.
|
||||
*
|
||||
* AD - Array of ascending/descending sequences (passed in).
|
||||
* DT - Array of key fields' data types.
|
||||
* KY - Array to pass info to the sort routine.
|
||||
* LN - Array of key lengths (passed in).
|
||||
* ST - Array of key starting positions (passed in).
|
||||
*
|
||||
D ad s 1 dim(10) ascend/descend
|
||||
D dt s 1 dim(10) data type
|
||||
D ln s 5 0 dim(10) lengths
|
||||
D st s 5 0 dim(10) start positions
|
||||
* ************************************************************************
|
||||
* Data structures.
|
||||
*
|
||||
* BINALP - Converts binary to alpha field.
|
||||
* ERROR - Formats error fields for sort APIs.
|
||||
* INDTA - Creates a 9,000-byte field.
|
||||
* MISC - Defines some binary fields.
|
||||
* OUTDTA - Creates a 9,000-byte field.
|
||||
* RCVVAR - Defines some binary fields for user space lists.
|
||||
* SORT - Formats sort control block for QLGSORT API.
|
||||
* SORTIN - Formats input fields for QLGSRTIO API.
|
||||
* SORTOU - Formats output fields for QLGSRTIO API.
|
||||
*
|
||||
*-----------------------------------------------------------------------
|
||||
* Converts binary to alpha field.
|
||||
*
|
||||
D binalp ds
|
||||
D alpha 4
|
||||
D binary 9b 0 overlay(alpha)
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats error fields for sort APIs.
|
||||
*
|
||||
D error ds
|
||||
D errlen 9b 0
|
||||
D erravl 9b 0
|
||||
D errid 7
|
||||
D errdta 17 272
|
||||
*-----------------------------------------------------------------------
|
||||
* Creates a 9,000-byte field.
|
||||
*
|
||||
D indta ds 9000
|
||||
D hold 9000 9000
|
||||
*-----------------------------------------------------------------------
|
||||
* Defines some binary fields.
|
||||
*
|
||||
D misc ds
|
||||
D lendta 9b 0
|
||||
D strpos 9b 0
|
||||
D lenspc 9b 0
|
||||
D lenvar 9b 0
|
||||
D parm3 9b 0
|
||||
D parm4 9b 0
|
||||
D outlen 9b 0
|
||||
*-----------------------------------------------------------------------
|
||||
* Creates a 9,000-byte field.
|
||||
*
|
||||
D outdta ds 9000
|
||||
D holda 9000 9000
|
||||
*-----------------------------------------------------------------------
|
||||
* Defines some binary fields for user space lists.
|
||||
*
|
||||
D rcvvar ds
|
||||
D offset 9b 0
|
||||
D nbrent 9 12b 0
|
||||
D sizent 9b 0
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats sort control block for QLGSORT API.
|
||||
*
|
||||
D sort ds
|
||||
D blklen 1 4b 0
|
||||
D reqtyp 5 8b 0
|
||||
D fill01 9 12b 0
|
||||
D option 13 16b 0
|
||||
D rcdlen 17 20b 0
|
||||
D rcdcnt 21 24b 0
|
||||
D keyoff 25 28b 0
|
||||
D keys 29 32b 0
|
||||
D lanoff 33 36b 0
|
||||
D inoff 37 40b 0
|
||||
D #infil 41 44b 0
|
||||
D outoff 45 48b 0
|
||||
D #outfi 49 52b 0
|
||||
D fill02 53 56b 0
|
||||
D ky 57 216
|
||||
D dim(40) key fields
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats input fields for QLGSRTIO API.
|
||||
*
|
||||
D sortin ds
|
||||
D intype 9b 0
|
||||
D infil1 9b 0
|
||||
D inlen 9b 0
|
||||
D inrecs 9b 0
|
||||
*-----------------------------------------------------------------------
|
||||
* Formats output fields for QLGSRTIO API.
|
||||
*
|
||||
D sortou ds
|
||||
D ourprc 9b 0
|
||||
D ouravl 9b 0
|
||||
D oufil1 9b 0
|
||||
D oufil2 9b 0
|
||||
*---------------------------------------------------------------------
|
||||
* BEGIN of work fields added by CONNECTIONS 2000's CVTILERPG utility
|
||||
*---------------------------------------------------------------------
|
||||
D #keys s like(dec003 )
|
||||
D #recs s like(int )
|
||||
D byte s 1
|
||||
D chr032 s 32
|
||||
D dec003 s 3 0
|
||||
D exiter s like(byte )
|
||||
D force s like(byte )
|
||||
D i s like(int )
|
||||
D inbuff s like(chr032 )
|
||||
D int s 9 0
|
||||
D i1 s like(int )
|
||||
D i2 s like(int )
|
||||
D i3 s like(int )
|
||||
D i4 s like(int )
|
||||
D lib s like(name )
|
||||
D name s 10
|
||||
D oubuff s like(chr032 )
|
||||
D qname s 20
|
||||
D spacer s like(qname )
|
||||
D tmp50 s like(int )
|
||||
D totrec s like(int )
|
||||
D usrspc s like(name )
|
||||
*---------------------------------------------------------------------
|
||||
* END of work fields added by CONNECTIONS 2000's CVTILERPG utility
|
||||
*---------------------------------------------------------------------
|
||||
**************************************************************************
|
||||
*
|
||||
* Mainline.
|
||||
*
|
||||
C exsr inzpgm
|
||||
C exsr prcpgm
|
||||
C exsr trmpgm
|
||||
*
|
||||
C return
|
||||
*-----------------------------------------------------------------------
|
||||
* CHK4ER: Look to see whether error has occurred; if so, exit.
|
||||
*
|
||||
C chk4er begsr
|
||||
*
|
||||
B001 C if *in01 = *on error in call
|
||||
001 C or errid <> *blanks returned error
|
||||
001 C exsr *pssr
|
||||
E001 C endif
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* DCLVAR: Declare program variables.
|
||||
* This subroutine is never executed.
|
||||
*
|
||||
C dclvar begsr
|
||||
* Declare data types.
|
||||
C eval byte = *blank
|
||||
C eval chr032 = *blank
|
||||
C eval dec003 = 0
|
||||
C eval int = 0
|
||||
C eval name = *blank
|
||||
C eval qname = *blank
|
||||
*
|
||||
* Declare variables based on data types.
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* INZPGM: Initialize program.
|
||||
*
|
||||
C inzpgm begsr
|
||||
*
|
||||
C *entry plist
|
||||
C parm usrspc user space
|
||||
C parm lib user space lib
|
||||
C parm #keys nbr of keys
|
||||
C parm st start positions
|
||||
C parm ln lengths
|
||||
C parm ad ascend/descend
|
||||
C parm dt data types
|
||||
C parm exiter *ON=error
|
||||
*
|
||||
* Clear error flag.
|
||||
C move *off exiter
|
||||
*
|
||||
* Get some info in the user space header.
|
||||
C movel usrspc spacer
|
||||
C move lib spacer
|
||||
*
|
||||
C call 'QUSRTVUS' 01
|
||||
C parm spacer
|
||||
C parm 125 strpos
|
||||
C parm 16 lendta
|
||||
C parm rcvvar
|
||||
*
|
||||
C exsr chk4er
|
||||
*
|
||||
* Determine starting position of list in the user space.
|
||||
C eval strpos = offset
|
||||
C eval strpos = strpos + 1
|
||||
*
|
||||
* Initialize the sort function.
|
||||
C eval blklen = #keys length of
|
||||
C eval blklen = blklen * 16 sort control
|
||||
C eval blklen = blklen + 56 block
|
||||
C eval reqtyp = 8 sort type
|
||||
C eval fill01 = 0 filler
|
||||
C eval option = 0 no options
|
||||
C eval rcdlen = sizent rec size
|
||||
C eval rcdcnt = 0 no rec count
|
||||
C eval keyoff = 56 offset to keys
|
||||
C eval keys = #keys # of keys
|
||||
C eval lanoff = 0 language offset
|
||||
C eval inoff = 0 no input files
|
||||
C eval #infil = 0 no input files
|
||||
C eval outoff = 0 no out files
|
||||
C eval #outfi = 0 no out files
|
||||
C eval fill02 = 0
|
||||
*
|
||||
* Fill the key field area.
|
||||
B001 C 1 do #keys i
|
||||
001 C eval i1 = i - 1
|
||||
001 C eval i1 = i1 * 4
|
||||
001 C eval i1 = i1 + 1
|
||||
001 C eval i2 = i1 + 1
|
||||
001 C eval i3 = i2 + 1
|
||||
001 C eval i4 = i3 + 1
|
||||
001 *
|
||||
001 * Convert start position to binary and place into array.
|
||||
001 C eval binary = st(i)
|
||||
001 C movel alpha ky(i1)
|
||||
001 *
|
||||
001 * Convert key length to binary and place into array.
|
||||
001 C eval binary = ln(i)
|
||||
001 C movel alpha ky(i2)
|
||||
001 *
|
||||
001 * Convert data type to binary and place into array.
|
||||
B002 C select
|
||||
002 C when dt(i) = 'Z' zoned decimal
|
||||
002 C eval binary = 2
|
||||
002 C when dt(i) = 'B' binary
|
||||
002 C eval binary = 0
|
||||
002 C when dt(i) = 'P' packed decimal
|
||||
002 C eval binary = 3
|
||||
002 C other all else
|
||||
002 C eval binary = 6
|
||||
E002 C endsl
|
||||
001 *
|
||||
001 C movel alpha ky(i3)
|
||||
001 *
|
||||
001 * Convert the sort order to binary and place into array.
|
||||
B002 C if ad(i) = 'D' descend
|
||||
002 C eval binary = 2
|
||||
X002 C else
|
||||
002 C eval binary = 1
|
||||
E002 C endif
|
||||
001 *
|
||||
001 C movel alpha ky(i4)
|
||||
E001 C enddo
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* PRCPGM: Process program.
|
||||
*
|
||||
C prcpgm begsr
|
||||
*
|
||||
* Now that the sort control block is built, initialize
|
||||
* the sort routine and get it ready to accept records.
|
||||
*
|
||||
C eval errlen = 272 avail space
|
||||
*
|
||||
C call 'QLGSORT' 01
|
||||
C parm sort control block
|
||||
C parm inbuff input buffer
|
||||
C parm oubuff output buffer
|
||||
C parm 0 parm3 not used
|
||||
C parm 0 parm4 not used
|
||||
C parm error error ds
|
||||
*
|
||||
C exsr chk4er
|
||||
*
|
||||
* Pass a block of records to the sort routine. The block
|
||||
* can contain up to 9,000 bytes.
|
||||
*
|
||||
C eval #recs = 9000 / rcdlen number of recs
|
||||
C eval intype = 1 put records
|
||||
C eval infil1 = 0 not used
|
||||
C eval inlen = rcdlen rec len
|
||||
C eval inrecs = #recs
|
||||
C eval totrec = 0
|
||||
* Do for blocks of records:
|
||||
B001 C dow totrec < nbrent
|
||||
001 C eval totrec = totrec + #recs
|
||||
B002 C if totrec > nbrent
|
||||
002 C eval tmp50 = totrec - nbrent
|
||||
002 C eval inrecs = inrecs - tmp50
|
||||
E002 C endif
|
||||
001 C eval lendta = rcdlen * inrecs
|
||||
001 * Retrieve a block of records.
|
||||
001 C call 'QUSRTVUS' 01
|
||||
001 C parm spacer
|
||||
001 C parm strpos
|
||||
001 C parm lendta
|
||||
001 C parm indta
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 * Send them to the sort routine.
|
||||
001 C call 'QLGSRTIO' 01
|
||||
001 C parm sortin
|
||||
001 C parm indta
|
||||
001 C parm outdta
|
||||
001 C parm outlen
|
||||
001 C parm sortou
|
||||
001 C parm error
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 *
|
||||
001 C eval strpos = strpos + lendta
|
||||
E001 C enddo
|
||||
*
|
||||
* Tell the sort routine we are all done.
|
||||
C eval intype = 2 end put
|
||||
C call 'QLGSRTIO' 01
|
||||
C parm sortin
|
||||
C parm indta
|
||||
C parm outdta
|
||||
C parm outlen
|
||||
C parm sortou
|
||||
C parm error
|
||||
*
|
||||
C exsr chk4er
|
||||
*
|
||||
* Retrieve records from the sort and place back into user space.
|
||||
C eval intype = 3 get records
|
||||
C eval strpos = offset
|
||||
C eval strpos = strpos + 1
|
||||
C eval inrecs = #recs
|
||||
C eval totrec = 0
|
||||
*
|
||||
* Do for blocks of records:
|
||||
B001 C dow totrec < nbrent
|
||||
001 C eval totrec = totrec + #recs
|
||||
B002 C if totrec > nbrent
|
||||
002 C eval tmp50 = totrec - nbrent
|
||||
002 C eval inrecs = inrecs - tmp50
|
||||
E002 C endif
|
||||
001 C eval lendta = rcdlen * inrecs
|
||||
001 * Retrieve a block of records.
|
||||
001 C call 'QLGSRTIO' 01
|
||||
001 C parm sortin
|
||||
001 C parm indta
|
||||
001 C parm outdta
|
||||
001 C parm outlen
|
||||
001 C parm sortou
|
||||
001 C parm error
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 * Place them back into user space.
|
||||
001 C call 'QUSCHGUS' 01
|
||||
001 C parm spacer
|
||||
001 C parm strpos
|
||||
001 C parm lendta
|
||||
001 C parm outdta
|
||||
001 C parm '2' force
|
||||
001 *
|
||||
001 C exsr chk4er
|
||||
001 *
|
||||
001 C eval strpos = strpos + lendta
|
||||
E001 C enddo
|
||||
*
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* *PSSR: Error handling subroutine.
|
||||
*
|
||||
C *pssr begsr
|
||||
C move *on exiter
|
||||
C move *on *inlr
|
||||
C return
|
||||
C endsr
|
||||
*-----------------------------------------------------------------------
|
||||
* TRMPGM: Terminate program.
|
||||
*
|
||||
C trmpgm begsr
|
||||
* All done.
|
||||
C move *on *inlr
|
||||
*
|
||||
C endsr
|
||||
@@ -0,0 +1,25 @@
|
||||
|
||||
//=== USPHDR Description =============================================
|
||||
// The list APIs which return data in a user space put a standard
|
||||
// header at the start of the user space. This descibes the header.
|
||||
//=== Basing Pointer for Header ======================================
|
||||
D UspPtr s * inz(*Null)
|
||||
//=== User Space Header Layout =======================================
|
||||
D UspHdr ds based(UspPtr)
|
||||
D UspH 192a
|
||||
D UspUser 64a overlay(UspH:1)
|
||||
D UspSize 10i 0 overlay(UspH:65)
|
||||
D UspInfSts 1a overlay(UspH:104)
|
||||
D UspICmpl c const('C')
|
||||
D UspIPrtl c const('P')
|
||||
D UspIIncp c const('I')
|
||||
D UspSpSize 10i 0 overlay(UspH:105)
|
||||
D UspInOff 10i 0 overlay(UspH:109)
|
||||
D UspInSize 10i 0 overlay(UspH:113)
|
||||
D UspHdrOfs 10i 0 overlay(UspH:117)
|
||||
D UspHdrSize 10i 0 overlay(UspH:121)
|
||||
D UspLstOfs 10i 0 overlay(UspH:125)
|
||||
D UspLstSize 10i 0 overlay(UspH:129)
|
||||
D UspLst#Ent 10i 0 overlay(UspH:133)
|
||||
D UspLstEntSz 10i 0 overlay(UspH:137)
|
||||
|
||||
@@ -1,15 +1,15 @@
|
||||
# RPGLE free format, SQL and CLP Code for the IBM i
|
||||
|
||||
This repository contains *working* example code, using RPGLE free-format, enbedded SQL and CLP for the IBM i
|
||||
More developers are learning about the **IBM i** as a wonderful business platform. (It was formerly known as the **AS/400**.)
|
||||
|
||||
My intent is to provide real programs that help you learn, or improve your current understanding, and which you can adapt to you needs.
|
||||
This repository contains *working* example code, using RPGLE free-format, enbedded SQL and CLP for the IBM i.
|
||||
|
||||
More developers are learning about the **IBM i** as a wonderful business platform. ( It was formerly known as the **AS/400**.)
|
||||
|
||||
Feel free to provide comments and feedback as issues.
|
||||
My intent is to provide real programs that help you learn and/or improve your current understanding. Explore and adapt the code to your needs. Some of the code may be of use "as is" but no guarantee is provided.
|
||||
|
||||
**Each folder has its own ReadMe with additional infomation/documentation.**
|
||||
|
||||
Feel free to provide comments and feedback as issues.
|
||||
|
||||
## Copy_Mbrs
|
||||
|
||||
Code to be copied into other programs.
|
||||
@@ -38,6 +38,10 @@ SQL User Defined Functions to convert legacy dates to true dates. Written in RP
|
||||
|
||||
A standardized way to handle locked records in an interactive program, and display information about who is holding the lock. For programs that use native IO.
|
||||
|
||||
## APIs
|
||||
|
||||
Commands, with CLP and RPG programs, calling IBM i APis.
|
||||
|
||||
## GRP_JOB
|
||||
|
||||
Sets up group jobs suitable for an IBM i developer.
|
||||
@@ -48,4 +52,4 @@ Developer Utilities.
|
||||
|
||||
QRY - Qry (List) Contents of a file
|
||||
|
||||
RC - Display File Record count
|
||||
RC - Display File Record count
|
||||
|
||||
Reference in New Issue
Block a user