Close *ALL the files on-exit

I have previously mentioned the ON-EXIT operation code, and now it’s the turn of something I should have known about years ago.

Back in the old days, handling files was simple. All of the files you declared would be opened when the program starts and closed again when the program ends.

Now, however, the RPG Cycle is no longer used and all code is (or should be) broken out into discrete procedures. This means that we should also be manually opening and closing files as and when needed. The impact of this is that we need to ensure that any open files are closed when we exit a procedure.

The ON-EXIT opcode helps here, but it’s still a bit of a grind if you have to manually check and close every file that may still be open. It turns out, however, that you don’t need to as the CLOSE operation allows you to close all of the globally defined files at once.

Here’s an example. Run it in debug and watch those files magically close themselves when the program ends.

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

        dcl-f LSM101P rename(LSM101P: LSM101R) usropn;
        dcl-f LSM102P rename(LSM102P: LSM102R) usropn;

        dcl-proc Main;

            dcl-pi *n end-pi;

            if not %open(LSM101P);
                open LSM101P;
            endif;

            if not %open(LSM102P);
                open LSM102P;
            endif;

            // Do some processing here
            read LSM101P;
            dsply DESC101;

            return;

        on-exit;
            close *all;

        end-proc;

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.

Returning data structures from Procedures

This post stems from recent conversation on the subject of prototyped parameters. I always pass parameters as read only (using the const keyword) in order to ensure that no unexpected changes in the called procedure can impact the calling procedure.

With this approach, the only value you need to worry about is the value explicitly returned by the procedure and this enforced simplicity makes life much, much easier for whoever ends up maintaining the application.

But, my colleague wanted to know, what do you do if you want your procedure to return multiple values? It doesn’t make much sense, for example, to call a separate procedure for each line of a customer address.

The answer is to use a data structure.

As an example, here’s a main procedure that, among other things, retrieves a customer address. As should be clear, I am using a data structure (ADR) to hold the address and using the procedure getAddress to populate this data structure.

     p Main            b
     d Main            pi

     d ADR             ds                  qualified
     d  Street                       50a   inz
     d  House                         5s 0 inz
     d  Postcode                      4s 0 inz
     d  City                         50a   inz
      /free

        // Some loop reading customers
        // ...

            // Retrieve the customer address
            ADR = GetAddress(CustomerNumber);

            // Continue
            // ...


        return;

      /end-free
     p Main            e

And this is what the getAddress procedure looks like:

     p getAddress      b
     d getAddress      pi                  likeds(ADR)
     d  Customer                     10p 0

      
     d ADR             ds                  qualified
     d  Street                       50a   inz
     d  House                         5s 0 inz
     d  Postcode                      4s 0 inz
     d  City                         50a   inz
      /free


        // Populate the ADR fields
        ADR.Street = 'SomeStreet';
        ...

        // And return the data structure
        return ADR;

      /end-free
     p getHistory      e

As you can see, as long as the ADR data structure is locally defined in both procedures you can easily pass the contents of the data structure from one procedure to the other.

Footnote

I know I am using fixed format definitions here, but the box we were looking at while discussing this is only on 7.1.

Service Programs, signatures and RTVBNDSRC

I have talked about service programs in the past and, at the time, I mentioned that you need a binding source without really saying why. So, to revisit the subject, using the binding language allows you to change your service program without needing to recompile all of the programs that reference it.

It all comes down to signatures.

You can display the signature of a service program using the following command (adjust for your own library and service program, obviously):

DSPSRVPGM SRVPGM(LSCLIB/LSSUTIL) DETAIL(*SIGNATURE)

This will display a screen similar to the one below:

                      Display Service Program Information
                                                                 Display 1 of 1
 Service program  . . . . . . . . . . . . :   LSSUTIL
   Library  . . . . . . . . . . . . . . . :     LSCLIB
 Owner  . . . . . . . . . . . . . . . . . :   QPGMR
 Service program attribute  . . . . . . . :   RPGLE
 Detail . . . . . . . . . . . . . . . . . :   *SIGNATURE

                                  Signatures:

 62C9C0FAA16B653C4359413F3E9CEB81

Now take a look at any program that references the service program:

DSPPGM PGM(LSCLIB/LS0190R) DETAIL(*SRVPGM)

Will something like this:

                          Display Program Information
                                                                 Display 1 of 1
 Program  . . . . . . . :   LS0190R       Library  . . . . . . . :   LSCLIB
 Owner  . . . . . . . . :   QPGMR
 Program attribute  . . :   RPGLE
 Detail . . . . . . . . :   *SRVPGM


 Type options, press Enter.
   5=Display

      Service
 Opt  Program     Library     Activation  Signature
      LSSUTIL     *LIBL       *IMMED      62C9C0FAA16B653C4359413F3E9CEB81
      QRNXIE      QSYS        *IMMED      D8D9D5E7C9C540404040404040404040
      QRNXIO      QSYS        *IMMED      D8D9D5E7C9D640404040404040404040
      QLEAWI      QSYS        *IMMED      44F70FABA08585397BDF0CF195F82EC1

Note that the signqture of the service program needs to match the signature the referencing program expects, and if they don’t you will waste a day dealing with signature violation errors.

So if I want to add a procedure to a service program (which will change the service program’s signature) without having to identify and recompile every program that refers to it, I need to make use of the binder language.

I generally create the binder language source manually but, if you don’t have this, you can use the RTVBNDSRC command. To retrieve the source for service program LSSUTIL in library LSCLIB you would do this:

RTVBNDSRC SRVPGM(LSCLIB/LSSUTIL) SRCFILE(LSCLIB/QSRVSRC) MBROPT(*ADD)

Then go and look at your binder source and you will a listing of all your exported procedures in a format that looks see something like this:

STRPGMEXP PGMLVL(*CURRENT) SIGNATURE(X'62C9C0FAA16B653C4359413F3E9CEB81')
/********************************************************************/
/*   *MODULE      LSSUTIL      LSCLIB      08/02/18  10:49:27      */
/********************************************************************/
   EXPORT SYMBOL("GETCORRECTION")
   EXPORT SYMBOL("GETERRTEXT")
ENDPGMEXP

Just to tidy things up a bit, move the comment lines to the top and get rid of the SIGNATURE keyword (it’s the PGMLVL that you really need) so that the source now looks like this:

/********************************************************************/
/*   *MODULE      LSSUTIL      LSCLIB      08/02/18  10:49:27      */
/********************************************************************/
STRPGMEXP PGMLVL(*CURRENT)
  EXPORT SYMBOL("GETCORRECTION")
  EXPORT SYMBOL("GETERRTEXT")
ENDPGMEXP

Now you want to tell it that this is the old version and the new current version of the service program contains your shiny new procedure. This is how:

/********************************************************************/
/*   *MODULE      LSSUTIL      LSCLIB      08/02/18  10:49:27      */
/********************************************************************/
STRPGMEXP PGMLVL(*CURRENT)
  EXPORT SYMBOL("GETCORRECTION")
  EXPORT SYMBOL("GETERRTEXT")
  EXPORT SYMBOL("GETSHINY")
ENDPGMEXP
/********************************************************************/
STRPGMEXP PGMLVL(*PRV)
  EXPORT SYMBOL("GETCORRECTION")
  EXPORT SYMBOL("GETERRTEXT")
ENDPGMEXP
/********************************************************************/

Then create your service program using:

CRTSRVPGM SRVPGM(LSCLIB/LSSUTIL) MODULE(LSCLIB/LSSUTIL) SRCFILE(LSCLIB/QSRVSRC) SRCMBR(LSSUTIL)

And display the service program signatures:

DSPSRVPGM SRVPGM(LSCLIB/LSSUTIL) DETAIL(*SIGNATURE)

And here’s what you should have:

                      Display Service Program Information
                                                                 Display 1 of 1
 Service program  . . . . . . . . . . . . :   LSSUTIL
   Library  . . . . . . . . . . . . . . . :     LSCLIB
 Owner  . . . . . . . . . . . . . . . . . :   QPGMR
 Service program attribute  . . . . . . . :   RPGLE
 Detail . . . . . . . . . . . . . . . . . :   *SIGNATURE

                                  Signatures:

 2C9C0F7DED8A1897F656D6C9CBB17DDD
 62C9C0FAA16B653C4359413F3E9CEB81

The service program now has two signatures. The new one is at the top of the list and the previous one is below it. What’s more, I can specify PGMLVL(*PRV) as many times as I need to.

When a program uses the service program, it will look down the list until it finds a signature that matches to identify the list of modules it can use. And this means that you can change your service program as much and as many times as you like without needing to worry about any of the programs that uses it.

A final note

You only need to change your binding source when you change the list of exported procedures (generally by adding a new procedure). Changing an existing procedure won’t impact your signatures.

A final final note

When you do add a new procedure, always add it to the bottom.

Guaranteed exit code with ON-EXIT

Here’s handy:

The ON-EXIT operation code begins the ON-EXIT section. The ON-EXIT section contains code that runs every time that the procedure ends, whether it ends normally or abnormally. The ON-EXIT section runs under the following conditions:

  • The procedure reaches the end of the main part of the procedure.
  • The procedure reaches a RETURN operation.
  • The procedure ends with an unhandled exception.
  • The procedure is canceled, due to the end of the job or subsystem, or due to an exception message being sent to a procedure higher in the call stack.

By placing your clean-up code, such as deleting temporary files and deallocating heap storage, in the ON-EXIT section, you ensure that it is always run, even if your procedure ends with an unhandled exception, or if it is canceled.

As someone who likes to exit procedures as quickly as possible, this opcode has a great deal of potential when it comes to simplifying the structure of my code, and for reducing the number of things I have to think about. This is always a good thing.

ON-EXIT was introduced in version 7.2 and is well worth investigating.

Converting to CHAR with leading zeros

This is as much a reminder to myself as anything else because the %CHAR built in function has the unfortunate behaviour of stripping leading zeroes when converting a number to a character value. Sometimes I need to keep those leading zeroes, for example when handling elderly date fields.

Fortunately, there’s %EDITC.

This function returns a character result representing the numeric value edited according to the edit code.

The edit codes allow you to do pull all sorts of neat little tricks but, for my purposes, the most useful one is the X edit code which (obscurely) ensures a hexadecimal F sign for positive values. Handily, this means that leading blanks are converted into leading zeroes when converting from numeric to character.

Here’s an example:

      **Free

        // Converting to character with leading zeros
        ctl-opt dftactgrp(*no) actgrp(*new) main(Main);

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

            dcl-s numYear packed(4) inz(2016);
            dcl-s numMonth packed(2) inz(9);
            dcl-s numDay packed(2) inz(1);
            dcl-s charDate char(8) inz;
            dcl-c edit 'X';

            // This converts the numeric fields ino string '20160901'
            charDate = %editc(numYear: edit) +
                       %editc(numMonth: edit) +
                       %editc(numDay: edit);

            // And then I can convert the string into a date and display it
            dsply %date(charDate: *ISO);

            return;

        end-proc;

And if you need a reminder of what the other edit codes are, or what they do, you’re welcome

Using %TLOOKUP: An example

Firstly, a disclaimer. The CTDATA definition keyword indicates that an array or table should be loaded at compile time. This is a terrible idea for a whole host of reasons, not least of which is that the data is locked away in the program and that you need a programmer to change the data. It is far, far better to store any and all data outside of the program — physical files, SQL tables and data areas all exist for this purpose.

However, there are times when compile time tables cannot be avoided. These are times that I find myself looking at a really old program which is, inevitably, broken.

%TLOOKUP is weird. The function searches a table for an argument and returns either *ON or *OFF depending on whether or not a match was found. All pretty straightforward so far, if a little pointless. The oddities begin when you include the third, alt-table parameter.

Here’s an example:

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

        //---------------------------------------------------------------------
        // Tables
        //---------------------------------------------------------------------
        dcl-s TABA char(3) dim(4) ctdata perrcd(1);
        dcl-s TABB char(2) dim(4) alt(TABA);

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

            dcl-s check ind;


            check = %tlookup('129': TABA: TABB);
            dsply TABB;

            return;

        end-proc;
      * ---------------------------------------------------------------------- *
**  TABA - TABB
112G
113LU
129NL
150B

If I run this program, the tlookup searches table TABA for argument ‘129’. The third element of TABA matches this exactly, so the value of check is set to *ON.

And the value of TABB is set to ‘NL’, which is what we’re looking for.

But TABB is not a real field and cannot, for example, be used as an SQL host variable. For this, you would need to define another standalone field and populate it with TABB.

%TLOOKUP is an odd little function, and one that is very rarely needed. This post goes a very little way towards rectifying the fact that no-one else on the web wanted to provide an example of its use.

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.

Fun with varying length fields

So here’s a really simple little program that puts the first five characters of a ten character field into a five character field. So why doesn’t it work?

      **Free

        // Fun with variable length fields

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

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

            dcl-s LongString varchar(10) inz('123');
            dcl-s ShortString char(5) inz;
                                                             
            shortstring = %subst(longstring: 1: 5);                 
            dsply shortstring;                                      
                                                             
            return;                                                 
        end-proc;

If you compile and run this program, it will return an RNX0100 error: “Length or start position is out of range for the string operation”.

The reason, of course, is that LongString is a varying length field. The ten character length in the field definition defines the maximum size but, because the field is initialised with a three character value, the length of the field when the program starts is only three characters. And using the %subst bif to find the first five characters of a three character field will, of course, return an error.

The above program is so simple that the problem probably leapt out at you but when you are dealing with a bunch of externally defined fields, gotchas like this are less immediately apparent. So take this as a reminder to be wary of documentation and to familiarise yourself with the DSPFFD command.