/* REXX ISRTHDR Insert header lines to a dataset.
Written by Frank Clarke 20060224
Impact Analysis
. SYSEXEC TRAPOUT
Modification History
ccyymmdd xxx .....
....
*/ arg argline
address TSO /* REXXSKEL ver.20040227 */
arg parms "((" opts
signal on syntax
signal on novalue
call TOOLKIT_INIT /* conventional start-up -*/
rc = Trace("O"); rc = Trace(tv)
info = parms /* to enable parsing */
call A_INIT /* */
"NEWSTACK"
call B_GET_DATA /* */
call C_OUTPUT /* */
"DELSTACK"
if \sw.nested then call DUMP_QUEUE /* -*/
exit /*@ ISRTHDR */
/*
Initialization
. ----------------------------------------------------------------- */
A_INIT: /*@ */
if branch then call BRANCH
address TSO
parse value "" with,
hdr.
parse value "0 0 0 0 0 0 0 0 0 0 0 0 0" with,
hdrct ,
.
call AK_KEYWDS /* */
return /*@ A_INIT */
/*
. ----------------------------------------------------------------- */
AK_KEYWDS: /*@ */
if branch then call BRANCH
address TSO
sw.0Shift = SWITCH("SHIFT") /* data has no ASA */
indsn = KEYWD("INPUT")
hdrdsn = KEYWD("HEADERDS")
outdsn = KEYWD("SAVETO")
if indsn = "" then,
helpmsg = "Must specify 'INPUT'. "
if outdsn = "" then,
helpmsg = helpmsg " Must specify 'SAVETO'. "
else
do
ldrc = Listdsi(outdsn "norecall") /* sets: */
if Pos("A",sysrecfm) = 0 then, /* SYSRECFM */
helpmsg = helpmsg " "outdsn "is not a printform dataset"
end
if hdrdsn = "" then, /* they're internal */
parse value KEYWD("HDRCT") hdrct, /* how many ? */
with hdrct .
if hdrdsn = "" & hdrct = 0 then,
helpmsg = helpmsg " Must specify 'HEADERDS' or 'HDRCT'."
if helpmsg <> "" then
do
helpmsg = Strip(helpmsg)
call HELP
end
parse value KEYWD("LINES") 57 , /* how many ? */
with pagesize .
return /*@ AK_KEYWDS */
/*
Are the headers embedded with the data? Extract them and make two
separate entities.
If the headers are external, they're already separate.
Insert a set of headers, add -n- lines of data next; repeat until
no more data.
. ----------------------------------------------------------------- */
B_GET_DATA: /*@ */
if branch then call BRANCH
address TSO
"ALLOC FI($TMP) DA("indsn") SHR REU"
"EXECIO * DISKR $TMP (FINIS"
if hdrct = 0 then, /* external source */
do
"ALLOC FI($TMP) DA("hdrdsn") SHR REU"
"EXECIO * DISKR $TMP (STEM HDR. FINIS"
hdrct = hdr.0
end
else /* internal headers */
do
do zz = 1 to hdrct
parse pull hdr.zz
end /* hdrct */
/* The queue now contains only data lines */
end
"FREE FI($TMP)"
queue Copies('01'x , 35) /* marker record */
do forever /* the entire queue */
do zz = 1 to hdrct
queue hdr.zz
end
cchar = "0"
do pagesize-hdrct /* enough to fill a page */
parse pull dataline
if dataline = Copies('01'x , 35) then leave
if sw.0Shift then,
queue cchar""dataline
else queue dataline
cchar = " "
end /* pagesize */
if dataline = Copies('01'x , 35) then leave
end /* forever */
/* The queue has been replaced with output+headers */
return /*@ B_GET_DATA */
/*
Ship the output.
. ----------------------------------------------------------------- */
C_OUTPUT: /*@ */
if branch then call BRANCH
address TSO
"ALLOC FI($TMP) DA("outdsn") SHR REU"
"EXECIO" queued() "DISKW $TMP (FINIS"
"FREE FI($TMP)"
address ISPEXEC "VIEW DATASET("outdsn")"
return /*@ C_OUTPUT */
/*
. ----------------------------------------------------------------- */
LOCAL_PREINIT: /*@ customize opts */
address TSO
return /*@ LOCAL_PREINIT */
/* subroutines below LOCAL_PREINIT are not selected by SHOWFLOW */
/*
. ----------------------------------------------------------------- */
HELP: /*@ */
address TSO;"CLEAR" ; say ""
if helpmsg <> "" then do ; say helpmsg; say ""; end
ex_nam = Left(exec_name,8) /* predictable size */
say " "ex_nam" Insert header lines to a dataset. "
say " "
say " Syntax: "ex_nam" (Required)"
say " "
say " (Required)"
say " "
say " "
say " "
say " "
say " dsn identifies a TSO-form dataset name (quoted if "
say " fully-qualified) The 'SAVETO' dataset must have a "
say " DCB RECFM of the form '..A'. "
say " "
say " # for input datasets with embedded headers, the number"
say " of such header lines. "
say " "
say " more .... "
"NEWSTACK"; pull ; "CLEAR" ; "DELSTACK"
say " "
say " ## the number of lines to be written per page. This "
say " number includes headers. "
say " "
say " SHIFT asserts that the data does NOT have carriage control"
say " characters in column-1. ASA controls will be added."
say " "
say " HDRCT and HEADERDS are mutually exclusive. One and only one "
say " of these must be specified. "
say " "
"NEWSTACK"; pull ; "CLEAR" ; "DELSTACK"
say " Debugging tools provided include: "
say " "
say " BRANCH: show all paragraph entries. "
say " "
say " TRACE tv: will use value following TRACE to place the "
say " execution in REXX TRACE Mode. "
say " "
say " "
say " Debugging tools can be accessed in the following manner: "
say " "
say " TSO "ex_nam" parameters (( debug-options "
say " "
say " For example: "
say " "
say " TSO "ex_nam" (( MONITOR TRACE ?R "
if sw.inispf then,
address ISPEXEC "CONTROL DISPLAY REFRESH"
exit /*@ HELP */
/*
. ----------------------------------------------------------------- */
BRANCH: Procedure expose, /*@ */
sigl exec_name
rc = trace("O") /* we do not want to see this */
arg brparm .
origin = sigl /* where was I called from ? */
do currln = origin to 1 by -1 /* inch backward to label */
if Right(Word(Sourceline(currln),1),1) = ":" then do
parse value sourceline(currln) with pgfname ":" . /* Label */
leave ; end /* name */
end /* currln */
select
when brparm = "NAME" then return(pgfname) /* Return full name */
when brparm = "ID" then do /* wants the prefix */
parse var pgfname pgfpref "_" . /* get the prefix */
return(pgfpref)
end /* brparm = "ID" */
otherwise
say left(sigl,6) left(pgfname,40) exec_name "Time:" time("L")
end /* select */
return /*@ BRANCH */
/*
. ----------------------------------------------------------------- */
DUMP_QUEUE: /*@ Take whatever is in stack */
rc = trace("O") /* and write to the screen */
address TSO
arg mode .
"QSTACK" /* how many stacks? */
stk2dump = rc - tk_init_stacks /* remaining stacks */
if stk2dump = 0 & queued() = 0 then return
if mode <> "QUIET" then,
say "Total Stacks" rc , /* rc = #of stacks */
" Begin Stacks" tk_init_stacks , /* Stacks present at start */
" Excess Stacks to dump" stk2dump
do dd = rc to tk_init_stacks by -1 /* empty each one. */
if mode <> "QUIET" then,
say "Processing Stack #" dd " Total Lines:" queued()
do queued();parse pull line;say line;end /* pump to the screen */
"DELSTACK" /* remove stack */
end /* dd = 1 to rc */
return /*@ DUMP_QUEUE */
/* Handle CLIST-form keywords added 20020513
. ----------------------------------------------------------------- */
CLKWD: Procedure expose info /*@ hide all except info */
arg kw
kw = kw"(" /* form is 'KEY(DATA)' */
kw_pos = Pos(kw,info) /* find where it is, maybe */
if kw_pos = 0 then return "" /* send back a null, not found*/
rtpt = Pos(") ",info" ",kw_pos) /* locate end-paren */
slug = Substr(info,kw_pos,rtpt-kw_pos+1) /* isolate */
info = Delstr(info,kw_pos,rtpt-kw_pos+1) /* excise */
parse var slug (kw) slug /* drop kw */
slug = Reverse(Substr(Reverse(Strip(slug)),2))
return slug /*@CLKWD */
/* Handle multi-word keys 20020513
. ----------------------------------------------------------------- */
KEYWD: Procedure expose info /*@ hide all vars, except info*/
arg kw /* form is 'KEY DATA' */
kw_pos = wordpos(kw,info) /* find where it is, maybe */
if kw_pos = 0 then return "" /* send back a null, not found*/
kw_val = word(info,kw_pos+Words(kw))/* get the next word */
info = Delword(info,kw_pos,2) /* remove both */
return kw_val /*@ KEYWD */
/*
. ----------------------------------------------------------------- */
KEYPHRS: Procedure expose, /*@ */
info helpmsg exec_name /* except these three */
arg kp /* form is 'KEY ;: DATA ;:' */
wp = wordpos(kp,info) /* where is it? */
if wp = 0 then return "" /* not found */
front = subword(info,1,wp-1) /* everything before kp */
back = subword(info,wp+1) /* everything after kp */
parse var back dlm back /* 1st token must be 2 bytes */
if length(dlm) <> 2 then /* Must be two bytes */
helpmsg = helpmsg "Invalid length for delimiter("dlm") with KEYPHRS("kp")"
if wordpos(dlm,back) = 0 then /* search for ending delimiter*/
helpmsg = helpmsg "No matching second delimiter("dlm") with KEYPHRS("kp")"
if helpmsg <> "" then call HELP /* Something is wrong */
parse var back kpval (dlm) back /* get everything b/w delim */
info = front back /* restore remainder */
return Strip(kpval) /*@ KEYPHRS */
/*
. ----------------------------------------------------------------- */
NOVALUE: /*@ */
say exec_name "raised NOVALUE at line" sigl
say " "
say "The referenced variable is" condition("D")
say " "
zsigl = sigl
signal SHOW_SOURCE /*@ NOVALUE */
/*
. ----------------------------------------------------------------- */
SHOW_SOURCE: /*@ */
call DUMP_QUEUE /* Spill contents of stacks -*/
if sourceline() <> "0" then /* to screen */
say sourceline(zsigl)
rc = trace("?R")
nop
exit /*@ SHOW_SOURCE */
/*
. ----------------------------------------------------------------- */
SS: Procedure /*@ Show Source */
arg ssbeg ssct . /* 'call ss 122 6' maybe */
if ssct = "" then ssct = 10
if \datatype(ssbeg,"W") | \datatype(ssct,"W") then return
ssend = ssbeg + ssct
do ssii = ssbeg to ssend ; say Strip(sourceline(ssii),'T') ; end
return /*@ SS */
/*
. ----------------------------------------------------------------- */
SWITCH: Procedure expose info /*@ */
arg kw /* form is 'KEY' */
sw_val = Wordpos(kw,info) > 0 /* exists = 1; not found = 0 */
if sw_val then /* exists */
info = Delword(info,Wordpos(kw,info),1) /* remove it */
return sw_val /*@ SWITCH */
/*
. ----------------------------------------------------------------- */
SYNTAX: /*@ */
errormsg = exec_name "encountered REXX error" rc "in line" sigl":",
errortext(rc)
say errormsg
zsigl = sigl
signal SHOW_SOURCE /*@ SYNTAX */
/*
Can call TRAPOUT.
. ----------------------------------------------------------------- */
TOOLKIT_INIT: /*@ */
address TSO
info = Strip(opts,"T",")") /* clip trailing paren */
parse source sys_id how_invokt exec_name DD_nm DS_nm,
as_invokt cmd_env addr_spc usr_tokn
parse value "" with tv helpmsg .
parse value 0 "ISR00000 YES" "Error-Press PF1" with,
sw. zerrhm zerralrm zerrsm
if SWITCH("TRAPOUT") then do
"TRAPOUT" exec_name parms "(( TRACE R" info
exit
end /* trapout */
sw.nested = sysvar("SYSNEST") = "YES"
sw.batch = sysvar("SYSENV") = "BACK"
sw.inispf = sysvar("SYSISPF") = "ACTIVE"
if Word(parms,1) = "?" then call HELP /* I won't be back */
"QSTACK" ; tk_init_stacks = rc /* How many stacks? */
parse value SWITCH("BRANCH") SWITCH("MONITOR") SWITCH("NOUPDT") with,
branch monitor noupdt .
parse value mvsvar("SYSNAME") sysvar("SYSNODE") with,
#tk_cpu node .
parse value KEYWD("TRACE") "O" with tv .
tk_globalvars = "exec_name tv helpmsg sw. zerrhm zerralrm ",
"zerrsm zerrlm tk_init_stacks branch monitor ",
"noupdt"
call LOCAL_PREINIT /* for more opts -*/
return /*@ TOOLKIT_INIT */