Tuesday, November 22, 2016

Validation trigger in RPG

validation trigger written in rpg

When I wrote about creating a validation trigger in SQL several people asked me to give an example using RPG. Never being one to turn down a challenge this post is going to show how to do the same as my SQL example, but completely in RPG.

I am not going to go into the reasons why you might want to consider using validation triggers, as I gave my opinion in the previous post.

I started my previous example giving an example of a SQL DDL table, in this example I am going to use a DDS physical file. FILE1 has three fields:

  1. CUSTOMER - customer number
  2. TRANSID - unique transaction id
  3. AMOUNT - transaction amount in dollars

The DDS code for the file is very straight forward:

A                                      UNIQUE
A          R FILE1R
A            CUSTOMER       5A
A            TRANSID       10P 0
A            AMOUNT        10P 2
A          K CUSTOMER
A          K TRANSID

When a record is added or changed in the file I want to be sure that the total amount for the customer is not greater than the credit limit for the customer on the Customer Balance file, CUSTBAL.

I have based this program loosely on my example RPG "after" trigger program that writes the added, changed, and deleted records to a log file.

I am going to start describing the RPG program starting with the definitions.

01    ctl-opt option(*nodebugio:*srcstmt:*nounref)
                dftactgrp(*no) ;

02    dcl-pr SendMessage ;
03      *n char(80) ;
04    end-pr ;

05    dcl-f CUSTBAL keyed prefix(a_) ;
06    dcl-f FILE1 keyed prefix(b_) ;

07   /copy mylib/devsrc,trigger_ds

08    dcl-s AfterRecordPointer pointer ;

09    dcl-ds AfterSpace extname('FILE1')
                          qualified
                          based(AfterRecordPointer) ;
10    end-ds ;

11    dcl-ds Data extname('FILE1') ;
12    end-ds ;

13    dcl-s Message char(80) ;
14    dcl-s TotalAmount like(AMOUNT) ;

15  C     *entry        plist
16  C                   parm                    Parm1
17  C                   parm                    Parm2

Line 1: These are my standard control options I use in all my programs. I need to specify DFTACTGRP(*NO) as I will be calling a subprocedure.

Lines 2 – 4: This the subprocedure I will be calling. Recently I have been giving examples of what I call "open" subprocedures, this is what I call a "closed" subprocedure. This subprocedure is passed just one parameter, which is a character variable that is 80 long.

Lines 5 and 6: These are the two files I will be using in this program. As the files have some fields with the same names I use the prefix to help me differentiate which field I am using.

Line 7: TRIGGER_DS is just a copybook member that contains the standard code for the two input parameters all RPG trigger programs receive:

  1. Parm1 – The data structure that contains all the trigger data.
  2. Parm2 - The length of the Parm1 data structure.

I am not going to give those here, but refer you to my previous RPG trigger program example. By having this in a copybook I can insert it into every RPG trigger program I write.

Lines 8 - 10: I am using a pointer so I can retrieve the data from the trigger data structure, and have a data structure, based upon that pointer, to receive the data into.

Lines 11 and 12: This is the data structure I will be moving the data into before I can use it.

Line 13: Message is the variable I will be using to pass any message back to the calling program.

Line 14: TotalAmount is the variable I will using to calculate the customer's balance.

Lines 15 – 17: As I used a C-spec Parameter list in my previous example RPG trigger I am doing the same here.

And now onto the validation of the received data:

18    AfterRecordPointer = %addr(Parm1) + AfterOffset ;
19    Data = AfterSpace ;

20    if (Customer = ' ') ;
21      Message = 'U0000 Key field is blank' ;
22      SendMessage(Message) ;
23    endif ;

24    if (TransId = 0) ;
25      Message = 'U0001 Transaction id cannot be 0' ;
26      SendMessage(Message) ;
27    endif ;

28    if (Amount <= 0) ;
29      Message = 'U0002 Amount cannot be less or equal to 0' ;
30      SendMessage(Message) ;
31    endif ;

32    chain (CUSTOMER) CUSTBALR ;
33    if not(%found) ;
34      Message = 'U0004 Customer not in Customer Balance file' ;
35      SendMessage(Message) ;
36    endif ;

37    TotalAmount = AMOUNT ;
38    setll (CUSTOMER) FILE1R ;
39    dow (1 = 1) ;
40      reade (CUSTOMER) FILE1R ;
41      if (%eof) ;
42        leave ;
43      endif ;

44      TotalAmount += b_AMOUNT ;
45    enddo ;

46    if (TotalAmount > a_TOTAL) ;
47      Message = 'U0003 Customer maximum balance exceeded' ;
48      SendMessage(Message) ;
49    endif ;

50    return ;

Line 18: I retrieve the after record data from memory using the a pointer to the Parm1 data structure and the offset value from the data structure, and moving it into the AfterRecordPointer data structure.. I am only interested in the after image of the data as I want to work with what is going to be used to be added or changed in the file.

Line 19: I have found that I cannot use the data from AfterRecordPointer, therefore, I move it to another data structure, Data, that I can use the data within. As I did not use the QUALIFIED keyword in the definition of Data is means I can just use the subfields' names.

Lines 20 – 21: I start by checking if the Customer is not blank. If it is I move what I want my message to be to the variable Message, and then call the subprocedure SendMessage. As there is no SQL state code and SQL message text in a RPG trigger program I have combined the two into the Message variable.

Lines 24 – 27: Check if the Transaction id, TRANSID, is not zero.

Lines 28 – 31: The Amount, AMOUNT, has to be greater than zero.

Lines 32 – 36: I get the customer's maximum balance from the Customer Balance file, CUSTBAL. If a record is not found for this customer a message is sent to the SendMessage subprocedure.

Lines 37 – 45: Here I read the transaction file, FILE1, to calculate the total amount. I also include the amount from the trigger data structure. I would have preferred to do this using the SQL statement I did in the SQL validation trigger, but this is a totally RPG trigger.

Lines 46 – 49: If the total of transactions is greater than the customer balance maximum amount a message is sent, using the SendMessage subprocedure.

Line 50: Rather than closing the program by setting on *INLR I am just using a RETURN.

All of that code is simple. What about the subprocedure to send the message?

01  dcl-proc SendMessage ;
02      dcl-pi *n ;
03        Message char(80) ;
04      end-pi ;

05      dcl-pr SndMsgPgm extpgm('QMHSNDPM') ;
06        *n char(7) const ;   //Message id
07        *n char(20) const ;  //Message file
08        *n char(80) const ;  //Message text
09        *n int(10) const ;   //Length of message text
10        *n char(10) const ;  //Message type
11        *n char(10) const ;  //Call stack entry
12        *n int(10) const ;   //Call stack counter
13        *n char(4) ;         //Message key
14        *n char(16) ;        //Error data structure
15      end-pr ;

16      dcl-s ErrorDs char(16) ;
17      dcl-s MessageKey char(4) ;

18      SndMsgPgm('CPF9898':
19                'QCPFMSG   QSYS':
20                Message:
21                %len(%trimr(Message)):
22                '*ESCAPE':
23                '*':
24                2:
25                MessageKey:
26                ErrorDs) ;
27  end-proc ;

All the SendMessage subprocedure does is call the Send Program Message API, QMHSNDPM.

Line 1: All subprocedures start with a DCL-PROC.

Lines 2 – 4: The procedure interface states that we will receive one parameter that is a 80 long character variable that I am choosing to call Message.

Lines 5 – 15: This is the procedure definition for calling the QMHSNDPM API program. As it is a program I need the EXTPGM keyword on line 5, and as I am not using the API's name for this procedure I need to define it within the EXTPGM keyword.

Lines 16 and 17: I need these two variables as they are used by the API to return values to this, the calling subprocedure.

Lines 18 – 26: This is the call to the API with all its parameters. I have put only one per line to make it easier for you to see what each one is.

Line 18: The first parameter is the message number I am sending. IBM provides us with some generic messages that I can provide any text to I want. CPF9898 is one of those.

Line 19: This is the message file that CFP9898 is found in.

Line 20: This is the message I will be sending, which happens to be in the variable Message, that was passed to this subprocedure.

Line 21: I need to give the length of the message within Message. %TRIMR "removes" the training blanks, and %LEN determines the length of that.

Line 22: To be considered an error I need to give the message type of *ESCAPE.

Line 23: This is call stack entry. By passing "*" I am saying that the message is sent to the current call stack.

Line 24: This is the call stack counter. This number denotes which call stack I want to send the message to. As I want to return the message to the call stack of the calling program I have found that the value of '2' works best.

Lines 25 and 26: I don't care for the values returned from the API, but I do need to place the returned values into variables, that I defined on lines 16 and 17.

Line 27: Every subprocedure ends with END-PROC.

After I have compiled the program, as the program BEFTRG, then I need to add this trigger to the file. I do using the Add Physical file trigger command, ADDPFTRG:

ADDPFTRG FILE(FILE1) TRGTIME(*BEFORE) +
           TRGEVENT(*INSERT) PGM(BEFTRG)

ADDPFTRG FILE(FILE1) TRGTIME(*BEFORE) +
           TRGEVENT(*UPDATE) PGM(BEFTRG)

OK, so what about a program to try and add invalid data to FILE1. I am going to use the same "template " of a program and change a small part to illustrate my examples.

01  ctl-opt option(*nodebugio:*srcstmt:*nounref)
              dftactgrp(*no) ;

02  dcl-pr RetrieveMessage char(80) ;
03  end-pr ;

04  dcl-f FILE1 usage(*output) ;

05  dcl-s MessageCode char(5) ;
06  dcl-s MessageText char(80) ;

   //Something happens

20  *inlr = *on ;

Line 1: My standard control options for programs.

Lines 2 and 3: I am defining an external subprocedure. I do not want to say much about until I use it later.

Line 4: I am defining FILE1 as an output file.

Lines 5 and 6: More on these later.

The //Something happens is where I am going to insert the various snippets of code for my examples will be placed.

Line 20: And the programs ends with…

This example does not end well.

07  CUSTOMER = ' ' ;
08  TRANSID = 0 ;
09  AMOUNT = -1 ;

10  write FILE1R ;

As the when the write happens I receive the following error message:

Message ID . . . . . . :   RNQ1023  Severity . . . . . . . :   99
Message type . . . . . :   Inquiry

Message . . . . :   An error in the trigger program was detected before 
  WRITE on file FILE1 (C G D F).
Cause . . . . . :   RPG procedure TESTPGM in program MTLIB/TESTPGM detected
  an error in the trigger program before WRITE operation was done on file
  FILE1. The actual file is MYLIB/FILE1(FILE1). The WRITE operation was not 
  performed.

I need to add some error handling to my RPG code. Let me start with a Monitor group:

07  CUSTOMER = ' ' ;
08  TRANSID = 0 ;
09  AMOUNT = -1 ;

10  monitor ;
11    write FILE1R ;
12  on-error ;
13  endmon ;

The program does not error, and I see the error on the job log.

U0000 Key field is blank
Application error.  CPF9898 unmonitored by BEFTRG1 at statement *N,
  instruction X'0000'.
Error occurred in trigger program.
C
Error occurred in trigger program.
C
An error in the trigger program was detected before WRITE on file FILE1.

I can also use the error operation extender to the WRITE operation code.

07  CUSTOMER = ' ' ;
08  TRANSID = 0 ;
09  AMOUNT = -1 ;

10  write(e) FILE1R ;
11  if (%error) ;
12  endif ;

Preventing the error from stopping the program is good, but what about retrieving it so that the program can make use of it. This is the part of the program I spent the longest thinking about. I could use the Receive Message command, RCVMSG, in CL, or one of the APIs I can call from the RPG program. But I wanted something really simple, and fortunately there is the Joblog information SQL table function, JOBLOG_INFO. I also decided to make this an external subprocedure, in its own module, which can be bound into programs. By doing I only have to code it once and use in many programs.

01  ctl-opt option(*nodebugio:*srcstmt) nomain ;

02  dcl-pr RetrieveMessage char(80) ;
03  end-pr ;

04  dcl-proc RetrieveMessage export ;
05    dcl-pi *n char(80) ;
06    end-pi ;

07    dcl-s MessageText char(80) ;

08    exec sql  SELECT CAST(MESSAGE_TEXT AS CHAR(80) CCSID 37)
09                INTO :MessageText
10                FROM TABLE(QSYS2.JOBLOG_INFO('*')) A
11               WHERE MESSAGE_ID = 'CPF9898'
12               ORDER BY ORDINAL_POSITION DESC
13               FETCH FIRST ROW ONLY ;

14    return MessageText ;
15  end-proc ;

Line 1: Pretty standard control options. As this is a subprocedure member I have the NOMAIN to indicate to the compiler there is no main procedure.

Lines 2 and 3: The procedure interface definition. No parameters passed into the subprocedure, and one returned.

Line 4: Start of the subprocedure RetrieveMessage. The EXPORT keyword is needed as I want this subprocedure to return a value.

Line 5 and 6: The procedure interface.

Line 7: This variable is the will be used to hold the retrieved message text.

Lines 8 - 13: The SQL Select statement to retrieve the message text from the job log.

Line 8: On the IBM i I wrote this on I had to use the CAST function to convert the original value in the table column MESSAGE_TEXT to be something that is human readable. You might not have to do this.

Line 9: This the variable I am returning the message's text into.

Line 10: The asterisk ( * ) denotes that I only want to retrieve rows from this job.

Line 11: I need find the row with the message of CPF9898 as that is the message id the trigger program used.

Line 12: ORDINAL_POSITION is a unique number given to each job log entry. By sorting in descending order I will get the most recent log entry with the message id of CPF9898.

Line 13: I only need to retrieve the first, most recent, row that matches my criteria.

Line 14: I return the message text to the calling program.

Line 15: All procedures end with END-PROC.

Let me modify my test program to include the code to call this subprocedure:

07  CUSTOMER = ' ' ;
08  TRANSID = 0 ;
09  AMOUNT = -1 ;

10  monitor ;
11    write FILE1R ;
12  on-error ;
13    Message = RetrieveMessage() ;
14    MessageCode = %subst(Message:1:5) ;
15    Message = %triml(%subst(Message:6)) ;
16    dsply (MessageCode + ' : ' + %subst(Message:1:40)) ;
17  endmon ;

Line 13: When the subprocedure is called the returned value is placed in the program's variable Message.

Line 14: I want to put the first part of the message in its own field. This can be used to check which message this is, rather than have to compare the whole string.

Line 15: The rest of the string is left justified in Message.

Line 16: And now I can display the message from my job log.

DSPLY  U0000 : Key field is blank.

I think you will agree that is easier than using an API or the RCVMSG command.

Let me do the next one a bit different using the error operation extender:

07  CUSTOMER = '1' ;
08  TRANSID = 0 ;
09  AMOUNT = -1 ;

10  write(e) FILE1R ;
11  if (%error) ;
12    Message = RetrieveMessage() ;
13    MessageCode = %subst(Message:1:5) ;
14    Message = %triml(%subst(Message:6)) ;
15    dsply (MessageCode + ' - ' + %subst(Message:1:40)) ;
16  endif ;

This gives me:

DSPLY  U0001 : Transaction id cannot be 0.

I can keep going to the most complex part of the trigger program:

07  CUSTOMER = '1' ;
08  TRANSID = 1 ;
09  AMOUNT = 1.00 ;

10  write(e) FILE1R ;
11  if (%error) ;
12    Message = RetrieveMessage() ;
13    MessageCode = %subst(Message:1:5) ;
14    Message = %triml(%subst(Message:6)) ;
15    dsply (MessageCode + ' - ' + %subst(Message:1:40)) ;
16  endif ;

As this exceeds the maximum customer balance I see:

DSPLY  U0003 : Customer maximum balance exceeded.

 

Which is better RPG or SQL validation trigger? I would say it depends on what you are doing and how you want to do it, you have a go and decided which you prefer. I must admit even in RPG validation triggers I do use SQL statements.

 

You can learn more about the QMHSNDPM API from the IBM website here.

 

This article was written for IBM i 7.3, and should work for earlier releases too.

4 comments:

  1. Your comment incorrectly says DFTACTGRP(*YES) to call a subprocedure, while your code uses DFTACTGRP(*NO), which is correct.

    ReplyDelete
    Replies
    1. A big "Oops" there. Thank you for letting me know about it. I have made the correction.

      Delete
  2. Really helpful post

    ReplyDelete
  3. this is great! I'm an old RPGII programmer (IBM s/36,HP3000) and haven't used it in years. that being said I still remember it and it was more powerful than people gave it credit for. I'm glad too see its still relevant today and has kept up with the ever changing IT programming choices. I look forward to more discussion and hopefully getting to program in it again. (before I retire)

    ReplyDelete

To prevent "comment spam" all comments are moderated.
Learn about this website's comments policy here.

Some people have reported that they cannot post a comment using certain computers and browsers. If this is you feel free to use the Contact Form to send me the comment and I will post it for you, please include the title of the post so I know which one to post the comment to.