/* Rexx - Ispf lab data set setup - Doug nadel - ispf project */ /* */ /* This program is an example of using REXX to add data sets to */ /* existing concatenations. It checks to see if the ddname is */ /* open. If it is not, it will create the file to concatenate */ /* if it needed and will then reallocate the dd to add or remove */ /* the new data set. */ /* */ /* This program creates ispf work libraries for the user and */ /* concatenates them ahead of the existing system libraries. */ /* */ /* Data sets created: */ /* userid.ISPFLAB.PANELS */ /* userid.ISPFLAB.MSGS */ /* userid.ISPFLAB.SKELS */ /* userid.ISPFLAB.CLIST */ /* userid.ISPFLAB.LOAD (Not set in this version) */ /* */ /* Attributes are inherited from existing allocations. */ /* */ /* Since ispxlibs may be open, this must be run outside of ispf. */ /*********************************************************************/ /* */ /* * * Customization section */ /* */ /*********************************************************************/ /*-------------------------------------------------------------------*/ /* Set up middle qualifier of new data sets here */ /*-------------------------------------------------------------------*/ middle_qualifier = '.ISPFLAB.' /*-------------------------------------------------------------------*/ /* Set up ddnames, suffixes and attributes here */ /*-------------------------------------------------------------------*/ ddlist ='ISPPLIB ISPMLIB ISPSLIB SYSPROC' suffix ='PANELS MSGS SKELS CLIST ' defrf =' FB FB FB FB ' defrl =' 80 80 80 80 ' /*-------------------------------------------------------------------*/ /* Determine when the program should end. If all values are */ /* zero (0) the program will try to reallocate all closed files */ /* regardless previous failures. */ /*-------------------------------------------------------------------*/ stop_If_in_ispf = 0 stop_If_any_ddnames_are_open = 1 /*********************************************************************/ Parse Upper Arg option . If abbrev('REMOVE',option,1)=1 Then option='REMOVE' Parse Source . . me . Numeric digits 10 /* Allow up to 7fffffff */ If stop_If_in_ispf=1 & sysvar(sysispf)='ACTIVE' Then Do Parse Value 'YES * The 'me 'command must be run outside of ISPF', With zerralrm zerrhm zerrlm zerrsm='' Address ispexec 'SETMSG MSG(ISRZ002)' Exit End If sysvar(syspref) <> '' Then If sysvar(syspref) <> userid() Then prefix=sysvar(syspref)'.'userid() Else prefix=sysvar(syspref) Else prefix=userid() If stop_If_any_ddnames_are_open = 1 Then Do fail='' Do a=1 to words(ddlist) /* Check if any ddnames are open */ If check_If_ddname_is_open(subword(ddlist,a,1))=1 Then fail=fail subword(ddlist,a,1) End If fail<>"" Then Do Say me': Error:' Say ' The following files are open:'fail Say ' No changes were made by the 'me' command.' Exit End End Do a=1 to words(ddlist) /* If all closed, reallocate */ Call reallocate subword(ddlist,a,1),subword(suffix,a,1),, subword(defrf,a,1),subword(defrl,a,1) End Exit /*-------------------------------------------------------------------*/ reallocate: Procedure Expose prefix option middle_qualifier dsn=''''prefix||middle_qualifier||Arg(2)'''' If option <>'REMOVE' Then Do If sysdsn(dsn) <>'OK' Then Do If 0 <> listdsi(Arg(1) 'FILE ') Then Parse Value Arg(3) Arg(4) With sysrecfm syslrecl recfm='' Do a=1 to length(sysrecfm) recfm=recfm substr(sysrecfm,a,1) End 'ALLOC FI(ISPFTEMP) NEW CAT DA('dsn') DSO(PO) DIR(10) REUSE ', 'SPACE(1,2) TRACK UNIT(SYSALLDA) ', 'LRECL('syslrecl') recfm('recfm')' If rc=0 Then 'FREE F(ISPFTEMP)' End End If sysdsn(dsn) = 'OK' Then Do Call get_allocations Arg(1) already_there = 0 Do a=1 to dsname.0 If ''''dsname.a''''=dsn Then already_there=1 End If option <> 'REMOVE' Then If already_there<>1 Then If check_If_ddname_is_open(Arg(1))=0 Then Do cmd= 'ALLOC REU SHR F('Arg(1)') DA('dsn Do a = 1 to dsname.0 cmd=cmd ''''dsname.a'''' End cmd=cmd')' Say 'Reallocating DDNAME 'Arg(1)' with 'dsn'...' Address tso cmd If rc>0 Then Do Say 'Reallocation of 'Arg(1)' failed!! Exiting...' Exit End End Else Say '===> File 'Arg(1)' is open and has not been changed.' Else Say dsn' is already allocated to 'Arg(1)'.' Else /* Option is remove */ If already_there=1 Then If check_If_ddname_is_open(Arg(1))=0 Then Do cmd= 'ALLOC REU SHR F('Arg(1)') DA(' other_ds_found = 0 Do a = 1 to dsname.0 If ''''dsname.a''''<>dsn Then Do cmd=cmd ''''dsname.a'''' other_ds_found=1 End End If other_ds_found=0 Then cmd='FREE FI('Arg(1) cmd=cmd')' Say 'Reallocating DDNAME 'Arg(1)' without 'dsn'...' Address tso cmd End Else Say '===> File 'Arg(1)' is open and has not been changed.' Else Nop /* Nothing to remove */ End Return /*-------------------------------------------------------------------*/ get_allocations: /* populate stems with names */ Procedure Expose ddname. dsname. Drop ddname. dsname. tiotptr=24+ptr(12+ptr(ptr(ptr(16)))) /* Get ddname array */ tioelngh=c2d(stg(tiotptr,1)) /* Length of 1st entry */ a=0 ddname=' ' Do Until tioelngh=0 /* Scan until dd found */ tioeddnm=strip(stg(tiotptr+4,8)) /* Get ddname from tiot */ If substr(tioeddnm,1,1) <>'00'x Then Do If substr(tioeddnm,1,1) <>" " Then ddname=tioeddnm If ddname=Arg(1) Then Do a=a+1 ddname.a=ddname tioelngh=c2d(stg(tiotptr,1)) /* Length of next entry */ tioejfcb=stg(tiotptr+12,3) jfcb=swareq(tioejfcb) /* Convert sva to 31-Bit addr */ dsname.a=strip(stg(jfcb,44)) /* Dsname jfcbdsnm */ End End tiotptr=tiotptr+tioelngh /* Get next entry */ tioelngh=c2d(stg(tiotptr,1)) /* Get entry length */ End dsname.0=a Return /*-------------------------------------------------------------------*/ check_If_ddname_is_open: Procedure tiotptr=24+ptr(12+ptr(ptr(ptr(16)))) /* Get ddname array */ tioelngh=c2d(stg(tiotptr,1)) /* Length of 1st entry */ a=0 p = find_dsab_chain() Do Until tioelngh=0 /* Scan until dd found */ tioeddnm=strip(stg(tiotptr+4,8)) /* Get ddname from tiot */ If tioeddnm=Arg(1) Then Do While p <>0 If c2d(stg(p+16,4))=tiotptr Then /* Found dsab of ddname */ If stg(p+14,2) <>'0000'x Then Return 1 /* Indicate ddname is open */ Else Return 0 /* Indicate ddname is not open*/ p=ptr(4+p) End tiotptr=tiotptr+tioelngh /* Get next entry */ tioelngh=c2d(stg(tiotptr,1)) /* Get entry length */ End Return 0 /* Indicate ddname is not open*/ /*-------------------------------------------------------------------*/ ptr: Return c2d(storage(d2x(Arg(1)),4)) /* Return a pointer */ /*-------------------------------------------------------------------*/ stg: Return storage(d2x(Arg(1)),Arg(2)) /* Return storage */ /*-------------------------------------------------------------------*/ swareq: Procedure If right(c2x(Arg(1)),1) <> 'F' Then /* Swa=Below ? */ Return c2d(Arg(1))+16 /* Yes, return sva+16 */ sva = c2d(Arg(1)) /* Convert to decimal */ tcb = ptr(540) /* Tcb psatold */ jscb = ptr(tcb+180) /* Jscb tcbjscb */ qmpl = ptr(jscb+244) /* Qmpl jscbqmpi */ qmat = ptr(qmpl+24) /* Qmat qmadd */ Do While sva>65536 qmat = ptr(qmat+12) /* Next qmat qmat+12 */ sva=sva-65536 /* 010006F -> 000006F */ End Return ptr(qmat+sva+1)+16 /*-------------------------------------------------------------------*/ find_dsab_chain: /* 10.???+B4?+140?+C? */ Return ptr(12+ptr(320+ptr(180+ptr(ptr(ptr(16))))))