RPG Cheat Sheet

DB2/400 Date Format

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  ********

AS400 Window With Radio Button and Message Subfile

This example uses MSGSFL and SNGCHCFLD in the Display File and QMHSNDPM API in the RPG. After compiling RPG module SENDPGMMSG, run the following command
CRTSRVPGM lib/SENDPGMMSG EXPORT(*ALL)
and then create the UTIL binding directory and add the SRVPGM to the BNDDIR as follows
crtbnddir lib/UTIL
addbnddire lib/UTIL OBJ((SENDPGMMSG))

TESTDISPLAY DSPF Source

A                                      DSPSIZ(27 132 *DS3)                
A                                      PRINT                              
A                                      CA03(03)                           
A                                      CF10(10)                           
A          R DUMMY                                                        
A                                      ASSUME                             
A                                  1  2' '                                
A                                      DSPATR(ND)                         
A*---------------------------------------------------------------         
A          R DSPRECORD                                                    
A                                      WINDOW(5 5 17 90 *NOMSGLIN)        
A                                      WDWTITLE((*TEXT ' Account Info ') -
A                                      (*COLOR BLU) (*DSPATR RI))         
A                                      WDWBORDER((*COLOR BLU))            
A                                      OVERLAY                            
A                                  3  2'First Name.............-          
A                                      ...:'                              
A            FNAME         20A  O    +2                                   
A                                      DSPATR(HI)                         
A                                  4  2'Last Name..............-          
A                                      ...:'                              
A            LNAME         20A  O    +2                                   
A                                      DSPATR(HI)                         
A                                  6  2'Account Number (masked)-          
A                                      ...:'                    
A            ACTNBRMSK     11A  O    +2COLOR(WHT)               
A  50                                  DSPATR(RI)               
A                                  7  2'Routing Number.........-
A                                      ...:'                    
A            RTENBR        10A  O    +2COLOR(WHT)               
A  50                                  DSPATR(RI)               
A                                  8  2'Account Description....-
A                                      ...:'                    
A            BNKACTDES     32A  O    +2COLOR(WHT)               
A  50                                  DSPATR(RI)               
A                                  9  2'Created Timestamp......-
A                                      ...:'                    
A            CRT             Z  O    +2COLOR(WHT)               
A  50                                  DSPATR(RI)               
A                                 10  2'Created By.............-
A                                      ...:'                    
A            CRTBY         20A  O    +2COLOR(WHT)               
A  50                                  DSPATR(RI)               
A                                 11  2'Updated Timestamp......-
A                                      ...:'                    
A            LSTUPD          Z  O    +2COLOR(WHT)               
A  50                                  DSPATR(RI)               
A                                 12  2'Updated By.............-
A                                      ...:'                               
A            LSTUPDBY      10A  O    +2COLOR(WHT)                          
A  50                                  DSPATR(RI)                          
 *..1....+....2....+....3....+....4....+....5....+....6....+....7....+....8
A                                 14  2'Transaction Amount.....-           
A                                      ...:'                               
A            D_OR_W_AMT     9Y 2B    +2EDTCDE(1)                           
A                                      DSPATR(HI)                          
A  50                                  DSPATR(PR)                          
A                                 15  2'Transaction Type.......-           
A                                      ...:'                               
A            D_OR_W_CHK     2Y 0B    +2SNGCHCFLD(*NOAUTOSLT (*NUMROW 1))   
A                                      CHOICE(1 '>Deposit')                
A                                      CHOICE(2 '>Withdrawal')             
A                                      DSPATR(HI)                          
A                                 16  2'F3=Exit'                           
A                                      COLOR(BLU)                          
A                                    +2'F10=Process'                       
A                                      COLOR(BLU)                          
A  50                                  DSPATR(ND)                          
                                                                           
 * Message subfile                                                         
A          R MSGSFL                    SFL                                 
A                                      SFLMSGRCD(17)                       
A            MSGKEY                    SFLMSGKEY        
A            PROGRAM                   SFLPGMQ          
 *                                                      
A          R MSGCTL                    SFLCTL(MSGSFL)   
A                                      WINDOW(DSPRECORD)
A                                      PUTOVR           
A                                      OVERLAY          
A                                      SFLDSP           
A                                      SFLDSPCTL        
A                                      SFLINZ           
A N99                                  SFLEND           
A                                      SFLSIZ(10)       
A                                      SFLPAG(1)        
A            PROGRAM                   SFLPGMQ          

TESTPGMMSG RPGLE Source

h bnddir('QC2LE':'UTIL')                                    
h dftactgrp(*no) actgrp(*caller)                            
h alwnull(*usrctl)                                          
h option(*nodebugio:*srcstmt) debug(*yes)                   
FTESTDISPLYCF   E             WORKSTN                       
 *                                                          
 * program status data structure                            
 *                                                          
D PSDS           SDS                                        
D  Program          *proc                                   
 *                                                          
 * Display Screen Indicators                                
 *                                                          
D $Indicators     s               *   inz(%addr(*IN))       
D Indicators      DS                  based($Indicators)    
D F3_Exit                         N   Overlay(Indicators:3) 
D F10_ProcessACH                  N   Overlay(Indicators:10)
D DataNotFound                    N   Overlay(Indicators:50)
 *                                                          
 * Working Storage                                          
 *                                                          
D ErrorPreNoteScreen...                                     
D                 s               N                         
D msgData         s             80A                         
 *                                                        
 * SendPgmMsg Prototype Definition                        
 *                                                        
D/include QRPGLESRC,sendpgmmpr                            
 *                                                        
 * This Program's Prototype Definition                    
 *                                                        
D TESTPGMMSG      pr                  extpgm('TESTPGMMSG')
 *                                                        
 * This Program's Interface Definition                    
 *                                                        
d TESTPGMMSG      pi                                      
 *                                                        
 /free                                                    
     dou F3_Exit;                                         
       exsr PreparePrenoteScreen;                         
       dou F3_Exit;                                       
         write DSPRECORD;                                 
         write MSGCTL;                                    
         read  DSPRECORD;                                 
         ClearDspMsgSfl();                                
         if F3_Exit;                                      
           leave;                                         
         endif;                                           
         if DataNotFound;                                 
           WriteDspMsgSfl('Unable to process.' + msgData);
           iter;                                          
         endif;                                           
         exsr EditPrenoteScreen;                          
         if ErrorPreNoteScreen;                           
           iter;                                          
         endif;                                           
       enddo;                                             
       if F10_ProcessACH;                                 
         exsr CreateACH;                                  
       endif;                                             
     enddo;                                               
     *INLR = *ON;                                         
                                                          
  // *****************************************************
  // get data for screen                                  
  // *****************************************************
     begsr PreparePrenoteScreen;                          
       DataNotFound = *OFF;                               
       MONITOR;                                           
         FNAME = 'Greg';                                  
         LNAME = 'Helton';                                
         ACTNBRMSK = 'XXXX';                              
         RTENBR    = '001234567';                                      
         BNKACTDES = 'Checking';                                       
         CRT   = %TimeStamp;                                           
         CRTBY = 'GHELTON';                                            
         LSTUPD = %TimeStamp;                                          
         LSTUPDBY = 'GHELTON';                                         
       on-error;                                                       
         DataNotFound = *ON;                                           
         msgData = 'Error retrieving data';                            
         WriteDspMsgSfl(msgData);                                      
       endmon;                                                         
     endsr;                                                            
                                                                       
  // *****************************************************             
  // edit the screen                                                   
  // *****************************************************             
     begsr EditPrenoteScreen;                                          
       ErrorPreNoteScreen = *OFF;                                      
       if D_OR_W_AMT <= 0;                                             
         ErrorPreNoteScreen = *ON;                                     
         msgData = '''Transaction Amount'' must be greater than zero.';
         WriteDspMsgSfl(msgData);                                      
       endif;                                                          
       if D_OR_W_CHK = 0;                                              
         ErrorPreNoteScreen = *ON;                                 
         msgData = 'Please highlight ''Deposit'' or ''Withdrawal'''
         + ' and press space bar to select.';                      
         WriteDspMsgSfl(msgData);                                  
       endif;                                                      
     endsr;                                                        
                                                                   
  // *****************************************************         
  // create the ACH                                                
  // *****************************************************         
     begsr CreateACH;                                              
     endsr;                                                        
                                                                   
 /end-free                                                         

SENDPGMMPR RPGLE Copybook

D WriteDspMsgSfl...                                            
D                 pr                  EXTPROC('WriteDspMsgSfl')
D message                       80    CONST                    
                                                               
D ClearDspMsgSfl...                                            
D                 pr                  EXTPROC('ClearDspMsgSfl')

SENDPGMMSG RPGLE Module Source

H nomain option(*nodebugio:*srcstmt)                    
                                                        
 /include qrpglesrc,SENDPGMMPR                          
                                                        
P WriteDspMsgSfl...                                     
P                 b                   EXPORT            
D                 pi                                    
D message                       80    CONST             
                                                        
D SendPgmMsg      pr                  EXTPGM('QMHSNDPM')
D   MsgID                        7    const             
D   MsgFile                     20    const             
D   MsgDta                      80    const             
D   MsgDtaLen                   10i 0 const             
D   MsgType                     10    const             
D   MsgQ                        10    const             
D   MsgQNbr                     10i 0 const             
D   MsgKey                       4                      
D   Error                             like(ErrorDS)     
                                                        
D ErrorDS         ds            16                      
D   BytesProv                   10i 0 inz(16)           
D   BytesAvail                  10i 0                   
D   ExceptionID                  7                      
                                                                  
D MsgKey          s              4                                
                                                                  
 /free                                                            
      SendPgmMsg('CPF9897': 'QCPFMSG   QSYS': message :           
                 80 : '*INFO' : '*PGMBDY' : 1 : MsgKey : ErrorDS);
 /end-free                                                        
p                 e                                               
                                                                  
p ClearDspMsgSfl...                                               
p                 b                   EXPORT                      
D ClrMsgQ         pr                  EXTPGM('QMHRMVPM')          
D   MsgQueue                   276a   const                       
D   CallStack                   10i 0 const                       
D   MsgKey                       4a   const                       
D   MsgRmv                      10a   const                       
D   Error                             like(ErrorDS)               
                                                                  
D ErrorDS         ds            16                                
D   BytesProv                   10i 0 inz(16)                     
D   BytesAvail                  10i 0                             
D   ExceptionID                  7                                
                                                                  
 /free                                                            
        ClrMsgQ('*': 1: *blanks: '*ALL': ErrorDS);       
 /end-free                                               
p                 e                                      

Where is IBM's Power Server Revenue Heading?

Updated Oct 17, 2013 with Q3 results.

So as to be able to compare IBM's revenues from Intel and Power server lines, I went back through IBM's press releases to get these numbers.

         Q1/11 Q2/11 Q3/11 Q4/11 Q1/12 Q2/12 Q3/12 Q4/12 Q1/13 Q2/13 Q3/13
Power     +19%  +12%  +15%  +6%    0%   -7%   -3%   -19%  -32%  -25%  -38%
System x  +13%  +15%   +1%  -2%    0%   -8%   -5%    -2%   -9%  -11%  -18%


IBM Server News: Linux & Power8

IBM is expected to announce at the Linuxcon 2013 conference in New Orleans, that it is pledging to invest $1bn in Linux and other open source technologies for its Power system servers. The company will also grow its Power Systems cloud, which lets developers remotely access Power, AIX, and IBM i gear on which to prototype, build, port, and test Linux apps.

IBM introduced its Power hardware to a world-wide audience on the game show Jeopardy where the Linux-based Watson supercomputer won.

The Power8 chip architecture has new technologies compared to its predecessors including the PCI-Express 3.0 protocol, shared memory and a new CAPI (Coherence Attach Processor Interface) for outside components to communicate with the CPU and other processing units. POWER8 is designed to be a massively multithreaded chip, capable of handling 96 hardware threads simultaneously.

IBM is building a Power Systems Linux Center in Montpellier, France, where developers will get access to Power chip and server technologies to develop and deploy Linux applications. The company already has similar centers in Beijing, New York and Austin, Texas.

The 22nm POWER8 chip, with its 96 hardware threads, is 650mm² and requires 200 watts. By comparison, next year's Intel 22nm Xeon chips are to have a die size of 100 to 200mm², 2, 4, 6 or 8 cores at two threads per core with the four core chip burning 45 watts. The 2.7Ghz 12-core chip draws 130 watts of power, and the 2.4Ghz Xeon draws 115 watts of power.

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