Source on IFS & Local Development

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
+58 -66
View File
@@ -1,67 +1,59 @@
*==============================================================
* Program that locks a record and then waits for input from
* the operator.
*
* Call this program in two different sessions to see the effect.
* Second program will typically get a error:
* 'Unable to allocate a record in file' (RNX1218)
* and the end user typically choses an unhelpful response.
*==============================================================
* Note: This is a poor technique because the record remains
* locked to all other users until the transaction is
* completed, which may be in a few seconds or after lunch.
*
*Note: Pgm reads by RRN for convenience. This is not a good
* idea is a production program.
*
*Note: DSPLY is use to simulate a display file interaction
* with the user.
*
*Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
*==============================================================
**free
// ==============================================================
// Program that locks a record and then waits for input from
// the operator.
//
// Call this program in two different sessions to see the effect.
// Second program will typically get a error:
// 'Unable to allocate a record in file' (RNX1218)
// and the end user typically choses an unhelpful response.
// ==============================================================
// Note: This is a poor technique because the record remains
// locked to all other users until the transaction is
// completed, which may be in a few seconds or after lunch.
//
// Note: Pgm reads by RRN for convenience. This is not a good
// idea is a production program.
//
// Note: DSPLY is use to simulate a display file interaction
// with the user.
//
// Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
// ==============================================================
H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
H DFTACTGRP(*NO) ACTGRP(*NEW)
FQCUSTCDT UF E DISK USROPN EXTDESC('QIWS/QCUSTCDT')
F RECNO(RRN)
F* INFSR(*PSSR)
D QCmdexc PR EXTPGM('QCMDEXC')
D CMD 512A
D lgth 15P 5 const
D RRN s 10p 0 inz(10)
D reply S 1A inz('*')
D Cmd S 512A
/free
*inlr = *on;
// Set update file to a short wait time. Otherwise the file or
// system default wait time applies.
cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCMDEXC(cmd:512);
open QCUSTCDT;
chain RRN QCUSTCDT;
if %found(QCUSTCDT);
// Logic to update the record would be here.
dsply 'Read for update' ' ' reply;
else;
// Logic for record not found would be here
dsply 'Record not found' ' ' reply;
endif;
// === End of Program =========================================
// Close file before returning
close QCUSTCDT;
return;
// Often found in old programs. Uncomment INFSR(*PSSR) in the
// F-SPEC to make this active.
BEGSR *PSSR;
dsply 'In the *PSSR' ' ' reply;
dump(a);
ENDSR '*CANCL';
Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output) USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
// INFSR(*PSSR)
;
Dcl-PR QCmdexc EXTPGM('QCMDEXC');
Cmd Char(512);
lgth Packed(15:5) CONST;
End-PR;
Dcl-S RRN Packed(10:0) INZ(10);
Dcl-S reply Char(1) INZ('*');
Dcl-S Cmd Char(512);
*inlr = *on;
// Set update file to a short wait time. Otherwise the file or
// system default wait time applies.
Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCmdexc(Cmd:512);
open QCUSTCDT;
chain RRN QCUSTCDT;
if %found(QCUSTCDT);
// Logic to update the record would be here.
dsply 'Read for update' ' ' reply;
else;
// Logic for record not found would be here
dsply 'Record not found' ' ' reply;
endif;
// === End of Program =========================================
// Close file before returning
close QCUSTCDT;
return;
// Often found in old programs. Uncomment INFSR(*PSSR) in the
// F-SPEC to make this active.
BEGSR *PSSR;
dsply 'In the *PSSR' ' ' reply;
dump(a);
ENDSR '*CANCL';
+85 -89
View File
@@ -1,93 +1,89 @@
*==============================================================
* Program that locks a record and then waits for input from
* the operator.
*
* Call this program in two different sessions to see the effect.
*==============================================================
* - Locking the record first is a poor technique because
* the record remains locked to all other users until the
* transaction is completed, which may be in a few seconds or
* after lunch.
* It is used here to demonstate the RCDLCKDSP processing.
*==============================================================
* - Pgm reads by RRN for convenience. This is generally not a
* good idea is a production program.
*
*- DSPLY is use to simulate a display file interaction with
* the user. Not normally done in production.
*
* - QIWS/QCUSTCDT: believed to be on virtually all systems.
*==============================================================
**free
// ==============================================================
// Program that locks a record and then waits for input from
// the operator.
//
// Call this program in two different sessions to see the effect.
// ==============================================================
// - Locking the record first is a poor technique because
// the record remains locked to all other users until the
// transaction is completed, which may be in a few seconds or
// after lunch.
// It is used here to demonstate the RCDLCKDSP processing.
// ==============================================================
// - Pgm reads by RRN for convenience. This is generally not a
// good idea is a production program.
//
// - DSPLY is use to simulate a display file interaction with
// the user. Not normally done in production.
//
// - QIWS/QCUSTCDT: believed to be on virtually all systems.
// ==============================================================
H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
H DFTACTGRP(*NO) ACTGRP(*NEW)
Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
FQCUSTCDT UF E DISK USROPN EXTDESC('QIWS/QCUSTCDT')
F RECNO(RRN)
F* INFSR(*PSSR)
Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output)
USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
// INFSR(*PSSR)
;
D RCDLCKDSP PR EXTPGM('RCDLCKDSP')
D poReply 1A
D piPSDS *
Dcl-PR RCDLCKDSP EXTPGM('RCDLCKDSP');
poReply Char(1);
piPSDS Pointer;
End-PR;
Dcl-PR QCmdexc EXTPGM('QCMDEXC');
Cmd Char(512);
lgth Packed(15:5) CONST;
End-PR;
Dcl-S RRN Packed(10:0) INZ(10);
Dcl-S reply Char(1) INZ('*');
Dcl-S Cmd Char(512);
Dcl-DS myPSDS PSDS;
End-DS;
Dcl-S myPSDS_ptr Pointer INZ(%ADDR(myPSDS));
*inlr = *on;
// Set update file to a short wait time. Otherwise the file or
// system default wait time applies.
Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCmdexc(Cmd:512);
open QCUSTCDT;
dou not %error;
chain(e) RRN QCUSTCDT;
if %error;
RCDLCKDSP(reply: myPSDS_ptr);
if reply = 'R';
iter;
endif;
if reply = 'C';
exsr Prog_Cancelled;
endif;
if reply = 'D';
dump(a);
exsr Prog_Cancelled;
endif;
endif;
enddo;
if %found(QCUSTCDT);
// Logic to update the record would be here.
dsply 'Read for update' ' ' reply;
else;
// Logic for record not found would be here
dsply 'Record not found' ' ' reply;
endif;
// === End of Program =========================================
// Close file before returning
close QCUSTCDT;
return;
begsr Prog_Cancelled;
close QCUSTCDT;
// Put graceful ending logic & notification to user here
return;
endsr;
D QCmdexc PR EXTPGM('QCMDEXC')
D CMD 512A
D lgth 15P 5 const
D RRN s 10p 0 inz(10)
D reply S 1A inz('*')
D Cmd S 512A
D myPSDS SDS
D myPSDS_ptr S * inz(%addr(myPSDS))
/free
*inlr = *on;
// Set update file to a short wait time. Otherwise the file or
// system default wait time applies.
cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCMDEXC(cmd:512);
open QCUSTCDT;
dou not %error;
chain(e) RRN QCUSTCDT;
if %error;
RCDLCKDSP(reply: myPSDS_ptr);
if reply = 'R';
iter;
endif;
if reply = 'C';
exsr Prog_Cancelled;
endif;
if reply = 'D';
dump(a);
exsr Prog_Cancelled;
endif;
endif;
enddo;
if %found(QCUSTCDT);
// Logic to update the record would be here.
dsply 'Read for update' ' ' reply;
else;
// Logic for record not found would be here
dsply 'Record not found' ' ' reply;
endif;
// === End of Program =========================================
// Close file before returning
close QCUSTCDT;
return;
begsr Prog_Cancelled;
close QCUSTCDT;
// Put graceful ending logic & notification to user here
return;
endsr;
// Often found in old programs. Uncomment INFSR(*PSSR) in the
// F-SPEC to make this active.
BEGSR *PSSR;
dsply 'In the *PSSR' ' ' reply;
dump(a);
ENDSR '*CANCL';
// Often found in old programs. Uncomment INFSR(*PSSR) in the
// F-SPEC to make this active.
BEGSR *PSSR;
dsply 'In the *PSSR' ' ' reply;
dump(a);
ENDSR '*CANCL';
+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;
+1 -1
View File
@@ -16,7 +16,7 @@ The top half of the window is information for the current user of the interactiv
The bottom half provides information for the IT Department should the need arise.
## RCDLCKDSP
## RCDLCKDSP.RPGLE
This is the standalone RPG program that handles the window display. It is passed two parameters: