ecki/IBM-i-RPG-Free-CLP-Code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Add *

Browse Source
This commit is contained in:
SJLennon
2021-04-20 12:23:10 -04:00
parent fb82bdd0bb
commit f42995b70b
10 changed files with 318 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files
BASE36/BASE36_P.RPGLE
+5
View File
@@ -0,0 +1,5 @@
**FREE
// === BASE36ADD prototype ==========================================
dcl-pr BASE36ADD varchar(50);
theValue varchar(50) const;
end-pr;
BASE36/BTBR.SQLRPGLE
+79
View File
@@ -0,0 +1,79 @@
**FREE
//====================================================================
// Test program to exercise BASE36ADD in batch.
// Result values are written out to table BTB.
// Call with two parameters:
// 1) Starting value to increment, e.g. '988'
// 2) Ending value, e.g. '992'
// Examples:
// CALL PGM(BTBR) PARM('988' '992')
// Should write 31 records.
// CALL PGM(BTBR) PARM('1B999999999999999998' '1CAAAAAAAAAAAAAAAAAD')
// Should write 6 records.
// SQL error checking is functional but it is not production
// quality. Do not copy!
//====================================================================
ctl-opt debug option(*nodebugio: *srcstmt) dftactgrp(*no)
actgrp(*caller) bnddir('SRV_BASE36')
main(Main);
/include base36,base36_p
dcl-proc Main ;
dcl-pi *N extpgm('BTBR');
pi_First char(20);
pi_Last char(20);
end-pi;
dcl-s wkNext varchar(50);
dcl-s wkLast varchar(50);
dcl-s count int(10) inz(0);
dcl-s msg char(52);
*inlr = *on;
exec sql set option
datfmt=*iso,
closqlcsr=*endmod,
commit=*none
;
//=== Convert input parms to varchar ================================
wkNext = %trim(pi_First);
wkLast = %trim(pi_Last);
//=== Drop and recreate output Table =================================
exec sql set schema lennons1; // <----- Change this to your library!
exec sql drop table btb;
exec sql create table btb (
theSeq int,
theValue varchar(50),
constraint value_primary primary key( theValue )
);
if SQLSTATE <> '00000' and SQLSTATE <> '01567';
dsply 'Create Table failed';
return;
endif;
exec sql alter table btb
add constraint seq_unique unique( theSeq )
;
if SQLSTATE <> '00000';
dsply 'Alter Table failed';
return;
endif;
//=== Run the Test ===================================================
dow wkNext <= wkLast;
wkNext = BASE36ADD(wkNext);
count += 1;
exec sql insert into btb values (:count, :wkNext);
if SQLSTATE <> '00000';
dsply 'Insert failed';
count -= 1;
leave;
endif;
enddo;
msg = 'Records written: ' +%char(count);
dsply msg;
return;
end-proc;
BASE36/BTID.DSPF
+60
View File
@@ -0,0 +1,60 @@
A*===============================================================
A DSPSIZ(24 80 *DS3)
A PRINT
A INDARA
A CF04
A CA05
A CA03
A*===============================================================
A R SCREEN
A TEXT('Screen Header')
A SH_PGM 10A O 1 2
A 1 21'Test BASE36ADD'
A 1 47DATE
A EDTCDE(Y)
A 2 1USER
A 2 47TIME
A*---------------------------------------------------------------
A 3 30'<-Rolling Value(s)'
A 4 30'<-'
A 5 30'<-'
A 6 30'<-'
A 7 30'<-'
A 8 30'<-'
A 9 30'<-'
A 10 30'<-'
A 11 30'<-'
A 12 30'<-'
A 13 30'<-'
A 14 30'<-'
A 15 30'<-'
A 16 30'<-'
A 17 30'<-'
A 18 30'<-'
A 19 30'<-'
A 20 30'<-Rolling Value(s)'
A VAL1 20A O 3 1
A VAL2 20A O 4 1
A VAL3 20A O 5 1
A VAL4 20A O 6 1
A VAL5 20A O 7 1
A VAL6 20A O 8 1
A VAL7 20A O 9 1
A VAL8 20A O 10 1
A VAL9 20A O 11 1
A VAL10 20A O 12 1
A VAL11 20A O 13 1
A VAL12 20A O 14 1
A VAL13 20A O 15 1
A VAL14 20A O 16 1
A VAL15 20A O 17 1
A VAL16 20A O 18 1
A VAL17 20A O 19 1
A VAL18 20A O 20 1
A VAL 20A B 21 1
A 21 30'Value'
A N40 21 38'<- Enter a starting Value'
A 40 22 30'Press enter to add 1 to value'
A 40 23 30'F5 to enter new Value'
A 24 30'F3 to EXIT'
BASE36/BTIR.RPGLE
+90
View File
@@ -0,0 +1,90 @@
**FREE
//====================================================================
// Interactive program to demonstrate/exercise BASE36ADD.
// Enter a value up to 20 characters. Press enter and the value + 1
// is displayed. Each enter increments by 1 and the values roll
// up the screen.
// Not a lot of error checking. You can see what happens if you
// enter a character that is not A-Z or 0-9.
//====================================================================
ctl-opt debug option(*nodebugio: *srcstmt) dftactgrp(*no)
actgrp(*caller) bnddir('SRV_BASE36')
main(Main);
/include base36,base36_p
dcl-f BTID WORKSTN INFDS(dfInfDS) Usropn;
dcl-ds dfInfDS;
Key char(1) pos(369);
end-ds;
dcl-c F03 x'33';
dcl-c F05 x'35';
dcl-s ValVar varchar(20);
dcl-s j int(10);
dcl-ds *N; // Rolling screen fields
Val1;
Val2;
Val3;
Val4;
val5;
val6;
val7;
val8;
val9;
val10;
val11;
val12;
val13;
val14;
val15;
val16;
val17;
val18;
Values char(20) dim(18) pos(1);
end-ds;
dcl-proc Main ;
if not %open(BTID);
open BTID;
endif;
exsr GetVal;
dow Key <> F03;
*in40 = *on;
if Key = F05;
exsr GetVal;
iter;
endif;
// Roll values up the screen
for j = 1 to %elem(Values)-1;
Values(j) = Values(J+1);
endfor;
Val18 = Val;
// Increment by 1
valVar = %trim(val);
valVar = BASE36ADD(ValVar);
Val = ValVar;
exfmt SCREEN;
enddo;
close BTID;
*inlr=*on;
// Get the starting value
begsr GetVal;
*in40 = *off;
Values = *blanks;
dou Val <> *blanks;
exfmt SCREEN;
if Key = F03;
return;
endif;
enddo;
endsr;
end-proc;
BASE36/CRTBNDDIR.CLLE
+8
View File
@@ -0,0 +1,8 @@
PGM
/* Create UTIL_BND binding directory in *CURLIB */
/* Change next statement if needed */
CRTBNDDIR BNDDIR(*CURLIB/SRV_BASE36) TEXT('BASE36 ADD +
Service PGMs')
ADDBNDDIRE BNDDIR(SRV_BASE36) OBJ((SRV_BASE36 *SRVPGM +
*DEFER))
ENDPGM
BASE36/Images/BTIR_1.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 10 KiB

BASE36/Images/BTIR_2.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 14 KiB

BASE36/SRV_BASE36.RPGLE
+55
View File
@@ -0,0 +1,55 @@
**FREE
// ====================================================================
// Contains BASE36ADD procedure to increments by 1 a Character value.
// Pass in a value and it returns the value incremtented by 1.
// ====================================================================
// - It works on any string length up to an arbitrary 50 characters.
// So the value must be passed in as varying character and the
// incremented value is returned as varying character.
// - It is the callers responsibility to ensure that if the absolute
// maximum value is returned then some action must be taken to
// report/handle the situation where no more values are available.
// If called with the maximum value it will roll over to the minimum
// value. E.g., call with 999 and AAA will be returned.
// - This code is based on the 36 character set A-Z and 0-9.
// - As coded, the sequence of the values follows the EBCDIC raw
// sorting sequence.
// - If a different character set is needed, e.g., you wish to omit
// O and L because they look to much like 0 and 1, simply
// remove them from the "From" and "To" strings.
//
// 1) CRTRPGMOD MODULE(SRV_BASE36)
// 2) CRTSRVPGM SRVPGM(SRV_BASE36) EXPORT(*ALL) TEXT('BASE36 Service Pgm')
// 3) ADDBNDDIRE BNDDIR(SRV_BASE36) OBJ((SRV_BASE36 *SRVPGM *DEFER))
ctl-opt debug nomain option(*nodebugio: *srcstmt) ;
/include BASE36,BASE36_P
dcl-proc BASE36ADD export ;
dcl-pi BASE36ADD varchar(50);
PI_Value varchar(50) const; // Input value
end-pi BASE36ADD;
dcl-s wkValue like(PI_Value);
dcl-s inx int(10);
// Ascending values of a postion is A,B,...,Y,Z,0,1,2,...,7,8,9.
dcl-c From 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
dcl-c To 'BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789A';
wkValue = PI_Value;
// Increment the last position in the input value. If it now is
// equal to the last character in "To" then it has rolled over,
// so move to the prior input value field and repeat.
inx = %len(PI_Value);
dow inx > 0;
%subst(wkValue:inx:1) = %xlate(From:To:%subst(wkValue:inx:1));
// if %subst(wkValue:inx:1) <> 'A'; // Not rolled over
if %subst(wkValue:inx:1) <> %subst(To:%size(To):1) ; // Not rolled over
leave;
endif;
inx -= 1;
enddo;
return wkValue; // return incremented value
end-proc BASE36ADD;