zOs/REXX/CSRXUTIL
/*------------------------------- REXX ----------------------------*/
/* */
/* Function : Dataset Copy Utility */
/* Mlv : CS159X56 */
/*_________________________________________________________________*/
Parse Source procinfo
procname = Word(procinfo,3)
zerrsm = ""
zerrlm = ""
zerrxm = ""
freedd = ""
Numeric Digits 20
Parse Upper Arg parms
Parse Upper var parms cmd dsnfrom kwto dsnto opt prt
If cmd ^= 'COPY' Then Do
zerrsm = procname':Parameter1 "COPY" missing'
zerrlm = 'Input was:'parms
zerrxm = 'Parm1 was:'cmd
Call SetMsg 'L' 'YES'
End
If dsnfrom = '' Then Do
zerrsm = procname':Parameter2 "System/Vol:Dataset(Member)" missing'
zerrlm = 'Input was:'parms
Call SetMsg 'L' 'YES'
End
If P_Parms(dsnfrom,'()M*') > 0 Then Do
zerrsm = procname ||,
':Parameter2 "System/Vol:Dataset(Member)" was invalid'
zerrlm = 'Input was:'parms
zerrxm = 'Parm2 was:'dsnfrom
Call SetMsg 'L' 'YES'
End
sysf = sys
volf = vol
dsnf = dsn
mbrf = mbr
If kwto ^= 'TO' Then Do
zerrsm = procname':Parameter3 "TO" missing'
zerrlm = 'Input was:'parms
zerrxm = 'Parm3 was:'kwto
Call SetMsg 'L' 'YES'
End
If P_Parms(dsnto,'') > 0 Then Do
zerrsm = procname ||,
':Parameter4 "System/Vol:Dataset(Member)" was invalid'
zerrlm = 'Input was:'parms
zerrxm = 'Parm4 was:'dsnto
Call SetMsg 'L' 'YES'
End
syst = sys
volt = vol
dsnt = dsn
If opt = 'PRINT' & prt = '' Then Do
prt = opt
opt = ''
End
If opt ^= '' & ,
opt ^= 'NOREPLACE' & ,
opt ^= 'REPLACE' & ,
opt ^= 'ZERODIR' Then Do
zerrsm = procname':Parameter5 "NOREPLACE/REPLACE/ZERODIR" expected'
zerrlm = 'Input was:'parms
zerrxm = 'Parm5 was:'opt
Call SetMsg 'L' 'YES'
End
If prt ^= '' & ,
prt ^= 'PRINT' Then Do
zerrsm = procname':Parameter6 "PRINT" expected'
zerrlm = 'Input was:'parms
zerrxm = 'Parm5 was:'prt
Call SetMsg 'L' 'YES'
End
volp = ''
If volf ^= '' Then ,
volp = "VOLUME("volf") UNIT(SYSALLDA)"
"CSMEXEC ALLOCATE DATASET('"dsnf"') DISP(SHR) SYSTEM('"sysf"')",
volp
If Rc > 0 Then ,
Exit 8
freedd = SUBSYS_DDNAME
ddnf = SUBSYS_DDNAME
devtypxf = Val('SUBSYS_DEVTYPEX')
f1dscbf = Val('SUBSYS_F1DSCB')
dstpf = Val('SUBSYS_RDSNTYPE')
rvolf = Val('SUBSYS_RVOLUMES')
dsorgf = Strip(Val('SUBSYS_DSORG'))
lreclf = Strip(Val('SUBSYS_LRECL'))
blkszf = Strip(Val('SUBSYS_BLKSIZE'))
recfmf = Strip(Val('SUBSYS_RECFM'))
If Substr(dsorgf,1,2) ^= '??' & ,
Substr(dsorgf,1,2) ^= 'PO' & ,
Substr(dsorgf,1,2) ^= 'PS' Then Do
zerrsm = procname':Data set 'dsnf' has an unsupported DSORG: 'dsorgf
zerrlm = 'DSORG must be PS,PSU,PO or POU'
Call SetMsg 'L' 'YES'
End
If f1dscbf = '' Then Do
zerrsm = procname':Data set 'dsnf' must be a DASD dataset'
zerrlm = 'no Format-1-DSCB found on Volume:'rvolf
Call SetMsg 'L' 'YES'
End
If Substr(dsorgf,1,2) ^= '??' & ,
Substr(dsorgf,1,2) ^= 'PO' & ,
Substr(dsorgf,1,2) ^= 'PS' Then Do
zerrsm = procname':Data set 'dsnf' has an unsupported DSORG: 'dsorgf
zerrlm = 'DSORG must be PS,PSU,PO or POU'
Call SetMsg 'L' 'YES'
End
If Substr(dsorgf,1,2) = 'PS' & mbrf ^= '' Then Do
zerrsm = procname':Data set 'dsnf' has DSORG: 'dsorgf
zerrlm = 'no member specifiction allowed. Member: 'mbrf
Call SetMsg 'L' 'YES'
End
If Substr(dsorgf,1,2) = 'PO' & ,
dstpf ^= '40' & ,
dstpf ^= '80' Then Do
zerrsm = procname':Data set 'dsnf' has an invalid DSNTYPE: 'dstpf
zerrlm = 'only PDS (40) or PDSE (80) are supported'
Call SetMsg 'L' 'YES'
End
volp = ''
If volt ^= '' Then ,
volp = "VOLUME("volt") UNIT(SYSALLDA)"
Call Tsoexec "CSMEXEC ALLOCATE DATASET('"dsnt"') ",
" DISP(SHR) SYSTEM('"syst"') "volp,16
new = 0
If rc <> 0 Then Do
msgnc = 'DATA SET ' || dsnt || ' NOT IN CATALOG'
ok = 0
Do i = 1 To ot.0 While ^ok
If Wordpos(Word(ot.i,1),'CSMSV29E IKJ56228I') > 0 | ,
ot.i = msgnc Then ,
ok = 1
End
If ^ok Then Do
Do i = 1 To ot.0 While ^ok
Say ot.i
End
Call Go_Home 12
End
new = 1
End
Else Do
ddnt = SUBSYS_DDNAME
dsorgt = Strip(SUBSYS_DSORG)
If Substr(dsorgt,1,2) ^= '??' & ,
Substr(dsorgt,1,2) ^= 'PO' & ,
Substr(dsorgt,1,2) ^= 'PS' Then Do
zerrsm = procname ||,
':Data set 'dsnt' has an unsupported DSORG: 'dsorgt
zerrlm = 'DSORG must be PS, PSU, PO or POU'
Call SetMsg 'L' 'YES'
End
f1dscbt = Val('SUBSYS_F1DSCB')
If f1dscbt = '' Then Do
new = 1
"FREE F("ddnt")"
End
Else Do
freedd = freedd ddnt
lreclt = Strip(SUBSYS_LRECL)
blkszt = Strip(SUBSYS_BLKSIZE)
recfmt = Strip(SUBSYS_RECFM)
dstpt = SUBSYS_RDSNTYPE
End
End
MBR_MEM# = 1
MBR_DIRA = 0
If Substr(dsorgf,1,2) = 'PO' Then Do
"CSMEXEC MBRLIST DDNAME("ddnf") INDEX(' ') SHORT"
If Rc ^= 0 Then ,
Call Go_Home 12
If opt = '' Then ,
opt = 'NOREPLACE'
End
Else Do
If opt = 'NOREPLACE' | ,
opt = 'ZERODIR' Then Do
zerrsm = procname':Parameter5 "REPLACE/<BLANK>" expected'
zerrlm = 'Input was:'parms
zerrxm = 'Parm5 was:'opt
Call SetMsg 'L' 'YES'
End
opt = 'REPLACE'
End
If ^new Then Do
If Substr(dsorgt,1,2) ^= Substr(dsorgf,1,2) Then Do
zerrsm = procname ||,
':DSORG of input must be the same as DSORG of output data set'
zerrlm = 'Input :'Left(dsnf,44)' Dsorg:'dsorgf
zerrxm = 'Output :'Left(dsnt,44)' Dsorg:'dsorgt
Call SetMsg 'L' 'YES'
End
If Substr(dsorgt,1,2) = 'PO' Then Do
If Substr(recfmt,1,1) ^= Substr(recfmf,1,1) Then Do
zerrsm = procname ||,
':RECFM of input must be the same as RECFM of output data set'
zerrlm = 'Input :'Left(dsnf,44)' Recfm:'recfmf
zerrxm = 'Output :'Left(dsnt,44)' Recfm:'recfmt
Call SetMsg 'L' 'YES'
End
If Substr(recfmf,1,1) = 'V' & lreclf > lreclt Then Do
zerrsm = procname ||,
':INVALID LRECL. INPUT LRECL ('lreclf') EXCEEDS',
'OUTPUT LRECL ('lreclt').'
zerrlm = 'Input :'Left(dsnf,44)
zerrxm = 'Output :'Left(dsnt,44)
Call SetMsg 'L' 'YES'
End
End
End
Else Do
Gen_Alloc()
Ac = Rc
If Ac ^= 0 Then Do
Say ccmd
Call Go_Home 12
End
ddnt = SUBSYS_DDNAME
freedd = freedd ddnt
End
csmsysin = SUBSYS_DDNPREF'I'
csmsyspr = SUBSYS_DDNPREF'L'
spc = MBR_MEM#%625 + 1
If mbrf = '' Then ,
mbrf = '*'
If Substr(dsorgf,1,2) = 'PS' | ,
opt ^= 'NOREPLACE' & ,
mbrf = '*' Then Do
Call Tsoexec "ALLOC File("csmsysin") Dummy Reuse",4
End
Else Do
If opt = 'NOREPLACE' Then Do
"CSMEXEC MBRLIST DDNAME("ddnt") INDEX('.2') SHORT"
If Rc ^= 0 Then ,
Call Go_Home 12
End
Call Tsoexec "ALLOC File("csmsysin") New Space("spc" 1) Tracks",
" Lrecl(80) Recfm(F B) Reuse Dsorg(PS) ",
" Blksize(0)",4
found = 0
n = 0
ttrmem. = ''
Do i = 1 To MBR_NAME.0
mbr = Strip(MBR_NAME.i)
ttr = MBR_TTRP.i
If Bitand(X2c(MBR_INDC.i),'80'X) ^= '80'X Then Do
If Pat_Match(mbrf,mbr) Then Do
found = 1
If opt ^= 'NOREPLACE' | ,
MBR_NDX.2.mbr = 0 Then Do
n = n + 1
mbr.n = mbr
ttr.n = MBR_TTRP.i
End
End
End
Else Do
ttrmem.ttr = ttrmem.ttr mbr
End
End
If n = 0 Then Do
If found then ,
zerrsm = procname':Member:'mbrf' not replaced'
else ,
zerrsm = procname':Member:'mbrf' not found'
Call SetMsg 'N' 'YES'
Call Go_Home 4
End
k = 0
Do i = 1 To n
k = k + 1
O.k = ' S M='mbr.I
ttr = ttr.i
ttrmem = ttrmem.ttr
Do j = 1 To Words(ttrmem)
k = k + 1
O.k = ' S M='Word(ttrmem,j)
End
End
Call Tsoexec "Execio "k" Diskw "csmsysin" (Stem O. Finis)",4
End
freedd = freedd csmsysin
/* spc = spc * 3 */
Call Tsoexec "ALLOC File("csmsyspr") New Space("spc" 5) Cylinder",
" Lrecl(137) Recfm(V B) Reuse Dsorg(PS) ",
" Blksize(32760)",4
freedd = freedd csmsyspr
cmdu = 'CSMUTIL CSM,COPY'opt',DD(,,,,'csmsysin',' ||,
csmsyspr',,'||,
ddnf',' ||,
ddnt'),MARC(0)'
x = Outtrap('Ot.',,'NOCONCAT')
ot.0 = 0
cmdu
uc = Rc
x = Outtrap('OFF')
msg. = ''
If uc ^= 0 | prt = 'PRINT' Then Do
Call Tsoexec "Execio * Diskr "csmsyspr" (Stem msg. Finis)",4
Do i = 1 To ot.0
Say ot.i
End
Do i = 1 To Msg.0
Say msg.i
End
End
Call Go_Home uc
Exit
/* --------------------------------------------------------------------
Procedure Go_Home
----------------------------------------------------------------- */
Go_Home:
If freedd ^= '' Then ,
"FREE F("freedd")"
Exit Arg(1)
/* --------------------------------------------------------------------
Procedure Gen_Alloc
----------------------------------------------------------------- */
Gen_Alloc:
unitc = Length(rvolf)%6
ds1Lsta = Substr(f1dscbf,109,6)
spcb = X2c(Substr(f1dscbf,101,2))
ext2spc = X2d(Substr(f1dscbf,103,6))
spcround = 1
spcunit = ''
avgrec = ''
Select
When Bitand(Spcb,'10'X) = '10'X Then Do
spcx = X2c(Substr(f1dscbf,71,2))
secspace = X2d(Substr(f1dscbf,73,4))
Select
When Bitand(spcx,'08'X) = '08'X Then ,
secspace = secspace * 256
When Bitand(spcx,'04'X) = '04'X Then ,
secspace = secspace * 65536
Otherwise Nop
End
Select
When Bitand(spcx,'80'X) = '80'X Then Do
spcunit = 'BLOCKS('blkszf')'
spcround = blkszf
End
When Bitand(spcx,'40'X) = '40'X Then Do
spcunit = 'BLOCKS(1)'
avgrec = 'M'
ext2spc = Secspace
spcround = 1000000
End
When Bitand(spcx,'20'X) = '20'X Then Do
spcunit = 'BLOCKS(1)'
avgrec = 'K'
ext2spc = secspace
spcround = 1000
End
When Bitand(spcx,'10'X) = '10'X Then Do
spcunit = 'BLOCKS(1)'
avgrec = 'U'
ext2spc = secspace
spcround = 1
End
Otherwise Nop
End
End
When Bitand(spcb,'C0'X) = 'C0'X Then Do
spcunit = 'CYLINDER'
End
When Bitand(spcb,'80'X) = '80'X Then Do
spcunit = 'TRACKS'
End
When Bitand(spcb,'40'X) = '40'X Then Do
spcunit = 'BLOCKS('blkszf')'
spcround = blkszf
End
Otherwise Do
spcunit = '?'
End
End
ext1spc = 0
k64 = 2**16
If Substr(f1dscbf,123,2) ^= '00' Then Do
c1 = X2d(Substr(f1dscbf,127,4))+,
(X2d(Substr(f1dscbf,131,3))*k64)
t1 = X2d(Substr(f1dscbf,134,1))
c2 = X2d(Substr(f1dscbf,135,4))+,
(X2d(Substr(f1dscbf,139,3))*k64)
t2 = X2d(Substr(f1dscbf,142,1))
ext1spc = ((c2*15+t2)-(c1*15+t1))+1
End
Select
When Substr(spcunit,1,3) = 'TRA' Then Nop
When Substr(spcunit,1,3) = 'CYL' Then ,
ext1spc = ext1spc % 15
Otherwise Do
If blkszf = 0 Then Do
spcunit = 'TRACKS'
avgrec = ''
End
Else Do
"CSMEXEC TRKCAL "Substr(devtypxf,7,2),
D2x(ext1spc,8),
D2x(MBR_DIRA,8),
D2x(blkszf,4),
ds1Lsta
If Rc = 0 Then ,
ext1spc = (SUBSYS_BYTESALC)%spcround
End
End
End
ccmd = "CSMEXEC ALLOCATE DATASET('"dsnt"')",
"DISP(CAT)",
"SYSTEM("syst")",
"RECFM("recfmf") "spcunit
If unitc > 1 Then ,
ccmd = ccmd" UNITCNT("unitc")"
If volt ^= '' Then ,
ccmd = ccmd" VOLUME("volt")"
ccmd = ccmd" BLKSIZE("blkszf")"
ccmd = ccmd" LRECL("lreclf")"
ccmd = ccmd" DSORG("dsorgf")"
If Substr(dsorgf,1,2) = 'PO' Then Do
If dstpf = '40' Then ,
ccmd = ccmd" DSNTYPE(PDS)"
If dstpf = '80' Then Do
ccmd = ccmd" DSNTYPE(LIBRARY)"
MBR_DIRA = 0
End
End
If avgrec ^= '' Then ,
ccmd = ccmd" AVGREC("avgrec")"
dir = ''
If MBR_DIRA > 0 Then ,
dir = ','MBR_DIRA
ccmd = ccmd" SPACE("ext1spc','ext2spc || dir")"
Return ccmd
/* --------------------------------------------------------------------
Procedure SetMsg:
----------------------------------------------------------------- */
SetMsg:
Parse Arg MsgOpt .
If zerrsm ^= '' Then ,
Say zerrSm
If zerrlm ^= '' Then ,
Say zerrlm
If zerrxm ^= '' Then ,
Say zerrxm
If msgopt = 'L' Then ,
Call Go_Home 12
zerrsm = ""
zerrlm = ""
zerrxm = ""
Return
Val:
If Wordpos(Arg(1),SUBSYS_VNAMES) > 0 Then ,
Return Value(Arg(1))
Else ,
Return ''
P_Parms:Procedure Expose sys dsn vol mbr
Zprefix= Sysvar('SYSPREF')
svdm = Arg(1)
sys = ''
vol = ''
mbr = ''
dsn = ''
zerrxm = ''
Select
When Pos('/',svdm) = 0 &,
Pos(':',svdm) = 0 Then ,
Parse Upper Var svdm dsn .
When Pos('/',svdm) = 0 &,
Pos(':',svdm) > 0 Then ,
Parse Upper Var svdm vol':'dsn .
When Pos('/',svdm) > 0 &,
Pos(':',svdm) > 0 Then ,
Parse Upper Var svdm sys'/'vol':'dsn .
Otherwise ,
Parse Upper Var svdm sys'/'dsn .
End
If sys = '*' | ,
sys = '' Then ,
sys = Mvsvar('SYSNAME')
If sys ^= '' Then Do
res = VerifySystemName(sys,' ')
Parse Var res frc zerrsm zerrlm
If frc = 8 Then Do
zerrsm = zerrsm' . Token:'Arg(1)
Call SetMsg 'I' 'YES'
Return 8
End
End
trail = ''
If Pos('(',dsn) > 0 Then Do
Parse Var dsn dsnx'('mbr')'trail
If trail ^= '' & trail ^= "'" Then Do
zerrsm = 'invalid dsname'
zerrlm = 'Data set name:'dsn' is invalid'
Call SetMsg 'I' 'YES'
Return 8
End
dsn = dsnx
End
If dsn = '' Then Do
zerrsm = 'dsname missing'
zerrlm = 'Token:'Arg(1)
Call SetMsg 'I' 'YES'
Return 8
End
qu = ""
If Substr(dsn,1,1) = "'" Then ,
qu = "'"
dsn = Strip(dsn,,"'")
If mbr ^= '' Then ,
cdsn = qu || dsn"("mbr")" || qu
Else ,
cdsn = qu || dsn || qu
res = DsnCheck(cdsn,Arg(2)"''",zprefix)
Parse Var res frc dsn mbr
If Frc = 8 Then Do
Parse Var res frc zerrsm zerrlm
zerrsm = zerrsm' . Token:'Arg(1)
Call SetMsg 'I' 'YES'
Return 8
End
/*
say 'system:'sys
say 'vol :'vol
say 'dsn :'dsn
say 'member:'mbr
*/
Return 0
/* $INCLUDE IRPVERSN */
/* $START IRPVERSN */
/* ------------------------------------------------------------------ *
* Procedure VerifySystemName: *
* Rc = 0 ===> Ok *
* ^= 0 ===> invalid *
* ------------------------------------------------------------------ */
VerifySystemName:Procedure
Rmtsys = Strip(Arg(1))
If Arg(2) = '' & Rmtsys = '' Then ,
Return 0
If Rmtsys = '*' Then ,
Return 0
Sc = '0'
Do I = 1 To Length(Rmtsys)
Mask = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ#$@0123456789' || Sc
If Pos(Substr(Rmtsys,I,1),Mask) = 0 Then Do
Sm = 'invalid_System_Name'
Lm = 'at Position 'I'. Valid Characters: 'mask
Return 8 Sm Lm
End
Sc = '_'
End
Return 0
/* --------------------------------------------------------------------
End, VerifySystemName
----------------------------------------------------------------- */
/* $END IRPVERSN */
/* $INCLUDE IRPTSOEX */
/* $START IRPTSOEX */
/* --------------------------------------------------------------------
Procedure Tsoexec: Execute TSO Commands
----------------------------------------------------------------- */
Tsoexec:
x = Outtrap('Ot.',,'NOCONCAT')
Address Tso Arg(1)
Lc = Rc
x = Outtrap('OFF')
If Lc > Arg(2) | Lc < 0 & Arg(2) ^= 99 Then Do
Say Copies('*',79)
Say 'Rc('Lc') executing "'Arg(1)'" at Line 'Sigl ,
'in Procedure 'Procname
Do II = 1 To Ot.0
Say Ot.II
End
Say Copies('*',79)
Call Go_Home Lc
End
Return
/* --------------------------------------------------------------------
End, Tsoexec
----------------------------------------------------------------- */
/* $END IRPTSOEX */
/* $INCLUDE IRPVERDS */
/* $START IRPVERDS */
/* ------------------------------------------------------------------ *
* Procedure DsnCheck: Dsname, Options, Prefix *
* Options: ) ==> add missing ) *
* ( ==> allow Member or Gdg *
* G ==> allow Gdg *
* + ==> allow Gdg +1 *
* - ==> allow Gdg -n *
* 0 ==> allow Gdg 0 *
* M ==> allow Member *
* * ==> allow generic Membername *
* ' ==> allow quoted Dsname *
* '' ==> allow quoted Dsname, add *
* Rc = 0 ===> Dsname missing quote *
* 1 ===> Dsname(Member) *
* 2 ===> Dsname(*Member%) *
* 3 ===> Dsname(Gdg) *
* 8 ===> Error *
* ------------------------------------------------------------------ */
DsnCheck:Procedure Expose Dsnqual.
Dsnqual. = ''
Dsnqual.0= 0
Dsn = Translate(Arg(1))
Ldsn = Length(Dsn)
Dsn1 = Dsn
If Dsn = '' Then
Return '8 missing_Dsname'
If Pos(' ',Dsn) > 0 Then
Return '8 invalid_Dsname (contains one or more Blanks) Dsn:'Dsn
If Pos("'",Arg(2)) > 0 Then Do
If Substr(Dsn,1,1) = "'" Then Do
If Ldsn = 1 Then ,
Return '8 invalid_Dsname (ending quote missing) Dsn:'Dsn
If Substr(Dsn,Ldsn,1) <> "'" Then Do
If Pos("''",Arg(2)) > 0 Then Do
Ldsn = Ldsn + 1
Dsn = Dsn"'"
End
Else ,
Return '8 invalid_Dsname (ending quote missing) Dsn:'Dsn
End
If Ldsn = 2 Then ,
Return '8 missing_Dsname Dsn:'Dsn
Dsn1 = Substr(Dsn,2,Ldsn-2)
End
Else Do
If Arg(3) <> '' Then ,
Dsn1 = Arg(3)'.'Dsn1
End
End
Else Do
If Pos("'",Dsn) > 0 Then
Return '8 invalid_Dsname (no quotes allowed) Dsn:'Dsn
End
Mbr = ''
Ldsn = Length(Dsn1)
Cp = Pos("(",Dsn1)
If Cp > 0 Then Do
If Pos("(",Arg(2)) = 0 Then ,
Return '8 invalid_Dsname (member not allowed) Dsn:'Dsn
Mbr = Substr(Dsn1,Cp+1)
Lmbr = Length(Mbr)
If Lmbr= 0 Then
Return '8 missing_Member/GDG Dsn:'Dsn
If Substr(Mbr,Lmbr,1) <> ")" & ,
Pos(")",Arg(2)) > 0 Then Do
Mbr = Mbr')'
Lmbr = Lmbr + 1
End
If Lmbr <= 1 Then ,
Return '8 invalid_Member/GDG (Member or ending ")"',
'missing) Dsn:'Dsn
Dsn1 = Substr(Dsn1,1,Cp-1)
Ldsn = Cp-1
If Substr(Mbr,Lmbr,1) <> ")" Then ,
Return '8 invalid_Member (ending ")" missing) Dsn:'Dsn
Mbr = Substr(Mbr,1,Lmbr-1)
Lmbr = Lmbr - 1
If Lmbr = 0 Then ,
Return '8 missing_Member/GDG Dsn:'Dsn
If Lmbr > 8 Then ,
Return '8 invalid_Member/GDG (more than 8 bytes) Dsn:'Dsn
End
If Ldsn = 0 Then ,
Return '8 missing_Dsname Dsn:'Dsn
If Ldsn > 44 Then ,
Return '8 invalid_Dsname (more than 44 Bytes) Dsn:'Dsn1
If Substr(Dsn1,1,1) = '.' | ,
Substr(Dsn1,Ldsn,1) = '.' Then ,
Return '8 invalid_Dsname (.) Dsn:'Dsn1
Dsn2 = Translate(Dsn1,' ','.')
Dsnqual.0 = Words(Dsn2)
Chars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ#$@'
Do I = 1 To DsnQual.0
Dsnqual.I = Word(Dsn2,I)
If Length(DsnQual.I) > 8 Then ,
Return '8 invalid_Dsname ('I'.Qualifier > 8) Dsn:'Dsn1
Okc = Chars
Do J = 1 To Length(DsnQual.I)
C = Substr(DsnQual.I,J,1)
If Pos(C,Okc) = 0 Then ,
Return '8 invalid_Dsname (Invalid ',
'Char.:"'C'" found) Dsn:'Dsn1
Okc = Chars'01234567890-'
End
End
Okm = ''
Frc = 0
If Pos("*",Mbr) > 0 | ,
Pos("%",Mbr) > 0 Then Do
If Pos("*",Arg(2)) = 0 Then ,
Return '8 invalid_Member (no generic Member allowed) Dsn:'Dsn
Frc = 2
Okm = '*%'
End
C1 = Substr(Mbr,1,1)
If Pos(C1,"+-0") > 0 Then Do
If Pos("G",Arg(2)) = 0 Then ,
Return '8 invalid_Member ',
'(no gdg specification allowed) Dsn:'Dsn
If Pos(C1,Arg(2)) = 0 Then ,
Return '8 invalid_Gdg ',
'(no gdg with "'C1'" allowed) Dsn:'Dsn
If Mbr <> '0' Then Do
If Datatype(Substr(Mbr,2)) <> 'NUM' Then ,
Return '8 invalid_Gdg_Spec. ',
'(numeric value expected) Dsn:'Dsn
End
If C1 = '-' & Mbr = '0' Then Do
Return '8 invalid_Gdg_Spec. ',
'(-0 not allowed) Dsn:'Dsn
End
If C1 = '+' & Mbr <> '+1' Then Do
Return '8 invalid_Gdg_Spec. ',
'(only +1 allowed) Dsn:'Dsn
End
Return 3 Dsn1 Mbr
End
If Pos("M",Arg(2)) = 0 & Length(Mbr) > 0 Then ,
Return '8 Member_invalid ',
'(only gdg specification allowed) Dsn:'Dsn
Okc = Chars || Okm
Do J = 1 To Length(Mbr)
C = Substr(Mbr,J,1)
If Pos(C,Okc) = 0 Then ,
Return '8 invalid_Member (Invalid ',
'Char.:"'C'" found) Dsn:'Dsn
Okc = Chars'01234567890-'Okm
Frc = 1
End
Return Frc Dsn1 Mbr
/* --------------------------------------------------------------------
End, Dsn_Check
----------------------------------------------------------------- */
/* $END IRPVERDS */
/* $INCLUDE IRPPATTM */
/* $START IRPPATTM */
/* --------------------------------------------------------------------
Procedure Pat_Match Check Pattern
----------------------------------------------------------------- */
Pat_Match:Procedure
Pat = Arg(1)
P = Pos('**',Pat)
Do While P>0
Pat = Substr(Pat,1,P-1)Substr(Pat,P+1)
P = Pos('**',Pat)
End
Patl= Length(Pat)
Str = Arg(2)
Strl= Length(Str)
If Patl = 0 Then Do
If Strl = 0 Then ,
Return 1
Return 0
End
If Pat == '*' Then ,
Return 1
If Strl = 0 Then ,
Return 0
Patc = Substr(Pat,1,1)
If Patc = '*' Then Do
Do I = 1 To Strl
If Pat_Match(Substr(Pat,2),Substr(Str,I)) Then ,
Return 1
End
End
Else Do
If Patc = '%' | ,
Patc = Substr(Str,1,1) Then ,
Return Pat_Match(Substr(Pat,2),Substr(Str,2))
End
Return 0
/* --------------------------------------------------------------------
End, Pat_Match
----------------------------------------------------------------- */
/* $END IRPPATTM */