***************************************************************** * * Module Name: CONDHDLR * * This module is used to produce the service program of the * condition handler demo. The following are the procedures which * are exported from this service program. * * pCondHdlr - This is the main export. This procedure can be * registered as a condition handler in any of * your interactive programs. It checks the error * that caused the condition, if it is a record * lock, and if running interactively, it displays * a window with information regarding the record lock * (including the fully qualified job name, file name * record format name, record number, etc.) and asks * the user to reply R to retry or C to cancel. It then * communicates the user reply to the failing * procedure which is then free to take any action * chooses. If the error is anything other than a * record lock error, this condition handler * marks the exception as unhandled. * * pInteractive - This and pExtractMsgId were simply functions * that were needed by pCondHdlr. So I decided to * include them as well in the exported procedures * from this service program. This procedure simply * returns an indicator variable which is *On if * we are running interactively and is *Off if * not running interactively * * pExtractMsgId - This and pExtractMsgId were simply functions * that were needed by pCondHdlr. So I decided to * include them as well in the exported procedures * from this service program. When you call a CEE API * you may optionally pass a 12-byte feedback area. * Deciphering this feedback area is a bit cryptic. * This procedure returns a 7-character message * (e.g., CEE0001) which is the AS/400 message * id associated with the error (if any) encoded * in the feedback field. If the feedback field * indicates that there was no error, then this * procedure returns blanks. * * To install this module, perform the following steps. * * 1) Compile display file CONDHDLRD (option 14 PDM) * 2) Compile this module with option 15 in PDM (CrtRpgMod) * 3) Execute the following command: * CrtSrvPgm SrvPgm( CONDHDLR ) Export( *All ) ActGrp( SrvPgmAct ) * * To run the condition handler demo software do the following: * * * 1) Compile physical file CUST (option 14 in PDM) * 2) Use DFU or a third party file editor to put a couple of * records into CUST. The only thing that really needs to be * filled in for the purposes of this demo is the customer number * (CuNum). For simplicity use customer numbers 1 and 2 * 3) Issue the following command: * ChgPf File( Cust ) WaitRcd( *Immed ) * Note, when using the CONDHDLR service program, this command * should be issued for any file in which you want the pCondHdlr * procedure to handle file lockout conditions. This will eliminate * a waiting period for the record to be unlocked. * 4) Compile display file TSTDSPF (PDM option 14) * 5) Compile ILE RPG module TSTCNDHDLR with option 15 (CrtRpgMod) * 6) Issue the following command * * CrtPgm Pgm( TSTCNDHDLR ) ActGrp( *Caller ) BndSrvPgm( CONDHDLR ) * 7) Sign on to a second interactive session so you now have 2 * interactive sessions. * 8) In interactive session 1), Call TSTCNDHDLR. * 9) Fill in customer number 1 and press Enter. * 10) Without modifying the record, jump over to your second * interactive session and repeat steps 8 and 9 over there. * 11) You should see the record locked window. You can try either * of the replies and see what happens. * ***************************************************************** H NoMain FCondHdlrD CF E WorkStn UsrOpn * If you wish to use this module, you should copy into your source * the line following the "Start of copy area" comment below * and ending with the line preceding the "End of copy area" * comment line *********Start of copy area*************** * Standard Types D MsgIdType S 7 Based( DummyPtr ) D TypeNoMsgId C *Blank D FeedbackType S 12 Based( DummyPtr ) * Prototypes D pExtractMsgId PR Like( MsgIdType ) D Feedback Like( FeedbackType ) D pInteractive PR N D DummyPrm 1 Options( *Omit ) D pCondHdlr PR D InpFeedback Like( FeedBackType ) D ActionPtr * D ResultCode 10I 0 D ResultCodeResume... D C 10 D ResultCodeUnhandled... D C 20 D NewFeedback Like( FeedbackType ) *********End of copy area **************** D HexArr S 2 Dim( 256 ) D PerRcd( 32 ) D CtData * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * Procedure pInteractive - Determines whether we are running * interactively or not P pInteractive B Export D pInteractive PI N D DummyPrm 1 Options( *Omit ) * Local variables D RetdInfDs DS D 4 D 10I 0 Inz( %Size( RetdInfDs ) ) D RiJobType 61 61 D RiTypeInteractive... D C 'I' D LenRetdInf S 10I 0 Inz( %Size( RetdInfDs ) ) D FmtName S 8 Inz( 'JOBI0100' ) D QlJobName S 26 Inz( '*' ) D IntJobId S 16 Inz( *Blank ) C Call 'QUSRJOBI' C Parm RetdInfDs C Parm LenRetdInf C Parm FmtName C Parm QlJobName C Parm IntJobId C If RiJobType = RiTypeInteractive C Return *On C Else C Return *Off C EndIf P pInteractive E * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * Procedure pExtractMsgId - Extracts the message id from a condition * token. Returns either the message id or * if the token indicates a normal completion * it returns blanks. P pExtractMsgid B Export D pExtractMsgId PI Like( MsgIdType ) D Feedback Like( FeedbackType ) * Local variables D FeedbackDs DS Based( FeedbackDsPtr ) D FtCondId 4 D FtMsgSev 5I 0 Overlay( FtCondId ) D FtMsgNo 2 Overlay( FtCondId: *Next ) D FtMsgNoHi 1 Overlay( FtMsgNo ) D FtMsgNoLo 1 Overlay( FtMsgNo: *Next ) D 1 D FtMsgIdPrefix 3 D FtMsgInfo 4 D HexArrIdxDs DS D Hi2ByteBin 5I 0 D HiLoOrdByte 1 Overlay( Hi2ByteBin: 2 ) D RetdMsgId S 7 * Set addressability to the local based feedback data structure C Eval FeedbackDsPtr = %Addr( Feedback ) C If FtCondId = *Loval C Return *Blank C EndIf * Initialize the returned message id with the 3-character * prefix. C Eval RetdMsgId = FtMsgIdPrefix * Convert the 2-byte hex field to external display format. * For example, X'E54F' is converted to the character constant * 'E54F'. C Eval Hi2ByteBin = *Zero C Eval HiLoOrdByte = %Subst( FtMsgNo: C 1: 1 ) C Eval Hi2ByteBin = Hi2ByteBin + 1 C Eval %Subst( RetdMsgId: 4: 2 ) C = HexArr( Hi2ByteBin ) C Eval Hi2ByteBin = *Zero C Eval HiLoOrdByte = %Subst( FtMsgNo: C 2: 1 ) C Eval Hi2ByteBin = Hi2ByteBin + 1 C Eval %Subst( RetdMsgId: 6: 2 ) C = HexArr( Hi2ByteBin ) C Return RetdMsgId P pExtractMsgid E * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * = * Procedure pCondHdlr - Sample condition handler. This one * handles a record lock condition by * displaying a window if running interactively, * or sending an inquiry message to qsysopr * if not running interactively. In both * cases, the user is asked to indicate * whether they want to cancel or retry. * The user's response is then made available * to the failing procedure in the communications * area (called Action). The failing procedure * can take whatever action it wants based on * users's response. If the failure is due to * anything other than a locked record then * the exception is marked as unhandled. P pCondHdlr B Export D pCondHdlr PI D InpFeedback Like( FeedBackType ) D ActionPtr * D ResultCode 10I 0 D ResultCodeResume... D C 10 D ResultCodeUnhandled... D C 20 D NewFeedback Like( FeedbackType ) * Local Variables D Action S 1 Based( ActionPtr ) D ActionCncl C 'C' D ActionRetry C 'R' D MsgId S Like( MsgIdType ) * The following data structure contains the fields needed * from the message data for IBM message CPF5027 D MsgDtaForCPF5027... D DS Based( MsgDtaPtr ) D MdFileName 11 20 D MdFileLib 21 30 D MdMbr 31 40 D MdRec#Area 65 68B 0 *Note, the following overlay is defined because RPG (at least * during one point in its history) treated MdRec#Area as a 9-digit * field, thus not allowing the full range of values that can be * assumed in a 4-byte binary field. It might not be necessary * but I made the following definition just in case. D MdRec# 10I 0 Overlay( MdRec#Area ) D MdJobId 81 108 D MsgInfDs DS 2000 D MiBytesRetd 10I 0 D MiBytesAvl 10I 0 Inz( %Size( MsgInfDs ) ) D MiMsgId 13 19 D MiStartOfMsgDta... D 49 49 D LenMsgInf S 10I 0 Inz( %Size( MsgInfDs ) ) D FmtName S 8 Inz( 'RCVM0100' ) D ClStkEntry S 10 Inz( '*' ) D ClStkCounter S 10I 0 Inz( 2 ) D MsgType S 10 Inz( '*NOTIFY' ) D MsgKey S 4 Inz( *Blank ) D WaitTime S 10I 0 Inz( *Zero ) D MsgAction S 10 Inz( '*OLD' ) D ApiErr DS D AeBytesProv 10I 0 Inz( %Size( ApiErr ) ) D AeBytesAvl 10I 0 D AeMsgId 7 D 1 D AeMsgDta 256 * If this is not a record timeout, mark message as unhandled C If pExtractMsgId( InpFeedback ) <> 'RNX1218' C Eval ResultCode = ResultCodeUnhandled C Return C EndIf * Invoke the subroutine that fills in the information obtained * from the CPF5027 message data C ExSr FillMsgDta * If the message wasn't found, mark error as unhandled C If MsgDtaPtr = *Null C Eval ResultCode = ResultCodeUnhandled C Return C EndIf * Invoke the interactive handler if running interactive, otherwise * percolate this error. C If pInteractive( *Omit ) C ExSr GetActionInt C Else C Eval ResultCode = ResultCodeUnhandled C Return C EndIf * The following subroutine looks for the CPF5027 notify message * in the message queue 2 levels prior in the call stack from this * procedure. If it finds it, it fills in data structure * MsgDtaForCPF5027. If it doesn't find it, it sets the basing pointer * for this data structure (MsgDtaPtr) to *Null. Note, * the message is marked as *OLD, so that it won't be retrieved * twice. C FillMsgDta BegSr * See if there is a CPF5027 message in the invoker's message queue C Call 'QMHRCVPM' C Parm MsgInfDs C Parm LenMsgInf C Parm FmtName C Parm ClStkEntry C Parm ClStkCounter C Parm MsgType C Parm MsgKey C Parm WaitTime C Parm MsgAction C Parm ApiErr * Set the basing pointer for data structure MsgDtaForCPF5027 * (MsgDtaPtr) to *Null if the above call fails to find * a notify message CPF5027. C If AeBytesAvl > *Zero C Eval MsgDtaPtr = *Null C LeaveSr C EndIf C If MiMsgId <> 'CPF5027' C Eval MsgDtaPtr = *Null C EndIf C Eval MsgDtaPtr = %Addr( MiStartOfMsgDta ) C EndSr * This subroutine displays a window to the user showing * the information about the file and job and record which * is locked. It asks the user to reply C to cancel or R to * retry. It places this reply into the Action field which is * available to the failing application procedure. C GetActionInt Begsr C Open CondHdlrD * Fill in the output screen fields C Eval JobId = MdJobId C Eval FileName = MdFileName C Eval FileLib = MdFileLib C Eval MbrName = MdMbr C Eval RecNo = MdRec# * Get the user's reply C ExFmt W01 * Save the user reply in the failing procedure's supplied * failing procedure's supplied data communication field. C If ScReply = 'R' C Eval Action = ActionRetry C Else C Eval Action = ActionCncl C EndIf * Specify that the exception is handled by setting a result code * of 10 (resume processing at the resume cursor). C Eval ResultCode = ResultCodeResume C Close CondHdlrD C EndSr P pCondHdlr E **CtData HexArr 000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F 202122232425262728292A2B2C2D2E2F303132333435363738393A3B3C3D3E3F 404142434445464748494A4B4C4D4E4F505152535455565758595A5B5C5D5E5F 606162636465666768696A6B6C6D6E6F707172737475767778797A7B7C7D7E7F 808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9F A0A1A2A3A4A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBF C0C1C2C3C4C5C6C7C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDCDDDEDF E0E1E2E3E4E5E6E7E8E9EAEBECEDEEEFF0F1F2F3F4F5F6F7F8F9FAFBFCFDFEFF