Skip to content

Instantly share code, notes, and snippets.

@Faq400Git

Faq400Git/GAMEOFLF_DSPF

Created April 13, 2020 15:44
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save Faq400Git/1ef052b01c69319a4968fa45031595fc to your computer and use it in GitHub Desktop.
Save Faq400Git/1ef052b01c69319a4968fa45031595fc to your computer and use it in GitHub Desktop.
Download ZIP
The Game Of Life - SQLRPGLE and 5250 John Conway's Tribute
Raw
example00.rle
#C Generated by copy.sh/life
x = 10, y = 10, rule = B3/S23
o$o$o
Raw
example01.rle
#C Generated by copy.sh/life
x = 36, y = 2, rule = B3/S23
24bo$22bobo$12b2o6b2o12b2o$11bo3bo4b2o12b2o$2o8bo5bo3b2o$2o8bo3bob2o4bobo
10bo5bo7bo$11bo3bo$12b2o!
Raw
example07.rle
#C Generated by copy.sh/life
x = 10, y = 10, rule = B3/S23
o3bo3b$2o3b2o$o3bo3b!
Raw
GAMEOFLF_DSPF
A*%%TS SD 20200413 144425 FAQ400 REL-V7R2M0 5770-WDS
A* Surce preso da esempio
A* http://www.rpgpgm.com/2016/05/example-subfile-program-using-modern-rpg.h
A*%%EC
A DSPSIZ(27 132 *DS4)
A CHGINPDFT(HI CS)
A PRINT
A INDARA
A CA03(03 'F3=Exit')
A R DUMMY
A ASSUME
A 1 3' '
A R FMT01
A*%%TS SD 20200413 144425 FAQ400 REL-V7R2M0 5770-WDS
A FRCDTA
A OVERLAY
A PUTOVR
A OVRDTA
A OVRATR
A 1 53'Game of life 5250 - RPG Free'
A DSPATR(HI)
A DSPATR(UL)
A ROW001 130A O 3 2
A ROW002 130A O 4 2
A ROW003 130A O 5 2
A ROW004 130A O 6 2
A ROW005 130A O 7 2
A ROW006 130A O 8 2
A ROW007 130A O 9 2
A ROW008 130A O 10 2
A ROW009 130A O 11 2
A ROW010 130A O 12 2
A ROW011 130A O 13 2
A ROW012 130A O 14 2
A ROW013 130A O 15 2
A ROW014 130A O 16 2
A ROW015 130A O 17 2
A ROW016 130A O 18 2
A ROW017 130A O 19 2
A ROW018 130A O 20 2
A ROW019 130A O 21 2
A ROW020 130A O 22 2
A ROW021 130A O 23 2
A ROW022 130 O 24 2
A NRITER 5Y 0B 2 60
A N01 DSPATR(HI)
A EDTCDE(Z)
A 01 DSPATR(PR)
A 2 83'Iteration nr'
A G 5S 0O 2 96DSPATR(HI)
A 2 66'Bounce:'
A BOUNCE 1A B 2 74
A N01 DSPATR(HI)
A 01 DSPATR(PR)
A 2 76'(Y/N)'
A 2 3'Pattern:'
A DSPATR(HI)
A PATTERN 30A B 2 12
A N01 DSPATR(HI)
A 01 DSPATR(PR)
A CHECK(LC)
A 2 43'Nr Of Iterations'
A DSPATR(HI)
A MSG 29A O 2103COLOR(RED)
A ROW023 130A O 25 2
A ROW024 130A O 26 2
A R FMT02
A*%%TS SD 20200413 085903 FAQ400 REL-V7R2M0 5770-WDS
A OVERLAY
A PUTOVR
A OVRDTA
A OVRATR
A 1 53'Game of life 5250 - RPG Free'
A DSPATR(HI)
A DSPATR(UL)
A ROX001 130A O 3 2
A ROX002 130A O 4 2
A ROX003 130A O 5 2
A ROX004 130A O 6 2
A ROX005 130A O 7 2
A ROX006 130A O 8 2
A ROX007 130A O 9 2
A ROX008 130A O 10 2
A ROX009 130A O 11 2
A ROX010 130A O 12 2
A ROX011 130A O 13 2
A ROX012 130A O 14 2
A ROX013 130A O 15 2
A ROX014 130A O 16 2
A ROX015 130A O 17 2
A ROX016 130A O 18 2
A ROX017 130A O 19 2
A ROX018 130A O 20 2
A ROX019 130A O 21 2
A ROX020 130A O 22 2
A ROX021 130A O 23 2
A ROX022 130A O 24 2
A NRITER 5Y 0B 2 60
A N01 DSPATR(HI)
A EDTCDE(Z)
A 01 DSPATR(PR)
A 2 83'Iteration nr'
A G 5S 0O 2 96DSPATR(HI)
A 2 66'Bounce:'
A BOUNCE 1A B 2 74
A N01 DSPATR(HI)
A 01 DSPATR(PR)
A 2 76'(Y/N)'
A 2 3'Pattern:'
A DSPATR(HI)
A PATTERN 30A B 2 12
A N01 DSPATR(HI)
A 01 DSPATR(PR)
A CHECK(LC)
A 2 43'Nr Of Iterations'
A DSPATR(HI)
A MSG 29A O 2103COLOR(RED)
Raw
GAMEOFLF_SQLRPGLE
// -----------------------------------------
// GAMEOFL Game of life Tribute
//-------------------------------------------------
ctl-opt option(*srcstmt:*nounref) dftactgrp(*no);
ctl-opt bnddir('QC2LE');
dcl-f GAMEOFLFV workstn indds(Dspf);
dcl-ds PgmDs psds qualified ;
PgmName *proc ;
end-ds ;
dcl-pr Usleep extproc('usleep');
mseconds uns(10) value;
END-PR;
dcl-pr sleep extproc('sleep');
seconds uns(10) value;
END-PR;
// Indicatori in variabili parlanti
dcl-ds Dspf qualified ;
Exit ind pos(3) ;
Refresh ind pos(5) ;
SflDspCtl ind pos(30) ;
SflDsp ind pos(31) ;
end-ds ;
// Null values
dcl-s Null_ind int(5);
dcl-ds £ind_Null;
Null_ds dim(2000) like(Null_ind);
END-DS;
dcl-c maxx const(130);
dcl-c maxy const(24);
dcl-c m_maxx const(300);
dcl-c m_maxy const(100);
dcl-c d_maxx const(170); // 300-130
dcl-c d_maxy const(88); // 100-22
dcl-ds matrix ;
row001 char(maxx);
row001h char(d_maxx);
row002 char(maxx);
row002h char(d_maxx);
row003 char(maxx);
row003h char(d_maxx);
row004 char(maxx);
row004h char(d_maxx);
row005 char(maxx);
row005h char(d_maxx);
row006 char(maxx);
row006h char(d_maxx);
row007 char(maxx);
row007h char(d_maxx);
row008 char(maxx);
row008h char(d_maxx);
row009 char(maxx);
row009h char(d_maxx);
row010 char(maxx);
row010h char(d_maxx);
row011 char(maxx);
row011h char(d_maxx);
row012 char(maxx);
row012h char(d_maxx);
row013 char(maxx);
row013h char(d_maxx);
row014 char(maxx);
row014h char(d_maxx);
row015 char(maxx);
row015h char(d_maxx);
row016 char(maxx);
row016h char(d_maxx);
row017 char(maxx);
row017h char(d_maxx);
row018 char(maxx);
row018h char(d_maxx);
row019 char(maxx);
row019h char(d_maxx);
row020 char(maxx);
row020h char(d_maxx);
row021 char(maxx);
row021h char(d_maxx);
row022 char(maxx);
row022h char(d_maxx);
row023 char(maxx);
row023h char(d_maxx);
row024 char(maxx);
row024h char(d_maxx);
rows char(m_maxx) dim(m_maxy) pos(1);
END-DS;
dcl-ds matrixNextGen qualified;
rows char(m_maxx) dim(m_maxy);
END-DS;
dcl-s x int(5);
dcl-s y int(5);
dcl-s i int(5);
dcl-s g packed(5:0);
dcl-s on char(1) inz('O'); // Alive
dcl-s off char(1) inz(' '); // Dead
dcl-s rowoff char(m_maxx);
dcl-s rowon char(m_maxx);
// Default
pattern='example00.rle';
NrIter=300;
bounce='Y';
msg='';
dow 1=1;
*in01=off; // Input parameters
exfmt fmt01;
if dspf.exit;
*inlr=*on;
return;
ENDIF;
*in01=off; // parameters protected
// All off
set_alloff();
// Load pattern
if not load_pattern(pattern);
iter;
ENDIF;
msg =' Press Enter to start!';
exfmt fmt01;
if dspf.exit;
*inlr=*on;
return;
ENDIF;
// Loop for NrIter iteration
for g=2 to NrIter;
check_matrix();
msg='Looping through generations ';
//write fmt02;
write fmt01;
usleep(50000);
endfor;
enddo;
*inlr = *on ;
//-----------------------------------
// set_alloff
//-----------------------------------
dcl-proc set_alloff ;
dcl-pi set_alloff;
END-PI;
dcl-ds row qualified;
pixel char(1) dim(m_maxx);
END-DS;
for x=1 to m_maxx;
row.pixel(x)=off;
ENDFOR;
rowoff=row;
for y=1 to maxy;
rows(y)=rowoff;
ENDFOR;
// Inizializate Rowon (bounce)
for x=1 to m_maxx;
row.pixel(x)=on;
ENDFOR;
rowon= row;
END-PROC;
//-----------------------------------
// load_pattern;
//-----------------------------------
dcl-proc load_pattern ;
dcl-pi load_pattern ind;
pattern char(30) const;
END-PI;
dcl-s PathFile varchar(300);
dcl-s okRule ind;
dcl-s Startx int(5);
dcl-s Starty int(5);
pathFile='/home/faq400/GameOfLife/'+pattern;
if not get_start(Startx:Starty:pathfile);
return *off;
ENDIF;
// Read and set Pattern splitting RLE Text file in
// ROWS ($ divided)
set_pattern(Startx:Starty:pathfile);
return *on;
END-PROC;
//-----------------------------------
// get_start;
//-----------------------------------
dcl-proc get_start ;
dcl-pi get_start ind;
StartX int(5);
StartY int(5);
pathfile varchar(300) const;
END-PI;
dcl-s RLEHeader char(300);
startx=0;
starty=0;
// Pattern must be in B3/S23 Rule for GameOfLife
exec sql
declare RLEH cursor for
select trim(value) as RLEheader
from table(faq400.ReadIFSFR(trim(:pathfile), X'25'))
,table(faq400.split(linetext, ','))
where lower(linetext) like '%rule = b3/s23%';
exec sql open RLEH;
dow 1=1;
exec sql fetch RLEH into : RLEHeader :Null_ds;
select;
when sqlcod=100;
exec sql close RLEH;
leave;
when sqlcod<>0;
msg='Error SQL '+%editc(sqlcod:'X');
exec sql close RLEH;
return *off;
ENDSL;
select;
// StartX
when %subst(RLEHeader:1:3)='x =';
monitor;
Startx=%dec(%subst(RLEHeader:4:3):3:0);
on-error;
endmon;
when %subst(RLEHeader:1:2)='x=';
monitor;
Startx=%dec(%subst(RLEHeader:3:3):3:0);
on-error;
endmon;
// StartY
when %subst(RLEHeader:1:3)='y =';
monitor;
StartY=%dec(%subst(RLEHeader:4:3):3:0);
on-error;
endmon;
when %subst(RLEHeader:1:3)='y=';
monitor;
StartY=%dec(%subst(RLEHeader:3:3):3:0);
on-error;
endmon;
ENDSL;
ENDDO;
// No startx or Starty ... KO
if Startx=0 or Starty=0;
msg='Starting coordinates not found';
return *off;
ENDIF;
// Ok
return *on;
END-PROC;
//-----------------------------------
// set_pattern;
//-----------------------------------
dcl-proc set_pattern ;
dcl-pi set_pattern ind;
StartX int(5) const;
StartY int(5) const;
pathfile varchar(300) const;
END-PI;
dcl-s RLERow char(300);
dcl-s Currentx int(5);
dcl-s Currenty int(5);
dcl-s Repetition int(5);
dcl-s iChar char(1);
// Starty - start line
Currenty=Starty;
// Split RLE text file in ROWS using $ as separator
exec sql
declare RLER cursor for
select trim(value) as RLErow
from table(faq400.ReadIFSFR(trim(:pathfile), X'25'))
,table(faq400.split(linetext, '$')) s
where lower(linetext) not like 'x =%'
and lower(linetext) not like 'x=%'
and lower(linetext) not like '#n%'
and lower(linetext) not like '#c%'
order by line_no;
exec sql open RLER;
dow 1=1;
exec sql fetch RLER into : RLErow :Null_ds;
select;
when sqlcod=100;
exec sql close RLER;
leave;
when sqlcod<>0;
exec sql close RLER;
return *off;
ENDSL;
// New line, start column
Currentx=Startx;
// Try to parse the row char by char
repetition=0;
for i=1 to %len(%trim(RLErow));
ichar=%subst(RLErow:i:1);
select;
// tag 'b' dead cell ... set a r-cell as dead
when ichar='b'; // dead cell
set_npixel(currentx:currenty:repetition:*off);
// tag 'o' alive cell ... set a r-cell as alive
when ichar='o'; // alive cell
set_npixel(currentx:currenty:repetition:*on);
// number
when ichar>='0'
and ichar<='9';
repetition=repetition*10+%dec(ichar:1:0);
ENDSL;
ENDFOR;
// Next row y
Currenty+=1;
ENDDO;
return *on;
END-PROC;
//-----------------------------------
// set_generation();
//-----------------------------------
dcl-proc set_generation ;
dcl-pi set_generation;
generation int(5) const;
END-PI;
select;
when generation=1; // Blinker
setPixel_alive(50:10);
setPixel_alive(50:11);
setPixel_alive(50:12);
when generation=2; // glider
setPixel_alive(3:2);
setPixel_alive(4:3);
setPixel_alive(2:4);
setPixel_alive(3:4);
setPixel_alive(4:4);
when generation=3; // glider3
setPixel_alive(2:2);
setPixel_alive(3:3);
setPixel_alive(4:3);
setPixel_alive(2:4);
setPixel_alive(3:4);
when generation=4; // glider4
setPixel_alive(2:2);
setPixel_alive(3:3);
setPixel_alive(4:3);
setPixel_alive(2:2);
setPixel_alive(2:3);
when generation=5;
ENDSL;
END-PROC;
//-----------------------------------
// check_matrix;
//-----------------------------------
dcl-proc check_matrix;
dcl-pi check_matrix;
END-PI;
dcl-ds row qualified;
pixel char(1) dim(m_maxx);
END-DS;
dcl-s neighbours int(5);
for y=1 to maxy;
row=rows(y);
for x=1 to m_maxx;
// if pixel is alive
if row.pixel(x)=on;
neighbours=neighbours_count(x:y:bounce);
row.pixel(x)=alivePixel_rules(neighbours);
else;
// if is death
neighbours=neighbours_count(x:y:'N');
row.pixel(x)=deadPixel_rules(neighbours);
ENDIF;
ENDFOR;
// save row in the matrix
matrixNextGen.rows(y)=row;
ENDFOR;
// Show Next Generation
matrix=MatrixNextGen;
END-PROC;
//-----------------------------------
// neighbours_count(x:y)
//-----------------------------------
dcl-proc neighbours_count ;
dcl-pi neighbours_count int(5);
x int(5) const;
y int(5) const;
ibounce char(1) const;
END-PI;
dcl-s count int(5);
dcl-ds row qualified;
pixel char(1) dim(m_maxx);
END-DS;
// Same row
row=getrow(y:ibounce);
count+=ifalive(row:x-1);
count+=ifalive(row:x+1);
// upper row
row=getrow(y-1:ibounce);
count+=ifalive(row:x-1);
count+=ifalive(row:x);
count+=ifalive(row:x+1);
// lower row
row=getrow(y+1:ibounce);
count+=ifalive(row:x-1);
count+=ifalive(row:x);
count+=ifalive(row:x+1);
return count;
end-proc ;
//-----------------------------------
// getrow(y)
//-----------------------------------
dcl-proc getrow ;
dcl-pi getrow char(m_maxx);
y int(5) const;
ibounce char(1) const;
END-PI;
if y>=1 and y<=maxy;
return rows(y);
else;
if ibounce='Y';
return rowon;
else;
return rowoff;
ENDIF;
ENDIF;
end-proc ;
//-----------------------------------
// ifalive(x:y)
//-----------------------------------
dcl-proc ifalive ;
dcl-pi ifalive int(5);
irow char(m_maxx) const;
x int(5) const;
END-PI;
dcl-ds row qualified;
pixel char(1) dim(m_maxx);
END-DS;
row=irow;
if x>=1 and x<=m_maxx;
if row.pixel(x)=on;
return 1; // alive
ENDIF;
ENDIF;
return 0; // death
end-proc ;
//-----------------------------------
// alivePixel_rules
//-----------------------------------
dcl-proc alivePixel_rules ;
dcl-pi alivePixel_rules char(1);
neighbours int(5) const;
END-PI;
select;
when neighbours<=1; // die
return off;
when neighbours<=3; // rest alive
return on;
when neighbours>3; // die
return off;
ENDSL;
end-proc ;
//-----------------------------------
// deathPixel_rules
//-----------------------------------
dcl-proc deadPixel_rules ;
dcl-pi deadPixel_rules char(1);
neighbours int(5) const;
END-PI;
select;
when neighbours=3; // becomes alive
return on;
other; // rest dead
return off;
ENDSL;
end-proc ;
//-----------------------------------
// set_NPixel
//-----------------------------------
dcl-proc set_nPixel ;
dcl-pi set_nPixel;
currentx int(5);
currenty int(5);
repetition int(5);
on_off ind const;
END-PI;
dcl-s i int(5);
if repetition=0;
repetition=1;
ENDIF;
for i=1 to repetition;
if on_off;
setPixel_alive(currentx:currenty);
else;
setPixel_dead(currentx:currenty);
ENDIF;
currentx+=1;
ENDFOR;
// Reset repetition;
repetition=0;
end-proc ;
//-----------------------------------
// setPixel_alive
//-----------------------------------
dcl-proc setPixel_alive ;
dcl-pi setPixel_alive;
x int(5) const;
y int(5) const;
END-PI;
dcl-ds row qualified;
pixel char(1) dim(m_maxx);
END-DS;
if x>=1 and x<=m_maxx and
y>=1 and y<=m_maxy;
row=rows(y);
row.pixel(x)=on;
rows(y)=row;
endif;
end-proc ;
//-----------------------------------
// setPixel_dead
//-----------------------------------
dcl-proc setPixel_dead ;
dcl-pi setPixel_dead;
x int(5) const;
y int(5) const;
END-PI;
dcl-ds row qualified;
pixel char(1) dim(m_maxx);
END-DS;
if x>=1 and x<=m_maxx and
y>=1 and y<=m_maxy;
row=rows(y);
row.pixel(x)=off;
rows(y)=row;
endif;
end-proc ;
Raw
READIFSFR_RPGLE
// READIFSFR - Read an IFS Text File
//
// This program will read an IFS file and
// return one line at a time based on the
// delimiter parameter.
//
//
// SQL Function Registration:
// ====================================
// Create Function xxxxx/ReadIFSFR
// (FileName VarChar(128),
// EOL_Delim VarChar(10))
// Returns Table
// (Line_No Integer,
// Cont_No Integer,
// LineText VarChar(2048))
// External
// Language RPGLE
// Disallow Parallel
// Returns Null On Null Input
// Parameter Style DB2SQL
//
//
// Common EBCDIC EOL Characters:
// =============================
// CR X'0D'
// LF X'25'
// CRLF X'0D25'
//
//
// Example:
// Select *
// From Table(ReadIFSFR('/data/ItemList.txt',X'0D25')) A
//
//
//
// Compile Instructions:
// CRTBNDRPG SRCFILE(xxxxx/QRPGLESRC) PGM(xxxxx/READIFSFR)
// -or-
// PDM Option 14
//
//
// NOTES:
// * Minimum of V5R2 Required
// * Adopted Authority Does Not work with IFS Files
//
H ActGrp(*Caller) DftActGrp(*No) UsrPrf(*Owner)
// SQL State
D SQLState S 5
// Function Name Schema.Def name - Input only
D Function_Name S 517
// Function Specifc Name - Input Only
D Specific_Name S 128
// Message Text - Input/Output
D Msg_Text S 70 Varying
//
// Misc Program Variables
//
D FileHandle S 10I 0
D Null C X'00'
D WrkFile S 128
D ReadLine PR N
D pDelim 10 Varying
D pLineText 2048 Varying
D pLine_No 10I 0
D pCont_No 10I 0
//
// IFS API Prototypes and Constants
//
DOpen PR 10I 0 ExtProc('open')
D Filename * Value
D OpenFlags 10I 0 Value
D Mode 10U 0 Value Options(*NoPass)
D CodePage 10U 0 Value Options(*NoPass)
// Read an IFS file
DRead PR 10I 0 ExtProc('read')
D FileHandle 10I 0 Value
D Buffer * Value
D NumberOfBytes 10U 0 Value
// Close an IFS file
DClose PR 10I 0 ExtProc('close')
D FileHandle 10I 0 Value
// File Access Modes for Open API
D O_RDONLY S 10I 0 Inz(1)
D O_TEXTDATA S 10I 0 Inz(16777216)
//
// Table Function Inputs
//
D FileName S 128 Varying
D EOL_Delim S 10 Varying
//
// Table Function Columns
// NOTE: If the file has over 2 billion lines
// this value will be incorrect (signed int)
D Line_No S 10I 0
D Cont_No S 10I 0
D LineText S 2048 Varying
//
// NULL Indicator Variables
//
D FileName_NI S 5I 0
D EOL_Delim_NI S 5I 0
D Line_No_NI S 5I 0
D Cont_No_NI S 5I 0
D LineText_NI S 5I 0
//
// UDTF Call Type Parm
//
D CallType s 10i 0
//
// UDTF call parameter constants
//
D UDTF_FirstCall s 10i 0 Inz(-2)
D UDTF_Open s 10i 0 Inz(-1)
D UDTF_Fetch s 10i 0 Inz(0)
D UDTF_Close s 10i 0 Inz(1)
D UDTF_LastCall s 10i 0 Inz(2)
//
// SQL States
//
D SQLSTATEOK c '00000'
D ENDOFTABLE c '02000'
D UDTF_ERROR c 'US001'
//
// NULL Constants
//
D ISNULL c -1
D NOTNULL c 0
C *Entry PList
//
// Function input parameters
//
C Parm FileName
C Parm EOL_Delim
//
// Function output parameters
//
C Parm Line_No
C Parm Cont_No
C Parm LineText
//
// Function NULL input parameter indicators
//
C Parm FileName_NI
C Parm EOL_Delim_NI
//
// Function NULL output parameter indicators
//
C Parm Line_No_NI
C Parm Cont_No_NI
C Parm LineText_NI
//
// DB2SQL Style Parms
//
C Parm SQLState
C Parm Function_Name
C Parm Specific_Name
C Parm Msg_Text
//
// UDTF CallType flag parm (Open,Fetch,Close)
//
C Parm CallType
C/Free
Select;
When CallType=UDTF_Open;
//
// Open Stream File
//
WrkFile=FileName+NULL;
FileHandle=Open(%Addr(WrkFile)
:O_RDONLY+O_TEXTDATA);
If FileHandle<*Zero;
SQLState=UDTF_Error;
Msg_Text='Couldn''t open requested file.';
EndIf;
When CallType=UDTF_Fetch;
//
// Read File Line By Line
//
Monitor;
If ReadLine(EOL_Delim:LineText:Line_No:Cont_No);
SQLState=ENDOFTABLE;
EndIf;
On-Error *All;
SQLState=UDTF_Error;
Msg_Text='Error reading IFS file.';
EndMon;
When CallType=UDTF_Close;
CallP Close(FileHandle);
*InLR=*On;
EndSl;
Return;
/End-Free
//--------------------------------------------------------------------
// ReadLine
//--------------------------------------------------------------------
P ReadLine B
D ReadLine PI N
D pDelim 10 Varying
D pLineText 2048 Varying
D pLine_No 10I 0
D pCont_No 10I 0
DdsBufferInfo Ds Static
D NeedMoreData N Inz(*On)
D DelimFound N Inz(*On)
D EOF N Inz(*Off)
D StartPos 5U 0 Inz(1)
D EndPos 5U 0 Inz(0)
D Line_No 10I 0 Inz(0)
D Cont_No 10I 0 Inz(0)
D BufferFixed 2058 Inz(*Blanks)
D Buffer 4116 Inz('') Varying
D SaveData 2058 Inz('') Varying
D BytesToRead S 10I 0 Inz(0)
D BytesRead S 10U 0 Inz(0)
D LineLen S 5U 0 Inz(0)
D DelimLen S 5U 0 Inz(0)
C/Free
LineLen=%Size(pLineText)-2;
DelimLen=%Len(pDelim);
BytesToRead=LineLen+DelimLen;
// If delimiter was found last time through,
// increment line counter
If DelimFound;
DelimFound=*Off;
Line_No+=1;
Cont_No=*Zero;
Else;
Cont_No+=1;
EndIf;
If NeedMoreData;
ExSr ReadFile;
StartPos=1;
If BytesRead=*Zero;
If SaveData>'';
EndPos=%Scan(pDelim:SaveData);
If EndPos>1;
pLineText=%Subst(SaveData:1:EndPos-1);
Else;
pLineText=SaveData;
EndIf;
SaveData='';
pLine_No=Line_No;
pCont_No=Cont_No;
Return *Off;
Else;
// No more data -- prepare for next time
Reset dsBufferInfo;
Return *On;
EndIf;
Else;
NeedMoreData=*Off;
EndIf;
EndIf;
EndPos=%Scan(pDelim:Buffer:StartPos);
If EndPos=*Zero
Or EndPos>StartPos+LineLen;
If LineLen>%Len(Buffer);
LineLen=%Len(Buffer);
EndIf;
pLineText=%Subst(Buffer:StartPos:LineLen);
StartPos+=LineLen;
//
// Get more data if buffer is empty
//
If StartPos>%Len(Buffer);
SaveData='';
NeedMoreData=*On;
//
// Get more data if we don't have enough to cover a full line
//
ElseIf %Len(Buffer)-StartPos+1<LineLen;
SaveData=%Subst(Buffer:StartPos);
NeedMoreData=*On;
EndIf;
pLine_No=Line_No;
pCont_No=Cont_No;
Return *Off;
Else;
DelimFound=*On;
pLineText=%Subst(Buffer:StartPos:EndPos-StartPos);
StartPos=EndPos+DelimLen;
If StartPos>%Len(Buffer);
SaveData='';
NeedMoreData=*On;
ElseIf %Scan(pDelim:Buffer:StartPos)=*Zero;
SaveData=%Subst(Buffer:StartPos);
NeedMoreData=*On;
EndIf;
pLine_No=Line_No;
pCont_No=Cont_No;
Return *Off;
EndIf;
BegSr ReadFile;
If EOF;
BytesRead=*Zero;
Else;
BytesRead=Read(FileHandle:%Addr(BufferFixed):BytesToRead);
If BytesRead<BytesToRead;
EOF=*On;
EndIf;
If BytesRead=*Zero;
Buffer='';
Else;
Buffer=SaveData + %Subst(BufferFixed:1:BytesRead);
EndIf;
EndIf;
EndSr;
/End-Free
P ReadLine E
Raw
READIFSFR_SQL_UDTF
-- Generazione SQL
-- Versione: V7R2M0 140418
-- Generata su: 13/04/20 17:35:11
-- Database relazionale: C2077CCV
-- Opzioni standard: DB2 for i
CREATE FUNCTION FAQ400.READIFSFR (
FILENAME VARCHAR(128) ,
EOL_DELIM VARCHAR(10) )
RETURNS TABLE (
LINE_NO INTEGER ,
CONT_NO INTEGER ,
LINETEXT VARCHAR(2048) )
LANGUAGE RPGLE
SPECIFIC FAQ400.READIFSFR
NOT DETERMINISTIC
READS SQL DATA
RETURNS NULL ON NULL INPUT
EXTERNAL NAME 'FAQ400/READIFSFR'
PARAMETER STYLE DB2SQL ;
GRANT ALTER , EXECUTE
ON SPECIFIC FUNCTION FAQ400.READIFSFR
TO FAQ400 WITH GRANT OPTION ;
GRANT EXECUTE
ON SPECIFIC FUNCTION FAQ400.READIFSFR
TO PUBLIC ;
Raw
SPLIT_SQL_UDTF
-- Generazione SQL
-- Versione: V7R2M0 140418
-- Generata su: 13/04/20 17:35:51
-- Database relazionale: C2077CCV
-- Opzioni standard: DB2 for i
SET PATH "QSYS","QSYS2","SYSPROC","SYSIBMADM","FAQ400" ;
CREATE FUNCTION FAQ400.SPLIT (
VDATA VARCHAR(32000) ,
VDELIMITER VARCHAR(5) )
RETURNS TABLE (
"ID" INTEGER ,
"VALUE" VARCHAR(256) )
LANGUAGE SQL
SPECIFIC FAQ400.SPLIT
DETERMINISTIC
READS SQL DATA
CALLED ON NULL INPUT
NOT FENCED
SET OPTION ALWBLK = *ALLREAD ,
ALWCPYDTA = *OPTIMIZE ,
COMMIT = *NONE ,
DECRESULT = (31, 31, 00) ,
DYNDFTCOL = *NO ,
DYNUSRPRF = *USER ,
SRTSEQ = *HEX
RETURN
WITH CTE_ITEMS ( ID , STARTSTRING , STOPSTRING ) AS
(
SELECT
1 AS ID
, 1 AS STARTSTRING
, LOCATE ( VDELIMITER , VDATA ) AS STOPSTRING
FROM SYSIBM . SYSDUMMY1
WHERE LENGTH ( VDELIMITER ) > 0
AND LENGTH ( VDATA ) > 0
UNION ALL
SELECT
ID + 1
, STOPSTRING + LENGTH ( VDELIMITER )
, LOCATE ( VDELIMITER , VDATA , STOPSTRING + LENGTH ( VDELIMITER ) )
FROM
CTE_ITEMS
WHERE
STOPSTRING > 0
)
SELECT ID , SUBSTRING ( VDATA , STARTSTRING ,
CASE WHEN STOPSTRING = 0
THEN LENGTH ( VDATA )
ELSE STOPSTRING - STARTSTRING END )
FROM CTE_ITEMS ;
GRANT ALTER , EXECUTE
ON SPECIFIC FUNCTION FAQ400.SPLIT
TO FAQ400 WITH GRANT OPTION ;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment