ecki/IBM-i-RPG-Free-CLP-Code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Source on IFS & Local Development

Browse Source
This commit is contained in:
SJLennon
2024-04-10 16:16:48 -04:00
parent 57c4efd0aa
commit a2d8f9c33c
83 changed files with 5807 additions and 4011 deletions
Download Patch File Download Diff File Expand all files Collapse all files
RcdLckDsp/RCDLCKDSP.RPGLE
+169 -198
View File
@@ -1,202 +1,173 @@
*==============================================================
* When an interactive program tries to update a record that is
* locked by another user, often the program doesn't handle it.
* The RPG error routines kick in and give the user a confusing
* error message.
*
* Instead, trap the error and handle it by calling this program.
*
* This program communicates info about a locked record to an
* interactive user telling who has the lock.
**free
// ==============================================================
// When an interactive program tries to update a record that is
// locked by another user, often the program doesn't handle it.
// The RPG error routines kick in and give the user a confusing
// error message.
//
// Instead, trap the error and handle it by calling this program.
//
// This program communicates info about a locked record to an
// interactive user telling who has the lock.
* See program RCDLCKDEMO for a usage example.
*
* RCDLCKDSP accepts a continuation reply from the user and
* passes it back to the caller.
*
* If the status is not 1218, then it is considered an
* unexpected error and a slightly different dialog is
* presented, asking the user to contact IT. You can
* customize this as you see fit. Or add other statuses.
*
* Information is retrieved from the *PSDS passed from the caller.
*
*==============================================================
* Parameters
* ==========
* 1 Output CL1 User's reply about what to do:
* R - Retry the IO operation that failed
* C - Cancel the program
* D - DUmp the program and cancel
* 2 Input * Pointer to the *PSDS in the calling program.
* (A pointer is used because the *PDSD is not
* always the same length in a program.)
*==============================================================
* Create with CRTBNDRPG
* New activation group so we destroy nothing in the caller.
* No worries about overhead since rarely called.
h OPTION(*NODEBUGIO: *SRCSTMT)
H DFTACTGRP(*NO) ACTGRP(*NEW)
*==============================================================
// See program RCDLCKDEMO for a usage example.
//
// RCDLCKDSP accepts a continuation reply from the user and
// passes it back to the caller.
//
// If the status is not 1218, then it is considered an
// unexpected error and a slightly different dialog is
// presented, asking the user to contact IT. You can
// customize this as you see fit. Or add other statuses.
//
// Information is retrieved from the *PSDS passed from the caller.
//
// ==============================================================
// Parameters
// ==========
// 1 Output CL1 User's reply about what to do:
// R - Retry the IO operation that failed
// C - Cancel the program
// D - DUmp the program and cancel
// 2 Input * Pointer to the *PSDS in the calling program.
// (A pointer is used because the *PDSD is not
// always the same length in a program.)
// ==============================================================
// Create with CRTBNDRPG
// New activation group so we destroy nothing in the caller.
// No worries about overhead since rarely called.
Ctl-Opt OPTION(*NODEBUGIO: *SRCSTMT);
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
// ==============================================================
FrcdlckdspdCF E WORKSTN
Dcl-F rcdlckdspd WORKSTN;
Dcl-PR RCDLCKDSP;
poReply Char(1);
piPSDS Pointer;
End-PR;
Dcl-PI RCDLCKDSP;
poReply Char(1);
piPSDS Pointer;
End-PI;
d RCDLCKDSP pr
D poReply 1A
D piPSDS *
// === The caller's Program Status Data Structure ===============
// Many fields not currently used.
Dcl-DS PSDS QUALIFIED BASED(PIPSDS);
PROC_NAME Char(10) Pos(1); //* Procedure name
PGM_STATUS Zoned(5:0) Pos(11); //* Status code
PRV_STATUS Zoned(5:0) Pos(16); //* Previous status
LINE_NUM Char(8) Pos(21); //* Src list line num
ROUTINE Char(8) Pos(29); //* Routine name
PARMS Char(3) Pos(37); //* Num passed parms
EXCP_TYPE Char(3) Pos(40); //* Exception type
EXCP_NUM Char(4) Pos(43); //* Exception number
PGM_LIB Char(10) Pos(81); //* Program library
EXCP_DATA Char(80) Pos(91); //* Exception data
EXCP_ID Char(4) Pos(171); //* Exception Id
LAST_FILE_IO Char(10) Pos(175); //* Last file used
DATE Char(8) Pos(191); //* Date (*DATE fmt)
YEAR Zoned(2:0) Pos(199); //* Year (*YEAR fmt)
LAST_FILE Char(8) Pos(201); //* Last file used
FILE_INFO_STATUS Zoned(5:0) Pos(209) ; //* Last file status
FILE_INFO_OPCODE Char(6) Pos(214); //* Last file opcode
FILE_INFO_ROUTINE Char(8) Pos(220) ; //* Last file RPG
FILE_INFO_LIST_NUM Char(8) Pos(228) ; //* Last file listing
FILE_INFO_RECORD Int(20) Pos(236) ; //* Last file record
JOB_NAME Char(10) Pos(244); //* Job name
USER Char(10) Pos(254); //* User name
JOB_NUM Zoned(6:0) Pos(264); //* Job number
JOB_DATE Zoned(6:0) Pos(270); //* Date (UDATE fmt)
RUN_DATE Zoned(6:0) Pos(276); //* Run date (UDATE)
RUN_TIME Zoned(6:0) Pos(282); //* Run time (UDATE)
CRT_DATE Char(6) Pos(288); //* Create date
CRT_TIME Char(6) Pos(294); //* Create time
CPL_LEVEL Char(4) Pos(300); //* Compiler level
SRC_FILE Char(10) Pos(304); //* Source file
SRC_LIB Char(10) Pos(314); //* Source file lib
SRC_MBR Char(10) Pos(324); //* Source file mbr
PROC_PGM Char(10) Pos(334); //* Pgm Proc is in
PROC_MOD Char(10) Pos(344); //* Mod Proc is in
LINE_NUM_SRCID Int(5) Pos(354); //* Src list source ID
FILE_INFO_LIST_NUM_SRCID Int(5) Pos(356) ; //* Last file listing
CURR_USER Char(10) Pos(358) ; //* Current user
EXTERNAL_RC Int(10) Pos(368) ; //* External return
NUM_XML_ELEMS Int(20) Pos(372) ; //* Number of XML
End-DS;
// === My Variables ==============================================
Dcl-DS MyPSDS PSDS;
MyName Char(10) Pos(1); //* This program
End-DS;
d RCDLCKDSP pi
D poReply 1A
D piPSDS *
* === The caller's Program Status Data Structure ===============
* Many fields not currently used.
D PSDS DS qualified based(piPSDS)
D PROC_NAME 1 10 * Procedure name
D PGM_STATUS 11 15s 0 * Status code
D PRV_STATUS 16 20S 0 * Previous status
D LINE_NUM 21 28 * Src list line num
D ROUTINE 29 36 * Routine name
D PARMS 37 39 * Num passed parms
D EXCP_TYPE 40 42 * Exception type
D EXCP_NUM 43 46 * Exception number
D PGM_LIB 81 90 * Program library
D EXCP_DATA 91 170 * Exception data
D EXCP_ID 171 174 * Exception Id
D LAST_FILE_IO 175 184 * Last file used
D DATE 191 198 * Date (*DATE fmt)
D YEAR 199 200S 0 * Year (*YEAR fmt)
D LAST_FILE 201 208 * Last file used
D FILE_INFO_STATUS...
D 209 213S 0 * Last file status
D * Code
D FILE_INFO_OPCODE...
D 214 219 * Last file opcode
D FILE_INFO_ROUTINE...
D 220 227 * Last file RPG
D * routine
D FILE_INFO_LIST_NUM...
D 228 235 * Last file listing
D * line
D FILE_INFO_RECORD...
D 236 243I 0 * Last file record
D * name
D JOB_NAME 244 253 * Job name
D USER 254 263 * User name
D JOB_NUM 264 269S 0 * Job number
D JOB_DATE 270 275S 0 * Date (UDATE fmt)
D RUN_DATE 276 281S 0 * Run date (UDATE)
D RUN_TIME 282 287S 0 * Run time (UDATE)
D CRT_DATE 288 293 * Create date
D CRT_TIME 294 299 * Create time
D CPL_LEVEL 300 303 * Compiler level
D SRC_FILE 304 313 * Source file
D SRC_LIB 314 323 * Source file lib
D SRC_MBR 324 333 * Source file mbr
D PROC_PGM 334 343 * Pgm Proc is in
D PROC_MOD 344 353 * Mod Proc is in
D LINE_NUM_SRCID...
D 354 355I 0 * Src list source ID
D FILE_INFO_LIST_NUM_SRCID...
D 356 357I 0 * Last file listing
D * source ID
D CURR_USER 358 367 * Current user
D * profile
D EXTERNAL_RC 368 371I 0 * External return
D * code
D NUM_XML_ELEMS 372 379I 0 * Number of XML
d * elements
*=== My Variables ==============================================
D MyPSDS sDS
D MyName 1 10 * This program
D User c 'User: '
D UserPrf S 10A inz(' ')
D UserName S 40A inz(' ')
D wkI s 10I 0
D wkJ s 10I 0
d myStatus s 4S 0
D*AAA DS likeds(PSDS)
/FREE
// AAA = PSDS; // Eases Debugging...
SH_PGM = MyName;
// Sometimes the Status is not numeric
monitor;
myStatus = psds.FILE_INFO_STATUS;
on-error;
myStatus = -0;
ENDMON;
// Display fields are prefixed with SC_.
select;
when myStatus = 1218; //Record locked
SC_USER1 = 'Cannot continue until the user below completes';
SC_USER2 = 'their transaction or exits their application.';
exsr GetUserPrf;
//exsr GetUserName;
// Fill in user profile and user name
select;
when UserPrf = ' ' and UserName = ' ';
SC_USER3 = User + '*Unknown* -- Call IT Now.';
when UserName = ' ';
SC_USER3 = User + UserPrf;
other;
SC_USER3 = User + UserName;
endsl;
SC_INSTR = 'Enter R to Retry, C to Cancel';
other; //Unknown error
SC_USER1 = 'An unexpected error has occurred.';
SC_USER2 = 'Please contact IT now.';
SC_INSTR = 'IT: D=Dump, C=Cancel; R=Retry';
endsl;
// We try to fill in this info for all conditions
SC_IT_PGM = PSDS.PROC_NAME;
SC_IT_STS = myStatus;
SC_IT_FILE = PSDS.LAST_FILE;
SC_IT_OPCD = PSDS.FILE_INFO_OPCODE;
SC_IT_EM1 = %subst(PSDS.EXCP_DATA: 1: %len(SC_IT_EM1));
SC_IT_EM2 = %subst(PSDS.EXCP_DATA: %len(SC_IT_EM1)+1);
exfmt dspwin;
poReply = 'R'; //Default to R
if SC_RESP = 'C' or SC_RESP = 'R' or SC_RESP = 'D';
poReply = SC_RESP;
endif;
*inlr = *on;
return;
begsr GetUserPrf;
// Dig the user profile out of the error message (EXCP_DATA)
// which looks like this:
// Record 3317 in use by job 018249/SLENNON/MISREMSAM
UserPrf = ' ';
wkI = %scan('/':PSDS.EXCP_DATA);
if wkI <> 0;
wkI = wkI +1;
wkJ = %scan('/' :PSDS.EXCP_DATA: wkI);
if WkJ <> 0;
wkJ = WkJ - wkI;
if wkI > 0;
UserPrf = %subst(PSDS.EXCP_DATA: wkI: wkJ);
endif;
endif;
endif;
endsr;
begsr GetUserName;
// If you have a way to connect a user name to a user
// then set UserName here.
UserName = ' ';
endsr;
/END-FREE
Dcl-C USER 'USER: ';
Dcl-S UserPrf Char(10) INZ(' ');
Dcl-S UserName Char(40) INZ(' ');
Dcl-S wkI Int(10);
Dcl-S wkJ Int(10);
Dcl-S myStatus Zoned(4:0);
//Dcl-DS AAA LIKEDS(PSDS);
// AAA = PSDS; // Eases Debugging...
SH_PGM = MyName;
// Sometimes the Status is not numeric
monitor;
myStatus = PSDS.FILE_INFO_STATUS;
on-error;
myStatus = -0;
ENDMON;
// Display fields are prefixed with SC_.
select;
when myStatus = 1218; //Record locked
SC_USER1 = 'Cannot continue until the user below completes';
SC_USER2 = 'their transaction or exits their application.';
exsr GetUserPrf;
//exsr GetUserName;
// Fill in user profile and user name
select;
when UserPrf = ' ' and UserName = ' ';
SC_USER3 = USER + '*Unknown* -- Call IT Now.';
when UserName = ' ';
SC_USER3 = USER + UserPrf;
other;
SC_USER3 = USER + UserName;
endsl;
SC_INSTR = 'Enter R to Retry, C to Cancel';
other; //Unknown error
SC_USER1 = 'An unexpected error has occurred.';
SC_USER2 = 'Please contact IT now.';
SC_INSTR = 'IT: D=Dump, C=Cancel; R=Retry';
endsl;
// We try to fill in this info for all conditions
SC_IT_PGM = PSDS.PROC_NAME;
SC_IT_STS = myStatus;
SC_IT_FILE = PSDS.LAST_FILE;
SC_IT_OPCD = PSDS.FILE_INFO_OPCODE;
SC_IT_EM1 = %subst(PSDS.EXCP_DATA: 1: %len(SC_IT_EM1));
SC_IT_EM2 = %subst(PSDS.EXCP_DATA: %len(SC_IT_EM1)+1);
exfmt DSPWIN;
poReply = 'R'; //Default to R
if SC_RESP = 'C' or SC_RESP = 'R' or SC_RESP = 'D';
poReply = SC_RESP;
endif;
*inlr = *on;
return;
begsr GetUserPrf;
// Dig the user profile out of the error message (EXCP_DATA)
// which looks like this:
// Record 3317 in use by job 018249/SLENNON/MISREMSAM
UserPrf = ' ';
wkI = %scan('/':PSDS.EXCP_DATA);
if wkI <> 0;
wkI = wkI +1;
wkJ = %scan('/' :PSDS.EXCP_DATA: wkI);
if wkJ <> 0;
wkJ = wkJ - wkI;
if wkI > 0;
UserPrf = %subst(PSDS.EXCP_DATA: wkI: wkJ);
endif;
endif;
endif;
endsr;
begsr GetUserName;
// If you have a way to connect a user name to a user
// then set UserName here.
UserName = ' ';
endsr;