RPG Exit Strategy
LR & Return, CEE or exit function?
With the advent of ILE, setting on LR, followed by a RETRUN operation might not be enough to allow the system to recover all of the resources assigned to the job. This can be particularly troublesome. Executing in the default activation group, the Original Program Model (OPM) expects that everything is shutdown and the system may reclaim job resources. However, with an Integrated Language Model (ILE) application, LR and RETURN does not release all resources for clean up. If a mix of ILE and OPM programs co-exist, different exit strategies are required.
ctl-Opt DEBUG(*YES) OPTION(*SRCSTMT : *NODEBUGIO)
DFTACTGRP(*NO) ACTGRP('QILE') Main(SC0320RP)
BNDDIR('QC2LE':'SC0000_BD') ;
********************************************************************
* Program Name - SC0320RP *
* *
* Function - This program was designed to allow a user to *
* work with expansion project objects *
* *
* Programmer - Steve Croy *
********************************************************************
********************************************************************
* Compile instructions *
*CRTPGM *RPGLE *
*DBGVIEW *SOURCE *
* *
********************************************************************
********************************************************************
* Modification log *
* *
* Date Programmer Description *
* *
********************************************************************
**------------ File section -----------------------------------------
Dcl-F SC0320DF WORKSTN UsrOpn
SFILE(SC0320S1:RRNSI)
INFDS(DSPDS) ;
**------------ Data Structures --------------------------------------
/copy qrpglesrc,SCMAPS_pr
Dcl-DS functionkey extname('SCKEYSPF') qualified end-DS;
Dcl-DS OBJECT extname('SCOBJSPF') end-DS;
Dcl-DS before extname('SCOBJSPF') qualified end-DS;
Dcl-DS after extname('SCOBJSPF') qualified end-DS;
* Default cursor position
Dcl-DS #DFPOS INZ ;
#DFROW packed(2:0) INZ(8) ;
#DFCOL packed(3:0) INZ(17);
End-DS ;
* Default message file
Dcl-DS dftPgmMsgF ;
dftMsglib char(10) INZ('*LIBL') ;
dftMsgFile Char(10) INZ('SCMSSGF');
End-DS ;
**------------ Procedure Prototypes ---------------------------------
/copy qrpglesrc,SC0000_pr
/copy qrpglesrc,SC0320_pr
**------------ Define constants -------------------------------------
Dcl-C #TITLE CONST('** Work With Objects List **') ;
**------------ Define Global Variables ------------------------------
Dcl-S dtaPtr pointer inz( %addr(object));
Dcl-S indPtr pointer inz( %addr(*in) ) ;
Dcl-DS indicators len(99) based( indPtr ) ;
ScreenChange ind pos(22) ;
SflControl ind pos(50) ;
SflDisplay ind pos(51) ;
SflInitialize ind pos(52) ;
SflClear ind pos(53) ;
SflEnd ind pos(54) ;
SflDelete ind Pos(55) ;
SflNxtChange ind pos(58) ;
SflMSGQdisplay ind pos(59) ;
End-DS ;
Dcl-S ErrorOccurred ind ;
Dcl-S listAction ind ;
Dcl-S MessageToDisplay ind ;
Dcl-S MoreRecordsRemain ind ;
Dcl-S NoMoreRecords ind ;
Dcl-S objectFound ind ;
Dcl-S authl char(3) inz('999') ;
Dcl-S CMDKEY char(720) ;
Dcl-S dspatr char(1) ;
Dcl-S FKEYDS char(1) ;
Dcl-S fmt char(10) inz('BEGIN');
Dcl-S INDLR char(1) ;
Dcl-S Keyidx char(2) ;
Dcl-S MorOpt char(1) ;
Dcl-S MSG char(80) ;
Dcl-S MSGDTA char(132) ;
Dcl-S MSGF char(10) ;
Dcl-S MSGPGM char(10) ;
Dcl-S MSGRLQ char(5) ;
Dcl-S optIdx char(2) ;
Dcl-S OPTION char(720) ;
Dcl-S p$err char(7) ;
Dcl-S p$mod char(1) ;
Dcl-S p$mode char(1) ;
Dcl-S parm01 char(10) ;
Dcl-S parm02 char(10) ;
Dcl-S passc char(1) ;
Dcl-S promptDta char(256) ;
Dcl-S orderBy char(256) ;
Dcl-S selectOnly char(256) ;
Dcl-S thisOption char(10) ;
Dcl-S thisFormat char(10) ;
Dcl-S thisPgm char(10) inz('SC0320RP');
Dcl-S typatr char(1) ;
Dcl-S UsrNam char(10) ;
Dcl-S CATEG zoned(3:0) inz(500) ;
Dcl-S CL zoned(3:0) ;
Dcl-S dtaSize int(10) inz( %size(object));
Dcl-S M zoned(3:0) ;
Dcl-S O zoned(3:0) ;
Dcl-S RCDNBR int(5) INZ(1) ;
Dcl-S RRNSI binDec(4) ;
Dcl-S RW zoned(3:0) ;
Dcl-S SAVRRN binDec(4) ;
Dcl-S SFLLOD binDec(4) ;
Dcl-S SFLMAX binDec(4) INZ(12) ;
Dcl-S SFLPOS binDec(4) ;
Dcl-S SFLRCN binDec(4) ;
**------------ End of work fields -----------------------------------
Dcl-Proc SC0320RP ;
Dcl-PI SC0320RP extPgm('SC0320RP') ;
END-PI;
CheckAuthority(USER:THISPGM:CATEG:PASSC:AUTHL);
IF PASSC <> 'P';
QUIT();
ENDIF;
If not %open(SC0320DF);
OPEN SC0320DF ;
ENDIF;
z$seq1 = #TITLE;
functionKey = FunctionKeys();
getMessage('MIS0001');
FilterSelect ( zfcat: zfseq: zfobj: zftyp: zfdsc: zfsts: 'GET');
resetDisplay();
DOU keyPressed = functionKey.F3;
IF MessageToDisplay;
SflMSGQdisplay = *ON;
ELSE;
SflMSGQdisplay = *OFF;
ENDIF;
WRITE SC0320C2 ; // write subfile message queue
IF ScreenChange;
#ROW = #DFROW;
#COL = #DFCOL;
ENDIF;
rrnsi = 0 ;
sflControl = *ON ; // Set subfile control on
IF sflrcn > 0 ; // and if records were loaded
sflDisplay = *ON ; // turn on subfile display
ENDIF ;
WRITE SC032001;
EXFMT SC0320C1;
sflControl = *OFF;
sflDisplay = *OFF;
getCsrLoc(ROW:COL:rw:cl);
#ROW = rw;
#COL = cl;
IF MessageToDisplay;
RmvMessage(prgnam);
MessageToDisplay = *OFF;
ENDIF;
ThisFormat = fmtnam;
GetFunction(thisPgm:thisFormat:keypressed:fkeyid:macro:authl);
SELECT;
WHEN KeyPressed = functionKey.ENTER;
processChanges();
READ SC032001;
If ScreenChange ;
resetDisplay() ;
ENDIF;
WHEN KeyPressed = functionKey.ROLLUP;
loadSubfile();
WHEN KeyPressed = functionKey.ROLLDN;
pageDown();
WHEN KeyPressed = functionKey.F23;
DisplayOptions(option: z$opt1: z$opt2: O);
WHEN KeyPressed = functionKey.F24;
DisplayKeys(cmdkey: z$key1: z$key2: M);
WHEN Function = 'EXIT';
QUIT(); [1]
WHEN Function = 'CANCEL';
EXSR returnToCaller; [2]
WHEN Function = 'RESET';
resetDisplay();
WHEN Function = 'PROMPT';
READ SC032001;
displayPrompt(rtnFld) ;
resetDisplay();
WHEN Function = 'HELP';
HelpText(ThisPgm:fmt);
WHEN SUBOP = 'CALL';
callProgram();
WHEN Function = 'CMDLINE';
CommandLine();
ENDSL;
CLEAR macro;
ENDDO;
//*----------------------------------------------------------------
BEGSR returnToCaller;
If %open(SC0320DF) ;
CLOSE SC0320DF ;
ENDIF ;
ErrorOccurred = CloseObjectCursor() ;
*inlr = *on ;
return ;
ENDSR;
End-Proc SC0320RP ;
//*================================================================
Dcl-Proc resetDisplay;
Dcl-PI resetDisplay end-PI;
rrnsi = 1;
rcdnbr = 1;
sflrcn = 0;
sflpos = 0;
SflInitialize = *ON;
WRITE SC0320C1;
SflInitialize = *OFF;
SflEnd = *OFF;
ThisFormat = fmtnam;
m = 0;
o = 0;
usrnam = user;
reset dftPgmMsgF ;
GetKeyText(thisPgm:thisFormat:cmdkey:authl);
GetOptText(thisPgm:thisFormat: option: authl);
DisplayKeys(cmdkey: z$key1: z$key2: M);
DisplayOptions(option: z$opt1: z$opt2: O);
// Format the SQL request ...
FormatSQL ( zfcat: zfseq: zfobj: zftyp: zfdsc: zfsts:
SelectOnly: orderBy);
CloseObjectCursor();
ClearObject();
SetObjectCursor(orderby: selectOnly);
FilterSelect ( zfcat: zfseq: zfobj: zftyp: zfdsc: zfsts: 'SET');
loadSubfile() ;
Return ;
END-Proc resetDisplay ;
//*================================================================
Dcl-Proc pageDown;
Dcl-PI pageDown end-PI;
Z$RRN2 = Z$rrn2 - SFLMAX;
SFLPOS = (SFLPOS - SFLMAX);
IF SFLPOS < 1;
SFLPOS = sflmax;
ENDIF;
IF Z$RRN2 < 1;
Z$RRN2 = 1;
getMessage('MIS0006');
ENDIF;
Return ;
END-Proc pageDown ;
//*================================================================
Dcl-Proc loadSubfile;
Dcl-PI loadSubfile end-PI;
sfllod = 0;
savrrn = z$rrn2;
SflEnd = *OFF;
NoMoreRecords = *OFF;
DOU NoMoreRecords or sfllod >= sflmax;
MoreRecordsRemain = NextObject();
IF MoreRecordsRemain;
OBJECT = GetObjectData();
sflrcn = sflrcn + 1;
sfllod = sfllod + 1;
RRNSI = SFLRCN;
Z$RRN1 =SFLRCN;
z$opt = *BLANKS;
z$desc = exdesc;
zfstat = *blanks;
SELECT;
WHEN exproc = 'Y';
dspatr = SetColor('BLU');
typatr = SetColor('WHT');
zfstat = dspatr + 'Revised';
WHEN exproc = 'E';
dspatr = SetColor('YLW');
typatr = SetColor('WHT');
zfstat = dspatr + 'Review';
WHEN exproc = 'X';
dspatr = SetColor('GRN');
typatr = SetColor('GRN');
zfstat = dspatr + 'Tested';
WHEN exproc = 'N';
dspatr = SetColor('GRN');
typatr = SetColor('GRN');
zfstat = dspatr + 'Pending';
WHEN exproc = 'O';
dspatr = SetColor('RED');
typatr = SetColor('RED');
zfstat = dspatr + 'Obsolete';
OTHER;
dspatr = SetColor('GRN');
typatr = SetColor('GRN');
zfstat = dspatr + 'Undefined';
ENDSL;
zfobnm = dspatr + exobnm + typatr + exobtp;
WRITE SC0320S1;
ELSE ;
Sflend = *ON;
NoMoreRecords = *ON;
ENDIF;
ENDDO;
sflpos = sflpos + sflmax;
z$rrn2 = (sflpos - sflmax) + 1;
IF z$rrn2 > sflrcn;
sflpos = sflpos - sflmax;
z$rrn2 = savrrn;
getMessage('MIS0007');
ENDIF;
Return ;
END-Proc loadSubfile ;
//*================================================================
Dcl-Proc callProgram;
Dcl-PI callProgram end-PI;
setParameters();
MONITOR;
CallPrograms( subPgm :
callPM :
subAct :
dtaPtr :
dtaSize:
p$err ) ;
ON-ERROR;
P$ERR = 'MIS0012';
GetMessage('MIS0012');
ENDMON;
getParameters();
Return ;
END-Proc callProgram ;
//*================================================================
Dcl-Proc setParameters;
Dcl-PI setParameters end-PI;
p$err = *blanks;
IF listAction;
IF RetrieveObject(exobnm:exobtp);
before = GetObjectData();
ELSE;
CLEAR before;
ENDIF;
ENDIF;
Return ;
END-Proc setParameters ;
//*================================================================
Dcl-Proc getParameters;
Dcl-PI getParameters end-PI;
IF listAction;
IF RetrieveObject(exobnm:exobtp);
after = GetObjectData();
ELSE;
CLEAR after;
ENDIF;
ENDIF;
IF p$err <> *BLANKS;
getMessage(P$ERR);
ENDIF;
Return ;
END-proc getParameters ;
//*=====================================================================
Dcl-Proc getMessage ;
Dcl-PI getMessage ;
thisMsg char(7) const ;
end-PI ;
msgID = thisMsg ;
msgdta = *BLANKS;
msg = *BLANKS;
msgf = dftMsgFile;
MONITOR;
RtvMessage(msgid:msgf:msgdta:msg);
msgtxt = msg;
ON-ERROR;
msgf = errFil;
ENDMON;
msgRlq = '*SAME' ;
msgdta = msgtxt;
msgpgm = PRGNAM;
SndMessage(msgid : msgF: msgdta : msgrlq : msgpgm);
MessageToDisplay = *ON;
Return ;
END-Proc getMessage ;
//*=====================================================================
Dcl-Proc Quit ;
Dcl-PI *n end-PI ;
ErrorOccurred = CloseObjectCursor();
*inlr = *on ;
exit(0) ;
Return ;
End-Proc Quit ;
//*=====================================================================
Dcl-Proc displayPrompt ;
Dcl-PI displayPrompt ;
promptField char(10) ;
END-PI;
Dcl-S pmt char(10) ;
If promptField = *blanks;
pmt = 'PROMPT' ;
Else ;
pmt = promptField ;
ENDIF;
PromptDta = *blanks;
Prompter( Thispgm : pmt : PromptDta );
SELECT;
WHEN rtnfld = 'ZFSTS';
zfsts = %trim(PromptDta);
WHEN rtnfld = 'ZFSEQ';
promptDta = %xlate(' ':'0':promptDta);
zfseq = %dec(%subst(PromptDta:1:7):7:0);
WHEN rtnfld = 'ZFCAT';
promptDta = %xlate(' ':'0':promptDta);
zfcat = %dec(%subst(PromptDta:1:3):3:0);
WHEN rtnfld = 'ZFOBJ';
zfobj = %trim(PromptDta);
WHEN rtnfld = 'ZFTYP';
zftyp = %trim(PromptDta);
WHEN rtnfld = 'ZFDSC';
zfdsc = %trim(PromptDta);
OTHER;
PromptDta = *blanks;
ENDSL;
Return ;
END-Proc displayPrompt ;
//*=====================================================================
Dcl-Proc processChanges;
Dcl-PI processChanges end-PI;
IF Z$RRN1 > 0;
DOU %eof(SC0320DF);
READC SC0320S1;
listAction = *off;
IF NOT %eof(SC0320DF);
IF Z$OPT <> *BLANK;
listAction = *ON;
thisOption = %triml(z$opt);
ThisFormat = fmtnam;
GetOption(Thispgm:ThisFormat:thisOption:macro:authl);
SELECT;
WHEN SUBOP = 'CALL';
callProgram();
Other ;
setParameters() ;
executeFunction( exobnm : exobtp : function : p$err);
getParameters() ;
ENDSL;
z$opt = *BLANK;
IF before <> after;
SELECT;
WHEN p$mode = 'C';
OBJECT = after;
exdesc= '*changed';
WHEN p$mode = 'D';
exdesc = '*deleted';
*IN30 = *ON;
ENDSL;
ENDIF;
z$rrn2 = z$rrn1;
UPDATE SC0320S1;
*IN30 = *OFF;
CLEAR MACRO;
ENDIF;
ENDIF;
ENDDO;
ENDIF;
Return ;
END-PROC processChanges ; ;