diff --git a/Service_Pgms/SRV_MSG.RPGLE b/Service_Pgms/SRV_MSG.RPGLE new file mode 100644 index 0000000..17e1b21 --- /dev/null +++ b/Service_Pgms/SRV_MSG.RPGLE @@ -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 diff --git a/Service_Pgms/SRV_MSGTR.RPGLE b/Service_Pgms/SRV_MSGTR.RPGLE new file mode 100644 index 0000000..8d9c09d --- /dev/null +++ b/Service_Pgms/SRV_MSGTR.RPGLE @@ -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 + + diff --git a/Service_Pgms/SRV_STR.RPGLE b/Service_Pgms/SRV_STR.RPGLE new file mode 100644 index 0000000..03731f0 --- /dev/null +++ b/Service_Pgms/SRV_STR.RPGLE @@ -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 diff --git a/Service_Pgms/SRV_STRTR.RPGLE b/Service_Pgms/SRV_STRTR.RPGLE new file mode 100644 index 0000000..1c5b876 --- /dev/null +++ b/Service_Pgms/SRV_STRTR.RPGLE @@ -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