Greg Helton's RPG Cheat Sheet

RPG Program Working With JRuby to Respond to Ajax Request

UNDER CONSTRUCTION

This Javascript and JRuby code will work with most databases but, in this case, the stored procedure language is RPG. The data retrieved by the RPG program is sent to the web page as JSON. Right now the rendered HTML is pretty ugly because I haven't gotten around to utilizing the CSS.

The button defined in the HTML controls the submission of the AJAX request for JSON (line 20) which is a GET request processed by the JRuby code. The JRuby calls the RPG program via JDBC.

CAVEATS: The bootstrap is referenced in the web page but not yet utilized. The HTML will get a rewrite. Also the SQL wrapper code is omitted for brevity. Should you need it, you can find the JDBC config yaml file in this earlier post.

Functors in RPG

I read somewhere that functors (which are somehow related to monads and lambdas) are functions that contain static storage and I thought "RPG has that! Static fields in subprocedures!". I composed a little experiment to see for what purpose such a beast might be used. I developed a functor subprocedure which contains a static local variable, a date field. Other subprocedures call the functor to manipulate the date.

Essentially the functor I created simply protects the date field. Nothing too fantastic. Note that the program that uses the functor has NO GLOBAL FIELDS IN ITS D SPECS! RPG programs with thousands of globally defined fields are difficult to maintain so the functor has a big plus in that regard.

The three RPG sources below are (1.) the FUNCTOR module containing the ILE subprocedures, (2.) FUNCTOR_H the copybook that contains the prototypes and (3.) FUNCTOR_T the program that uses the ILE subprocedures.

Create the modules and program with the following commands (changing CURLIB as necessary):

chgcurlib ...

crtrpgmod functor dbgview(*source) 

crtrpgmod functor_t dbgview(*source) 

crtpgm functor_t module(functor_t functor) actgrp(home) 

RPG Built-In Function %NULLIND

I wanted to investigate the %NULLIND built-in function and keyword. I learned that subprocedures must be defined with the *NULLIND keyword on parameters that are nullable.
h dftactgrp(*no) actgrp('HOME')                                 
h option(*srcstmt:*nodebugio) debug(*yes)                       
h ALWNULL(*USRCTL)  
 *
 * CRAZYTABLE contains ADATE, a nullable date field
 * 
d               e ds                  extname(CRAZYTABLE)
 * 
d sendNullDate    pr                                            
d  enrollDate                     D   options(*NULLIND)         
 * 
d getNullDate     pr                                            
d  aDate                          D   options(*NULLIND)         
 *----------------------------------------------------------    
 /free 
               %nullInd(ADATE) = *on;                           
               sendNullDate(ADATE);                             
               *inlr = *on;                                     
 /end-free
 *----------------------------------------------------------    
p sendNullDate    b
d                 pi
d aDate                           D   options(*NULLIND)     
 /free 
               getNullDate(aDate);                          
 /end-free 
p                 e
 *----------------------------------------------------------
p getNullDate     b
d                 pi 
d aDate                           D   options(*NULLIND)     
 /free 
               if %nullind(aDate);
                 dsply 'NULL';      // DSPLY  NULL
               endIf; 
 /end-free 
p                 e
It is interesting that the ADATE field retains the date value even after NULLIND has been set to *ON for the field. Wow, the field can be both NULL and contain a value! Don't get bit by that one!
 /free 
               ADATE = d'2014-10-24';
               %nullInd(ADATE) = *on;  // here ADATE is both NULL and 2014-10-24       
 /end-free 
I wanted to see if a subprocedure can return a field that is NULL and contains a value. It can be done!
h dftactgrp(*no) actgrp('HOME')                                 
h option(*srcstmt:*nodebugio) debug(*yes)                       
h ALWNULL(*USRCTL) 
 *  
d               e ds                  extname(CRAZYTABLE)
 *  
d getDate         pr                  LIKE(ADATE)               
d  enrollDate                   10A   CONST                     
 *----------------------------------------------------------    
 /free 
               aDate = getDate('2014-10-24'); 
               dsply aDate;          // DSPLY  2014-10-24
               if %nullind(aDate); 
                 dsply 'NULL';       // DSPLY  NULL
               endIf; 
               *inlr = *on; 
 /end-free
 *----------------------------------------------------------    
p getDate         b 
d                 pi                  LIKE(ADATE)               
d cDate                         10A   CONST                     
 /free 
               aDate = %date(cDate);                            
               %nullind(aDate) = *on;                           
               return aDate;
 /end-free 
p                 e
I tried several ways to define a NULL capable field in my code but I always had to rely on defining an external (file based) data structure and using LIKE to define the field I wanted to be NULLable. iProDeveloper forums has a good discussion of defining NULL capable fields here. That issue was with defining fields that work with %NULLIND so I thought of using pointer based NULLs instead.

Looking at database NULLs brings up the question of working with pointer NULLs. If my getDate() subprocedure is given an invalid date in the character field it accepts, I have it return *NULL.
h dftactgrp(*no) actgrp('HOME')                             
h option(*srcstmt:*nodebugio)                               
h debug(*yes)                                               
h ALWNULL(*USRCTL)                                          
h datfmt(*ISO)                                              
 *                                                          
d nullabledate    s               d   datfmt(*ISO)          
d                                     based(datepointer)    
d datepointer     s               *   inz                   
 *                                                          
d getDate         pr                  LIKE(datepointer)     
d  enrollDate                   10A   CONST                 
 *----------------------------------------------------------
 /free                                                      
               datepointer = %alloc(%size(nullabledate));   
                                                            
               datepointer = getDate('2014-xx-yy');         
               if datepointer <> *NULL;                     
                 dsply nullabledate;                        
               endIf;                                       
                                                            
               datepointer = getDate('2014-10-24');         
               if datepointer <> *NULL;                     
                 dsply nullabledate; 
               endIf;                                       
                                                            
               datepointer = getDate('2014-12-31');         
               if datepointer <> *NULL;                     
                 dsply nullabledate;                        
               endIf;                                       
                                                            
               datepointer = getDate('2014-44-44');         
               if datepointer <> *NULL;                     
                 dsply nullabledate;                        
               endIf;                                       
               *inlr = *on;                                 
 /end-free                                                  
 *----------------------------------------------------------
p getDate         b                                         
d                 pi                  LIKE(datepointer)     
d cDate                         10A   CONST                 
d nonnulldate     s               D   STATIC                
 /free                                                      
               monitor ;                                    
                 nonnulldate = %date(cDate);                
               on-error;                                    
                 return *NULL;                              
               endmon;
               return %addr(nonnulldate); 
 /end-free                                
p                 e 
I used the STATIC keyword on the definition of nndatepointer so that the memory can be addressed outside of the subprocedure.

Language Choice

Dr Frank Soltis, "the father of the AS/400", designed the single level store and the technology-independent machine interfaces of the System/38 and the AS/400 (i.e., iSeries). Dr Soltis wrote a book ""Fortress Rochester: the Inside Story of the IBM iSeries"" in which he tells of his experiences designing and implementing the technologies of his machine. There is an interesting fact Dr Soltis states beginning at the bottom of page 110 in his book:

The programming language that had been used since the original S/38 development, called PL/MP ...

Selection of the C++ programming language was reasonably straightforward....

OO held the promise of greater productivity for our developers. During the SLIC development, our programmers who used OO saw a gain of four times the productivity over traditional methods. OO delivered on its promise.


9B Integer Program Parameter in RPG

A PHP program is going to pass a SQL row identity value (integer) to my RPG program. Simply passing 2409 as the first argument will not work. In the RPG world, 2409 is not an integer.

d MYPGM           pi                         
d chgid                          9B 0        
d chgfax                        20a   varying
d chguser                       20a   varying
To test the program from the command line, the number must be formatted correctly. A 9B integer is actually 8 hex digits. A decimal value of 2409 is 969 in hex.
CALL PGM(mylib/mypgm) PARM(x'00000969' '8005551212' 'ghelton')

JRuby Executes AS400 RPG Program Stored Procedure

Simple JRuby program to run an AS400 program via JDBC using jt400.jar.



A second example in which a JRuby/Sinatra app displays the results in a web page is here

Date Function for CLLE Program

Here we have a RPG subprocedure that exposes RPG's Built-In date functions to CLLE programs. I tested with a CL program (below) but my coworker has another test technique and I think it works very well.

Java to Test AS400 Stored Procedures

I've previously posted code in which RPG programs are used as stored procedure programs. These programs were modeled after those in the "Stored Procedures, Triggers and User Defined Functions ..." redbook (see 6.4.2 Coding External Stored Procedures Returning Array Result Sets). Writing the Java to call a stored procedure is sometimes a little tedious so many years ago I wrote a Java program that will write a Java program that will execute an AS400 stored procedure. (Please note that the code in the redbook is out of date. It omits the "for return to client" portion of the SQL result sets statement.)

See the code in github.

AS400 Stored Procedures' Parameters

The System i Navigator will display the information about your AS400's stored procedures but I more often use some version of this SQL statement, modifying the WHERE clause as needed.
select substr(A.ROUTINE_SCHEMA,1,10) AS "LIB",     
       substr(A.ROUTINE_NAME,1,15) AS "SPROC",     
       B.ORDINAL_POSITION AS "POS",                
       B.PARAMETER_MODE AS "MODE",                 
       substr(B.PARAMETER_NAME,1,15) AS "PARMNAME",
       substr(B.DATA_TYPE,1,15) AS "TYPE",         
       B.CHARACTER_MAXIMUM_LENGTH AS "CHARLEN",    
       B.NUMERIC_PRECISION AS "PRECISION",         
       B.NUMERIC_SCALE AS "SCALE"                  
from qsys2/sysprocs A
join qsys2/sysparms B
on A.SPECIFIC_SCHEMA = B.SPECIFIC_SCHEMA           
and A.SPECIFIC_NAME = B.SPECIFIC_NAME
WHERE A.ROUTINE_NAME LIKE 'SP\_P%' ESCAPE '\'

And, if there is an underscore in the query name and you want to use a "LIKE" search condition, you need to escape the underscore which is SQL's single character wildcard. This LIKE clause will search for names like 'SP_P...'.
WHERE A.ROUTINE_NAME like 'SP\_P%' ESCAPE '\'                         

RPG's %NULLIND Built-In Function

The ALWNULL directive coded on the H spec and the %nullind BIF allow RPG to deal with NULLs.
h option(*srcstmt:*nodebugio)                                               
h datfmt(*iso) alwnull(*usrctl)                                             
 ***************************************************************************
 *                                                                          
 *   1. Run the following SQL statements to create a table and add one row.
 *                                                                          
 *      create table somelib/datetbl ( 
 *      id int generated always as identity primary key,                       
 *      datefld date)                                                          
 *                                                                          
 *      insert into datetbl (DATEFLD) values(NULL)                             
 *                                                                          
 *   2. Run this program.  
 *   3. View the result. 
 *   4. Then, uncomment the commented line, compile and run again. 
 *   5. View the result and see the difference. 
 ***************************************************************************
fdatetbl   if a e           k disk    rename(DATETBL:RDATETBL)              
d mykey           s              9B 0 inz(1)                                
d mydate          s               D                                         
 /free                                                                      
          chain mykey datetbl;                                              
          mydate = d'2014-08-08';                                           
          // %nullind(DATEFLD) = *off;  // uncomment to fix                 
          DATEFLD = mydate;
          write rdatetbl;  
          *inlr = *on;     
 /end-free 

The %NULLIND BIF corrected the problem where the value moved to the field was not recorded in the inserted record.
....+....1....+....2....+.
           ID   DATEFLD   
            1   -         
            2   -         
            3   2014-08-08
********  End of data  ***

Get AS400 OS Version

Scott Klement provided this program that calls the API to get the OS version.
CALL PGM(GETREL) PARM(&RELEASE)
PGM PARM(&RELEASE)
                                                     
    DCL VAR(&RELEASE)  TYPE(*CHAR) LEN(6)            
    DCL VAR(&RCVVAR)   TYPE(*CHAR) LEN(32)           
    DCL VAR(&RCVLEN)   TYPE(*CHAR) LEN(4)            
    DCL VAR(&PRODINFO) TYPE(*CHAR) LEN(27)           
    DCL VAR(&ERRCODE)  TYPE(*CHAR) LEN(8)            
                                                     
    CHGVAR VAR(%BIN(&RCVLEN  1 4)) VALUE(32)         
    CHGVAR VAR(%BIN(&ERRCODE 1 4)) VALUE(0)          
                                                     
    CHGVAR VAR(%SST(&PRODINFO  1  7)) VALUE('*OPSYS')
    CHGVAR VAR(%SST(&PRODINFO  8  6)) VALUE('*CUR'  )
    CHGVAR VAR(%SST(&PRODINFO 14  4)) VALUE('0000'  )
    CHGVAR VAR(%SST(&PRODINFO 18 10)) VALUE('*CODE' )
                                                     
    CALL PGM(QSZRTVPR) PARM(&RCVVAR    +             
                            &RCVLEN    +             
                            'PRDR0100' +             
                            &PRODINFO  +             
                            &ERRCODE   )             
                                                     
    CHGVAR VAR(&RELEASE) VALUE(%SST(&RCVVAR 20 6))   

    ENDPGM

RPG Subprocedure for Comma Delimited Numbers

The nextNumber subprocedure (shown in the program below) will accept a comma delimited list of unsigned numbers and, for each call to the subprocedure, it will return the next number in the list until there are no more numbers and then it will return -1.

The subprocedure has a *NOPASS parameter so it will accept 0 or 1 arguments. When an argument is passed to it, the subprocedure will initialize the list of numbers and return the first number. On subsequent calls, no argument should be passed and the next number in the list will be returned until there are no more numbers and -1 is returned.

The static keyword is used on variables in the subprocedure to retain values between calls to the subprocedure.

The program is meant only to test the subprocedure.
     h dftactgrp(*no) actgrp(*caller)                                    
     h option(*nodebugio:*srcstmt) debug(*yes)                           
                                                                         
     d testnextn       pr                  extpgm('TESTNEXTN')           
                                                                         
     d testnextn       pi                                                
                                                                         
     d nextNumber      pr            10i 0 extproc('nextNumber')         
     d                            10000a   CONST VARYING Options(*Nopass)
                                                                         
     d NBRS            s             99a   dim(2) perrcd(1) CTDATA       
     d rcdid           s             10i 0                               
     d N               s              3p 0                               
                                                                         
     d psds           sds                                                
     d  proc             *proc                                           
     d  status           *status                                         
     d  user                 358    367                                  
                                                                         
      /free                                                              
              // first test - show result when uninitialized             
              rcdid = nextNumber();
              dsply rcdid;

              // next test - show proper use of nextNumber for 2 different lists
              for N = 1 to 2;                                                   
                 // nextNumber will initialize with list from CTDATA arrays     
                 rcdid = nextNumber(NBRS(N));
                 dsply rcdid;                
                 dou rcdid < 0;              
                    rcdid = nextNumber();    
                    dsply rcdid;             
                 enddo;                       
              endfor;                                                           
                                                                                
              *inlr = *on;                                                      
      /end-free                                                                 
     p nextNumber      b                   EXPORT                               
     d                 pi            10I 0                                      
     d pnbrs                      10000a   CONST VARYING Options(*Nopass)       
     d start           s              5I 0 inz(0)                               
     d index           s              5I 0 static inz(0)                        
     d listLength      s              5i 0 static                               
     d nbrList         ds                  static                               
     d nbrs                           1a   DIM(10000)                           
      /free 
                 if %parms() = 1;
                    index = 0;
                    nbrList = pnbrs; 
                    listLength = %len(%trim(nbrList));                                         
                 endif;                                                        
                                                                               
                 // get to start of next number                                
                 dou nbrs(index) >= '0' and nbrs(index) <= '9';                
                    if index = listLength;                                      
                       return -1;                                              
                    endif;                                                     
                    index += 1;                                                
                 enddo;                                                        
   
                 start = index; 
   
                 dow index <= listLength;                                       
                    select;
                       when not (nbrs(index) >= '0' and nbrs(index) <= '9');   
                          return %int(%SUBST(nbrList:start:(index - start)));
                       other; 
                          index += 1; 
                    endsl; 
                 enddo; 
                 return -1; 
      /end-free 
     p                 e                                 
**CTDATA NBRS                                            
14,15,18,72,220,256,274,292,310,328,346,364,382,2393,2394
1061,1065,1072,1079,1519,2408,

DB2/400 Date Format

Use F13 to change interactive SQL attributes in the green-screen.
create table ghelton/datetest3 
(id int generated always as identity,
effdate date, primary key(id))         
Table DATETEST3 in GHELTON created but was not journaled.

insert into ghelton/datetest3 (effdate) values(date('2014-07-14'))
1 rows inserted in DATETEST3 in GHELTON.

insert into ghelton/datetest3 (effdate) values(date('2014-07-17'))
1 rows inserted in DATETEST3 in GHELTON.                          

insert into ghelton/datetest3 (effdate) values(date('2099-12-31'))
1 rows inserted in DATETEST3 in GHELTON. 

select * from ghelton/datetest3                                   
where cast(effdate as timestamp) > cast(curdate() as timestamp)   
SELECT statement run complete. 
The result from the SELECT statement, when shown with the default date format option, includes a date that appears to be invalid for some reason.
....+....1....+....2....       
           ID   EFFDATE        
            2   07/17/14 
            3   ++++++++       
********  End of data  ********
After changing the date format option to *ISO, the date now appears valid
....+....1....+....2....+.     
           ID   EFFDATE        
            2   2014-07-17     
            3   2099-12-31     
********  End of data  ********

Unit Testing RPG with JUnit

The slides from my presentation given to my local AS400 user group on October 17, 2006.


AS400's Representations of Datetime Values

Representations of Datetime Values

Although datetime values can be used in certain arithmetic and string operations and are compatible with certain strings, they are neither strings nor numbers.

Values whose data types are DATE, TIME, or TIMESTAMP are represented in an internal form that is transparent to the user of SQL.

DeveloperWorks article showing date/time manipulation with SQL.

Other articles on IBM i DB2.

Database Normalization

1st Normal Form
None of the domains of that relation should have elements which are themselves sets

In other words, each row of a table should represent one and only one entity so, eliminate duplicative columns from the same table.

2nd Normal Form
No non-key attribute is dependent on any proper subset of any candidate key of the table

In other words, the entity (the fields in a row) represented should be dependent on the whole key, not a subset of the key so, remove columns that are not dependent on the key

3rd Normal Form
[Every] non-key [attribute] must provide a fact about the key, the whole key, and nothing but the key

In other words, the entity should not be dependent on non-key fields

Summary
"The key, the whole key, and nothing but the key, so help me Codd."

Requiring existence of "the key" ensures that the table is in 1NF; requiring that non-key attributes be dependent on "the whole key" ensures 2NF; further requiring that non-key attributes be dependent on "nothing but the key" ensures 3NF.

SDLC

SDLC - System Development Lifecycle
1. Initiation - begins when a sponsor identifies a need
2. System Concept Development - defines the scope or boundary
3. Planning - develop a management plan
4. Requirements Analysis - develops user requirements based on user needs
5. Design - transform detailed requirements into detailed design document
6. Development - convert a design into a completed system
7. Integration and Test - conducted by QA to demonstrate system conforms to requirements
8. Implementation - the move to a production environment
9. Operations and Maintenance - production environment operations
10. Disposition - is end of system activities

Built-In Functions

V7R1 Built-In Functions

 

 
 
 

%ABS (Numeric Expression) Absolute Value of Expression x = %ABS(y);
%ADDR (Variable) Get Address of Variable ptr = %ADDR(CustDS : *DATA)
%ALLOC (Bytes To Allocate) Allocate Storage dataptr = %ALLOC(2000);
%BITAND (Expression : Expression [ : Expression [ : Expression … ] ]) Bitwise AND Operation var1 = %BITAND(char1 : char2)
%BITNOT(Expression) Invert Bits var = %BITNOT(Expression)
%BITOR (Expression : Expression [ : Expression [ : Expression … ] ]) Bitwise OR Operation char1 = x'FF';
char2 = x'AA';
var1 = %BITOR(char1 : char2)
%BITXOR (Expression : Expression ) Bitwise Exclusive-OR Operation char1 = x'FF';
char2 = x'AA';
var1 = %BITXOR(char1 : char2)
%CHAR (Expression : Format) Convert to Character Data num1 = 7.2;
var1 = %CHAR(num1);
%CHECK (Search Arg : String [ : Start]) Check Characters. Returns the position in first char in String that is not in Search Arg. num1 = %CHECK('xXyYzZ' : SomeString);
%CHECKR (Search Arg : String [ : Start]) returns the position in last char in String that is not in Search Arg. num1 = %CHECKR('xXyYzZ' : SomeString);
%DATE (Expression [ : Format]) may be used with no arguments to return current date
%DAYS (Number) returns a duration that may be added to a Date or TimeStamp value
%DEC (Numeric or Character Expression : [Precision : [ Decimal Places]]) converts the value of the first parameter to Packed Decimal format
%DECH (Numeric or Character Expression : [Precision : [ Decimal Places]]) Convert to Packed Decimal Format with HalfAdjust
%DECPOS(Numeric Expression) Get Number of Decimal Positions
%DIFF (op1:op2:unit)
unit may be *MSECONDS|*SECONDS|*MINUTES|*HOURS|*DAYS|*MONTHS|*YEARS
Difference Between Two Date, Time, or Timestamp values
%DIV(Numerator : Denominator) Return Integer Portion of Quotient
%EDITC(Numeric : Editcode {: *ASTFILL | *CURSYM | currency-symbol}) Edit Value Using an Editcode
%EDITFLT(val)Convert to Float External Representation
%EDITW(val) Edit Value Using an Editword
%ELEM(array) Get Number of Elements
%EOF() Return End or Beginning of File Condition
%EQUAL() Return Exact Match Condition
%ERROR() Return Error Condition
%FIELDS() Fields to update
%FLOAT() Convert to Floating Format
%FOUND() Return Found Condition
%GRAPH(CharValue) Convert to Graphic Value graph = %GRAPH(CharVar);
%HANDLER(ProcedureName : communicationArea) Names a Procedure to Handle an Event xml-sax(e)
%HOURS (Number) Number of Hours. Converts a number to a duration newDate = %DATE() + %HOURS(2)
%INT (Numeric or Character Expression) Convert to Integer Format int1 = %INT(charVar);
%KDS (DataStructureName [ : Number of Keys]) Search Arguments in Data Structure CHAIN %KDS(dataStruct);
%LEN(Expression) Get or Set Length num1 = %LEN(%TRIM(char1)) + %LEN(%TRIM(char2));
%LOOKUPxx(array)Look Up an Array Element
%MINUTES() Number of Minutes
%MONTHS() Get Number of Months
%MSECONDS() Get Number of Microseconds
%NULLIND() Query or Set Null Indicator
%OCCUR() Set/Get Occurrence of a Data Structure
%OPEN() Return File Open Condition
%PADDR() Get Procedure Address
%PARMS() Return Number of Parameters
%PARMNUM() Return Parameter Number
%REALLOC() Reallocate Storage
%REM() Return Integer Remainder
%REPLACE() Replace Character String
%SCAN() ScanforCharacters
%SCANRPL() Scan and Replace Characters
%SECONDS() Number of Seconds
%SHTDN() ShutDown
%SIZE() Get Size in Bytes
%SQRT() Square Root of Expression
%STATUS() Return File or Program Status
%STR() Get or Store Null-Terminated String
%SUBARR() Set/Get Portion of an Array
%SUBDT() Extract a Portion of a Date, Time or Timestamp
%SUBST() Get Substring
%THIS() Return Class Instance for Native Method
%TIME() ConverttoTime
%TIMESTAMP() Convert to Timestamp
%TLOOKUPxx() Look Up a Table Element
%TRIM() Trim Characters at Edges
%TRIML() Trim Leading Characters
%TRIMR() Trim Trailing Characters
%UCS2() Convert to UCS-2 Value
%UNS() Convert to Unsigned Format
%XFOOT() Sum Array Expression Elements
%XLATE() Translate
%XML(xmlDocument {:options})
%YEARS()Number of Years

Elegant RPG

I saw this in some of Scott Klement's code.
    if getOrder(ordno: ordDS) or reportError('Order Not Found');
       showOrder(ordDS);
    endif;


Multiple Row Insert

create table acctnbrs (acct# decimal(9,0))
Table ACCTNBRS created.

insert into acctnbrs values (1), (2), (3)
3 rows inserted in ACCTNBRS


Clear SQL Syntax in Summary Statement

I ran a DSPPGMREF to an outfile and now want to query the data. I've been running this statement to tell me the table names and the number of times each table is referenced by a program
select whsnam, count(*) as CT from dmdrefs group by whsnam

Source CT
File Name
DMHISTAA 25
DMHISTAB 4
DMHISTAC 9
DMHISTAD 4
DMHISTAE 4
DMHISTAF 4
DMHISTAG 4
DMHISTAH 14
DMHISTAJ 1
DMHISTPL 55
DMHISTQFM 3
DMHISTWRK 16
DMHISTWRKA 16


This tells me how many times I'm dealing with each table but I want to summarize how many tables and references there are overall.

To find out how many tables in all the previous statement returns, I can do this
with T1 as (select whsnam, count(*) AS CT
from dmdrefs group by whsnam)
select count(*), sum(CT) from T1

COUNT ( * ) SUM ( CT )
13 159


Though for the Day

A RDBMS does not necessarily a relational database make.

RPG Arrays

Many things in RPG are nothing like any other language. Arrays, for instance.
h option(*srcstmt:*nodebugio) 

d simplearry pr

d simplearry pi

d EmplTable ds Qualified
d EmplData dim(2) ASCEND
d name 20A overlay(EmplData:*next)
d address 20A overlay(EmplData:*next)
d city 20A overlay(EmplData:*next)
d state 2A overlay(EmplData:*next)
d zip 5S 0 overlay(EmplData:*next)
d 1 20 inz('Artie''s Art Supplies')
d 21 40 inz('123 Main Street')
d 41 60 inz('Seattle')
d 61 62 inz('WA')
d 63 67 inz('75075')
d 68 87 inz('Flora''s Flowers')
d 88 107 inz('456 Beach Blvd')
d 108 127 inz('Portland')
d 128 129 inz('ME')
d 130 134 inz('75022')

/free
sorta EmplTable.Address;
dsply EmplTable.Name(
%lookupgt( '123 Main Street' : EmplTable.Address ));
*inlr = *on;
/end-free


Eliminate Numbered Indicators

here's how:
D Indicators      s               *   inz(%addr(*IN))          
D WorkstnInds     DS                  Based(Indicators)        
D Exit                            N   Overlay(WorkstnInds : 3) 
D DispSubfl                       N   Overlay(WorkstnInds : 80)
D SubfileClr                      N   Overlay(WorkstnInds : 81)


Implementing Stack in RPG

Pascal Plus Data Structures is the textbook I got the most value from in school. A program's data structures are probably the biggest factor in the complexity of the program's code. In recent years, RPG's data structure syntax has been expanded to include reuse of definitions and nested data structures. Such features allow the code to be more concise while being more expressive.

Having recently coded some RPG-ILE subprocedures to implement a linked list (see previous post), I decided to implement a stack as well. The stack is a FILO (first in last out) data structure manipulated by Push and Pop functions.

The first field declared in the program code, stackable, is the definition of field that is stored in the stack. Changing this one field definition should be the only change necessary to change the element stored in the stack and referenced by the Push and Pop subprocedures.

The program code shows an example of the use of stacks. Five names are pushed on to stack1 then three names are popped from stack1 and saved on stack2. A new name is then pushed on to stack1 and the saved names restored from stack2 back to stack1. PrintStack() then is executed to perform a non-destructive print of the values in stack1.

h option(*srcstmt:*nodebugio)                                        
 
d stackable       s              6A                                  
  
d Print           pr                  extproc('Stack.Print') 
d  stack                              likeds(stack1) 
 
d Pop             pr                  extproc('Stack.Pop') like(stackable) 
d  field                              likeds(stack1) 
 
d Push            pr                  extproc('Stack.Push') 
d  stack                              likeds(stack1)
d  field                              like(stackable) CONST          
                                                                     
d Empty           pr              N   extproc('Stack.Empty')               
d  stack                              likeds(stack1) 
                                                                     
d stack1          ds                  qualified INZ 
d  nodes                              like(stackable) dim(20)        
d  cursor                        3P 0                                
  
d stack2          ds                  qualified INZ                  
d  nodes                              like(stackable) dim(20)       
d  cursor                        3P 0                              
  
d amy             s                   like(stackable) inz('Amy   ')
d betty           s                   like(stackable) inz('Betty ')
d carrie          s                   like(stackable) inz('Carrie')
d denise          s                   like(stackable) inz('Denise')
d ertha           s                   like(stackable) inz('Ertha ')
d fannie          s                   like(stackable) inz('Fannie')
d x               s              3P 0                              
    
 /free                                                             
           Stack.Push(stack1 : amy);                                     
           Stack.Push(stack1 : betty);                                   
           Stack.Push(stack1 : carrie);                                  
           Stack.Push(stack1 : denise);                                  
           Stack.Push(stack1 : ertha);                                   
   
           for x = 1 to 3;                                         
              Stack.Push(stack2 : Stack.Pop(stack1));                          
           endFor;                                                 
 
           Stack.Push(stack1 : fannie);                                  
 
           dow not Stack.Empty(stack2);                                 
              Stack.Push(stack1 : Stack.Pop(stack2));                    
           endDo;                                            
 
           Stack.Print(stack1);
 
           *inlr = *on;             
 /end-free  
 *********************************************************** 
 *                                                           
 *********************************************************** 
p Push            b                   EXPORT                 
d                 pi                                         
d stack                               likeds(stack1)         
d item                                like(stackable) CONST  
 /free        
            stack.cursor += 1;                               
            stack.nodes( stack.cursor ) = item;              
 /end-free        
p                 e                                          
 *********************************************************** 
 *      
 *********************************************************** 
p Pop             b                                          
d                 pi                  like(stackable)       
d stack                               likeds(stack1)         
 /free 
            stack.cursor -= 1;                               
            return stack.nodes(stack.cursor + 1);            
 /end-free 
p                 e   
 *********************************************************** 
 * 
 *********************************************************** 
p Print           b                   EXPORT                 
d                 pi 
d stack                               likeds(stack1)         
d name            s                   like(stackable)        
  
d stack3          ds                  qualified INZ          
d  nodes                              like(stackable) dim(20)
d  cursor                        3P 0 
 
 /free 
        dow (not Stack.Empty(stack));                              
           name = Stack.Pop(stack);                                
           Stack.Push(stack3:name);                                
           dsply name;                                       
        endDo;                                              
 
        dow (not Stack.Empty(stack3));                            
           Stack.Push(stack : Stack.Pop(stack3));                         
        endDo;                                              
 /end-free                                                  
p                 e                                         
 ***********************************************************
 *  
 ***********************************************************
p Empty           b                   EXPORT                
d                 pi              N                         
d stack                               likeds(stack1)        
 
 /free 
            return stack.cursor = 0;                        
 /end-free            
p                 e 

Most RPG programmers have adopted RPG-IV, ILE subprocedures and free form coding so many may find nothing new here. But, for those not completely familiar with these new facets of RPG, let's review the densest line of code in the program and work out from there. I consider the two calls in the one line of code to be a busy line of code. This line

Stack.Push(stack2 : Stack.Pop(stack1));

calls the Pop subprocedure which returns a value that is passed to the Push subprocedure. In other words, the value popped from stack1 is pushed onto stack2.

The fact that a subprocedure (Pop) is called from the argument list of another subprocedure (Push) did impact the coding of Pop. The second parameter of Push had to be declared as CONST to eliminate the compiler error. This is for similar reasons that the parameter has to be declared CONST when it accepts a literal argument. In both cases it is because there is no variable to accept any changes to the argument made within the subprocedure.

p Push            b                   EXPORT                 
d                 pi                                         
d stack                               likeds(stack1)         
d item                                like(stackable) CONST

There is a small but very significant difference between the coding of the parameters (and return value) of subprocedures Push and Pop. The style used to declare parameters and return values makes it easy to overlook the differences between Push and Pop. Pop returns a value and this is coded on the D spec 'pi' (subprocedure interface) line shown below. Push's 'pi' line (above) does not have a type defined on it so it has no return value. Both subprocedures name have a parameter named stack. Push has a second parameter named item. Pop has only the one parameter.
p Pop             b                                          
d                 pi                  like(stackable)       
d stack                               likeds(stack1) 

Now that we've seen the mechanics of the return value, let's put it to work. By having the Push() subprocedure return the stack passed to it as shown here:
 /free
            Push(Push(Push(Push(stack1:amy):betty):carrie):denise);
            *inlr = *on;
 /end-free
p Push            b                   EXPORT                 
d                 pi                  likeds(stack1)   
d stack                               likeds(stack1)         
d item                                like(stackable) CONST  
 /free        
            stack.cursor += 1;                               
            stack.nodes( stack.cursor ) = item;  
            return stack;            
 /end-free        
p                 e

But, the compiler complains that the stack passed to it must be declared CONST and, because doing so would contradict our desire to update the stack, a compromise is reached in which CONST is used but the parameter is now a pointer to a stack.

RPG Linked List

A developer told me about a problem he was having and I told him I thought a linked list would help in creating a good solution. Below is the example I created for him. There are many perfectly acceptable ways of creating a linked list but, I had a particular model in mind. My goal was to create a linked list that would both retain its original sequence and present the altered sequence. I also wanted the implementation to be clean and simple.
The purpose of the linked list is to be able to resequence data and that is exactly what this assignment required. I created the moveAbove() function that accepts two arguments, the node to be moved and the node to be superceded in the list.
The linked list data structure is a list of girls' names. The list was initialized with the girls' names in alphabetical order - Amy, Betty, Carrie, Denise, Ertha and Fannie. Then moveAbove(5:2) is run. The results are shown in blue above the program code. The DSPLY statements show the name, the original seq# and the nextPointer (not really a pointer). Note the seq# is their original sequence and the data in the array is still in that order. All that moveAbove() does is reassign next values and the print function prints in the linked list sequence. I was taught that the program is more efficient since data is not moved. The function is extensible as the data element is referenced by a pointer.
DSPLY  Amy    001 005
DSPLY  Ertha  005 002
DSPLY  Betty  002 003
DSPLY  Carrie 003 004
DSPLY  Denise 004 006
DSPLY  Fannie 006 007
h option(*srcstmt:*nodebugio)                          
                                                       
d printList       pr                                   
                                                       
d moveAbove       pr                                   
d                                3P 0 VALUE            
d                                3P 0 VALUE            
                                                       
d topOfList       s              3P 0 inz(1)           
                                                       
d list            ds                  qualified dim(20)
d seq                            3P 0 inz              
d data                            *   inz(*NULL)       
d next                           3P 0 inz              
                                                       
d dsplyField      s             14A                    
d amy             s              6A   inz('Amy   ')    
d betty           s              6A   inz('Betty ')    
d carrie          s              6A   inz('Carrie')    
d denise          s              6A   inz('Denise')    
d ertha           s              6A   inz('Ertha ')    
d fannie          s              6A   inz('Fannie')    
                                                      
 /free                                              list(1).seq  = 1;             
           list(1).next = 2;             
           list(1).data = %addr(amy);    
           list(2).seq  = 2;             
           list(2).next = 3;             
           list(2).data = %addr(betty);  
           list(3).seq  = 3;             
           list(3).next = 4;             
           list(3).data = %addr(carrie); 
           list(4).seq  = 4;             
           list(4).next = 5;             
           list(4).data = %addr(denise); 
           list(5).seq  = 5;             
           list(5).next = 6;             
           list(5).data = %addr(ertha);  
           list(6).seq  = 6;             
           list(6).next = 7;             
           list(6).data = %addr(fannie); 
                                         
           moveAbove(5:2);               
           printList();                  
           *inlr = *on;                  
 /end-free                              
p printList       b                                  
d                 pi                                 
d x               s              3P 0                
d ptrName         s               *                  
d name            s              6A   based(ptrName) 
 /free                                               
        x = topOfList;                               
        dow list(x).data <> *NULL;                   
           ptrName = list(x).data;                   
           dsplyField = name                         
                      + %editw(list(x).seq:'0   ')   
                      + %editw(list(x).next:'0   ') ;
           dsply dsplyField;                         
           x = list(x).next;                         
        endDo;                                       
 /end-free                                           
p                 e                                  
 *                                                   
p moveAbove       b                                  
d                 pi                                 
d number1                        3P 0 VALUE          
d number2                        3P 0 VALUE          
d x               s              3P 0                
d ptrName         s               *                 
d name            s              8A   based(ptrName)                                     
 /free                                                                                   
                                                          // move 5 above 2              
        for x = 1 to %elem(list) ;                                                       
           if list(x).next <> 0;                                                         
                                                          // make 4 point to 6           
              if list(x).next = list(number1).seq;        // 4.next = 5                  
                 list(x).next = list(list(x).next).next;  // 4.next = 6.seq              
                 leave;                                                                  
              endIf;                                                                     
           endIf;                                                                        
        endFor;                                                                          
                                                                                         
                                                                                         
        for x = 1 to %elem(list) ;                                                       
                                                          // make 1 point to 5 and 5 to 2
           if list(x).next = list(number2).seq;           // 1.next = 2.seq              
              list(x).next = list(number1).seq;           // 1.next = 5.seq              
              list(number1).next = list(number2).seq;     // 5.next = 2.seq              
              leave;                                                                     
           endIf;                                                                        
        endFor;                                                                          
                                                                                         
 /end-free                                                                              
p                 e


Retain Leading Zeroes When Concatenating Numbers

In %EDITW, the leading zero operates as the stop to the replacement of leading zeroes with blanks.  This means that for a 5 digit number, the edit word is seven characters, three zeroes, three blanks and one decimal. In other words, there is going to be one more character in the edit word than you would think if you simply count the digits, commas and decimal point in the numeric value.

This example was created for a client application that required several numbers to be concatenated into a single string.
h option(*srcstmt:*nodebugio)                   
d dollar1         s              5P 2 inz(9.99) 
d dollar2         s              5P 2 inz(11.11)
d mychar          s             15A             
 /free                                          
    mychar = %trim(%editw(dollar1:'0   .  ')) + 
             %trim(%editw(dollar2:'0   .  ')) ; 
    dsply mychar;                               
    *inlr = *on;                                
 /end-free 

Stored Proc Wrapper for ILE Procedure

A simple, straightforward extension and reuse of AS/400 code is to wrap an ILE service program procedure with an SQL wrapper to create a user defined function. This function is reusable by web clients and other SQL clients. Of course, the original ILE procedure can be used in complete disregard of the wrapper. Note that the ILE procedure must return a value for this to work.
h option(*srcstmt:*nodebugio)                                          
h nomain                                                               
d getDateOfMortgage... 
d                 pr              D   extproc('getDateOfMortgage') DATFMT(*ISO)
d                                9S 0 CONST                            
                                                                       
p getDateOfMortgage...
p b EXPORT d pi D datfmt(*ISO) d myacct 9S 0 CONST /free return %Date('2009-07-04':*ISO); /end-free p e
Create the service program that contains this ILE procedure with the commands crtrpgmod mylib/mortgagepr and crtsrvpgm mylib/mortgagesv module(mortgagepr) export(*all). In this example we will export(*all) to export (make visible to external objects) all procedures from the module.

And now, the SQL wrapper
create function MYLIB/getDateOfMortgage(myacct NUMERIC(9,0))  
      returns DATE                                          
      language RPGLE                                        
      specific MYLIB/getDateOfMortgage  
      CALLED ON NULL INPUT 
      external name 'MYLIB/MORTGAGESV(getDateOfMortgage)' 
      parameter style general with nulls 
Here is a code fragment that uses the SQL function which executes the RPG ILE procedure.
d mydate          s               D   datfmt(*ISO)
 /free
    exec sql 
       declare C1 cursor for          
          select getDateOfMortgage(:myacct)   
             from SYSIBM/SYSDUMMY1; 

    exec sql                          
       open C1;
    exec sql
       fetch C1 into :mydate;
   
    dsply mydate; 
    *inlr = *on;
 /end-free
This code fragment shows reuse of an ILE component in a OPM program. Using ILE in this manner is easier since the caller is not required to code a prototype. Additionally, web side developers may prefer having functions to mediate between legacy data and the web client code.

New DB2/400 Syntax

RCDFMT Keyword


Create Table MYTABLE (
Account_Number for Column
ACCT# Numeric(9,0) Not null with default,
. . .
PRIMARY KEY (Account_Number) )
RCDFMT RMYTABLE; // NEW KEYWORD

ASCII, CHR, MONTHS_BETWEEN, VARCHAR_FORMAT Functions


Select ASCII(' ') From SysIBM/SysDummy1 // returns a value of 32 (ASCII code for space). In EBCDIC space is 64.

Select CHR(48) From SysIBM/SysDummy1 // returns the character for ASCII code 48: '0'

Select * From (Values(CHR(65))) ASCII (CHRCODE) // returns an 'A'

MONTHS_BETWEEN('2007-11-22', '2007-03-17') // results in 8.1613 months

RID() // similar to RRN() but RID() returns BIGINT whereas RRN returns DEC(15,0)

Timestamp_Format('08/17/2008 10:30', 'MM/DD/YYYY HH24:MI') // TO_DATE performs the same function

VARCHAR_FORMAT(Ship_Stamp, 'MM/DD/YYYY HH24:MI') //

Row Change Expression


Query for "changed" rows on a table that has a row change timestamp. First, define the table:

Create Table AppData/DataTable
(RowId Integer As Identity Primary Key,
Data1 VarChar(1000) Not Null,
AddStamp Timestamp Not Null Default Current_Timestamp,
ChgStamp Timestamp Not Null
FOR EACH ROW ON UPDATE AS ROW CHANGE TIMESTAMP)

Select * From AppData/DataTable DT
Where Row Change Timestamp For DT>=Current_Timestamp-21 Days

The benefit of the row change expression is that it allows developers to write queries (or querying tools) that can
query for modified rows without having to know the "row change timestamp's" column name.
Change Tokens in Row Change Expressions

Select CusNum, Row Change Token For Cust As "Change Token"
From QIWS/QCUSTCDT Cust

The token is a BIGINT data type that returns a relative "update value" that is supposed to somehow indicate a sequence
of when a row was changed relative to other rows. This token feature is supposed to be used for tables with or without
a row change stamp column. When a row change timestamp is present, the token is derived from the row change timestamp
column.

Program Type Parameter on CREATE PROCEDURE


PROGRAM TYPE is used to specify whether a program or service program is created. Theoretically a service program should
give slightly better performance when the stored procedure is repetitively called.

Create Procedure xxxxx.Sample1
(In @Number1 Dec(15,5),
In @Number2 Dec(15,5),
Out @Number3 Dec(15,5))
Language SQL
Program Type Sub /* Main=Program Sub=Service Program */
Begin
Set @Number3=@Number1+@Number2;
End;

RUNSQLSTM can run CL Commands


RUNSQLSTM now has the ability to run CL commands

CL: DSPJOBLOG OUTPUT(*PRINT);

Comment on Constraint



COMMENT ON CONSTRAINT CK_PAY_TYPE IS 'Allowed values are
''S'' for Salary and ''H'' for Hourly'

Skip Locked Records When Deleting



Delete From ItemHistory
Where EffDate<='2007-01-01'
With CS
Skip Locked Data;

Implicitly Hidden


The IMPLICITLY HIDDEN column will not appear in a generic SELECT * query.

CREATE TABLE DataLib/BASEWAGE
(EMPLOYEE INT NOT NULL,
EFFDATE DATE NOT NULL DEFAULT CURRENT_DATE,
PAYRATE DEC(9,4) NOT NULL IMPLICITLY HIDDEN,
CONSTRAINT PK_BASEWAGE PRIMARY KEY (EMPLOYEE,EFFDATE))

NAMED COLUMN JOIN


A new shorthand join syntax called a "named column join" is implemented with the USING keyword.
For example, the following:

Select *
From Order
Join OrderLines On OrderLines.Company=Order.Company
And OrderLines.OrderID=Order.OrderID

Can be shortened to:

Select *
From Order
Join OrderLines Using (Company,OrderID)

EXCEPT Keyword


This query will only return rows from the OpenOrders table that don't exist in the Shipments table.

Select OrderID, CustName
From OpenOrders
Except
Select OrderID, CustName
From Shipments

INTERSECT Keyword


This query will combine row sets only under the condition that the same row exists in both row sets.

Select OrderID, CustName
From OpenOrders
Intersect
Select OrderID, CustName
From Shipments

Support For Qualified DataStructures

DdsScreenData     DS                  Qualified
D Item
D DueDate

C/Exec SQL
C+ Select *
C+ From MfgOrders
C+ Where MfgItem=:dsScreenData.Item
C+ And DueDate>=:dsScreenData.DueDate
C/End-Exec

And, even better ...

D dsShipInfo DS
D ShipNo 10I 0
D ShipQty 9P 3
D BOQty 9P 3
D InvAmt 17P 4

C/Exec-SQL
C+ Update OrderLine
C+ Set (ShipNo, ShipQty, BOQty, InvAmt)=:dsShipInfo
C+ Where Current Of OrderLines
C/End-Exec

Subprocedure ResultSets


Create Procedure xxxxx/OrderReport
(parmStartDate In Date,
parmEndDate In Date)
Result Sets 1
External Name 'xxxxx/ORDERRPT(getData)'
Language RPGLE
Parameter Style General
Reads SQL Data



// RPG procedure interface for service program ORDERRPT

h NOMAIN
h option(*nodebugio:*srcstmt)
d getData pr extproc('getData')
d D
d D

p getData b EXPORT
d pi
d start D
d end D

d occurs s 5P 0
d Sales ds occurs(100)
d item 9P 0
d totalSales 7P 2
/free
%occur(Sales) = 1;
item = 567;
totalSales = 912.87;
%occur(Sales) = 2;
item = 678;
totalSales = 123.55;
%occur(Sales) = 3;
item = 789;
totalSales = 213.72;
occurs = 3;

exec sql
Set Result Sets Array :Sales For :occurs Rows ;
/end-free
p e

Rollback to Savepoint


This application logic books airline reservations on a preferred date, then books hotel reservations. If the hotel is
unavailable, it rolls back the airline reservations and then repeats the process for another date. Up to 3 dates are
tried.

got_reservations =0;
EXEC SQL SAVEPOINT START_OVER UNIQUE ON ROLLBACK RETAIN CURSORS;
if (SQLCODE != 0) return;

for (i=0; i<3 & got_reservations == 0; ++i) {
Book_Air(dates(i), ok);
if (ok) {
Book_Hotel(dates(i), ok);
if (ok) got_reservations = 1;
else
{
EXEC SQL ROLLBACK TO SAVEPOINT START_OVER;
if (SQLCODE != 0) return;
}
}
}

EXEC SQL RELEASE SAVEPOINT START_OVER;

Inserting Multiple Rows Using the Blocked INSERT Statement
To add ten employees to the CORPDATA.EMPLOYEE table:

INSERT INTO CORPDATA.EMPLOYEE (EMPNO,FIRSTNME,MIDINIT,LASTNAME,WORKDEPT)
10 ROWS VALUES(:DSTRUCT:ISTRUCT)

DSTRUCT is a host structure array with five elements that is declared in the program. The five elements correspond to
EMPNO, FIRSTNME, MIDINIT, LASTNAME, and WORKDEPT. DSTRUCT has a dimension of at least ten. ISTRUCT is a host structure
array that is declared in the program. ISTRUCT has a dimension of at least ten small integer fields for the indicators.


IBM's Best Redbook

Stored Procedures, Triggers and User Defined Functions on DB2 Universal Database for iSeries

Although the book is very good, I see three problems in this example from page 67. First, it seems absurd to put stored procedure creation code in an RPG program. Since this is SQL code, put it in a source member in QSQLSRC.

The second problem is that the RPG program being called has the library name hard-coded on the call. We long ago learned that on the System i we don't hard-code library names. The library list in the JOBD will control the library list just as in a standard RPG application. Don't reinvent the wheel, go with what you know and eliminate hard-coded library names.

The third problem is that this code creates an object, the stored procedure. Creating objects on the production box is normally the function of your change control system. When this code is executed, you may find that the program runs without object creation authority and you end up having to handle (and explain) a production bug.

c/EXEC SQL
c+ CREATE PROCEDURE HSALES
c+ (IN YEAR INTEGER ,
c+ IN MONTH INTEGER ,
c+ OUT SUPPLIER_NAME CHAR(20) ,
c+ OUT HSALE DECIMAL(11,2))
c+ EXTERNAL NAME SPROCLIB.HSALES
c+ SPECIFIC HSALES
c+ LANGUAGE RPGLE
c+ PARAMETER STYLE GENERAL
c/END_EXEC
The same code as that above except without the 'c/...' and 'c+' elements of RPG syntax works perfectly well as a standalone SQL statement.

RUNSQLSTM

When you've coded the CREATE PROCEDURE statement in a SQL source member, how do you run the SQL statement? I create a command in my PDM options like this:

RUNSQLSTM SRCFILE(&L/&F) SRCMBR(&N) COMMIT(*NONE)


Generally, RPG programs do not use commitment control, that explains the COMMIT(*NONE) command parameter. You should use whatever commitment control your application requires.

You can see a similar solution using the PDM option here.

Recreating a procedure requires that the old one has been dropped. I add a line similar to the following to the beginning of the SQL source member

DROP PROCEDURE HSALES;




%LOOKUP

Arrays can be searched using %LOOKUP and %LOOKUPxx where xx may be LE, LT, GE or GT.

%LOOKUP(arg : array {: startindex {: numelems}})

if %lookup(val : array) = 0;
// not found
endif;

i = %lookup(val : array);
if i > 0;
// found, can work with array(i)
endif;


Stored Procedure Example


CREATE PROCEDURE SPROCLIB.SELPGMARR(IN orhnbr CHAR(5) )
RESULT SETS 1
LANGUAGE RPGLE
EXTERNAL NAME SPROCLIB.SELPGMARR
READS SQL DATA
PARAMETER STYLE GENERAL



forderdtl if e K disk rename(orderdtl:norderdtl)
di s 3 0
dproduct ds occurs(5)
dnumber 5
c *entry plist
c parm ordnbr 5
c eval i=0
c *LOVAL SETLL norderdtl
c read norderdtl
c dow not(%eof)
c if orhnbr=ordnbr
c eval i=i+1
c i occur product
c move prdnbr product
c endif
c read norderdtl
c enddo
c* in this loop -fetch all the rows in the resultant set into var:array
c/exec sql
c+ SET RESULT SETS FOR RETURN TO CLIENT ARRAY :product FOR :i ROWS
c/end-exec
c return



String url = "jdbc:as400://myiseries;naming=sql";
try {
DriverManager.registerDriver(
new com.ibm.as400.access.AS400JDBCDriver());

connection = DriverManager.getConnection(url, userid, passwd);
Statement stmt = connection.createStatement();
stmt.setInt(1,100);
ResultSet rs = stmt.executeQuery ("CALL SPROCLIB.SELPGMARR(?)");

while (rs.next ()) {
String product = rs.getString(1);
System.out.println ("Product: " + product);
}
}
catch (Exception e) {
throw new ApplicationError(e.getMessage());
}

finally {
try {
if (connection != null)
connection.close ();
}
catch (SQLException e) {
// Error is ignored.
}
}

%LEN BIF

Variable length strings can be modified by using %LEN BIF on the left side of the statement.

D city S 40A varying inz(’North York’)
D n1 S 5i 0
* %LEN used to get the current length of a variable-length field:
/FREE
n1 = %len(city);
// Current length, n1 = 10

// %LEN used to set the current length of a variable-length field:
%len(city) = 5;
// city = ’North’ (length is 5)

%len(city) = 15;
// city = ’North ’ (length is 15)
/END-FREE

%DATE BIF

%DATE{(expression{:date-format})}

%DATE- converts the value of the expression from character, numeric, or timestamp data to type date. The converted value remains unchanged, but is returned as a date.

Date Formats

2-Digit Year Formats 
Format Default
name *LOVAL *HIVAL Value
*MDY 01/01/40 12/31/39 01/01/40
*DMY 01/01/40 31/12/39 01/01/40
*YMD 40/01/01 39/12/31 40/01/01
*JUL 40/001 39/365 40/001

4-Digit Year Formats
Format Default
name *LOVAL *HIVAL Value
*ISO 0001-01-01 9999-12-31 0001-01-01
*USA 01/01/0001 12/31/9999 01/01/0001
*EUR 01.01.0001 31.12.9999 01.01.0001
*JIS 0001-01-01 9999-12-31 0001-01-01


D Date s d
/free
Date = %date(122507: *MDY);
Date = %date(251207: *DMY);
Date = %date(071225: *YMD);
Date = %date(12252007: *USA);
Date = %date(25122007: *EUR);
Date = %date(20071225: *ISO);

Date = %date('122507': *MDY0);
Date = %date('251207': *DMY0);
Date = %date('071225': *YMD0);
Date = %date('12252007': *USA0);
Date = %date('25122007': *EUR0);
Date = %date('20071225': *ISO0);

Date = %date('12/25/07': *MDY);
Date = %date('25/12/07': *DMY);
Date = %date('07/12/25': *YMD);
Date = %date('12/25/2007': *USA);
Date = %date('25.12.2007': *EUR);
Date = %date('2007-12-25': *ISO);
/end-free

Other BIFs Used with Date Fields


*...1....+....2....+....3....+....4....+....5....+....6....+....7...+....
/FREE
// Determine the date in 3 years
newdate = date + %YEARS(3);

// Determine the date in 6 months prior
loandate = duedate - %MONTHS(6);

// Construct a timestamp from a date and time
duestamp = duedate + t’12.00.00’;
/END-FREE

Character Data

%SCAN(search argument : source string {: start})
%SCAN returns the first position of the search argument in the source string, or 0 (zero) if it was not found.

%CHECK(comparator : base {: start})
%CHECK returns the first position of the string base that contains a character that does not appear in string comparator.   If all of the characters in base also appear in comparator, the function returns 0 (zero).

%EDITC(numeric : editcode {: *ASTFILL | *CURSYM | currency-symbol})
This function returns a character result representing the numeric value edited according to the edit code.

C EVAL msg = 'The annual salary is '+ %trim(%editc(salary * 12:'A': *CURSYM))

Parser Program

Can you spot the memory leak in the code below?   I wrote the code below to experiment with RPG's new (or, at least, newer and seldom used) features and I left the code incomplete.   The main program code simply tests the parsing procedure.

What I find interesting about this code is that the complex pieces are completely unnecessary.   I suppose that many C programmers would use pointers and memory allocation to solve a parsing problem but, it is apparent to any RPG programmer that there are simpler and less error prone solutions to parsing.
h option(*nodebugio:*srcstmt)                                    
                                                                 
d resultString    S               *   DIM(100)                   
                                                                 
d newString       PR              *                              
d  string                         *   CONST OPTIONS(*STRING)     
                                                                 
d parseString     PR             5I 0 extproc('parseString')     
d  input                          *   CONST OPTIONS(*STRING)     
d  output                             like(resultString) DIM(100)
d  separator                     1A   CONST OPTIONS(*OMIT)       
                                                                 
d PARSEPGM2       PR                                             
                                                                 
d PARSEPGM2       PI                                             
                                                                 
d J               s              5I 0                            
d K               s              5I 0                            
d L               s             40A                              
d xptr            s               *                              
d sz              s              3P 0                            
 /free                                                           
             resultString(1) = newString('one');                 
             resultString(2) = newString('two');           
             xptr = resultString(1);                       
             sz = %len(%str(xptr));                        
             dsply %char(sz);                              
                                                           
             K = parseString('one,two,three,four,five,six' 
                                     :resultString:' ');   
             for J = 1 to K;                               
                 xptr = resultString(J);                   
                 sz = %len(%str(xptr));                    
                 L = %str(resultString(J):sz);             
                 dsply L;                                  
             endFor;                                       
                                                           
             K = parseString('onetwothreefourfivesix'      
                                     :resultString:' ');   
             for J = 1 to K;                               
                 xptr = resultString(J);                   
                 sz = %len(%str(xptr));                    
                 L = %str(resultString(J):sz);             
                 dsply L;                                  
             endFor;                                       
             *inlr = *on;                                  
 /end-free 
 * ==========================================================     
 *                                                                
 * ==========================================================     
p parseString     b                   EXPORT                      
d                 pi             5I 0                             
d  input                          *   CONST OPTIONS(*STRING)      
d  procOut                            like(resultString) DIM(100) 
d  separator                     1A   CONST OPTIONS(*OMIT)        
d N               s              5P 0                             
d sep             s              1A                               
d parz            s               *   inz(%addr(parzField))       
d parzField       s            100A                               
d beginStr        s              5I 0                             
d endStr          s              5I 0                             
d final           s              5I 0                             
d Counter         s              5I 0 inz(0)                      
 /free                                                            
              beginStr = 1;                                       
              final = %len(%str(input));                          
              if %parms = 2;                                      
                 sep = separator;                                 
              else;                                               
                 sep = ',';  //assume comma sep if no parm given  
              endIf;
              for N = 1 to %elem(procOut);                          
                 Counter += 1;                                      
                 endStr = %scan(sep : %subst(%str(input):beginStr));
                 if endStr = 0;  // not found                       
                     endStr = final - beginStr + 1;                 
                     %str( parz : endStr + 1) =                     
                         %subst( %str(input) : beginStr : endStr ); 
                 else;                                              
                     %str( parz : endStr ) =                        
                         %subst( %str(input) : beginStr : endStr ); 
                 endIf;                                             
                 procout(N) = newString(parz);                      
                 beginStr += endStr;                                
                 if beginStr >= final;                              
                     leave;                                         
                 endIf;                                             
              endFor;                                               
              return Counter;                                       
 /end-free                                                          
p                 e                                                 
 * ==========================================================       
 *                                                                  
 * ==========================================================       
p newString       b                   EXPORT  
d                 PI              *                         
d  string                         *   CONST OPTIONS(*STRING)
d  ptr            S               *                         
d  newString      S          32676A   based(ptr)            
d  sizeOfString   S             10I 0                       
 /free                                                      
             ptr = %alloc(%size(string));                   
             %str(ptr:%size(newString)) = %str(string);     
             return ptr;                                    
 /end-free                                                  
p                 e  


Blog Archive