/* REXX - %include book parser */
/*** trace ?r ***************************************************** \| *
* (C) Copyright Robert AH Prins, 1992-2016 *
************************************************************************
* ------------------------------------------------------------------ *
* | Date | By | Remarks | *
* |------------+------+----------------------------------------------| *
* | | | | *
* |------------+------+----------------------------------------------| *
* | 2016-02-11 | RAHP | Add support for AREA | *
* |------------+------+----------------------------------------------| *
* | 2009-04-22 | RAHP | Update comment | *
* |------------+------+----------------------------------------------| *
* | 2009-03-30 | RAHP | Put under GPL V3 | *
* |------------+------+----------------------------------------------| *
* | 2009-03-16 | RAHP | Replace LISTDSI by BXPWDYN | *
* |------------+------+----------------------------------------------| *
* | 2007-09-24 | RAHP | Remove call to 'GETTEMP' | *
* |------------+------+----------------------------------------------| *
* | 2007-08-30 | RAHP | Use '(C)' comment delimiters in parse code | *
* |------------+------+----------------------------------------------| *
* | 2007-08-16 | RAHP | Split comment delimiters in strings | *
* |------------+------+----------------------------------------------| *
* | 2007-04-03 | RAHP | Map FILE to pointer | *
* |------------+------+----------------------------------------------| *
* | 2007-03-26 | RAHP | Store pop-up panel in exec | *
* |------------+------+----------------------------------------------| *
* | 2005-03-31 | RAHP | Add support for CHAR lengths > 9999 | *
* |------------+------+----------------------------------------------| *
* | 2001-06-14 | RAHP | Add support for BIT & FLOAT | *
* | | | Reduce levels to lowest possible | *
* |------------+------+----------------------------------------------| *
* | 1997-12-04 | RAHP | Allow INIT(IAL) in structures | *
* | | | (INIT(IAL) CALL not yet supported and don't | *
* | | | use INIT(IAL) as a name...) | *
* |------------+------+----------------------------------------------| *
* | 1997-05-24 | RAHP | Use GETVAR for some variables | *
* |------------+------+----------------------------------------------| *
* | 1995-07-10 | RAHP | Add minimal support for bit variables | *
* | | | (Treat as CHAR and ALIGNED!) | *
* |------------+------+----------------------------------------------| *
* | 1995-04-21 | RAHP | Add support for nested %includes | *
* |------------+------+----------------------------------------------| *
* | 1994-11-02 | RAHP | Add call to GURU for errors | *
* |------------+------+----------------------------------------------| *
* | 1993-11-01 | RAHP | Add support for pointers | *
* |------------+------+----------------------------------------------| *
* | 1992-02-20 | RAHP | Initial version | *
* |------------+------+----------------------------------------------| *
************************************************************************
* Name - RAP00110 *
* *
* Function - Parse a PL/I structure into a well defined format for *
* use by other utilities *
* *
* Arguments - PL/I %include book compressed into a single record with *
* x'ff' separating the original fields *
* - Optional, 'E' to 'explode' the arrays within the first *
* argument *
* - Optional, 'nopli', to omit PL/I attributes from the *
* returned record *
* *
* Returns : A single record containing a detailed break-up of the *
* original PL/I %include book. *
* *
* The record has the following structure: *
* *
* HEAD : x'00ffd9d7' *
* *
* followed by *
* *
* LEVEL : level of element of structure *
* SEP : x'ff' *
* NAME : name of element of structure *
* SEP : x'ff' *
* PLI : PL/I attributes (Not if 'nopli' is specified) *
* SEP : x'ff' *
* LENGTH: - bytes for FIXED BIN & CHAR variables *
* - digits for FIXED & PIC variables *
* SEP : x'ff' *
* PREC : precision for FIXED & PIC variables *
* SEP : x'ff' *
* TYPE : one character type of element descriptor *
* - A: pointer *
* - B: fixed bin *
* - C: char *
* - D: float *
* - F: fixed *
* - I: bit *
* - L: major structure *
* - P: picture *
* - R: area *
* - V: char var *
* SEP : x'01d9d701' *
* *
* for each element of the original structure, followed by *
* *
* TAIL : x'd7d9ff00' *
* *
* An example of the usage of this module is: *
* *
* 'execio * diskr idsn ( stem anyvar. finis' *
* *
* compress = '' *
* do i = 1 to anyvar.0 *
* compress = compress || x2c(ff) || strip(substr(anyvar.i, 2, 71)) *
* end *
* *
* call rap00110 compress (,e) (,nopli) *
* *
* tmp = result *
* *
* head = x2c(00ffd9d7) *
* tail = reverse(head) *
* sep = x2c(ff) *
* rsep = x2c(01d9d701) *
* *
* if substr(tmp, 1, 4) \= head |, *
* substr(tmp, length(tmp) - 3, 4) \= tail then *
* do *
* say 'The parser has returned an invalid string,', *
* 'processing terminated' *
* exit *
* end *
* *
* drop v. *
* vi = 0 *
* *
* tmp = substr(tmp, 5) *
* *
* do until tmp = tail *
* vi = vi + 1 *
* parse value tmp with v.vi.lev (sep), *
* v.vi.nam (sep), *
* v.vi.pli (sep), *
* v.vi.len (sep), *
* v.vi.prc (sep), *
* v.vi.typ (rsep) tmp *
* end *
* *
* v.0 = vi *
************************************************************************
* Send questions, suggestions and/or bug reports to: *
* *
* robert@prino.org / robert.ah.prins@gmail.com *
* *
* Robert AH Prins *
* Taboralaan 46 *
* 8400 Oostende *
* Belgium *
************************************************************************
* This program is free software: you can redistribute it and/or *
* modify it under the terms of the GNU General Public License as *
* published by the Free Software Foundation, either version 3 of *
* the License, or (at your option) any later version. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
* GNU General Public License for more details. *
* *
* You should have received a copy of the GNU General Public License *
* along with this program. If not, see <https://www.gnu.org/licenses/> *
***********************************************************************/
rap00110:
arg inrec, expand, nopli
parse source source
parse value source with . . moi .
signal on syntax
sep = x2c(ff)
tmp = translate(space(inrec))
scom = '/' || '*'
ecom = '*' || '/'
do until post = ''
parse value tmp with pre (scom) comment (ecom) post
tmp = pre || post
end
inrec = tmp
/*-------------------------------------------------------------------+
| Resolve any embedded %INCLUDEs |
+-------------------------------------------------------------------*/
do while pos('%INCLUDE', inrec) \= 0
parse value inrec with pre '%INCLUDE' rapinc ';' post
rapinc = strip(rapinc)
call pop_up
if result \= 'RESULT' then
inrec = pre || result || post
end
in.0 = 8
in.1 = ' INIT('
in.2 = sep || 'INIT('
in.3 = ' INIT ('
in.4 = sep || 'INIT ('
in.5 = ' INITIAL('
in.6 = sep || 'INITIAL('
in.7 = ' INITIAL ('
in.8 = sep || 'INITIAL ('
in.9 = ' INIT CALL '
in.10 = sep || 'INIT CALL '
in.11 = ' INITIAL CALL '
in.12 = sep || 'INITIAL CALL '
/*-------------------------------------------------------------------+
| Remove any initialisations, except calls... |
+-------------------------------------------------------------------*/
do i = 1 to in.0
l = length(in.i)
p = pos(in.i, inrec)
do while p \= 0
pre = substr(inrec, 1, p - 1)
post = substr(inrec, p + l)
par = 1
do p = 1 until par = 0
c = substr(post, p, 1)
select
when c = ')' then par = par - 1
when c = '(' then par = par + 1
otherwise
end
end
inrec = pre || substr(post, p + 1)
p = pos(in.i, inrec)
end
end
vi = 0
r = ''
drop v.
arrays = 0
/*-------------------------------------------------------------------+
| Main parse loop |
+-------------------------------------------------------------------*/
do until inrec = ''
parse value strip(inrec) with t (sep) inrec
t = r strip(t)
if substr(t, length(t), 1) \= ',' &,
substr(t, length(t), 1) \= ';' then
r = t
else
if strip(t) \= '' then
do
r = ''
parse value strip(t) with level ' ' t
if level = 'DCL' |,
level = 'DECLARE' then
parse value strip(t) with level ' ' t
parse value strip(t) with name ' ' type
level = strip(level, 'l', '0')
name = strip(name)
type = strip(type)
if substr(type, 1, 1) = '(' then
do
parse value type with array ')' type
type = strip(type)
name = name || strip(array)')'
end
/*-----------------------------------------------------------+
| Get rid of 'UNALIGNED' |
+-----------------------------------------------------------*/
parse value type with pre 'UNALIGNED' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'UNAL' |
+-----------------------------------------------------------*/
parse value type with pre 'UNAL' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'ALIGNED' |
+-----------------------------------------------------------*/
parse value type with pre 'ALIGNED' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'DECIMAL' |
+-----------------------------------------------------------*/
parse value type with pre 'DECIMAL' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'DEC' |
+-----------------------------------------------------------*/
parse value type with pre 'DEC' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'TURE' (from picture) |
+-----------------------------------------------------------*/
parse value type with pre 'TURE' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'ARY' (from binary) |
+-----------------------------------------------------------*/
parse value type with pre 'ARY' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'ACTER' (from character) |
+-----------------------------------------------------------*/
parse value type with pre 'ACTER' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of 'YING' (from varying) |
+-----------------------------------------------------------*/
parse value type with pre 'YING' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Replace 'POINTER' by 'PTR' |
+-----------------------------------------------------------*/
if pos('POINTER', type) \= 0 then
do
parse value type with pre 'POINTER' type
type = strip(pre) 'PTR' strip(type)
end
/*-----------------------------------------------------------+
| Get rid of ',0' in the precision |
+-----------------------------------------------------------*/
parse value type with pre ',0' type
type = strip(pre)strip(type)
/*-----------------------------------------------------------+
| Get rid of any spaces after a variable |
+-----------------------------------------------------------*/
if length(type) \= 0 then
if substr(type, length(type), 1) = ',' then
type = strip(strip(type,,','))','
else
if substr(type, length(type), 1) = ';' then
type = strip(strip(type,,';'))';'
/*-----------------------------------------------------------+
| Put 'BIN ' before the attributes |
+-----------------------------------------------------------*/
if pos('BIN', type) \= 0 then
do
parse value type with pre 'BIN' type
type = 'BIN 'strip(pre)strip(type)
end
/*-----------------------------------------------------------+
| Put 'FIXED ' before the attributes |
+-----------------------------------------------------------*/
if pos('FIXED', type) \= 0 then
do
parse value type with pre 'FIXED' type
type = 'FIXED 'strip(pre)strip(type)
end
/*-----------------------------------------------------------+
| Realign the type and precision fields |
+-----------------------------------------------------------*/
select
when pos('BIN', type) \= 0 then
do
parse value type with pre '(' type
type = strip(pre) '('type
end
when pos('FIXED', type) \= 0 then
do
parse value type with pre '(' type
type = strip(pre)left(' ', 9 - length(type))'('type
end
when pos('CHAR', type) \= 0 then
do
parse value type with pre '(' type
if pos('VAR', type) \= 0 then
do
type = ' ' || type || ' '
parse value type with ts 'VAR' te
type = space(ts || strip(te,,','))
!v = ' VAR'
end
else
!v = ''
type = strip(pre) ||,
left(' ', 10 - length(type))'('type || !v || ','
end
otherwise
end
/*-----------------------------------------------------------+
| Obtain the length, precision and type of the fields |
+-----------------------------------------------------------*/
select
when pos('PTR', type) \= 0 then
do
l = 4
prec = 0
tov = 'A'
end
when pos('FILE', type) \= 0 then
do
l = 4
prec = 0
tov = 'A'
end
when pos('FLOAT', type) \= 0 then
do
parse value type with . '(' l ')' .
if pos('BIN', type) \= 0 then
select
when l <= 21 then l = 4
when l <= 53 then l = 8
otherwise l = 16
end
else
select
when l <= 6 then l = 4
when l <= 16 then l = 8
otherwise l = 16
end
prec = 0
tov = 'D'
end
when pos('BIN', type) \= 0 then
do
parse value type with . '(' l ')' .
l = (l + 1) % 8
prec = 0
tov = 'B'
end
when pos('BIT', type) \= 0 then
do
parse value type with . '(' l ')' .
l = (l + 7) % 8
prec = 0
tov = 'I'
end
when pos('CHAR', type) \= 0 then
do
parse value type with . '(' l ')' cv
l = l
prec = 0
if pos('VAR', cv) = 0 then
tov = 'C'
else
tov = 'V'
end
when pos('AREA', type) \= 0 then
do
parse value type with . '(' l ')' .
l = l + 16
prec = 0
tov = 'R'
end
when pos('FIXED', type) \= 0 then
if pos(',', strip(type,,',')) \= 0 then
do
parse value strip(type,,',') with . '(' l ',' p ')'
l = l
prec = p
tov = 'F'
end
else
do
parse value strip(type,,',') with . '(' l ')'
l = l
prec = 0
tov = 'F'
end
when pos('PIC', type) \= 0 then
do
parse value type with . '''' tmp '''' .
do while pos('(', tmp) \= 0
parse value tmp with pre '(' cnt ')' tmp
c = substr(tmp, 1, 1)
tmp = strip(pre) ||,
left(c, cnt - 1, c) ||,
strip(tmp)
end
if pos('V', tmp) \= 0 then
do
parse value tmp with b 'V' a
l = length(a) + length(b)
prec = length(a)
tov = 'P'
end
else
do
l = length(tmp)
prec = 0
tov = 'P'
end
end
otherwise
do
l = 0
prec = 0
tov = 'L'
end
end
vi = vi + 1
v.0 = vi
v.vi.lev = level
v.vi.nam = name
v.vi.pli = type
v.vi.len = l
v.vi.prc = prec
v.vi.typ = tov
v.vi.arr = pos('(', name) \= 0
arrays = arrays + v.vi.arr
v.vi = v.vi.lev v.vi.nam v.vi.pli
end
end
if arg(2, 'e') then
do
call explode
compress = ''
do ei = 1 to e.0
compress = compress sep strip(e.ei)
end
interpret 'call' moi 'compress'
end
head = x2c(00ffd9d7)
tail = reverse(head)
rsep = x2c(01d9d701)
/*-------------------------------------------------------------------+
| Reduce v.vi.lev values to their lowest possible values |
| |
| - collect all levels used |
| - store in a sorted string |
| - match existing levels on string and set to wordpos of match in |
| string |
+-------------------------------------------------------------------*/
lev. = 0
max = -1
level = ''
do i = 1 to v.0
l = +v.i.lev
lev.l = l
max = max(max, l)
end
do i = 1 to max
if lev.i \= 0 then
level = level lev.i
end
if word(level, 1) = '2' then
level = '1' level
do vi = 1 to v.0
l = +v.vi.lev
ok = 0
do w = 1 to words(level) until ok
if l = word(level, w) then
do
v.vi.lev = w
ok = 1
end
end
end
/*-------------------------------------------------------------------+
| Create output record for caller |
+-------------------------------------------------------------------*/
outrec = head
if arg(3, 'e') then
do vi = 1 to v.0
outrec = outrec || v.vi.lev || sep ||,
v.vi.nam || sep ||,
v.vi.len || sep ||,
v.vi.prc || sep ||,
v.vi.typ || rsep
end
else
do vi = 1 to v.0
outrec = outrec || v.vi.lev || sep ||,
v.vi.nam || sep ||,
v.vi.pli || sep ||,
v.vi.len || sep ||,
v.vi.prc || sep ||,
v.vi.typ || rsep
end
outrec = outrec || tail
return outrec
/***********************************************************************
* Explode: *
* *
* This routine is optionally called to explode the arrays that may be *
* present in the original PL/I %include member. Array explosion is *
* necessary to map the structure to a record for the formatted *
* browse and edit functions. *
***********************************************************************/
explode:
xpni = 0
xpn. = 0
do i = 1 to arrays
slev = 0
/*-----------------------------------------------------------------+
| Find, starting at the end of the structure, the array that is |
| on the lowest level and save its position and level |
+-----------------------------------------------------------------*/
do vi = v.0 to 1 by -1
if v.vi.arr &,
v.vi.lev > slev then
do
svi = vi
slev = v.vi.lev
end
end
/*-----------------------------------------------------------------+
| Assume the array is a non-structure array |
| Reset the array indicator |
+-----------------------------------------------------------------*/
v.svi.exp = ''
v.svi.arr = 0
/*-----------------------------------------------------------------+
| Set up a list of all elements of the structure that are part |
| of the array, that is all subsequent elements in the structure |
| that are on a lower level |
+-----------------------------------------------------------------*/
do vi = svi + 1 to v.0 while v.vi.lev > slev
v.svi.exp = v.svi.exp vi sep
end
/*-----------------------------------------------------------------+
| Initialize a temporary structure |
+-----------------------------------------------------------------*/
drop e.
ei = 0
e.0 = 0
/*-----------------------------------------------------------------+
| Initialize an index to hold the bounds of the array |
+-----------------------------------------------------------------*/
drop bn.
bn.0 = 0
jj = 0
/*-----------------------------------------------------------------+
| Parse out the bounds of the array |
+-----------------------------------------------------------------*/
parse value v.svi.nam with . '(' tmp ')' .
do while tmp \= ''
jj = jj + 1
parse value tmp' ' with bn.jj ',' tmp
if pos(':', bn.jj) \= 0 then
do
parse value bn.jj with bnl.jj ':' bnh.jj
end
else
do
bnl.jj = 1
bnh.jj = bn.jj
end
end
bn.0 = jj
/*-----------------------------------------------------------------+
| Explode an array using REXX' capability of dynamically building |
| and executing instructions. In this case a nested do-loop is |
| generated. |
| |
| Variables used: |
| |
| - bn. : the array containing the bounds of the array to be |
| exploded |
| - jj : counter |
| - ei : counter |
| - e. : the array for the exploded array lines |
| - pre : the 'do v1 = 1 to n' instructions |
| - post : the 'end' instructions |
| - postdo: the actions following the 'do' statement |
| - preend: the actions before the 'end' statement |
+-----------------------------------------------------------------*/
pre = ''
post = ''
parse value v.svi.nam with postdo '(' .
postdo = "ei = ei + 1; e.ei = '"postdo"('"
preend = ''
/*-----------------------------------------------------------------+
| From the last bound to the first |
+-----------------------------------------------------------------*/
do jj = bn.0 to 1 by -1
/*---------------------------------------------------------------+
| Add an iterative 'do' statement in front of the current one |
+---------------------------------------------------------------*/
pre = 'do jj.'jj' = 'bnl.jj' to 'bnh.jj || ';'|| pre;
/*---------------------------------------------------------------+
| Add an 'end' statement after the current one |
+---------------------------------------------------------------*/
post = post || ';end'
/*---------------------------------------------------------------+
| Add the required index to the array |
+---------------------------------------------------------------*/
preend = 'jj.'jj || "','" || preend
end
/*-----------------------------------------------------------------+
| Remove that last "','" and add a "')'" or "'),'" to preend |
| depending on the fact of the current array is a single variable |
| array or an array of structures. |
+-----------------------------------------------------------------*/
if substr(strip(v.svi.nam), length(strip(v.svi.nam)), 1) = ',' then
preend = substr(preend, 1, length(preend) - 3)'''),'''
else
preend = substr(preend, 1, length(preend) - 3)''')'''
/*-----------------------------------------------------------------+
| Add some more code to preend to add the level and type of |
| variable to the e's. |
+-----------------------------------------------------------------*/
preend = preend";e.ei = v.svi.lev e.ei v.svi.pli"
/*-----------------------------------------------------------------+
| Execute the generated piece of code |
+-----------------------------------------------------------------*/
interpret pre || postdo || preend || post
e.0 = ei
/*-----------------------------------------------------------------+
| Save the expanded code as an additional field in the v. record |
+-----------------------------------------------------------------*/
v.svi.exp2 = ''
do jj = 1 to e.0
v.svi.exp2 = v.svi.exp2 e.jj sep
end
/*-----------------------------------------------------------------+
| Save order of records that have exp2 fields |
+-----------------------------------------------------------------*/
xpni = xpni + 1
xpn.xpni = svi
xpn.0 = xpni
end
/*-------------------------------------------------------------------+
| Set the exp2 fields of all records that don't have one to the |
| reformatted record |
+-------------------------------------------------------------------*/
do vi = 1 to v.0
if symbol('v.vi.exp2') = 'LIT' then
v.vi.exp2 = v.vi
end
/*-------------------------------------------------------------------+
| Do for all variables that have an extension |
+-------------------------------------------------------------------*/
do xpni = 1 to xpn.0
psi = 0
drop ps.
q = xpn.xpni
/*-----------------------------------------------------------------+
| Parse out the positions of the extensions |
+-----------------------------------------------------------------*/
tmp = v.q.exp
do while pos(sep, tmp) \= 0
psi = psi + 1
parse value tmp with ps.psi (sep) tmp
end
ps.0 = psi
/*-----------------------------------------------------------------+
| Parse out the individual elements of the exploded array |
+-----------------------------------------------------------------*/
exi = 0
drop ex.
tmp = v.q.exp2
do while pos(sep, tmp) \= 0
exi = exi + 1
parse value tmp with ex.exi (sep) tmp
end
ex.0 = exi
/*-----------------------------------------------------------------+
| Add the extension(s) to each element of the exploded array |
+-----------------------------------------------------------------*/
do exi = 1 to ex.0
do psi = 1 to ps.0
l = strip(ps.psi)
ex.exi = ex.exi sep v.l.exp2
end
end
/*-----------------------------------------------------------------+
| Remove the extension (This is possible because they reside on |
| a lower level in the structure) |
+-----------------------------------------------------------------*/
do psi = 1 to ps.0
l = strip(ps.psi)
v.l.exp2 = ''
end
/*-----------------------------------------------------------------*
| Concatenate the extensions for the individual array elements |
| into an extension for the current level of the structure |
+-----------------------------------------------------------------*/
v.q.exp2 = ''
do exi = 1 to ex.0
v.q.exp2 = v.q.exp2 sep ex.exi
end
end
/*-------------------------------------------------------------------+
| Concatenate all residual extensions into a new compressed |
| structure |
+-------------------------------------------------------------------*/
fin = ''
do vi = 1 to v.0
if v.vi.exp2 \= '' then
fin = fin sep v.vi.exp2
end
drop e.
ei = 1
e.0 = 0
/*-------------------------------------------------------------------+
| Break up the new structure in its individual elements, removing |
| all extra separators. |
+-------------------------------------------------------------------*/
do while fin \= ''
parse value fin with e.ei (sep) fin
if e.ei \= '' then
ei = ei + 1
end
e.ei = ''
e.0 = ei - 1
/*-------------------------------------------------------------------+
| Translate all ';'s (except the last) that may have been created |
| by exploding the arrays into ','s |
+-------------------------------------------------------------------*/
do ei = 1 to e.0
if ei < e.0 then
e.ei = translate(e.ei, ',', ';')
end
return
/***********************************************************************
* SYNTAX: *
* *
* This procedure gives a 'clean' exit for errors *
***********************************************************************/
syntax:
call guru source,rc,sigl,sourceline(sigl)
exit
/***********************************************************************
* POP_UP: *
* *
* Display a pop-up panel to ask for the .INC library *
***********************************************************************/
pop_up:
call load_dynlib
"ispexec libdef ispplib library id("dynlib") stack"
"ispexec addpop row(10) column(-1)"
cursor = 'raplib'
do until rc = 'OK' | resp = 'END'
do until rc \= 0
"ispexec display panel("moi") msg(isrz001) cursor("cursor")"
end
if resp \= 'END' then
do
rapincm = ''
raplibm = ''
/*-------------------------------------------------------------+
| Check that the user entered a valid dataset |
+-------------------------------------------------------------*/
if raplib \= strip(raplib,, '''') then
do
incdsn = "'" || strip(raplib,,'''')'('rapinc')' || "'"
rc = sysdsn("'" || strip(raplib,,'''')'('rapinc')' || "'")
end
else
do
incdsn = raplib'('rapinc')'
rc = sysdsn(raplib'('rapinc')')
end
select
when rc = 'OK' then nop
when rc = 'DATASET NOT FOUND' then
do
raplibm = raplib 'not found'
cursor = 'raplib'
end
when rc = 'MEMBER NOT FOUND' then
do
rapincm = ''''rapinc''' not found in' raplib
cursor = 'raplib'
end
otherwise
do
zedlmsg = rc
cursor = 'raplib'
end
end
end
end
"ispexec rempop"
"ispexec libdef ispplib"
"free f("dynlib")"
/*-------------------------------------------------------------------+
| User entered 'END', display a message |
+-------------------------------------------------------------------*/
if resp = 'END' then
do
zedsmsg = ''
zedlmsg = left('*', 75, '*')
zedlmsg = zedlmsg '*' center('Nested %INCLUDE not resolved,',
'application terminated', 71) '*'
zedlmsg = zedlmsg left('*', 75, '*')
"ispexec setmsg msg(ISRZ001)"
exit '%INCLUDE'
end
/*-------------------------------------------------------------------+
| Save for multiple invocations in same session |
+-------------------------------------------------------------------*/
"ispexec vput (raplib) shared"
"alloc f(#) da("incdsn") shr reu"
'execio * diskr # ( stem #. finis'
"free f(#)"
!inc = ''
scom = '/' || '*'
ecom = '*' || '/'
do ! = 1 to #.0
!inc = !inc || sep || substr(#.!, 2, 71)
end
!inc = space(!inc)
do until !post = ''
parse value !inc with !pre (scom) comment (ecom) !post
!inc = !pre || !post
end
return !inc
/***********************************************************************
* LOAD_DYNLIB: *
* *
* This procedure loads the via EPANQ generated panel, message and *
* skeleton code into a library. Note that there is no reason to use *
* different libraries for any of these objects, as long as they are *
* named differently| *
***********************************************************************/
load_dynlib:
dynlib = 'dyn'random(99999)
alloc = "alloc fi("dynlib") rtdsn(sysdsname) " ||,
"lrecl(80) blksize(0) dir(5) " ||,
"new delete reuse " ||,
"space(1,1)"
rc = bpxwdyn(alloc)
if rc = 0 then
ispdyn = sysdsname
else
ispdyn = 'NOT FOUND'
"newstack"
member = moi
queue ')attr default({$_)'
queue '/' || '***************************************************' ||,
'*******************' || '/'
queue '/' || '* (C) Copyright Robert AH Prins, 1995-' ||,
'2007 *' || '/'
queue '/' || '***************************************************' ||,
'*******************' || '/'
queue '/' || '* ------------------------------------------------' ||,
'---------------- *' || '/'
queue '/' || '* | Date | By | Remarks ' ||,
' | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
'----------------| *' || '/'
queue '/' || '* | | | ' ||,
' | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
'----------------| *' || '/'
queue '/' || '* | 2007-03-26 | RAHP | Change layout ' ||,
' | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
'----------------| *' || '/'
queue '/' || '* | 1995-04-24 | RAHP | Initial version ' ||,
' | *' || '/'
queue '/' || '* |------------+------+----------------------------' ||,
'----------------| *' || '/'
queue '/' || '***************************************************' ||,
'*******************' || '/'
queue '/' || '* Panel - RAP00110 ' ||,
' *' || '/'
queue '/' || '* ' ||,
' *' || '/'
queue '/' || '* This panel is used by the PL/I %include book pars' ||,
'er to obtain the *' || '/'
queue '/' || '* library for any nested %includes. ' ||,
' *' || '/'
queue '/' || '***************************************************' ||,
'*******************' || '/'
queue ' : type(text) intens(low) color(green)'
queue ' ^ type(text) intens(low) skip(on)'
queue ' { type(text) intens(high) color(white)'
queue ' _ type(input) intens(high) color(red)'
queue ' $ type(text) intens(low) color(blue)'
queue ' ¢ type(text) intens(high) color(yellow)'
queue ' ` type(text) intens(high) color(yellow)'
queue ' \ type(text) intens(high) color(turq)'
queue ' ~ type(output) intens(high) color(white) caps(off)'
queue ' @ type(output) intens(high) color(red)'
queue ' '
queue ')body window(77,9) expand(||)'
queue '\'moi' - Nested %include library specification -|-|-'
queue ':Command{==>_zcmd ' ||,
' ^'
queue ' '
queue '$%INCLUDE member {==>@rapinc'
queue ' ~rapincm'
queue '$%INCLUDE library {==>_raplib ' ||,
' ^'
queue ' ~raplibm'
queue ' '
queue '$Press¢ENTER$to parse the nested include or¢END$to cancel ' ||,
'the operation'
queue ')init'
queue ' &rtn = PFK(RETURN)'
queue ')proc'
queue ' &pfkey = .pfkey'
queue ' '
queue ' if (&rtn ^= &z)'
queue ' if (&pfkey = &rtn)'
queue ' .resp = END'
queue ' &resp = end'
queue ' '
queue ' if (.resp = END)'
queue ' &resp = END'
queue ' '
queue ' if (.resp ^= END)'
queue ' if (&raplib = &z)'
queue ' ver(&raplib nb dsnamepq)'
queue ' '
queue ' if (&raplib ^= &z)'
queue ' ver(&raplib dsnamepq)'
queue ' '
queue ' if (.msg ^= '' '')'
queue ' .attr(.cursor) = ''color(green) hilite(reverse)'''
queue ' .resp = ENTER'
queue ' '
queue ' if (.msg = '' '')'
queue ' .resp = END'
queue ' &resp = OK'
queue ')end'
put_object:
tfil = 'tfil'random(9999)
"alloc f("tfil") da('"ispdyn"("member")') shr reu"
"execio" queued() "diskw "tfil" (finis"
"free f("tfil")"
"delstack"
return