zOs/REXX.O13/PVSRTRAC
/* rexx ***************************************************************
pvsRTrac: Einschreiben_Nummern konsolidieren und versenden
dd parm in: parm file
key = value Syntax von scanKeyValPC(.,1,1,'*')
dd phase io: restart Information
filelist io: Liste der in der Write Phase verarbeiteten Files
Funktion:
Vorbereitung: parm File lesen, compilieren, ausführen
phase File einlesen und Restart Aktionen
PW: phaseWrite: die Track2 files aus dem Catalog lesen
(Maske $mask) und konkatinieren in temp BU-Files
PN: phaseRneame: die Track2 Files auf Track3 umbenennen
und die temp BU-Files auf den definitiven Namen
PS: phaseSend: die BU-Files mit Connect Direct verschicken
History
2005.12.22 W. Keller KRDO 4, Acc BU nur falls BU A.... definiert
2005.12.16 W. Keller KRDO 4, Acceptance: 6.Stelle FileNa = 'S'
2005.12.14 W. Keller KRDO 4, vereinfachte Syntax
2005.11.22 W. Keller KRDO 4, neu
***********************************************************************/
parse upper arg m.env
/* Konstanten abfüllen */
/* attribute (DSS) der BU-FIles */
m.attributes = 'space="(1,10) tracks" recfm=v,b lrecl=32756' ,
'mgmtClas=S005Y000'
/* Initialisierung */
m.trace = 0
call wrIni 0
m.foreground = sysvar(sysenv) == 'FORE'
if m.foreground then
call foregroundStart
call startCheckRestart
/* die 3 Phasen durchführen */
if m.phase == '' | m.phase == 'PE' | m.phase == 'PW' then do
call phaseWrite
m.phase = 'PR'
end
if m.phase == 'PR' then do
call phaseRename
m.phase = 'PS'
end
if m.phase == 'PS' then do
call phaseSend
call writePhaseFile 'PE', m.dateTime
say '--- Ende OK all Phasen'
end
if m.foreground then
call finishForeground
exit
/*--- read parm and phase file, check restart ------------------------*/
startCheckRestart: procedure expose m.
node = sysvar(sysnode)
say "--- Beginn PVSTRACK env" m.env 'im RZ' node
call readParm /* parameter analysieren */
call readPhaseFile /* letzte Aktion herausfinden */
if m.phase == '' then /* restart Aktionen */
say 'Start ohne Informationen über vorherigen Job Lauf'
else if m.phase == 'PE' then
say 'Start nach normal beendeten Job Lauf'
else if m.phase == 'PW' then do
say 'restart WRITE phase: cleanup old BU DSNs'
call cleanupPhaseWrite
end
else if m.phase == 'PR' then
say 'restart in RENAME phase'
else if m.phase == 'PS' then
say 'restart in SEND phase'
else
call err 'ungültige phase' m.phase
return
endProcedure startCheckRestart
/*--- catalog read und BU Files schreiben ----------------------------*/
phaseWrite: procedure expose m.
/* dateTime Suffix bestimmen */
daTi = time('n')
daTi = left(daTi, 2)substr(daTi, 4, 2)right(daTi,2)
daTi = 'D'date('j')'.T'daTi
/* phase file schreiben */
say 'phaseWrite mit DateTime Suffix' daTi ,
'jetzt ist' time('n') date()
call writePhaseFile 'PW', daTi
say '--- Beginn Phase Write'
/* rexx source erstellen, um für jeden TrackFile record
mit dem rexx aus dem Parmfile die BU zu finden
und dann Record in das richtige BU File schreiben */
wx = wrNew()
/* Files öffnen und Catalog lesen */
call openBUFiles
csiKey = m.mask
call readCat
liCnt = 0
/* jeden Catalog Eintrag verarbeiten */
do cx=1 to csiDsn.0
dsn = csiDsn.cx
/* in die FileListe eintragen */
call writeLn m.fileList, 'TRACK' dsn
/* file Lesen und verarbeiten */
call readDS wx, 'dsj='dsn
do while read(wx, trIn)
do rx=1 to m.trIn.0
call writeBuRec trIn.rx
end
end
/* file Lesen und mit wx verarbeiten */
say m.wr.readSX.wx 'Zeilen von' dsn
liCnt = liCnt + m.wr.readSX.wx
end
/* Zähler anzeigen */
say csiDsn.0 'DSNs mit total' liCnt 'Zeilen gelesen'
/* Files schliessen */
call closeBUFiles
say m.cnt.noWr 'Zeilen von unterdrückten BUs'
say m.cnt.undef 'Zeilen von nicht definierten BUs:' m.cnt.undefIds
return
endProcedure phaseWrite
/*--- rename der Track Files -----------------------------------------*/
phaseRename: procedure expose m.
trNew = m.renameLLQ
call writePhaseFile 'PR', m.dateTime
say '--- Beginn Phase Rename'
do retry=1 by 1
call readDS rFl, 'dd=filelist'
cnt = 0
cntTr = 0
cntRe = 0
m.disappeared = 0
do while readLn(rFl, rec)
cnt = cnt + 1
say cnt 'fileList' m.rec
parse var m.rec flTy old .
if flTy == 'BU' then
iterate
else if flTy ^== 'TRACK' then
call err 'bad type in fileList:' flTy
cntTr = cntTr + 1
new = left(old, dsnPosLev(old, -1)-1) || trNew
cntRe = cntRe + rename(old, new, 'trackfile')
end
say cntTr "TRACK-DSNs und" (cnt -cntTr) "BU-DSNs"
say cntRe 'rename''t' m.disappeared 'verschwunden'
cntEr = cntTr - cntRe -m.disappeared
if cntEr = 0 then
return
say '****** Fehler in' cntEr 'renames'
if retry > 3 then
call err 'nicht alle Datasets rename''t oder verschwunden'
say '--- retry' retry 'für Phase Rename'
end
endProcedure phaseRename
/*--- rename eines Datasets ------------------------------------------*/
rename: procedure expose m.
parse arg old, new, msg
if msg ^== '' then
say 'rename trackfile' old '==>' new
if adrTso("rename '"old"' '"new"'", '*') = 0 then
return 1
else if sysdsn("'"old"'") == 'DATASET NOT FOUND' then
m.disappeared = m.disappeared + 1
else
say 'dsn' old 'konnte nicht rename''t werden'
return 0
endProcedure rename
/*--- send and rename BU-Files ---------------------------------------*/
phaseSend: procedure expose m.
call writePhaseFile 'PS', m.dateTime
say '--- Beginn Phase Send'
call readDS rFL, 'dd=fileList'
m.disappeared = 0
cnt = 0
cntBu = 0
cntRe = 0
cntDi = 0
do while readLn(rFl, rec)
cnt = cnt + 1
parse var m.rec flTy old .
if flTy == 'TRACK' then
iterate
else if flTy ^= 'BU' then
call err 'bad type in fileList:' flTy
cntBu = cntBu + 1
buId = dsnGetLev(old, -1)
if symbol('m.bu.index.buId') ^== 'VAR' then
call err 'buId' buId 'nicht definiert, buFile' old
bx = m.bu.index.buId
rena = left(old, dsnPosLev(old, -2)-1) ,
|| buId || '.' || m.dateTime
if sysDsn("'"old"'") == 'DATASET NOT FOUND' then do
say 'dsn' old 'gibt es nicht'
cntDi = cntDi + 1
iterate
end
buFu = m.bu.bx.func
say 'send buId' buId 'typ' buFu 'dsn' old
if buFu == 'CD' then do
say 'connectDirect to node' m.bu.bx.node 'atts' m.bu.bx.atts
call cd old, m.bu.bx.node, m.bu.bx.atts
end
else if buFu ^== 'WR' then
call err 'bad buFunc' buFu
cntRe = cntRe + rename(old, rena, 'BU-File')
end
call readDDEnd fileList
say cntBu "BU- und" (cnt- cntBu) "TRACK-DSNs"
say cntRe 'gesendet und' cntDi 'verschwunden'
cntEr = cntBu - cntRe - cntDi
if cntEr ^= 0 then
call err 'Fehler in' cntEr 'DSNs'
return
endProcedure phaseSend
/*--- restart in phaseWrite:
alle erstellten DS löschen und neu anfangen ----------------*/
cleanupPhaseWrite: procedure expose m.
csiKey = m.prefix'.ATM.**'
call readCat
rmCnt = 0
diCnt = 0
do cx=1 to csiDsn.0
dsn = dsnFromJcl(csidsn.cx)
say 'cleanup' dsn
if adrTso("delete" dsn, '*') = 0 then
rmCnt = rmCnt + 1
else if sysdsn(dsn) == 'DATASET NOT FOUND' then
diCnt = diCnt + 1
else
say '****** Fehler beim Loeschen:' dsn':' sysdsn(dsn)
end
say rmCnt 'DSNs gelöscht' diCnt 'bereits verschwunden von' csiDsn.0
if rmCnt + diCnt ^== csiDsn.0 then
call err 'nicht alle DSNs gelöscht'
return
endProcedure cleanUpPhaseWrite
/*--- BU-Files neu erstellen -----------------------------------------*/
openBUfiles: procedure expose m.
m.fileList = wr2DS(wrNew(), "dd=filelist")
atts = "disp=new,catalog" m.attributes
m.cnt.undef = 0
m.cnt.undefIds = ''
do bx=1 to m.bu.0
id = m.bu.bx.buId
m.bu.bx.wd = ''
m.bu.bx.cnt = 0
if wordpos(m.bu.bx.func, 'CD WR') < 1 then
iterate
dsn = dsnApp(m.prefix '.ATM.'id)
call writeLn m.fileList, 'BU' dsn
say 'allocating BU' id 'dsn' dsn
m.bu.bx.wd = wr2DS(wrNew(), 'dsj='dsn atts)
end
return
endProcedure openBUFiles
/*--- BU-Files schliessen --------------------------------------------*/
closeBUfiles: procedure expose m.
m.cnt.noWr = 0
do bx=1 to m.bu.0
id = m.bu.bx.buId
if m.bu.bx.wd == '' then do
m.cnt.noWr = m.cnt.noWr + m.bu.bx.cnt
if m.bu.bx.cnt ^== 0 then
say 'close BU' id 'mit' m.bu.bx.cnt 'ignorierten Zeilen'
end
else do
call wrClose m.bu.bx.wd
say 'close BU' id 'mit' m.bu.bx.cnt 'geschriebenen Zeilen'
end
end
say 'closing fileList'
call wrClose m.fileList
return
endProcedure closeBUFiles
/*--- read Phase file, fill m.phase and m.dateTime -------------------*/
readPhaseFile: procedure expose m.
call ScanDS ps, 'dd=phase'
vars = phase dateTime
do kx=0 by 1 while scanKeyValPC(ps, 1, 1, '*')
k = m.ps.key
say 'phase' k 'val' m.ps.val
if wordPos(k, vars) < 1 then
call scanErr ps, 'key' k 'ungültig, erlaubt' vars
m.k = m.ps.val
end
if ^scanAtEnd(ps) then
call scanErr ps, 'key = value erwartet'
if kx = 0 then
say 'phase file ist leer oder enthält nur Kommentar'
call disp phase, 0, 'angefangene Phase'
call disp dateTime, 0, 'Datum Zeit file Suffix'
return
endProcedure readPhaseFile
/*--- write PhaseFile mit phase und dateTime aus Parameter -----------*/
writePhaseFile: procedure expose m.
parse arg m.phase, m.dateTime
say 'schreiben phase file mit phase='m.phase 'dateTime='m.dateTime
call wrDSFromDS 'dd=phase', 'stem='wrArgs('abc', 0,
, '*** restart file für pvsTrack Job PVT760* ***', '',
, ' * phase = letzte angefangene Phase' ,
, ' * PW = Write' ,
, ' * PR = Rename' ,
, ' * PS = Send' ,
, ' * PE = Erfolgreich beendet', ' ' ,
, ' * dateTime = Datum Zeit Suffix für Filenamen', ' ',
, 'phase = ' m.phase,
, 'dateTime = 'm.dateTime)
say 'geschrieben phase file mit phase='m.phase 'dateTime='m.dateTime
return
endProcedure writePhaseFile
/*--- compile und ausführen dd parm, Konfig anzeigen -----------------*/
readParm: procedure expose m.
say 'analysing parm file dd=parm'
call scanDS s, "dd=parm"
bx = 0
vars = mask renameLlq prefix
varBu = buId func node atts
do while scanKeyValPC(s, 1, 1, '*')
k = m.s.key
if wordPos(k, vars) > 0 then
m.k = m.s.val
else if k == defineBu then do
bx = bx + 1
call scanBegin bs, m.s.val
do ax=1 to 3
call scanWord bs, 1
w = word(varBu,ax)
m.bu.bx.w = m.bs.val
end
call scanChar bs
m.bu.bx.atts = m.bs.tok
end
else do
call scanErr s, 'ungültiger key' k 'gültig' vars
end
end
m.bu.0 = bx
if ^scanAtEnd(s) then
call scanErr s, 'key=value erwartet'
say ' '
call disp mask, 1, 'Maske der Input Trackfiles'
call disp renameLLQ, 1,"LLQ auf den die Trackfile umbenannt werden"
call disp prefix, 1,"Präfix der lokalen BU-Files"
say ''
do bx=1 to m.bu.0
say '--- BU-File' bx
call disp 'BU.'bx'.BUID', 1, 'BU Identifikation'
n = m.bu.bx.buId
m.bu.index.n = bx
call disp 'BU.'bx'.FUNC', 1, 'Funktion'
if wordPos(m.bu.bx.func, 'CD WR NN') < 1 then
call err 'ungültige BU Funktion' m.bu.bx.func
call disp 'BU.'bx'.NODE', 1, 'Empfänger Node'
call disp 'BU.'bx'.ATTS', 0, 'Empfänger Attribute'
end
return
endProcedure readParm
/*--- den Namen na, Wert einer Variabeln und msg anzeigen
falls obl Fehlermeldung falls leer oder undefiniert ------------*/
disp: procedure expose m.
parse arg na, obl, msg
if symbol("m.na") ^== 'VAR' | m.na = '' then
if obl then
call err 'variable' na 'leer oder nicht definiert'
else
m.na = ''
say left(na, 10) '=' m.na
say left('', 10) '*' msg
return
endProcedure disp
/*--- einen Track Record in die richtig BU schreiben -----------------*/
writeBURec: procedure expose m.
parse arg line
/* BU bestimmen */
buId = substr(m.line, 27, 4)
if buId = '' then
buId = '0011'
buId = 'U' || buId /* normaler prefix */
if substr(m.line, 56, 1) == 'S' then do
bb = overlay('A', buId) /* Acceptance prefix */
if symbol("m.bu.index.bb") == VAR then
buId = bb /* Acceptance is defined */
end
if symbol("m.bu.index.buId") ^== 'VAR' then do /* undefinierte BU */
m.cnt.undef = m.cnt.undef + 1
if wordPos(buId, m.cnt.undefIds) < 1 then
m.cnt.undefIds = m.cnt.undefIds buId
return
end
bx = m.bu.index.buId
m.bu.bx.cnt = m.bu.bx.cnt + 1 /* record zählen */
if m.bu.bx.wd ^== '' then
call writeLn m.bu.bx.wd, m.line /* record schreiben */
return
endProcedure writeBURec
/*--- set up test environment when started foreground ----------------*/
foregroundStart:
say 'start in foreground mode'
if env = '' then
env = 'WAK'
ph = "TEST.PVSTRACK.PHASE"
fl = "TEST.PVSTRACK.FILELIST"
pa = "'WGR.RZ1.T0.AKT.PARMLIB(PVT7600R)'"
pa = "wk.rexx(pvsrTraM)"
say 'allocating phase dd('phase') dsn('ph')'
call adrTso 'alloc dd(phase) old dsn('ph')'
say 'allocating filelist dd('filelist') dsn('fl')'
call adrTso 'alloc dd(filelist) old dsn('fl')'
say 'allocating parm dd('parm') dsn('pa')'
call adrTso 'alloc dd(parm) shr dsn('pa')'
return
endSubroutine foregroundStart
/*--- finish and cleanup in teset mode -------------------------------*/
finishForeground: procedure expose m.
say 'finish in foreground mode'
say 'freeing phase, filelist and parm'
call adrTso 'free dd(phase filelist parm)'
return
endProcedure finishForeground
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
/* copy csi begin ****************************************************/
/*===================================================================*/
READCAT:
/*===================================================================*/
/*********************************************************************/
/* */
/* PVS CATALOG SEARCHE INTERFACE */
/* */
/* DESCRIPTION: THIS REXX EXEC IS USED TO CALL THE CATALOG */
/* SEARCH INTERFACE IGGCSI00 */
/* (REPLACEMENT FOR THE IDCAMS LISTC) */
/* */
/* INPUT: CSIKEY DSLEVEL TO LOOK FOR */
/* */
/* OUTPUT: CSIDSN.0: NUMBER OF DSN'S RETURNED */
/* CSIDSN.: ARRAY WITH DSN'S */
/* */
/*********************************************************************/
/*********************************************************************/
/* */
/* INITIALIZE THE PARM LIST PASSED TO IGGCSI00 */
/* */
/*********************************************************************/
MODRSNRC = SUBSTR(' ',1,4) /* CLEAR MODULE/RETURN/REASON */
CSIFILTK = SUBSTR(CSIKEY,1,44) /* MOVE FILTER KEY INTO LIST */
CSICATNM = SUBSTR(' ',1,44) /* SET CATALOG NAME */
CSIRESNM = SUBSTR(' ',1,44) /* CLEAR RESUME NAME */
CSIDTYPS = SUBSTR(' ',1,16) /* CLEAR ENTRY TYPES */
CSICLDI = SUBSTR(' ',1,1) /* NO DATA AND INDEX */
CSIRESUM = SUBSTR(' ',1,1) /* CLEAR RESUME FLAG */
CSIS1CAT = SUBSTR(' ',1,1) /* SEARCH THIS CATALOG ONLY */
CSIRESRV = SUBSTR(' ',1,1) /* CLEAR RESERVE CHARACTER */
/*********************************************************************/
/* */
/* BUILD THE SELECTION CRITERIA FIELDS PART OF PARAMETER LIST */
/* */
/*********************************************************************/
CSIOPTS = CSICLDI || CSIRESUM || CSIS1CAT || CSIRESRV
CSIFIELD = CSIFILTK || CSICATNM || CSIRESNM || CSIDTYPS || CSIOPTS
/*********************************************************************/
/* */
/* INITIALIZE AND BUILD WORK ARE OUTPUT PART OF PARAMETER LIST */
/* */
/*********************************************************************/
WORKLEN = 1024
DWORK = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
/*********************************************************************/
/* */
/* INITIALIZE WORK VARIABLES */
/* */
/*********************************************************************/
RESUME = 'Y' /* SET RESUME FLAG */
CSIDSN.0 = 0 /* A COUNT OF DSNAMES FILLED */
/*********************************************************************/
/* */
/* SET UP LOOP FOR RESUME (IF A RESUME IS NECESSARY) */
/* */
/*********************************************************************/
DO WHILE RESUME = 'Y' /* UNTIL EOF OF CATALOG READ */
ADDRESS LINKPGM 'IGGCSI00 MODRSNRC CSIFIELD DWORK'
RESUME = SUBSTR(CSIFIELD,150,1) /* GET RESUME FLAG FOR NEXT LOOP */
USEDLEN = C2D(SUBSTR(DWORK,9,4)) /* GET AMOUNT OF WORK AREA USED */
POS1=15 /* STARTING POSITION */
/********************************************************************/
/* */
/* PROCESS DATA RETURNED IN WORK AREA */
/* */
/********************************************************************/
DO WHILE POS1 < USEDLEN /* UNTIL ALL DATA IS PROCESSED */
IF SUBSTR(DWORK,POS1+1,1) = '0' THEN /* IF ITS THE CATALOG */
DO
POS1 = POS1 + 50 /* SKIP TO THE END OF IT */
END
ELSE DO /* IF NOT CATALOG */
IF SUBSTR(DWORK,POS1+1,1) = 'A' THEN /* ONLY PROCESS NVSAM */
DO
CSIDSN.0 = CSIDSN.0 + 1 /* COUNT DSNAMES FILLED */
DSN = SUBSTR(DWORK,POS1+2,44) /* GET THE DSNAME */
I = CSIDSN.0
CSIDSN.I = DSN /* AND FILL INTO TABLE */
END
POS1 = POS1 + 46 /* SKIP TO RECORD END */
POS1 = POS1 + C2D(SUBSTR(DWORK,POS1,2)) /* ADD CSITOTLN */
END
END
END
RETURN /* RETURN TO INVOKER */
/* copy csi end *******************************************************/
/* copy cd begin **************************************************
send the file frDsn from the current not
to the node toNode as toDsn if not empty
using connect direct
default attributes may be overridden (inDISP=(OLD))
or additional connect direct attributes may be specified
in argument 4 with syntax a=b c = d etc.
***********************************************************************/
cd: procedure expose m.
parse upper arg frDsn, toNode, args
if toNode == 'RZ1' | toNode == 'RZ2' then
toNode = 'SKA.'toNode
toDsn = 'outDsn...fehlt'
as = wrArgs("CD.AS", 0 ,
, "SIGNON" ,
, " SUBMIT PROC=MVS03DSN - " ,
, "NEWNAME=PVT760MP - " ,
, "MAXDELAY=UNLIMITED - " ,
, "&DEST="toNode "- " ,
, "&INDSN="frDsn "- " ,
, "&INDISP=(SHR,KEEP,KEEP) - " ,
, "&OUTDSN="toDsn "- " ,
, "&OUTDISP=(NEW,CATLG,DELETE) - " )
call scanBegin s, args
call trc 'scanBegin' args
ax = 0
do while scanKeyValue(s, 1, 1)
k = m.s.key
if k = 'DSN' | k == 'OUTDSN' then do
k = 'OUTDSN'
toDsn = m.s.val
end
do y=2 to m.as.0
px = pos(k'=', m.as.y)
if px > 0 then
leave
end
if px > 0 then do
m.as.y= left(m.as.y, px-1)k'='m.s.val '-'
end
else do
ax = ax + 1
call wrArgs as, , "&OPARM" || ax || "="k"="m.s.val "-"
end
end
call scanVerify s, ' '
if ^scanAtEol(s) then
call scanErr s, 'key = value expected'
if pos('..', toDsn) > 0 then
call err 'no dsn specified in' args
say 'sending' frDsn 'to' toNode toDsn 'with connect direct'
hx = m.as.0
m.as.hx = left(m.as.hx, length(m.as.hx) - 1)
call wrArgs as, , 'SIGNOFF'
if m.trace == 1 then do
call trc 'connectDirect sysin'
call out as
end
if m.foreground then
if listdsi('dmpublib FILE') = 0 then
call err 'dmPublib already allocated, cdadm running?'
doAlloc = m.foreground
call adrTso "alloc new delete dd(sysIN) recfm(f,b) lrecl(80)"
call writeDDBegin sysin
call wrDSfromDS 'dd=sysIn', 'stem='as
if doAlloc then do
say 'dynamically allocating connectDirect files'
call adrTso "alloc dd(DMPUBLIB) shr" ,
"dsn('JOBP.FT1A.PRCS' 'SFT.DIV.X0.CD.PRCS')"
call adrTso "alloc dd(DMNETMAP) shr dsn('SFT.SKA.P0.CD.NETMAP')"
call adrTso "alloc dd(DMMSGFIL) shr dsn('SFT.DIV.X0.CD.MSG')"
call adrTso "alloc dd(DMPRINT) sysout(T)"
end
call trc "everything allocated callin dmBatch"
cdRc = adrTso("CALL *(DMBATCH) 'YYSLYNN'", '*')
call trc 'dmBatch rc' cdRc
call adrTso "free dd(sysin)"
if doAlloc then
call adrTso "free dd(DMPUBLIB DMPRINT DMNETMAP DMMSGFIL)"
if cdRc ^= 0 then
call err 'rc' cdRc 'in connectDirect'
return
endProcedure cd
/* copy cd end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanBegin(m,ln): set scan Source to ln
scanAtEnd(m) : returns whether we reached end of line already
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line aSrc ------------------------------*/
scanBegin: procedure expose m.
parse arg m, m.scan.m.src, m.scan.m.reader
m.scan.m.pos = 1
m.scan.m.tok = ''
m.scan.m.val = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
end
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.reader == '' then
return m.scan.m.pos > length(m.scan.m.src)
s = m.scan.m.reader
return m.wr.readEof.s
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
m.m.tok = substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
if nx = m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a number --------------------------------------------------*/
scanNum: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure scanNum
/*--- scan a word
either delimited by space or stopper
or a string (with single or double quotes
put value into *.val, upercased if uc=1 and not string ---------*/
scanWord: procedure expose m.
parse arg m, uc, stopper
call scanVerify m, ' '
if scanString(m, "'") then return 1
else if scanString(m, """") then return 1
else
res = scanVerify(m, ' 'stopper, 'm')
m.m.val = m.m.tok
if uc ^== 0 then
upper m.m.val
return res
endProcedure scanWord
/*--- scan a key = word phrase
put key into *.key (uppercase if uk) and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, uk, uv
call scanVerify m, ' '
bx = m.scan.m.pos
if scanName(m) then do
m.m.key = m.m.tok
if uk ^== 0 then
upper m.m.key
call scanVerify m, ' '
if scanLit(m, '=') then do
call scanWord m, uv
return 1
end
end
m.scan.m.pos = bx
return 0
endProcedure scanKeyValue
/*--- scan a key = word (multi line) phrase with comment and +
comment starts with cc up to NL
+ and ++ are concatenation ops (++ strict, + with 1 space)
words are delimeted by nl, ' ', '+' or cc
put key into m.m.key (uppercase if uk) and
put word into m.m.val (uppercase if uv) val --------------------*/
scanKeyValPC: procedure expose m.
parse arg m, uk, uv, cc
call scanSpaceNl m, cc
if ^ scanName(m) then
return 0
m.m.key = m.m.tok
if uk ^== 0 then
upper m.m.key
call scanSpaceNl m, cc
if ^ scanLit(m, '=') then do
m.m.val = ''
return 1
end
call scanSpaceNl m, cc
call scanWord m, uv, cc'+'
vv = m.m.val
do forever
call scanSpaceNl m, cc
if ^ scanLit(m, "+") then do
m.m.val = vv
return 1
end
strict = scanLit(m, "+")
call scanSpaceNl m, cc
call scanWord m, uv, cc'+'
if strict then
vv = vv || m.m.val
else
vv = vv m.m.val
end
endProcedure scanKeyValPC
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.scan.m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
if m.scan.m.reader ^== '' then
say readInfo(m.scan.m.reader, '*')
call err 'scanErr' txt
endProcedure scanErr
/*--- begin to scan all lines from readDescriptor rx -----------------*/
scanReader: procedure expose m.
parse arg m, rx
m.scan.m.reader = rx
return scanNL(m, 1)
endProcedure scanReader
scanDS: procedure expose m.
parse arg m, dss
return scanReader(m, readDS(m, dss))
endProcedure scanDS
/*--- if lx == '' and notScanning or not atEOL return false
if lx=='' or lx=='+' then lx = nextLineIndex
if lx > lastLine return false otherwise start scan line lx -----*/
scanNL: procedure expose m.
parse arg m, lx
if lx == '' then
if m.scan.m.reader=='' | m.scan.m.pos<=length(m.scan.m.src) then
return 0
if ^ readLn(m.scan.m.reader, scan.m.liCu) then do
m.scan.m.pos = 1 + length(m.scan.m.src)
return 0
end
call scanBegin m, m.scan.m.liCu, m.scan.m.reader
return 1
endProcedure scanNL
/*--- skip over space and NL (NewLines) and comments -----------------*/
scanSpaceNL: procedure expose m.
parse arg m, cc
res = scanVerify(m, ' ')
do forever
if scanNL(m) then nop
else if cc == '' then
return res
else if ^ scanLit(m, cc) then
return res
else if ^scanNL(m, 1) then
return 1
res = 1
call scanVerify m, ' '
end
endProcedure scanSpaceNL
/* copy scan end ****************************************************/
/* copy wr begin *****************************************************
out interface
define a current output destination (a writerDescriptor)
manage them in a stack
convenience function to write to current output
***********************************************************************/
/*--- write stem stem to current output ------------------------------*/
out: procedure expose m.
parse arg stem
call write m.wr.out, stem
return
endProcedure
/*--- write up to 3 strings to current output ------------------------*/
outLn: procedure expose m.
m = m.wr.out
ox=m.wr.wrBuf.m.0
do ax=1 to arg()
ox = ox + 1
m.wr.wrBuf.m.ox = arg(ax)
end
m.wr.wrBuf.m.0 = ox
if ox > 100 then
call write m
return
endProcedure
/*--- write to current output from datasetSpec dss -------------------*/
outDS: procedure expose m.
parse arg dss
call wrFromDS m.wr.out, dss
return
endProcedure outDS
/*--- write reader rx to out -----------------------------------------*/
outReader: procedure expose m.
parse arg rx
call wrReader m.wr.out, rx
return
endProcedure outReader
/*--- redirect current output ----------------------------------------*/
outPush: procedure expose m.
parse arg o, p
x = m.wr.out.0 + 1
m.wr.out.0 = x
m.wr.out.x = m.wr.out
m.wr.prc.x = m.wr.prc
if o ^== '' then
m.wr.out = o
if p ^== '' then
m.wr.prc = p
return
endProcedure outPush
/*--- redirect current output to previous ----------------------------*/
outPop: procedure expose m.
parse arg o
x = m.wr.out.0
m.wr.out.0 = x - 1
m.wr.out = m.wr.out.x
m.wr.prc = m.wr.prc.x
return
endProcedure outPop
/**********************************************************************
writer interface
a writerDescriptor wx is allocated with wrNew
we can define the write and wrClose functionality arbitrarily
***********************************************************************/
/*--- create a new writeDescriptore ----------------------------------*/
wrNew: procedure expose m.
parse arg typ, reuseOK
if m.wr.free.0 < 1 | reuseOK == 0 then do
nn = m.wr.new + 1
m.wr.new = nn
end
else do
fx = m.wr.free.0
m.wr.free.0 = fx - 1
nn = m.wr.free.fx
end
m.wr.prcTyp.nn = typ
m.wr.prcSta.nn = ''
m.wr.wrBuf.nn.0 = 0
return nn
endProcedure wrNew
/*--- free the writeDescriptors arg(1)... ----------------------------*/
wrFree: procedure expose m.
fx = m.wr.free.0
do i = 1 to arg()
fx = fx + 1
m.wr.free.fx = arg(i)
end
m.wr.free.0 = fx
return
endProcedure wrFree
/*--- for writeDescriptor m define write and close -------------------*/
wrDefine: procedure expose m.
parse arg m, m.wr.write.m, m.wr.close.m, wr2, wr3
if wr2 ^== '' then
m.wr.write.m = 'do;' m.wr.write.m'; end;',
'do ggLX=1 to m.stem.0;',
'line = stem"."ggLx;' wr2,
'; end; do;' wr3'; end'
else if wr3 ^== '' then
m.wr.write.m = 'do;' m.wr.write.m'; end; do;' wr3'; end'
return m
endProcedure wrDefine
/*--- write stem m.stem. to writeDescriptor m ------------------------*/
write: procedure expose m.
parse arg m, stem
if m.wr.write.m == 'b' then do
if stem ^== '' then
call wrStem 'WR.WRBUF.'m, , stem
return
end
if m.wr.wrBuf.m.0 ^== 0 then do
ggOrigStem = stem
stem = 'WR.WRBUF.'m
interpret m.wr.write.m
m.wr.wrBuf.m.0 = 0
stem = ggOrigStem
end
if stem ^== '' then
interpret m.wr.write.m
return
endProcedure write
/*--- write up to 3 strings to writeDescriptor m ---------------------*/
writeLn: procedure expose m.
parse arg m
ox=m.wr.wrBuf.m.0
do ax=2 to arg()
ox = ox + 1
m.wr.wrBuf.m.ox = arg(ax)
end
m.wr.wrBuf.m.0 = ox
if ox > 100 then
call write m
return
endProcedure writeLn
/*--- close writeDescriptor m ----------------------------------------*/
wrClose: procedure expose m.
parse arg m
if m.wr.wrBuf.m.0 ^== 0 then
call write m
m.wr.wrbuf.pp.0 = 0 /* in case it was buffering */
interpret m.wr.close.m
return
endProcedure wrClose
/*--- initialisation writer and output -------------------------------*/
wrIni: procedure expose m.
parse arg tr
m.wr.trace = tr = 1
m.wr.new = 0
m.wr.free.0 = 0
m.wr.out = wrNew()
m.wr.sysout = m.wr.out
m.wr.prc = wrNew()
m.wr.rootPrc = m.wr.prc
if m.wr.trace then
m.wr.sysOut = wrDefine(m.wr.out,,,'say "sysout:" quote(m.line)')
else
m.wr.sysOut = wrDefine(m.wr.out,,, 'say m.line')
m.wr.out.0 = 0
return
endProcedure wrIni
/**** simple convience function for stems *****************************/
/*--- fill stem st from index dx with lines from stem src ------------*/
wrStem: procedure expose m.
parse arg dst, dx, src
if dx == '' then
dx = m.dst.0
do ix = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.ix
end
m.dst.0 = dx
return dst
endProcedure wrStem
/*--- strip trailing spaces from stem dst ----------------------------*/
wrStrip: procedure expose m.
parse arg dst
do ix=1 to m.dst.0
m.dst.ix = strip(m.dst.ix, 't')
end
return dst
endProcedure wrStrip
/*--- fill stem dst from index dx with arguments ---------------------*/
wrArgs: procedure expose m.
parse arg dst, dx
if dx == '' then
dx = m.dst.0
do ix = 3 to arg()
dx = dx + 1
m.dst.dx = arg(ix)
end
m.dst.0 = dx
return dst
endProcedure wrArgs
/***********************************************************************
reader interface
define, read and close
***********************************************************************/
/*--- define read function -------------------------------------------*/
reDefine: procedure expose m.
parse arg m, m.wr.read.m, m.wr.readCLose.m, m.wr.readInfo.m
m.wr.readLX.m = ''
m.wr.readSX.m = 0
m.wr.readEOF.m = 0
return m
endProcedure reDefine
/*--- read from readDescriptor into stem stem
return true if data read, false at eof --------------------*/
read: procedure expose m.
parse arg m, stem
if m.wr.readEOF.m then
return 0
do forever
interpret m.wr.read.m
if ^ res then
return reClose(m)
if m.stem.0 > 0 then do
m.wr.readSX.m = m.wr.readSX.m + m.stem.0
return 1
end
end
endProcedure write
/*--- close readDescriptor m, if not already done --------------------*/
reClose: procedure expose m.
parse arg m
if ^ m.wr.readEOF.m then do
m.wr.readEOF.m = 1
interpret m.wr.readClose.m
end
return 0
endProcedure reClose
/*--- put next line into m.line, return false at eof -----------------*/
readLn: procedure expose m.
parse arg m, line
if m.wr.readLx.m == '' | m.wr.readLx.m >= m.wr.readStem.m.0 then do
if ^ read(m, 'WR.READSTEM.'m) then
return 0
lx = 1
end
else do
lx = 1 + m.wr.readLx.m
end
m.wr.readLx.m = lx
m.line = m.wr.readStem.m.lx
return 1
endProcedure readLn
/*--- return readInfo for line lx ------------------------------------*/
readInfo: procedure expose m.
parse arg m, lx
if m.wr.readEof.m then
txt = 'eof after line' m.wr.readSx.m
else if lx == '' then
txt = 'last line of stem' m.wr.readSx.m
else if lx == '*' then
txt = 'line' (m.wr.readSx.m - m.wr.readStem.m.0 + m.wr.readLX.m)
else
txt = 'line' (m.wr.readSx.m + lx)
return txt 'from dss' m.wr.readInfo.m
endProcedure readInfo
/***********************************************************************
Input-Ouput
transfer data betweeen stems and datasets
these are specified using a DataSetSpec DSS see wrAlloc:
***********************************************************************/
/*--- define writeDescriptor m to write to the datasetSpec dss */
wr2DS: procedure expose m.
parse arg m, dss
ty = wrAlloc(m, 'o', dss)
stmt = ''
if m.wr.allocStrip.m then
stmt = 'call wrStrip stem;'
if ty == 's' then do
call wrDefine m,
, stmt 'call wrStem' quote(m.wr.allocStem.m) ', , stem',
, m.wr.allocFree.m
end
else if ty == 'd' then do
dd = m.wr.allocDD.m
call writeDDBegin dd
call wrDefine m,
, stmt 'call writeDD' quote(dd) ', "M."'stem'"."',
, 'call writeDDEnd' quote(dd)';' m.wr.allocFree.m
end
else
call err 'wr2Ds bad allocType' ty 'from' dss
return m
endProcedure
/*--- define m as reader to read from datasetSpec dss ---------------*/
readDS: procedure expose m.
parse arg m, dss
if dss = '' then
call err 'wrFromDS empty datasetSpecification'
iTyp = wrAlloc(m, 'i', dss)
strp = ''
if m.wr.allocStrip.m then
strp = 'if res then call wrStrip stem;'
if iTyp == 's' then do
m.wr.readDone.m = 0
call reDefine m,
, 'if m.wr.readSX.m ^== 0 then res = 0;else do;' ,
'call wrStem stem, 0,' quote(m.wr.allocStem.m)';' ,
'res = m.stem.0 > 0;' strp 'end', , dss
end
else if iTyp = 'd' then do
dd = quote(m.wr.allocDD.m)
call reDefine m, 'res = readDD('dd', "m."stem".");' strp,
, 'call readDDEnd' dd';' m.wr.AllocFree.m, dss
end
else
call err 'readDS: bad allocTyp' iTyp 'from' dss
return m
endProcedure readDS
/*--- write to writeDescriptor m from readDescriptor r ---------------*/
wrReader: procedure expose m.
parse arg m, r
st = 'WR.FROMREAD.'m
do while read(r, st)
call write m, st
end
return
endProcedure wrReader
/*--- write to writeDescriptor m from datasetSpec dss ----------------*/
wrFromDS: procedure expose m.
parse arg m, dss
rx = wrNew('wrFromDS')
call wrReader m, readDS(rx, dss)
call wrFree rx
return
endProcedure wrFromDS
/*--- write to datasetSpec toSp from datasetSpec arg(2)... -----------*/
wrDSFromDS: procedure expose m.
parse arg toSP
m = wrNew('wrDSFromDS')
call wr2DS m, toSp
do ax=2 to arg()
frSp = arg(ax)
if ax ^= '' then
call wrFromDs m, frSp
end
call wrClose m
call wrFree m
return
endProcedure wrFromDS
/*----------------------------------------------------------------------
wrAlloc: allocate a file or stem withe default ioa
from datasetSpecification dss
dss in key=value syntax, either tso alloc attributes or
disp=...,
dsj= DatasetName in Jcl format (dsn= for tso format)
stem=xyz to allocate a stem m.xyz.*
strip=1 to strip trailing blanks before writing
ioa= i, o or a (input, output or append)
----------------------------------------------------------------------*/
wrAlloc: procedure expose m.
parse arg m, ioa, dss
s = 'WR.ALLOC'
m.wr.allocDD.m = ''
stem = ''
at = ''
disp = ''
m.wr.allocStrip.m = 0
m.wr.allocFree.m = ''
call scanBegin s, dss
do while scanKeyValue(s, 1, 0)
k = m.s.key
if k == 'DD' then m.wr.allocDD.m = m.s.val
else if k == 'DSJ' then at = at "dsn('"m.s.val"')"
else if k == 'STEM' then stem = m.s.val
else if k == 'DISP' then disp = m.s.val
else if k == 'STRIP' then m.wr.allocStrip.m = m.s.val
else if k == 'IOA' then ioa = m.s.val
else if left(m.s.val, 1) = '(' then
at = at m.s.key || m.s.val
else at = at m.s.key"("m.s.val")"
end
if ^scanAtEOL(s) then
call scanErr s, 'wrAlloc bad clause'
upper ioa
if stem ^= '' then do
m.wr.allocStem.m = stem
if ioa == 'O' then /* overrite existing lines */
m.stem.0 = 0
m.wr.allocType.m = 's'
end
else if at = '' then do
if m.wr.allocDD.m = '' then
call err 'dd or attribute must be specified:' dss
m.wr.allocType.m = 'd'
end
else do
m.wr.allocType.m = 'd'
if m.wr.allocDD.m = '' then
m.wr.allocDD.m = 'ALL'm
if disp ^= '' then nop
else if ioa == 'A' then disp = 'mod'
else if ioa == 'O' then disp = 'old'
else disp = 'shr'
if m.wr.allocApp.m = 1 then do
d3 = translate(strip(left(disp, 3)))
if d3 == 'OLD' | d3 == 'SHR' then
disp = 'mod' || substr(strip(disp), 4)
end
call adrTso "alloc dd("m.wr.allocDD.m")" disp at
m.wr.allocFree.m = 'call adrTso' ,
quote('free dd('m.wr.allocDD.m')')
end
return m.wr.allocType.m
endProcedure wrAlloc
/* copy wr end ****************************************************/
/* copy pos begin *****************************************************
StringHandling
pos*: several repetitions of pos (from left or right)
dsn*: convenience functions using pos* for dataset names
***********************************************************************/
/*--- return the index of rep'th occurrence of needle
negativ rep are counted from right -------------------------*/
posRep: procedure
parse arg needle, hayStack, rep, start
if rep > 0 then do
if start = '' then
start = 1
do cc = 1 to rep
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return sx
end
else if rep < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -rep
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return sx
end
else
return 0
endProcedure posRep
/*--- return n'th level (separated by needle, negative from right) ---*/
posLev: procedure
parse arg needle, hayStack, rep, start
if rep > 1 then do
sx = posRep(needle, hayStack, rep-1, start)
if sx < 1 then
return 0
return 1+sx
end
else if rep < -1 then do
sx = posRep(needle, hayStack, rep+1, start)
if sx < 1 then
return 0
return 1+lastPos(needle, hayStack, sx-1)
end
else if rep ^= -1 then
return rep /* for 0 and 1 */
else if start == '' then /* pos fails with empty start| */
return 1 + lastPos(needle, hayStack)
else
return 1 + lastPos(needle, hayStack, start)
endProcedure posLev
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
cnt = 0
do forever
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
cnt = cnt + 1
start = start + length(needle)
end
endProcedure posCount
/*--- concatenate several parts to a dsn -----------------------------*/
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
/*--- set the membername mbr into dsn --------------------------------*/
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
endProcedure dsnSetMbr
/*--- get the membername from dsn ------------------------------------*/
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1), 't', "'")
endProcedure dsnGetMbr
/*--- get the index of the lx'd level of dsn -------------------------*/
dsnPosLev: procedure
parse arg dsn, lx
sx = posLev('.', dsn, lx)
if sx ^= 1 then
return sx
else
return 1 + (left(dsn, 1) == "'")
endProcedure dsnPosLev
/*--- get the the lx'd level of dsn ----------------------------------*/
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
/* copy pos end ****************************************************/
/* copy adr begin ****************************************************/
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/* copy adr end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
/*--- set rc for ispf: -----------------------------------------------*/
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- return current time and cpu usage ------------------------------*/
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say 'help for rexx' s3
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
return 4
endProcedure help
/* copy err end *****************************************************/