Querying data queues with QMHQRDQD

Someone recently asked me if I knew of an API that could be used to retrieve the number of entries in a data queue without pulling the entries from the data queue.

I didn’t, but a quick search turned up QMHQRDQD.:

The Retrieve Data Queue Description (QMHQRDQD) API retrieves the description and attributes of a data queue. Examples include the number of entries currently on the data queue, the text description of the data queue, whether the queue includes sender ID information, and whether the data queue is keyed.

The attributes of a distributed data management (DDM) data queue can be retrieved with this API.

So here’s an example of the QMHQRDQD api in action.

       // --------------------------------------------------------------------
       // Program     : DSPDTAQSIZ
       // Description : Retrieve data queue size
       // --------------------------------------------------------------------
        ctl-opt main(Main) dftactgrp(*no) actgrp(*new) bnddir('QC2LE');

       // --------------------------------------------------------------------
       // Prototype declarations
       // --------------------------------------------------------------------
        dcl-pr Main extpgm('DSPDTAQSIZ');
            DTAQ Char(10) const;
            DTAQLIB char(10) const;
        end-pr;


        dcl-pr GetDtaqD extpgm('QMHQRDQD');
            RtnVariable char(2000) Options(*VarSize);
            RtnVarLen int(10) const;
            Format char(8) const;
            QDTAQ char(20) const;
        end-pr;

       // --------------------------------------------------------------------
       // Main Procedure
       // --------------------------------------------------------------------
        dcl-proc Main;

            dcl-pi Main;
                DTAQ Char(10) const;
                DTAQLIB char(10) const;
            end-pi;

           // ----------------------------------------------------------------
           // Data structures
           // ----------------------------------------------------------------
            dcl-ds F1 qualified inz;
                BytesRtn int(10);
                BytesAvail int(10) inz(%size(F1));
                Max_Len int(10);
                Key_Len int(10);
                Q_Seq char(1);
                Sender_ID char(1);
                Force_Write char(1);
                TextDesc char(50);
                DtaQ_Type char(1);
                Auto_Rcl char(1);
                Reserved1 char(1);
                Cur_Msgs int(10);
                CurEntry_Cap int(10);
                DtaQName char(10);
                DtaQLib char(10);
                Max_Entry int(10);
                Init_Entry int(10);
            end-ds;

           // ----------------------------------------------------------------
           // Standalone fields
           // ----------------------------------------------------------------
            dcl-s QualDtaQ char(20);
            dcl-s OutText char(30);
        
           // ----------------------------------------------------------------
           // Procedure mainline
           // ----------------------------------------------------------------
            
            // Qualified Data queue name is Data Queue Name + Library
            QualDtaQ = DTAQ + DTAQLIB;

            // Retrieve the data queue description
            GetDtaQD(F1: %size(F1): 'RDQD0100' : QualDtaQ );

            OutText = 'Current Messages: ' + %trim(%char(F1.Cur_Msgs));
            dsply OutText;

        end-proc;   
       // --------------------------------------------------------------------

Using QSYRUSRI to check whether a user profile exists

Sometimes you have a table that captures user profiles. Obviously, if the user profile is deleted, there is nothing to delete these table entries. And sometimes, auditors can see this as a problem.

There are several ways of handling this, one of which is to make use of the QSYRUSRI API.

The Retrieve User Information (QSYRUSRI) API provides information about a user profile. This API provides information similar to the Retrieve User Profile (RTVUSRPRF) command or the Display User Profile (DSPUSRPRF) command when *BASIC is specified for the type parameter.

The following sample program makes use of the fact that, if a user profile has been deleted, the API returns blanks in all for the user profile name, previous sign-on date and time and all other text fields.

       // --------------------------------------------------------------------
       // Program     : DSPUSRI
       // Description : Display User Profile information
       //             : Experiments with the QSYRUSRI API
       // --------------------------------------------------------------------
        ctl-opt main(Main) dftactgrp(*no) actgrp(*new) bnddir('QC2LE');

       // --------------------------------------------------------------------
       // Prototype declarations
       // --------------------------------------------------------------------
        dcl-pr Main extpgm('DSPUSRI');
            UserID char(10) const;
        end-pr;

        dcl-pr RtvUsrInf extpgm('QSYRUSRI');
            RtnVariable char(2000) options(*varsize);
            RtnVarLen int(10) const;
            APIFMT char(8) const;
            UserID char(10) const;
            Error char(1) const;
        end-pr;

       // --------------------------------------------------------------------
       // Main Procedure
       // --------------------------------------------------------------------
        dcl-proc Main;

            dcl-pi Main;
                UserID char(10) const;
            end-pi;


           // ----------------------------------------------------------------
           // Data structures
           // ----------------------------------------------------------------
            dcl-ds F1 qualified inz;
                BytesRtn int(10);
                BytesAvail int(10) inz(%size(F1));
                UserProfile char(10) inz;
                LastSignon char(13) inz;
                res1 char(1) inz;
                BadSignons int(10) inz;
                Status char(10) inz;
                PwdChange char(8) inz;
                NoPassword char(1) inz;
                res2 char(1) inz;
                PasswordExpInt int(10) inz;
                PasswordExpires char(8) inz;
                DaysToPassExp int(10) inz;
                PasswordExpired char(1) inz;
                DspSignOn char(10) inz;
                LocalPassword char(1) inz;
            end-ds;

           // ----------------------------------------------------------------
           // Standalone fields
           // ----------------------------------------------------------------
            dcl-s OutText char(50);

           // ----------------------------------------------------------------
           // Procedure mainline
           // ----------------------------------------------------------------

            // Retrieve the user profile
            RtvUsrInf(F1: %size(F1): 'USRI0100': UserID: ' ');

            if F1.UserProfile = *blank and F1.LastSignon = *blank;
                OutText = %trim(UserID) + ' has gone';
            else;
                OutText = %trim(UserID) + ' is still here';
            endif;

            dsply OutText;

        end-proc;
       // --------------------------------------------------------------------

You can call this program with the user ID as a parameter and it will display a message indicating whether or not the user profile exists. Extending it to do something useful is a pretty straightforward process.

Writing messages to the joblog with QMHSNDPM

I have previously mentioned using Qp0zLprintf (Print Formatted Job Log Data) to write messages to the joblog. Here’s an alternative approach using QMHSNDPM (Send Program Message). In this case, I am executing an SQL statement and checking the SQL state afterwards. If the state is not 00000 (completed normally), I use the LogError procedure to write the SQL code to the job log.

Obviously, it would be better to put the LogError procedure into a service program both for reusability and so that the QMHSNDPM prototype definition can be tucked out of the way.

This is the program:

        // Simple program to demonstrate sending SQL error states to the joblog
        // Written by Paul Pritchard

        ctl-opt main(Main) dftactgrp(*no) actgrp(*new);

        // --------------------------------------------------------------------
        // External Procedures
        // --------------------------------------------------------------------
        dcl-pr WriteJoblog extpgm('QMHSNDPM');
            MessageID char(7) const;
            MessageFile char(20) const;
            Message char(32767) const options(*varsize);
            MessageLength int(10) const;
            MessageType char(10) const;
            MessageStack char(10) const;
            MessageStackC int(10) const;
            MessageKey char(4);
            MessageError char(32767) options(*varsize);
        end-pr;


        // --------------------------------------------------------------------
        // Program main procedure
        // --------------------------------------------------------------------
        dcl-proc Main;
            dcl-pi *n end-pi;

            exec sql
                update employees
                set empvalid = 0
                where int(empnumber) < 0;

            if SQLSTATE <> '00000';
                LogError(SQLSTATE);
            endif;

            return;

        end-proc;

        // --------------------------------------------------------------------
        // Simple SQL Error Logging
        // --------------------------------------------------------------------
        dcl-proc LogError;

            dcl-pi LogError;
                ErrorCode char(5) const;
            end-pi;

            // The API message fields
            dcl-s MessageID char(7) inz('CPF9897');
            dcl-s MessageFile char(20) inz('QCPFMSG   *LIBL');
            dcl-s Message varchar(32767) inz;
            dcl-s MessageLength int(10) inz;
            dcl-s MessageType char(10) inz('*DIAG');
            dcl-s MessageStack varchar(32767) inz('*');
            dcl-s MessageStackC int(10) inz;
            dcl-s MessageKey char(4) inz;

            dcl-ds MessageError qualified;
                Input int(10) inz;
                Output int(10) inz;
            end-ds;


            Message = 'SQL Error encountered: ' + ErrorCode;
            MessageLength = %len(%trim(Message));
            WriteJoblog(MessageID: MessageFile: Message:
                        MessageLength: MessageType:
                        MessageStack: MessageStackC: MessageKey: MessageError);

            return;

        end-proc;
        // --------------------------------------------------------------------

And this is what it looks like in the joblog:

CPF9897    Diagnostic             40   17-11-12  18:31:37.319725  LSE001R
                                    From module . . . . . . . . :   SQLJOBLOG
                                    From procedure  . . . . . . :   LOGERROR
                                    Statement . . . . . . . . . :   137
                                    To module . . . . . . . . . :   SQLJOBLOG
                                    To procedure  . . . . . . . :   LOGERROR
                                    Statement . . . . . . . . . :   137
                                    Message . . . . :   SQL Error encountered: 22023
                                    Cause . . . . . :   No additional online help information is available.

Writing messages to the job log with RPG

So here’s a fun situation. An interface that works perfectly in the test environment but which randomly falls over in production. Better still, it’s part of the overnight batch processing so it tends to fall over at around 9:30 in the evening.

I need to be able to determine what the program is doing when it fails, specifically, in this case, what the data being processed looks like, but I don’t want to stay up half the night in order to do so.

Fortunately, there’s Qp0zLprintf (Print Formatted Job Log Data).

The Qp0zLprintf() function prints user data specified by format-string as an information message type to the job log.

If a second parameter, argument-list, is provided, Qp0zLprintf() converts each entry in the argument-list and writes the entry to the job log according to the corresponding format specification in format-string. If there are more entries in argument-list than format specifications in format-string, the extra argument-list entries are evaluated and then ignored. If there are less entries in argument-list than format specifications in format-string, the job log output for those entries is
undefined, and the Qp0zLprintf() function may return an error.

What this means, is that I can write out to the joblog at various points within the program so that I can pinpoint exactly what the program was doing and what data was being processed when it failed.

So here’s a simplified sample of what I mean

      **Free

        // Simple program to demonstrate writing to the job log
        // Written by Paul Pritchard

        ctl-opt dftactgrp(*no) actgrp(*new)
            main(Main);

        dcl-pr WriteJobLog int(10) extproc('Qp0zLprintf');
            *n pointer value options(*string);
        end-pr;

        dcl-proc Main;
            dcl-pi *n end-pi;

            dcl-s Message varchar(512);
            dcl-c CRLF x'0d25';

            // The easy way to put a message in the joblog
            // Is to construct the text, then print it
            Message = 'Hello World' + CRLF;
            WriteJobLog(Message);

            // And exit
            return;
        end-proc;

That CRLF is the hex codes for Carriage Return and Line Feed. You need to ensure that it’s tacked onto the end of each message to ensure the messages all remain readably laid out.

And this is what the output looks like

*NONE      Information                  17-10-11  14:36:17.490255  QP0ZCPA      QSYS        *STMT    QP0ZCPA     QSYS        *STMT
                                     From module . . . . . . . . :   QP0ZUDBG
                                     From procedure  . . . . . . :   Qp0zVLprintf
                                     Statement . . . . . . . . . :   64
                                     To module . . . . . . . . . :   QP0ZUDBG
                                     To procedure  . . . . . . . :   Qp0zVLprintf
                                     Statement . . . . . . . . . :   64
                                     Message . . . . :   Hello World

Service Programs and Call Stack APIs

I’m a big fan of service programs. From a maintainability point of view, encapsulated procedures are great. And exported procedures, which mean you only need to develop any piece of functionality once, are even better.

However, I now find myself in the position of having to start creating a set of these from scratch (nothing to copy/paste) and, since they can be a bit fiddly, now seems like a good time to document the steps.

In the example that follows, I create a service program with a single procedure, RtvProgram, which returns the name of the program that called the service program. It sounds a bit recursive, I know, but bear with me. Whenever coding a display file (or a report, for that matter) I like to put the program name somewhere on the screen (top left, unless someone tells me otherwise). This means that when someone has a problem, we can very quickly identify what program they are talking about.

Obviously, hard-coding the program name in the display file would be easy. But code gets copied and pasted and, sooner or later, all hard coded values end up being wrong. I have also seen cases of one display file being used by two or more programs, so it is much better to put the program name in a field and retrieve it dynamically. That way, you are always getting the right program.

So on to the service program.

First, you need a copy member to contain the procedure prototype. You could, of course, code the prototype in each program that uses the service program, but that way madness lies.

In my case, I have created the copy member in QRPGLESRC and called it LSS001RP. It looks like this:

 * Retrieve Program Name
d RtvProgram      pr            10a   

And then you need to write the service program:

 * ---------------------------------------------------------------------- *
 * Program     : LSS001R                                                  *
 * Description : Program information service programs                     *
 * ---------------------------------------------------------------------- *
h nomain

 * ---------------------------------------------------------------------- *
 * Exportable Prototypes                                                  *
 * ---------------------------------------------------------------------- *
 /copy LSCLIB/qrpglesrc,lss001rp

 * ---------------------------------------------------------------------- *
 * API Prototypes                                                         *
 * ---------------------------------------------------------------------- *
d RtvCallStack    pr                  extpgm('QWVRCSTK')
d                             2000a
d                               10i 0
d                                8a
d                               56a
d                                8a
d                               15a

 * ---------------------------------------------------------------------- *
 * RtvProgram: Retrieve the program name                                  *
 * ---------------------------------------------------------------------- *
p RtvProgram      b                   export
d RtvProgram      pi            10a

d Var             ds          2000    qualified
d  BytAvl                       10i 0
d  BytRtn                       10i 0
d  Entries                      10i 0
d  Offset                       10i 0
d  Count                        10i 0

d JobID           ds                  qualified
d  QName                        26a   inz('*')
d  IntID                        16a
d  Res3                          2a   inz(*loval)
d  ThreadInd                    10i 0 inz(1)
d  Thread                        8a   inz(*loval)

d Entry           ds                  qualified
d  Length                       10i 0
d  Program                      10a   overlay(Entry: 25)
d  Library                      10a   overlay(Entry: 35)

d VarLength       s             10i 0 inz(%size(Var))
d RcvFormat       s              8a   inz('CSTK0100')
d JobIdFmt        s              8a   inz('JIDF0100')
d ApiError        s             15a
d i               s             10i 0
 /free

     RtvCallStack(Var: VarLength: RcvFormat: JobID: JobIdFmt : ApiError);
     for i = 1 to 2;
         Entry = %subst(Var: Var.Offset + 1);
         Var.Offset += Entry.Length;
     endfor;

     return Entry.Program;

 /end-free
p RtvProgram      e
 * ---------------------------------------------------------------------- * 

I’m not going to go into too much detail here. The service program LSS001R contains one procedure, RtvProgram which uses the QWVRCSTK API to retrieve the current call stack then it reads back two entries: The first entry is the service program and the second entry is the calling program. And this is the program name that it returns.

You now need to create the RPG Module. Note the terminology here — you are not creating a Bound RPG Program (it’s the difference between options 15 and 14 in PDM).

I also need the binding source. In this case, the member is called LSS001S and I have put it in the QSRVSRC source file. It looks like this:

STRPGMEXP  PGMLVL(*CURRENT)
    EXPORT SYMBOL('RTVPROGRAM')
ENDPGMEXP

Note that the capitalisation is actually important here.

And now I’m ready to create the service program:

CRTSRVPGM SRVPGM(LSCLIB/LSS001R) MODULE(LSCLIB/LSS001R) SRCFILE(LSCLIB/QSRVSRC) SRCMBR(LSS001S)

Since I’m doing this from scratch, I need to create a binder directory:

CRTBNDDIR BNDDIR(LSCLIB/LSBNDDIR) TEXT('General purpose binding directory')

And add the service program to it:

ADDBNDDIRE BNDDIR(LSCLIB/LSBNDDIR) OBJ((LSS001R))

And we’re ready to go. All I have to do now is make a couple of amendments to the main program to take advantage of the service program:

The control spec needs this line:

h bnddir('LSBNDDIR')                                                       

Obviously, I need to copy the prototype definition somewhere in the definition specification:

 /copy LSCLIB/qrpglesrc,lss001rp                                       

And when the program starts, I need to identify the name of the program:

 /free

     // Identify the current program
     program = RtvProgram();
                                                                           

And that’s it.