/* rexx ****************************************************************00010000
line- word and character count 00020000
***********************************************************************/00030000
say 'num begin' 00040000
/* call adrTso 'alloc dd(ddIn) shr reuse dsn(wk.Text(testIn)' 00050002
call adrTso 'alloc dd(ddOut) shr reuse dsn(wk.Text(testOut)' 00060002
*/ 00070002
call readDDBegin ddIn 00080000
call writeDDBegin ddOut 00090000
cc = 0 00100000
lc = 0 00110000
lx = 0 00120000
wc = 0 00130000
do bc=1 by 1 while readDD(ddIn, r.) 00140000
lc = lc + r.0 00150000
do rx = 1 to r.0 00160000
lx = lx + 1 00170000
cc = cc + length(r.rx) 00180000
wc = wc + words(r.rx) 00190000
/* r.rx = overlay(lx*lx, r.rx, 10, 5) */ 00200002
r.rx = overlay(d2c(lx*lx, 4), r.rx, 16, 4) 00210001
end 00220000
call writeDD ddOut, r. 00230000
end 00240000
call readDDEnd ddIn 00250000
call writeDDEnd ddOut 00260000
call adrTso 'free dd(ddIN ddOut)' 00270000
say 'lc' lc 'wc' wc 'cc' cc 'for' dsn 00280000
exit 00290000
err: 00300000
parse arg ggMsg 00310000
call errA ggMsg 00320000
exit 12 00330000
endSubroutine err 00340000
/* copy adrTso begin *************************************************/ 00350000
/*--- format dsn from tso format to jcl format -----------------------*/00360000
dsn2jcl: procedure 00370000
parse arg dsn . 00380000
if left(dsn,1) = "'" then 00390000
return strip(dsn, 'b', "'") 00400000
else if sysvar('SYSPREF') = '' then 00410000
return dsn 00420000
else 00430000
return sysvar('SYSPREF')'.'dsn 00440000
endProcedure dsn2Jcl 00450000
00460000
/*--- format dsn from jcl format to tso format -----------------------*/00470000
dsnFromJcl: procedure 00480000
parse arg dsn . 00490000
return "'"dsn"'" 00500000
endProcedure dsnFromJcl 00510000
00520000
/********************************************************************** 00530000
io: read or write a dataset with the following callsequences: 00540000
read: readDDBegin, readDD*, readDDEnd 00550000
write: writeBegin, writeDD*, writeEnd 00560000
00570000
readDD returns true if data read, false at eof 00580000
***********************************************************************/00590000
00600000
/*--- prepare reading from a DD --------------------------------------*/00610000
readDDBegin: procedure 00620000
return /* end readDDBegin */ 00630000
00640000
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/00650000
readDD: 00660000
parse arg ggDD, ggSt, ggCnt 00670000
if ggCnt = '' then 00680000
ggCnt = 100 00690000
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2 00700000
return (value(ggSt'0') > 0) 00710000
return /* end readDD */ 00720000
00730000
readDDall: 00740000
parse arg ggDD, ggSt 00750000
call adrTso 'execio * diskr' ggDD '(stem' ggSt' finis)' 00760000
return 00770000
endSubroutine readDDall 00780000
00790000
readDSN: 00800000
parse arg dsn, ggSt 00810000
call adrTso 'alloc dd(readDsn) shr dsn('dsn')' 00820000
call readDDall readDsn, ggSt 00830000
call adrTso 'free dd(readDsn)' 00840000
return 00850000
endSubroutine readDsn 00860000
00870000
/*--- finish reading DD ggDD ----------------------------------------*/00880000
readDDEnd: procedure 00890000
parse arg ggDD 00900000
call adrTso 'execio 0 diskr' ggDD '(finis)' 00910000
return /* end readDDEnd */ 00920000
00930000
/*--- prepare writing to DD ggDD -------------------------------------*/00940000
writeDDBegin: procedure 00950000
parse arg ggDD 00960000
/* ensure file is erased, if no records are written */00970000
call adrTso 'execio' 0 'diskw' ggDD '(open)' 00980000
return /* end writeDDBegin */ 00990000
01000000
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/01010000
writeDD: 01020000
parse arg ggDD, ggSt, ggCnt 01030000
if ggCnt == '' then 01040000
ggCnt = value(ggst'0') 01050000
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')' 01060000
return 01070000
endSubroutine writeDD 01080000
01090000
/*--- end writing to dd ggDD (close) --------------------------------*/ 01100000
writeDDEnd: procedure 01110000
parse arg ggDD 01120000
call adrTso 'execio 0 diskw' ggDD '(finis)' 01130000
return /* end writeDDEnd */ 01140000
01150000
/*--- end write a stem to a dsn -------------------------------------*/ 01160000
writeDSN: 01170000
parse arg dsn, ggSt 01180000
call adrTso 'alloc dd(wriDsn) shr dsn('dsn')' 01190000
call adrTso 'execio' value(ggSt'0') , 01200000
'diskw wriDsn (stem' ggSt 'finis)' 01210000
call adrTso 'free dd(wriDsn)' 01220000
return 01230000
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/01240000
adrTso: 01250000
parse arg ggTsoCmd, ggRet 01260000
address tso ggTsoCmd 01270000
if rc == 0 then return 0 01280000
else if ggRet == '*' then return rc 01290000
else if wordPos(rc, ggRet) > 0 then return rc 01300000
else 01310000
call err 'adrTso rc' rc 'for' ggTsoCmd 01320000
return /* end adrTso */ 01330000
/* copy adrTso end ****************************************************/01340000
/* copy err begin ******************************************************01350000
messages, errorhandling,help 01360000
***********************************************************************/01370000
/* caller should define err as follows ---------------------------------01380000
err: 01390000
parse arg ggMsg 01400000
call errA ggMsg 01410000
exit 12 01420000
endSubroutine err 01430000
end call should define err ----------------------------------------*/01440000
01450000
/*--- error routine: abend with message ------------------------------*/01460000
errA: 01470000
parse arg ggTxt 01480000
parse source . . ggS3 . /* current rexx */01490000
say 'fatal error in' ggS3':' ggTxt 01500000
x = x / 0 01510000
exit setRc(12) 01520000
endSubroutine errA 01530000
01540000
/*--- abend with Message after displaying help -----------------------*/01550000
errHelp: procedure 01560000
parse arg ggMsg 01570000
say 'fatal error:' ggMsg 01580000
call help 01590000
call err ggMsg 01600000
endProcedure errHelp 01610000
01620000
/*--- set rc for ispf: -------------------------------------------------01630000
if a cmd is run by ispStart, its RC is ignored, 01640000
but ISPF passes the value of the shared varible zIspfRc 01650000
back as return code 01660000
----------------------------------------------------------------------*/01670000
setRc: procedure 01680000
parse arg zIspfRc 01690000
if sysVar('sysISPF') = 'ACTIVE' then do 01700000
say 'exitRc setting zIspfRc='zIspfRc 01710000
address ispExec vput 'zIspfRc' shared 01720000
end 01730000
return zIspfRc 01740000
endProcedure setRc 01750000
01760000
/*--- output a trace message if m.trace is set -----------------------*/01770000
trc: procedure expose m. 01780000
parse arg msg 01790000
if m.trace == 1 then 01800000
say 'trc:' msg 01810000
return 01820000
endProcedure trc 01830000
01840000
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/01850000
quote: procedure 01860000
parse arg txt, qu 01870000
if qu = '' then 01880000
qu = '"' 01890000
res = qu 01900000
ix = 1 01910000
do forever 01920000
qx = pos(qu, txt, ix) 01930000
if qx = 0 then 01940000
return res || substr(txt, ix) || qu 01950000
res = res || substr(txt, ix, qx-ix) || qu || qu 01960000
ix = qx + length(qu) 01970000
end 01980000
endProcedure quote 01990000
02000000
/*--- return current time and cpu usage ------------------------------*/02010000
showtime: procedure 02020000
parse arg showmsg 02030000
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg 02040000
02050000
/--- display the first comment block of the source as help -----------*/02060000
help: procedure 02070000
parse source . . s3 . 02080000
say 'help for rexx' s3 02090000
do lx=1 by 1 02100000
if pos('/*', sourceLine(lx)) > 0 then 02110000
leave 02120000
else if lx > 10 then do 02130000
say 'initial commentblock not found for help' 02140000
return 02150000
end 02160000
end 02170000
do lx=lx+1 by 1 02180000
li = strip(sourceLine(lx), 't', ' ') 02190000
if pos('*/', li) > 0 then 02200000
leave 02210000
say li 02220000
end 02230000
return 4 02240000
endProcedure help 02250000
/* copy err end *****************************************************/02260000