Change Demo, to Copy_MBRS

This commit is contained in:
SJLennon
2021-10-07 13:07:10 -04:00
parent c2866e7e41
commit 8cb6129e51
4 changed files with 545 additions and 0 deletions
+257
View File
@@ -0,0 +1,257 @@
//==============================================================
//=== SRV_MSG service program contains prodcedure for sending
//=== messages with QMHSNDPM
//==============================================================
// CRTRPGMOD MODULE(SRV_MSG)
// CRTSRVPGM SRVPGM(SRV_MSG) EXPORT(*ALL)
// ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_MSG *SRVPGM *DEFER))
h nomain option(*NoDebugIo: *srcstmt)
/include copy_mbrs,Srv_Msg_P
//=== QMHSNDPM internal prototype =============================
D QMHSNDPM pr ExtPgm('QMHSNDPM')
D piMsgId 7a Const
D piMsgFile 20a Const
D piMsgData 1024a Const OPTIONS(*varsize)
D piMsgDataLgth 10i 0 Const
D piMsgType 10a Const
D piCallStk 10a Const
D piRelCallStk 10i 0 Const
D piRtnMsgKey 4a
D apiErrorDS 17a
//=== QMHRMVPM internal prototype =============================
d QMHRMVPM pr Extpgm('QMHRMVPM')
d pPgmMsgQ 10a
d PgmStk 10i 0
d MsgKey 4a
d Remove 10a
D apiErrorDS 17a
//=== SNDMSGPGMQ ===============================================
// SeND a MeSsaGe to a ProGraM message Queue.
// Sends a pre-defined message to a program message queue
// that you provide as a parameter.
// Primarily designed to be used in interactive programs
// that send messages via a message subfile.
// See also CLRMSGPGMQ which clears messages from a program
// message queue.
//==============================================================
// Conceptual call:
//=================
// H BndDir('UTIL_BND')
// /include copy_mbrs,Srv_Msg_P
// D ProgStatus sds
// D PgmName *PROC
// SNDMSGPGMQ(PgmName:
// Msgid:
// MsgFile:
// MsgDta);
//==============================================================
P SndMsgPgmQ b export
d SndMsgPgmQ pi
d pMsgQ 10
d pMsgid 7
d pMsgFile 10
d pMsgDta 80 options(*NOPASS)
d Varying
//=== Calling Parameters =======================================
// Parm I/O/B Description
// ---- ----- -----------
// pMsgQ I Message queue to send to. Usually the
// program name, or the MAIN procedure name
// obtained with %proc().
// pMsgId I Predefined message id, e.g. CPF9898.
// pMsgFile I Message file containing pMsgid. (Library
// is assumed as *LIBL.)
// pMsgDta I Optional: Data to substitute into the message.
// (Trailing blanks will be truncated before use.)
//=== API Error Code Structure ==================================
// We don't provide any bytes, so an error will cause a crash,
// because if we get an error here something bad has happened.
dAPIError ds 272
d APIEProv 1 4b 0 inz(0)
d APIEAvail 5 8b 0 inz(0)
d APIErrId 9 15 inz(*blanks)
//=== QMHSNDPM Parameters =======================================
d QMsgFile s 20
d MsgType s 10 inz('*INFO')
d StackCntr s 10i 0 inz(0)
d MsgKey s 4 inz(' ')
d MsgDta s 256 inz(' ')
d MsgDtaLgth s 10i 0
//=== SNDMSGPGMQ execution starts here ==========================
/free
QMsgFile = pMsgFile + '*LIBL';
// Message data length for QMHSNDPM is optional. If supplied,
// use, else default to 0.
if %parms > 3;
MsgDta = pMsgDta;
MsgDtaLgth = %len(%trimr(MsgDta));
else;
MsgDtaLgth = 0;
endif;
//=== Send message with API =====================================
QMHSNDPM (pMsgid
:QMsgFile
:MsgDta
:MsgDtaLgth
:MsgType
:pMsgQ
:StackCntr
:MsgKey
:APIError);
// Exit with LR off. This is a tiny routine which will probably
// be called again.
return;
/end-free
p SndMsgPgmQ e
//=== CLRMSGPGMQ =-=============================================
// CLeaRs all MeSsaGes from a ProGraM message Queue
// Clears all the messages from a program message queue that
// you specify as a parameter.
// It is primarily designed for use by interactive programs that
// send messages through a message subfile.
// See also SNDMSGPGMQ which sends a message to the program queue.
//
// Always returns *OFF
//===============================================================
// Conceptual call:
//=================
// H BndDir('UTIL_BND')
// /include copy_mbrs,Srv_Msg_P
// D ProgStatus sds
// D PgmName *PROC
// CLRMSGPGMQ(PgmName)
p ClrMsgPgmQ b export
D ClrMsgPgmQ pi N
d pPgmMsgQ 10
//=== API Error Code Structure ==================================
// We don't provide any bytes, so an error will cause a crash,
// because if we get an error here something bad has happened.
dAPIError ds 272
d APIEProv 1 4b 0 inz(0)
d APIEAvail 5 8b 0 inz(0)
d APIErrId 9 15 inz(*blanks)
//=== Parameters for QMHRMVPM API ===============================
d PgmStk s 10i 0 inz(0)
d MSgKey s 4 inz(*blanks)
d Remove s 10 inz('*ALL')
//=== Calling Parameters =============================================
// Parm I/O/B Description
// ---- ----- -----------
// pPGMMsgQ I Program message queue to clear.
//=== ClrMsgPgmQ execution starts here ==========================
/free
QMHRMVPM(pPgmMsgQ
:PgmStk
:MsgKey
:Remove
:APIError);
/free
// Exit with LR off. This is a tiny routine which will probably
// be called again.
RETURN *off;
/end-free
p ClrMsgPgmQ e
//=== SndEscMsg ===============================================
// Sends CPF9898 Escape message of the provided text.
// This will kill the current program and cause an
// exception in the one that called it.
P SndEscMsg B Export
D SndEscMsg PI
D piMsg 1024a Const Varying
//--- Parameters for QMHSNDPM -------------------------
D MsgId c const('CPF9898')
d MsgF c const('QCPFMSG *LIBL ')
d MsgType c const('*ESCAPE ')
d PgmQue c const('* ')
d InvCount c const(2)
d ApiError s 17a inz(X'00')
d RetMsgKey s 4a
D DataLen s 10i 0
//--- Local Variables ---------------------------------
D MsgData s 1024a
/FREE
DataLen = %len(PiMSG);
MsgData = piMsg;
QMHSNDPM(MsgId
:MsgF
:MsgData
:DataLen
:MsgType
:PgmQue
:InvCount
:RetMsgKey
:APIError);
return;
/end-free
P SndEscMsg E
//=== SndInfMsg ===============================================
// Sends CPF9898 Info message of the provided text to the
// external message queue.
// Useful for debugging.
P SndInfMsg B Export
D SndInfMsg PI
D piMsg 1024a Const Varying
//--- Parameters for QMHSNDPM -------------------------
D MsgId c const('CPF9898')
d MsgF c const('QCPFMSG *LIBL ')
d MsgType c const('*INFO ')
d PgmQue c const('*EXT ')
d InvCount c const(2)
d ApiError s 17a inz(X'00')
d RetMsgKey s 4a
D DataLen s 10i 0
//--- Local Variables ---------------------------------
D MsgData s 1024a
/FREE
DataLen = %len(PiMSG);
MsgData = piMsg;
QMHSNDPM(MsgId
:MsgF
:MsgData
:DataLen
:MsgType
:PgmQue
:InvCount
:RetMsgKey
:APIError);
return;
/end-free
P SndInfMsg E
+165
View File
@@ -0,0 +1,165 @@
//=== Tests procedures in SRV_MSG service program =============
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND')
//=== Display File ============================================
FSRV_MSGTD CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS)
F USROPN
//=== Service Program Prototypes ==============================
/include copy_mbrs,Srv_Msg_P
//=== Named hexadecimal constants for function keys ===========
/include copy_mbrs,##AIDBYTES
//=== Display File Information Data Structure =================
// Allows us to determine which function key was pressed
D dfInfDS DS
D Key 369 369
//=== Display File Indicator Data Structure ===================
// This is a "private" indicator area for the display file.
D dfIndDS ds 99
D SH_ERR 40 40n
//=== Global Switches =========================================
D SflMsgSnt s n
D CowsComeHome c const('0')
//=== Work Fields =============================================
D inx s 10i 0
//=== Program Status Data Structure ===========================
D ProgStatus sds
D PgmName *PROC
/FREE
//=============================================================
// === Main Program Loop ======================================
//=============================================================
exsr init;
SFT_KEYS='F3/F12=Exit';
dou CowsComeHome;
write SH_HDR;
write SFT_FKEY;
if SflMsgSnt = *on;
write MSGCTL;
endif;
exfmt SH_HDR;
SH_ERR = *off;
if key = F03 or Key = F12;
exsr CloseDownPgm;
return;
endif;
if SH_MSG = ' ';
SH_ERR = *ON; // Please enter a message
iter;
endif;
select;
//-- Enter Key ---------------------------------------------
when Key = Enter;
//--- F04 --------------------------------------------------
when Key = F04;
SflMsgSnt= SndSflMsg('CPF9898' : SH_MSG);
iter;
//--- F05 --------------------------------------------------
when Key = F05;
if SflMsgSnt = *on;
SflMsgSnt = ClrMsgPgmQ(PgmName);
write MSGCTL;
iter;
endif;
//--- F06 --------------------------------------------------
when Key = F06;
SndInfMsg(SH_MSG);
iter;
//--- F07 --------------------------------------------------
when Key = F07;
SndEscMsg(SH_MSG);
iter;
endsl;
enddo;
//=============================================================
//=== End of Main Program Loop ================================
//=============================================================
//=== CloseDownPgm ============================================
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
*inlr = *on;
close SRV_MSGTD;
endsr;
//=== Init ====================================================
begsr Init;
MSGPGMQ = PgmName;
SH_PGM = PgmName;
if not %open(SRV_MSGTD);
open SRV_MSGTD;
endif;
endsr;
//=============================================================
// S u b P r o c e d u r e s
//=============================================================
//=== SndSflMsg ===============================================
// Send a message to the Error Subfile
// Returns: *ON
// Parameter: ErrMsgId => Msg Id to Send
// Parameter: ErrMsgData => Optional Error Message Data
// Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF
//------------------------------------------------------------
/END-FREE
P SndSflMsg B
D SndSflMsg PI N
D ErrMsgId 7A CONST
D ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST
D OPTIONS(*NOPASS)
// Local fields
D retField S N
D wkMsgId s 7a
D wkMsgFile s 10a
D wkMsgData s 80a varying
/FREE
if %parms >2;
wkMsgFile = ErrMsgFile;
else;
wkMsgFile = 'QCPFMSG';
ENDIF;
if %parms > 1;
wkMsgData = ErrMsgData;
else;
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(PgmName:
wkMsgid:
wkMsgFile:
wkMsgData);
retField = *on;
RETURN retField;
/END-FREE
P SndSflMsg E
+45
View File
@@ -0,0 +1,45 @@
//==============================================================
//=== SRV_STR service program contains procedures working
//=== with strings
//==============================================================
// CRTRPGMOD MODULE(SRV_STR)
// CRTSRVPGM SRVPGM(SRV_STR) EXPORT(*ALL)
// ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_STR *SRVPGM *DEFER))
//=== CenterStr ================================================
// Return the centered string. The input string is normally
// fixed length and RPG will promote it to varying on the
// call. A varying string is returned which RPG will reset
// to fixed if needed.
// It will also execute with a varying string input but the
// result may not be what you expect.
//
// Conceptual call:
//=================
// H BndDir('UTIL_BND')
// /include copy_mbrs,Srv_Str_P
// d Head S 20A inz('Inquiry')
// Head = CenterStr(Head);
// Notes:
// CenterStr is small, but it is convenient.
// Could add left and right justify, but...
// Left justify is simple in RPG:
// str = %trim(str);
// Right justify is also simple:
// evalr str = %trim(str);
h nomain option(*NoDebugIo: *srcstmt)
/include copy_mbrs,SRV_STR_P
p CenterStr b export
d CenterStr pi 256a varying
d InStr 256a varying const
d
d blanks s 256a varying inz
d trimInStr s 256a varying
/free
trimInStr = %trim(InStr);
// Set length to materialize required leading blanks.
%len(blanks) = %int((%len(inStr) - %len(trimInStr))/2);
return blanks + trimInStr;
/end-free
p CenterStr e
+78
View File
@@ -0,0 +1,78 @@
//=== Test the SRV_STR service program========================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND')
d X1 S 1A inz('A') One char
d X2 S 2A inz('B ') Two char
d X3 S 4A inz('C ') 3 blanks
d X4 S 5A inz('D ') 4 blanks
d X5 S 6A inz('E ') 5 blanks
d X0 S 5A inz(' ') all blank
d Xl S 20A inz('20-chars ') longer
d Xm S 21A inz(' 21-Chars') longer
d Xv S 24 inz(' 24-varying ') varying Varying-note result
d l1 S 20A inz(' ABCDE ') Left align
d l2 S 20A inz('Left already ') Left align
d r1 S 20A inz('abc') Right align
d r2 S 20A inz(' defgh ') Right align
/include copy_mbrs,SRV_STR_P
/free
x1 = tst(x1);
dsply ('-' + x1 + '-');
x2 = tst(x2);
dsply ('-' + x2 + '-');
x3 = tst(x3);
dsply ('-' + x3 + '-');
x4=tst(x4);
dsply ('-' + x4 + '-');
x5 = tst(x5);
dsply ('-' + x5 + '-');
x0 = tst(x0);
dsply ('-' + x0 + '-');
xl = tst(xl);
dsply ('-' + xl + '-');
xm = tst(xm);
dsply ('-' + xm + '-');
xv = tst(xv);
dsply ('-' + xv + '-');
dsply ('---- Left Justify ---');
dsply ('-' + l1 + '-');
l1 =%trim(l1);
dsply ('-' + l1 + '-');
dsply ('-' + l2 + '-');
l2 =%trim(l2);
dsply ('-' + l2 + '-');
dsply ('---- Right Justify ---');
dsply ('-' + r1 + '-');
evalr r1 = %trim(r1);
dsply ('-' + r1 + '-');
dsply ('-' + r2 + '-');
evalr r2 = %trim(r2);
dsply ('-' + r2 + '-');
*inlr = *on;
return;
/END-FREE
p tst b
d tst pi 50a varying
d II 50a varying const
/free
dsply '---------------------';
DSPLY ('-' + ii + '-');
return CenterStr(ii);
/end-free
p tst e