/* REXX NMAR NMR Application Repository. |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| | | | WARNING: EMBEDDED COMPONENTS. | | See text following TOOLKIT_INIT | | | |**-***-***-***-***-***-***-***-***-***-***-***-***-***-***-***-**| NMAR uses RXVSAM extensively. Information about RXVSAM can be obtained from the CBT archives at http://www.cbttape.org. While the syntax and function of RXVSAM calls is typically self-evident, maintainers are warned that its syntax is rigid and unforgiving. Written by Frank Clarke 20050129 Impact Analysis . ISPLLIB RXVSAM . SYSEXEC FIREHIST . SYSEXEC TRAPOUT Modification History 20091221 fxc inventory-for-application; */ arg argline address TSO /* REXXSKEL ver.20040227 */ arg parms "((" opts opts = Strip(opts,"T",")") /* clip trailing paren */ signal on syntax signal on novalue supported_functions = "QUERY CKOUT RLSE ADD DIR" /* needed for HELP */ call TOOLKIT_INIT /* conventional start-up -*/ if ^sw.inispf then do /* after TOOLKIT_INIT return */ arg line line = line "(( RESTARTED" /* tell the next invocation */ "ISPSTART CMD("exec_name line")" /* Invoke ISPF... */ exit /* ...then bail out */ end rc = Trace("O"); rc = Trace(tv) info = parms /* to enable parsing */ call A_INIT /* -*/ call B_MAIN_PROCESS /* -*/ call ZB_SAVELOG /* -*/ if \sw.nested then call DUMP_QUEUE /* -*/ if sw.0exit_ISPF then do /* just after DUMP_QUEUE */ rc = OutTrap('LL.') exit 4 end exit /*@ NMAR */ /* . ----------------------------------------------------------------- */ A_INIT: /*@ */ if branch then call BRANCH address TSO realuser = Userid() parse value "" with rxvsam_errormsg , appl. currver. obstat. , pattern. , /* patterns for types */ appusers. , /* authorized users by app */ applist patternlist , complist mluname. , warnmsg, zerrsm zerrlm , ddnlist sel comp. vskey apio = "OUTPUT" parse value "0 0 0 0 0 0 0 0 0" with, arsusp seq. sw_obs . call AA_SETUP_LOG /* -*/ call AK_KEYWDS /* -*/ if exec_name = "NMART" then do /* test */ ocompds = "'DTAFXC.@#AR.D01VCMP.KSD.PROD'" checkds = "'DTAFXC.@#AR.D01VCHK.KSD.PROD'" cleards = "'DTAFXC.@#AR.D20VHIS.PA1.PROD'" dirds = "'DTAFXC.@#AR.D01VDIR.KSD.PROD'" end /* */ if exec_name = "NMAR" then do /* prod */ ocompds = "'ACNV.TS.D822.D01VCMP.KSD.PROD'" xcompds = "'ACNV.TS.D822.D01VCMP.AX1.PROD'" checkds = "'ACNV.TS.D822.D01VCHK.KSD.PROD'" cleards = "'ACNV.TS.D822.D20VHIS.PA1.PROD'" dirds = "'ACNV.TS.D822.D01VDIR.KSD.PROD'" end /* */ obstext. = "" obstext.1 = "(Obsolete)" costat. = "??" costat.1C = "Ckout" costat.1D = "Cko/Susp" costat.2C = "Xmit" costat.2D = "Xmit/Susp" reportds = "NTIN.TS.D822.PRINT.REPORTS" tmtag = Time("S") $tn$ = "$AR"tmtag /* $AR04385 maybe */ return /*@ A_INIT */ /* . ----------------------------------------------------------------- */ AA_SETUP_LOG: /*@ */ if branch then call BRANCH address TSO parse value "0" with, log# log. parse value Date("S") Time("S") Time("N") with, yyyymmdd sssss hhmmss . parse var yyyymmdd 4 yrdigit 5 mm 7 dd /* 9 12 14 maybe */ if Pos(yrdigit,"13579") > 0 then mm = mm + 12 /* mm=24 */ logtag = Substr("ABCDEFGHIJKLMNOPQRSTUVWX",mm,1) /* logtag=X */ subid = logtag""dd""Right(sssss,5,0) /* X1423722 ? */ vb4k.0 = "NEW CATALOG UNIT(SYSDA) SPACE(1 5) TRACKS", "RECFM(V B) LRECL(4096) BLKSIZE(0)" vb4k.1 = "SHR" /* if it already exists... */ logdsn = "@@LOG."exec_name"."subid".#CILIST" origds = Find_Origin() /* -*/ locale = "("BRANCH("ID")")" call ZL_LOGMSG(exec_name "started by" Userid() yyyymmdd hhmmss) call ZL_LOGMSG( locale, "Running from" origds) call ZL_LOGMSG( locale, "Arg:" argline) return /*@ AA_SETUP_LOG */ /* . ----------------------------------------------------------------- */ AK_KEYWDS: /*@ */ if branch then call BRANCH address TSO appl = KEYWD("APPL") /* only needed for ADD -*/ altuser = KEYWD("ASUSER") /* alternate userid -*/ invuser = KEYWD("USER") /* alternate userid -*/ if sw.0MySUSP then return /* don't need a FUNC or KEY */ if invuser <> "" then return /* don't need a FUNC or KEY */ if info = "" then call HELP /* -*/ parse var info func key if WordPos(func,supported_functions) = 0 then do helpmsg = "Function >"func"< not recognized." call HELP /* ...and don't come back -*/ end if func = "QUERY" then do info = key sw.0Active = SWITCH("ACTIVE") key = info end savkey = key /* retain */ return /*@ AK_KEYWDS */ /* . ----------------------------------------------------------------- */ B_MAIN_PROCESS: /*@ */ if branch then call BRANCH address ISPEXEC if sw.0Admin then , parse value "INPUT" altuser realuser with, apio thisuser . else thisuser = realuser /* Sumus quid sumus */ if sw.0MySUSP then do call BS_SUSP /* calls NMAR recursively -*/ exit end if invuser <> "" then do call BU_INVENTORY /* calls NMAR recursively -*/ exit end call BIA_PROLOG /* extract ISPF assets -*/ "LIBDEF ISPLLIB DATASET ID('NTIN.TS.D822.LIB.ISPLLIB') STACK" call BB_AUTHORIZE /* identify A/R owners -*/ select when func = "ADD" then do call BA_ADD /* add a new component -*/ if ok_ct > 0 then, "DMND2CA7 MSDRTRIG,3" /* send new list to MACS */ end /* ADD */ when func = "CKOUT" then do call BC_CKOUT /* check out a component -*/ end /* CKOUT */ when func = "DIR" then do call BD_APP_DIR /* display an appl profile -*/ end /* DIR */ when func = "QUERY" then do call BI_INFO /* display A/R detail -*/ end /* QUERY */ when func = "RLSE" then do call BR_RLSE /* release check out -*/ end /* RLSE */ otherwise do /* */ end /* otherwise */ end /* select */ "LIBDEF ISPLLIB" /* finished with RXVSAM */ call BIZ_EPILOG /* drop LIBDEFs -*/ return /*@ B_MAIN_PROCESS */ /* Load appusers.COMMON . ----------------------------------------------------------------- */ BB_AUTHORIZE: /*@ */ if branch then call BRANCH address TSO orig_appl = appl /* save */ appl = "COMMON" call BAB_CHECK_APPL /* read AD0102 for COMMON -*/ appl = orig_appl /* restore */ return /*@ BB_AUTHORIZE */ /* Add a new component. Each 'key' must be exactly 10 characters long. The last two characters identify the type of component. . ----------------------------------------------------------------- */ BA_ADD: /*@ add a component */ if branch then call BRANCH address TSO parse value "0 0" with ok_ct ng_ct if appl = "" then do helpmsg = "APPL is required for ADD" call HELP /* ...and exit -*/ end if patternlist = "" then, /* not loaded */ call BAA_LOAD_PATTERNS /* identify type of data -*/ if WordPos(appl,applist) = 0 then do /* is it new? */ call BAB_CHECK_APPL /* read AD0102 for APPL -*/ locale = "("BRANCH("ID")")" if sw.0vdir_not_found then do return end end call BAC_LOAD_COMPONENTS /* load AD0104 -*/ return /*@ BA_ADD */ /* The supported components can be found in ACNN.PR.CTLCARD(AD02DA1P). Any line there whose first character is a dot contains as its first token the pattern for a component-type: . (n) dots represent the key-portion; . (m) asterisks represent the variable-portion; . the last two characters are the component-type. . ----------------------------------------------------------------- */ BAA_LOAD_PATTERNS: /*@ get lengths by datatype */ if branch then call BRANCH address TSO "ALLOC FI($TMP) DA('ACNN.PR.CTLCARD(AD02DA1P)') SHR REU" "NEWSTACK" "EXECIO * DISKR $TMP (FINIS" "FREE FI($TMP)" do queued() /* every row */ pull t1 . /* first token */ if Left(t1,1) = "." then do kl = LastPos(".",t1) /* last dot is key-length */ vl = 8 - kl parse var t1 9 type . pattern.type = kl vl /* 6 2, maybe */ patternlist = patternlist type end end /* queued */ "DELSTACK" return /*@ BAA_LOAD_PATTERNS */ /* Verify that the supplied application-id is valid. . AD0102: 03 APPL CHAR(8), /* 001 - 008 */ 03 TITLE CHAR(40), /* 009 - 048 */ 03 DATE_CHANGED CHAR(8), /* 049 - 056 */ 03 USER_CHANGED CHAR(8), /* 057 - 064 */ 03 FLAGS, /* 065 - 065 */ 05 OBSOLETE BIT(1), 03 FILLER CHAR(2), /* 066 - 067 */ 03 JOBNAME_PREFIX CHAR(3), /* 068 - 070 */ 03 SUPPORT_MANAGER CHAR(8), /* 071 - 078 */ 03 SQA CHAR(8), /* 079 - 086 */ 03 CUSTOMER(8) CHAR(8), /* 087 - 150 */ 03 PRODUCTION(8) CHAR(8), /* 151 - 214 */ 03 DEVELOPMENT(8) CHAR(8); /* 215 - 278 */ . ----------------------------------------------------------------- */ BAB_CHECK_APPL: /*@ is this a good APPL? */ if branch then call BRANCH address TSO sw.0vdir_not_found = 0 "ALLOC FI($VS) DA("dirds") SHR REU" rxv_rc = RXVSAM("OPENINPUT","$VS","KSDS") rxv_rc = RXVSAM('READ','$VS',Left(appl,8),'AD0102') if rxv_rc > 0 then do /* ...oops */ sw.0vdir_not_found = 1 zerrsm = "Appl INCORR" zerrlm = "Application" appl "is unknown." address ISPEXEC "SETMSG MSG(ISRZ002)" call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm ) end else do applist = applist appl call ZL_LOGMSG( "("BRANCH("ID")")" , "DIR:" AD0102 ) parse var ad0102 71 appmgr +8, 215 appdev +64 appusers.appl = appmgr appdev end rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" return /*@ BAB_CHECK_APPL */ /* Load the new key to the Component file. . AD0104: 03 APPL CHAR(8), /* 001 - 008 */ 03 COMPONENT CHAR(10), /* 009 - 018 */ 03 CURRENT_VERSION CHAR(10), /* 019 - 028 */ 03 FLAGS, /* 029 - 029 */ 05 OBSOLETE BIT(1), 05 LINKEDIT_ONLY BIT(1), 03 IFAM CHAR(1), /* 030 - 030 */ 03 ALIAS CHAR(24); /* 031 - 054 */ . ----------------------------------------------------------------- */ BAC_LOAD_COMPONENTS: /*@ write the CMP record */ if branch then call BRANCH address TSO locale = "("BRANCH("ID")")" zerrlm = "" "ALLOC FI($VS) DA("ocompds") SHR REU" rxv_rc = RXVSAM("OPENOUTPUT","$VS","KSDS") do Words(key) /* each key */ parse var key thiskey key /* isolate 10-char key */ if Length(thiskey) <> 10 then do emsg = thiskey "length not 10" zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) iterate end if Pos("*",thiskey) > 0 then do emsg = thiskey "refused - generic key" zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) iterate end /* thiskey contains stars */ parse var thiskey 9 suff . if pattern.suff = "" then do emsg = suff "not supported" zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) iterate end parse var pattern.suff kl vl . component = Left(thiskey,kl)Copies("*",vl)suff /* TA7RZ***PR */ ad0104 = Left(appl,8) ||, component ||, thiskey ||, x2c(00) ||, Copies(" ",25) rxv_rc = RXVSAM('WRITE','$VS',component,'AD0104') if rxv_rc <> 0 then do ng_ct = ng_ct + 1 emsg = component "not written, RC="rxv_rc zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) end else do ok_ct = ok_ct + 1 emsg = component "written." zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) end end /* key */ rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" address ISPEXEC zerrsm = "OK="ok_ct " NG="ng_ct zerrlm = Space(Strip(zerrlm,,";"),1) "SETMSG MSG(ISRZ002)" zerrlm = "" return /*@ BAC_LOAD_COMPONENTS */ /* . Read VCMP to find the base-component. . Read VCHK to acquire current data (if any). If key-not-found, build a new record. . Update VCHK to show component checked-out: . (a) #_OF_USERS +1 (but not >5) and convert to 2-byte binary; . (b) if necessary, purge oldest block . (c) add a new CHECKOUT block with STATUS = '1C'x A user may have no more than one active check-out for a component. . ----------------------------------------------------------------- */ BC_CKOUT: /*@ check out a component */ if branch then call BRANCH address TSO if patternlist = "" then, /* not loaded */ call BAA_LOAD_PATTERNS /* identify type of data -*/ locale = "("BRANCH("ID")")" do Words(key) /* each key */ parse var key thiskey key /* isolate A/R component name */ if Length(thiskey) <> 10 then do emsg = thiskey "length not 10" zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) iterate end if Pos("*",thiskey) > 0 then do emsg = thiskey "refused - generic key" zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) iterate end /* thiskey contains stars */ parse var thiskey 9 suff . if pattern.suff = "" then do emsg = suff "not supported" zerrlm = zerrlm";" emsg call ZL_LOGMSG( locale emsg ) iterate end parse var pattern.suff kl vl . component = Left(thiskey,kl)Copies("*",vl)suff call BCA_READ_VCMP /* Owned components (AD0104) -*/ if sw.0error_found then return if WordPos(appl,applist) = 0 then do call BAB_CHECK_APPL /* read AD0102 for APPL -*/ if WordPos( realuser,appusers.appl ) = 0 then do warnmsg = "You will not be able to transmit this element. ", "Your userid is not authorized for this ", "application." end call BCC_READ_VCHK /* Get Checkout (AD0106) -*/ call BCD_UPDATE_CKOUT /* Load new data and write -*/ end /* key */ return /*@ BC_CKOUT */ /* Pick up AD0104 (Component) 03 APPL CHAR(8), /* 001 - 008 */ 03 COMPONENT CHAR(10), /* 009 - 018 */ 03 CURRENT_VERSION CHAR(10), /* 019 - 028 */ 03 FLAGS, /* 029 - 029 */ 05 OBSOLETE BIT(1), 05 LINKEDIT_ONLY BIT(1), 03 IFAM CHAR(1), /* 030 - 030 */ 03 ALIAS CHAR(24); /* 031 - 054 */ . ----------------------------------------------------------------- */ BCA_READ_VCMP: /*@ */ if branch then call BRANCH address TSO sw.0vcmp_not_found = 0 "ALLOC FI($VS) DA("ocompds") SHR REU" rxv_rc = RXVSAM("OPENINPUT","$VS","KSDS") rxv_rc = RXVSAM('READ','$VS',component,'AD0104') if rxv_rc > 0 then do /* ...oops */ sw.0vcmp_not_found = 1 sw.0error_found = 1 end else do parse var ad0104 appl 9 component 19 currver 29 bits 30 call ZL_LOGMSG( "("BRANCH("ID")")" , "CMP:" ad0104 ) bits = X2B(C2X(bits)) /* '80'x -> 1000 0000 */ sw_obs = Left(bits,1) comp.thiskey = component appl.component = appl currver.component = currver obstat.component = obstext.sw_obs end rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" if sw.0vcmp_not_found then do address ISPEXEC zerrsm = "No Component" zerrlm = "Component" thiskey "not found" "SETMSG MSG(ISRZ002)" call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm ) end return /*@ BCA_READ_VCMP */ /* Part I of two parts: read the existing check-out record (AD0106), if any. Caller will set 'thiskey', length 10. . AD0106: %DCL MAX_CHECKOUT CHAR; %MAX_CHECKOUT = '5'; 03 COMPONENT CHAR(10), /* 001 - 010 */ 03 #_OF_USERS FIXED BIN(15), /* 011 - 012 */ 03 CHECKOUT(MAX_CHECKOUT REFER (#_OF_USERS)), 05 USER_ID CHAR(8), /* 013 - 020 */ 05 DATE CHAR(8), /* 021 - 028 */ 05 NAME_CHECKED_OUT CHAR(10), /* 029 - 038 */ 05 NAME_TRANSMITTED CHAR(10), /* 039 - 048 */ 05 STATUS FIXED DEC(1); /* 049 - 049 */ . ----------------------------------------------------------------- */ BCC_READ_VCHK: /*@ */ if branch then call BRANCH address TSO "ALLOC FI($VS) DA("checkds") SHR REU" rxv_rc = RXVSAM("OPENIO","$VS","KSDS") rxv_rc = RXVSAM('READ','$VS',thiskey,'AD0106') if rxv_rc > 0 then, /* ...oops */ sw.0key_not_found = 1 else, call ZL_LOGMSG( "("BRANCH("ID")")" , "CHK:" ad0106 ) return /*@ BCC_READ_VCHK */ /* Part II of two parts: (re-)construct the AD0106 record and (RE)WRITE it to the VSAM file. This was split from the READ to make the process clearer. . ----------------------------------------------------------------- */ BCD_UPDATE_CKOUT: /*@ */ if branch then call BRANCH address TSO if sw.0key_not_found then do /* build block #1 */ ardate = Date("S") argrp = component /* component with *'s */ arfile = "CHK" currver = currver.component /* from VCMP */ artext = Space( "U="realuser "CO="currver,1 ) artext = artext Left(" ",13) "ST="costat.1C parse value seq.arfile+1 with , arseq . 1 seq.arfile . blk1 = Left(realuser, 8) || , Left(ardate , 8) || , Left(currver ,10) || , /* from VCMP */ Left(' ' ,10) || , /* Transmit name */ x2c(1C) /* checked out */ ad0106 = Left(argrp ,10) || , X2C(0001) || , /* 2-byte binary */ blk1 /* 37 bytes */ if noupdt = 0 then, rxv_rc = RXVSAM("WRITE","$VS",argrp,"AD0106") else say, 'RXVSAM("WRITE","$VS",'argrp'"AD0106")' call ZL_LOGMSG( "("BRANCH("ID")")" , "WRITE CHK" ad0106 ) end /* WRITE */ else do /* key was found */ parse var ad0106 component 11 userct 13 blk1, +37 blk2, +37 blk3, +37 blk4, +37 blk5 userct = c2x(userct) + 0 /* how many blocks ? */ call BCDA_VERIFY_USER /* -*/ if sw.0Already_checked_out = 0 then do if userct = 5 then do /* already at max */ call BCDR_RELEASE_SUSP /* release any suspended c/o -*/ if userct = 5 then return /* no suspended blocks */ end userct = userct + 1 ardate = Date("S") argrp = component /* component with *'s */ arfile = "CHK" coname = currver.component /* from VCMP */ artext = Space( "U="realuser "CO="coname,1 ) artext = artext Left(" ",13) "ST="costat.1C parse value seq.arfile+1 with , arseq . 1 seq.arfile . new = Left(realuser, 8) || , Left(ardate , 8) || , Left(coname ,10) || , Left(' ' ,10) || , x2c(1C) /* checked out */ $rc = Value('blk'userct,new) /* load blk# */ userct = x2c(Right(userct,4,0)) /* 2-byte binary */ ad0106 = thiskey || userct || , blk1 || blk2 || blk3 || blk4 || blk5 if noupdt = 0 then, rxv_rc = RXVSAM("REWRITE","$VS",component,"AD0106") else say, 'RXVSAM("REWRITE","$VS",'component'"AD0106") ' call ZL_LOGMSG( "("BRANCH("ID")")" , "REWRITE CHK" ad0106 ) end /* not already checked out */ end /* REWRITE */ rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" if func = "QUERY" then do /* This was called from the component line on the display. */ artype = 3 address ISPEXEC "TBADD" $tn$ "ORDER" zerrsm = "Checked Out" if warnmsg <> "" then zerrsm = "Warning!" zerrlm = "Component" component "has been checked out. " warnmsg "SETMSG MSG(ISRZ002)" call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm) warnmsg = "" end return /*@ BCD_UPDATE_CKOUT */ /* Before a user can check out a component, we must verify that the user does not have the component checked out already! blk1 thru blk5 may have been populated. Examine each one to verify that this user is not represented there. . ----------------------------------------------------------------- */ BCDA_VERIFY_USER: /*@ */ if branch then call BRANCH address TSO sw.0Already_checked_out = 0 do zx = 1 to userct /* each block */ if Left(Value('blk'zx),8) = realuser then, sw.0Already_checked_out = 1 end /* zx */ if sw.0Already_checked_out = 1 then do zerrsm = "" zerrlm = "Component" coname "already checked-out by" realuser address ISPEXEC "SETMSG MSG(ISRZ002)" call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm) end return /*@ BCDA_VERIFY_USER */ /* If any existing checkouts are suspended, release them by purging the block and deleting the row from the display. . If any blocks are deleted, must be appropriately decremented and the remaining blocks compressed. The caller will REWRITE the record. . For QUERY calls, the existing table can be scanned to find rows where ARGRP=component, ARSUSP=1, and ARTYPE=3. All such rows can be purged. . ----------------------------------------------------------------- */ BCDR_RELEASE_SUSP: /*@ */ if branch then call BRANCH address ISPEXEC do zx = 1 to 5 co_temp = Value( 'blk'zx ) parse var co_temp couser 9 ardate 17 coname, 27 trname 37 decstat . stat = C2X(decstat) /* 1C, 2C, 1D, or 2D */ if WordPos( stat,"1D 2D" ) > 0 then do $rc = Value('blk'zx,"") /* zap this block */ userct = userct - 1 end end /* zx */ if userct < 5 then do /* something was purged */ /* recompress and rewrite the new record */ parse value blk1 || blk2 || blk3 || blk4 || blk5 with, 1 blk1 38 blk2 75 blk3 112 blk4 147 blk5 . if func = "QUERY" then, call BCDRP_PURGE_ROWS /* -*/ return end /* USERCT is not low enough to permit another checkout */ zerrsm = "MAX checkouts" zerrlm = "Only 5 simultaneous checkouts are permitted. ", "There are no suspended checkouts. ", "Some user with a current checkout will have to release one." "SETMSG MSG(ISRZ002)" return /*@ BCDR_RELEASE_SUSP */ /* . ----------------------------------------------------------------- */ BCDRP_PURGE_ROWS: /*@ */ if branch then call BRANCH address ISPEXEC "TBTOP" $tn$ do forever "TBSKIP" $tn$ /* next row */ if rc > 0 then leave if argrp = component &, arsusp = 1 &, artype = 3 then, "TBDELETE" $tn$ end /* forever */ return /*@ BCDRP_PURGE_ROWS */ /* SAVKEY is an APPLname. Use BAB_ to load AD0102 and display the application profile to the caller. . AD0102: 03 APPL CHAR(8), /* 001 - 008 */ 03 TITLE CHAR(40), /* 009 - 048 */ 03 DATE_CHANGED CHAR(8), /* 049 - 056 */ 03 USER_CHANGED CHAR(8), /* 057 - 064 */ 03 FLAGS, /* 065 - 065 */ 05 OBSOLETE BIT(1), 03 FILLER CHAR(2), /* 066 - 067 */ 03 JOBNAME_PREFIX CHAR(3), /* 068 - 070 */ 03 SUPPORT_MANAGER CHAR(8), /* 071 - 078 */ 03 SQA CHAR(8), /* 079 - 086 */ 03 CUSTOMER(8) CHAR(8), /* 087 - 150 */ 03 PRODUCTION(8) CHAR(8), /* 151 - 214 */ 03 DEVELOPMENT(8) CHAR(8); /* 215 - 278 */ . ----------------------------------------------------------------- */ BD_APP_DIR: /*@ */ if branch then call BRANCH address TSO if savkey = "" then do call BDA_BUILD_LIST /* table all APPLs -*/ return end /* no appl passed */ appl = savkey /* load APPL for BAB_ */ call BAB_CHECK_APPL /* read AD0102 for APPL -*/ if sw.0vdir_not_found then do zerrsm = "Appl INCORR" zerrlm = "Application" appl "is unknown." address ISPEXEC "SETMSG MSG(ISRZ002)" call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm) return end parse var ad0102 appl . +8 , appname +40 , appchgdt . +8 , appchgus . +8 , appflags +1 , dirfill +2 , apppref . +3 , appsptmg . +8 , appsqa . +8 , customers +64 , prod +64 , devl +64 . parse var customers cus1 cus2 cus3 cus4 cus5 cus6 cus7 cus8 . parse var prod prd1 prd2 prd3 prd4 prd5 prd6 prd7 prd8 . parse var devl dev1 dev2 dev3 dev4 dev5 dev6 dev7 dev8 . if sw.0Admin then do /* Preserve original settings */ parse var customers xus1 xus2 xus3 xus4 xus5 xus6 xus7 xus8 . parse var prod xrd1 xrd2 xrd3 xrd4 xrd5 xrd6 xrd7 xrd8 . parse var devl xev1 xev2 xev3 xev4 xev5 xev6 xev7 xev8 . xppsptmg = appsptmg xppsqa = appsqa end /* Admin */ appbits = X2B( C2X( appflags ) ) obsflag = Left( appbits,1 ) if obsflag then obstext = "Obsolete" else obstext = "Active" call BDN_LOAD_NAMES /* find realnames for userids-*/ sw.0UserChg = 0 address ISPEXEC "DISPLAY PANEL(APDISP)" if sw.0Admin then do /* */ call BDU_REPLACE_DIR /* */ end /* */ return /*@ BD_APP_DIR */ /* Func=DIR but no APPL was provided. Build a table of all APPLs and display for selection. . ----------------------------------------------------------------- */ BDA_BUILD_LIST: /*@ */ if branch then call BRANCH address TSO call BDAA_TBCREATE /* build table and load -*/ call BDAD_TBDISPL /* display APPL table -*/ return /*@ BDA_BUILD_LIST */ /* Build table ARAP and load all APPLs. . ----------------------------------------------------------------- */ BDAA_TBCREATE: /*@ */ if branch then call BRANCH address ISPEXEC "TBCREATE ARAP KEYS(APPL) NAMES(OBS APPNAME)", "NOWRITE REPLACE" address TSO "ALLOC FI($VS) DA("dirds") SHR REU" rxv_rc = RXVSAM("OPENINPUT","$VS","KSDS") do forever rxv_rc = RXVSAM('READNEXT','$VS',,'AD0102') if rxv_rc > 0 then leave parse var ad0102 appl +8 , appname +40 , . +8 , . +8 , appflags +1 . appbits = X2B( C2X( appflags ) ) obsflag = Left( appbits,1 ) if obsflag then obs = "*" else obs = "" "TBADD ARAP" /* appl and appname */ end /* forever */ rxv_rc = RXVSAM("CLOSE","$VS") address TSO "FREE FI($VS)" return /*@ BDAA_TBCREATE */ /* Display table ARAP and allow user to select applications for display of the detail. . ----------------------------------------------------------------- */ BDAD_TBDISPL: /*@ */ if branch then call BRANCH address ISPEXEC "TBTOP ARAP" do forever "TBDISPL ARAP PANEL(APLIST)" if rc > 4 then leave do ztdsels "CONTROL DISPLAY SAVE" savkey = appl if sel = "I" then, call BDI_INVENTORY /* */ else, call BD_APP_DIR /* -*/ "CONTROL DISPLAY RESTORE" if ztdsels > 1 then "TBDISPL ARAP" end /* ztdsels */ sel = "" end /* forever */ parse value "" with appl savkey /* prevent bounce */ return /*@ BDAD_TBDISPL */ /* Read xcompds for this appl and display entire inventory. XCOMPDS is an alternate index and is structured as follows: . AD010X: 03 * CHAR(5), /* 001 - 005 */ 03 APPL CHAR(8), /* 006 - 013 */ 03 COMPONENT CHAR(10), /* 014 - 023 */ 03 CURRENT_VERSION CHAR(10), /* 024 - 033 */ . ----------------------------------------------------------------- */ BDI_INVENTORY: Procedure expose, /*@ */ ( tk_globalvars ) xcompds appl appname if branch then call BRANCH address TSO /* ALLOC xcompds */ address TSO "ALLOC FI($VS) DA("xcompds") SHR REU" rxv_rc = RXVSAM("OPENINPUT","$VS","KSDS") /* TBCREATE a table */ address ISPEXEC "TBCREATE INV KEYS( XCMP ) NOWRITE REPLACE" /* READGENERIC the application */ rxv_rc = RXVSAM('READGENERIC','$VS',appl,'AD010X') /* TBADD and READNEXT while same appl */ do while rxv_rc = 0 parse var ad010x 6 xapp 14 xcmp 24 . if xapp <> appl then leave address ISPEXEC "TBADD INV" rxv_rc = RXVSAM('READNEXT','$VS',,'AD010X') end /* rxv_rc */ /* FREE xcompds */ rxv_rc = RXVSAM("CLOSE","$VS") address TSO "FREE FI($VS)" /* TBDISPL */ address ISPEXEC "TBTOP INV" do forever "TBDISPL INV PANEL(DSPINV)" if rc > 4 then leave end /* forever */ return /*@ BDI_INVENTORY */ /* Get the realnames for the userids associated with this APPL. . ----------------------------------------------------------------- */ BDN_LOAD_NAMES: /*@ */ if branch then call BRANCH address TSO "NEWSTACK" "WHOIS" appsptmg appsqa customers prod devl do Queued() parse pull uid name /* Fred C Smith */ name = Space(name,1) mluname.uid = name end /* queued */ "DELSTACK" sptn = mluname.appsptmg sqan = mluname.appsqa cus1n = mluname.cus1 cus2n = mluname.cus2 cus3n = mluname.cus3 cus4n = mluname.cus4 cus5n = mluname.cus5 cus6n = mluname.cus6 cus7n = mluname.cus7 cus8n = mluname.cus8 prd1n = mluname.prd1 prd2n = mluname.prd2 prd3n = mluname.prd3 prd4n = mluname.prd4 prd5n = mluname.prd5 prd6n = mluname.prd6 prd7n = mluname.prd7 prd8n = mluname.prd8 dev1n = mluname.dev1 dev2n = mluname.dev2 dev3n = mluname.dev3 dev4n = mluname.dev4 dev5n = mluname.dev5 dev6n = mluname.dev6 dev7n = mluname.dev7 dev8n = mluname.dev8 return /*@ BDN_LOAD_NAMES */ /* . ----------------------------------------------------------------- */ BDU_REPLACE_DIR: /*@ */ if branch then call BRANCH address TSO if Space(cus1 cus2 cus3 cus4 cus5 cus6 cus7 cus8,1) <> , Space(xus1 xus2 xus3 xus4 xus5 xus6 xus7 xus8,) then do sw.0UserChg = 1 customers = Left(cus1,8)Left(cus2,8)Left(cus3,8)Left(cus4,8) ||, Left(cus5,8)Left(cus6,8)Left(cus7,8)Left(cus8,8) end /* fix customers */ if Space(prd1 prd2 prd3 prd4 prd5 prd6 prd7 prd8,1) <> , Space(xrd1 xrd2 xrd3 xrd4 xrd5 xrd6 xrd7 xrd8,1) then do sw.0UserChg = 1 prod = Left(prd1,8)Left(prd2,8)Left(prd3,8)Left(prd4,8) ||, Left(prd5,8)Left(prd6,8)Left(prd7,8)Left(prd8,8) end /* fix production */ if Space(dev1 dev2 dev3 dev4 dev5 dev6 dev7 dev8,1) <> , Space(xev1 xev2 xev3 xev4 xev5 xev6 xev7 xev8,1) then do sw.0UserChg = 1 devl = Left(dev1,8)Left(dev2,8)Left(dev3,8)Left(dev4,8) ||, Left(dev5,8)Left(dev6,8)Left(dev7,8)Left(dev8,8) end /* fix development */ if appsptmg <> xppsptmg then do appsptmg = xppsptmg sw.0UserChg = 1 end if appsqa <> xppsqa then do appsqa = xppsqa sw.0UserChg = 1 end if sw.0UserChg then do /* rebuild the record */ newdir = Left( appl,8 )Left( appname,40 )Left( appchgdt,8 ) ||, Left( appchgus,8 )Left( appflags,1 )Left( dirfill,2 ) ||, Left( apppref,3 )Left( appsptmg,8 )Left( appsqa,8 ) ||, Left( customers,64 )Left( prod,64 )Left( devl,64 ) /* alloc, openio, read, rewrite, close, free */ appl = Left( appl,8 ) "ALLOC FI($VS) DA("dirds") SHR REU" rxv_rc = RXVSAM("OPENIO","$VS","KSDS") rxv_rc = RXVSAM('READ','$VS',appl ) if rxv_rc <> 0 then say, "READ" RXVSAM_RETURNMSG ";" RXVSAM_VSAMERRORMSG rxv_rc = RXVSAM("REWRITE","$VS",appl,"NEWDIR") if rxv_rc <> 0 then say, "REWRITE" RXVSAM_RETURNMSG ";" RXVSAM_VSAMERRORMSG rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" end return /*@ BDU_REPLACE_DIR */ /* Display all known info for a specified key: read VCMP to find the APPL; read VCHK to acquire checkout records; read VHIS to locate clearance records; store by date and activity. The key supplied may be generic. . ----------------------------------------------------------------- */ BI_INFO: /*@ */ if branch then call BRANCH address ISPEXEC "TBCREATE" $tn$ "KEYS(ARDATE ARFILE ARSEQ)", "NAMES(ARTEXT ARGRP ARTYPE ARSUSP)", "NOWRITE REPLACE" call BIB_CMP /* Owned components (AD0104) -*/ call BID_CHK /* Checkout data (AD0106) -*/ if sw.0NoHist = 0 then, call BIE_HIS /* Clearance history AD2002 -*/ call BIF_SHOW_TABLE /* Display collected info -*/ "TBEND" $tn$ return /*@ BI_INFO */ /* Extract ISPF assets and LIBDEF . ----------------------------------------------------------------- */ BIA_PROLOG: /*@ */ if branch then call BRANCH address ISPEXEC call DEIMBED /* extract ISPF assets -*/ dd = "" do Words(ddnlist) /* each LIBDEF DD */ parse value ddnlist dd with dd ddnlist $ddn = $ddn.dd /* PLIB322 <- PLIB */ "LIBDEF ISP"dd "LIBRARY ID("$ddn") STACK" end ddnlist = ddnlist dd return /*@ BIA_PROLOG */ /* Owned components: D01VCMP.KSD key is COMPONENT(10) . AD0104: 03 APPL CHAR(8), /* 001 - 008 */ 03 COMPONENT CHAR(10), /* 009 - 018 */ 03 CURRENT_VERSION CHAR(10), /* 019 - 028 */ 03 FLAGS, /* 029 - 029 */ 05 OBSOLETE BIT(1), 05 LINKEDIT_ONLY BIT(1), 03 IFAM CHAR(1), /* 030 - 030 */ 03 ALIAS CHAR(24); /* 031 - 054 */ . ----------------------------------------------------------------- */ BIB_CMP: /*@ */ if branch then call BRANCH address TSO parse value "CMP 1" with, arfile artype ardate "ALLOC FI($VS) DA("ocompds") SHR REU" rxv_rc = RXVSAM("OPENINPUT","$VS","KSDS") do Words(key) /* */ parse var key thiskey key /* isolate */ /* If the key is a full key -- no asterisks -- the READGENERIC will fail to deliver the proper key. A long key must be 'genericized' for this process to work. */ lkey = Length(thiskey) if lkey > 6 then , call BIK_ADJUST_KEY /* genericize the key -*/ rxv_rc = RXVSAM('READGENERIC','$VS',thiskey,'AD0104') do while rxv_rc = 0 /* */ parse var ad0104 9 slug 19 . if Left(slug,lkey) <> thiskey then leave call ZL_LOGMSG( "("BRANCH("ID")")" , "CMP:" ad0104 ) parse var ad0104 appl 9 component 19 currver 29 bits 30 bits = X2B(C2X(bits)) sw_obs = Left(bits,1) if sw.0Active + sw_obs = 2 then do call ZL_LOGMSG( "("BRANCH("ID")")" , "Rejected: obsolete and ACTIVE was specified") end else do complist = complist component appl.component = appl currver.component = currver /* needed for CHKOUT */ artext = "APPL="appl "VER="currver obstext.sw_obs artext = Space(artext,1) call ZL_LOGMSG( "("BRANCH("ID")")" artext ) argrp = component parse value seq.arfile+1 with , arseq . 1 seq.arfile . address ISPEXEC "TBADD" $tn$ end rxv_rc = RXVSAM('READNEXT','$VS',,'AD0104') end /* rxv_rc */ end /* key */ rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" return /*@ BIB_CMP */ /* Checkout data: D01VCHK.KSD key is COMPONENT(10) . AD0106: %DCL MAX_CHECKOUT CHAR; %MAX_CHECKOUT = '5'; 03 COMPONENT CHAR(10), /* 001 - 010 */ 03 #_OF_USERS FIXED BIN(15), /* 011 - 012 */ 03 CHECKOUT(MAX_CHECKOUT REFER (#_OF_USERS)), 05 USER_ID CHAR(8), /* 013 - 020 */ 05 DATE CHAR(8), /* 021 - 028 */ 05 NAME_CHECKED_OUT CHAR(10), /* 029 - 038 */ 05 NAME_TRANSMITTED CHAR(10), /* 039 - 048 */ 05 STATUS FIXED DEC(1); /* 049 - 049 */ . ----------------------------------------------------------------- */ BID_CHK: /*@ */ if branch then call BRANCH address TSO key = complist /* component keys */ parse value "00000000 CHK 3 " with, ardate arfile artype . "ALLOC FI($VS) DA("checkds") SHR REU" rxv_rc = RXVSAM("OPENINPUT","$VS","KSDS") do Words(key) /* */ parse var key thiskey key /* isolate */ lkey = Length(thiskey) rxv_rc = RXVSAM('READ','$VS',thiskey,'AD0106') do while rxv_rc = 0 /* */ parse var ad0106 slug 11 . if Left(slug,lkey) <> thiskey then leave parse var ad0106 component 11 userct 13 co_data call ZL_LOGMSG( "("BRANCH("ID")")" , "CHK:" ad0106 ) argrp = component userct = C2D(userct) do cx = 1 to userct /* each block is 37 bytes */ parse var co_data couser 9 ardate 17 coname, 27 trname 37 decstat 38 co_data stat = C2X(decstat) /* 1C, 2C, 1D, or 2D */ state = costat.stat /* Ckout or Xmit */ arsusp = Pos( stat,"1D 2D" ) > 0 artext = Space( "U="couser "CO="coname,1 ) if trname <> "" then artext = artext "TR="trname else artext = artext Left(" ",13) artext = artext "ST="state artext = Strip(artext) call ZL_LOGMSG( "("BRANCH("ID")")" artext ) parse value seq.arfile+1 with , arseq . 1 seq.arfile . address ISPEXEC "TBADD" $tn$ end /* cx */ rxv_rc = RXVSAM('READNEXT','$VS',,'AD0106') end /* rxv_rc */ end /* key */ rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" return /*@ BID_CHK */ /* History data: D20VHIS.PA1 key is COMPONENT(10) . AD2002: 03 COMPONENT CHAR(10), /* 001-010 */ 03 CHECKOUT_DATE CHAR(8), /* 011-018 */ 03 CHECKOUT_USER_ID CHAR(8), /* 019-026 */ 03 CHECKOUT_NAME CHAR(10), /* 027-036 */ 03 TRANSMIT_NAME CHAR(10), /* 037-046 */ 03 CLEAR_DATE CHAR(8), /* 047-054 */ 03 CLEAR_USER_ID CHAR(8), /* 055-062 */ 03 CLEAR_NAME CHAR(10), /* 063-072 */ 03 PRIOR_NAME CHAR(10); /* 073-082 */ . ----------------------------------------------------------------- */ BIE_HIS: /*@ */ if branch then call BRANCH address TSO key = complist /* reload key from saved copy */ parse value " 00000000 HIS 2 " with, ardate arfile artype . "ALLOC FI($VS) DA("cleards") SHR REU" rxv_rc = RXVSAM("OPENINPUT","$VS","KSDS") do Words(key) /* */ parse var key thiskey key /* isolate */ lkey = Length(thiskey) rxv_rc = RXVSAM('READ','$VS',thiskey,'AD2002') do while rxv_rc = 0 /* */ parse var ad2002 slug 11 /* component */ if Left(slug,lkey) <> thiskey then leave parse var ad2002 component 11 , hcodate 19 hcouser 27 hconame 37 htrname 47 , clrdate 55 clruser 63 clrname 73 obsname call ZL_LOGMSG( "("BRANCH("ID")")" , "HIS:" ad2002 ) argrp = component ardate = hcodate artext = "C/O" Strip(hconame) "by" Strip(hcouser) , "Xmit as" htrname call ZL_LOGMSG( "("BRANCH("ID")")" artext ) parse value seq.arfile+1 with , arseq . 1 seq.arfile . address ISPEXEC "TBADD" $tn$ ardate = clrdate artext ="CLR" Strip(clrname) "by" Strip(clruser) call ZL_LOGMSG( "("BRANCH("ID")")" artext ) parse value seq.arfile+1 with , arseq 1 seq.arfile address ISPEXEC "TBADD" $tn$ rxv_rc = RXVSAM('READNEXT','$VS',,'AD2002') end /* rxv_rc */ end /* key */ rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" return /*@ BIE_HIS */ /* Display the table. CKOUT is only valid for CMP table rows (ARDATE is empty). RLSE is only valid on CHK rows where the user (U=) is the active caller. DELETE is only valid on CMP rows (to prevent multiple requests), when HIS is displayed (not NOHIST) and there has been no activity on the component other than checkout. . ----------------------------------------------------------------- */ BIF_SHOW_TABLE: /*@ */ if branch then call BRANCH address ISPEXEC "VGET ZSCREEND" /* screen rows */ "TBSORT" $tn$ "FIELDS(ARGRP,C,A ARTYPE,N,A ARDATE,C,A ARSEQ,N,A)" do forever zerrsm = "" ; zerrlm = "" "TBQUERY" $tn$ "ROWNUM(ROWCT)" /* table rows */ if rowct < zscreend then, /* leave big tables as-is */ "TBTOP" $tn$ "TBDISPL" $tn$ "PANEL(ARDISP)" if rc > 4 then leave do ztdsels "CONTROL DISPLAY SAVE" select when sel = "F" then do /* Fetch from FireProtect */ fpcomp = Word( Translate(argrp , "" , "*") ,1) address TSO "FIREHIST" fpcomp end /* Fetch from FireProtect */ when sel = "R" then do /* Release checkout */ /* put to bifr_ */ if WordPos(arfile,"CHK") = 0 then do zerrlm = zerrlm";" argrp":" "R valid only for CHK rows" end else, if Pos("U="thisuser,artext) > 0 | arsusp then do parse var artext "U=" suspuser . parse value suspuser thisuser with, thisuser suspuser . key = argrp /* TA4DZ***PR maybe */ emsg = "Release key" argrp zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) component = key call BR_RLSE /* -*/ parse value suspuser thisuser with, thisuser suspuser . end else do emsg = argrp":" "You may only RLSE your own checkout." zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end /* end of put to bifr_ */ end /* Release checkout */ when sel = "U" then do /* Check-out */ /* put to bifu_ */ if WordPos(arfile,"CMP") = 0 then do emsg = argrp":" "U valid only for CMP rows" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end /* */ else do thiskey = argrp /* TA4DZ***PR maybe */ emsg = "Checkout key" argrp zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) component = thiskey call BCC_READ_VCHK /* Get Checkout record -*/ call BCD_UPDATE_CKOUT /* Load new data and write -*/ end /* end of put to bifu_ */ end /* Check-out */ when sel = "O" then do /* Mark OBSOLETE */ if WordPos(arfile,"CMP") = 0 then do emsg = argrp":" "O valid only for CMP rows" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end /* */ else do component = argrp /* TA4DZ***PR maybe */ emsg = "Component key" argrp zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) call BIFO_OBS_COMP /* Obsolete the Component -*/ end end /* Mark OBSOLETE */ when sel = "A" then do /* Application Info */ if WordPos(arfile,"CMP") = 0 then do emsg = argrp":" "A valid only for CMP rows" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end /* */ else do parse var artext "APPL=" savkey . call BD_APP_DIR /* display an appl profile -*/ end end /* Application Info */ when sel = "D" then do /* Delete request */ if WordPos(arfile,"CMP") = 0 then do emsg = argrp":" "D valid only for CMP rows" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end /* */ else do call BIFD_DELETE_COMP /* -*/ end end /* Delete request */ otherwise nop end /* select */ "CONTROL DISPLAY RESTORE" if ztdsels > 1 then "TBDISPL" $tn$ end /* ztdsels */ sel = "" if zerrlm <> "" then do zerrlm = Space(Strip(zerrlm,,";"),1) "SETMSG MSG(ISRZ002)" end end /* forever */ return /*@ BIF_SHOW_TABLE */ /* A CMP can only be deleted if several conditions ALL apply: 1. sw.0NoHist must be 0 (zero) so that HIS records are present 2. there must be no (that is: zero) HIS records present 3. there must be no CHK records showing 'ST=X' (transmitted) If ALL of these conditions apply, delete all CHK records and the single CMP record. . ----------------------------------------------------------------- */ BIFD_DELETE_COMP: /*@ */ if branch then call BRANCH address ISPEXEC if sw.0NoHist = 1 then do emsg = argrp":" "Delete-component not allowed when NOHIST" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) return end delkey = argrp dkeylist = "" /* init */ "TBTOP" $tn$ do forever /* */ "TBSKIP" $tn$ /* next row */ if rc > 0 then leave /* end of table */ if argrp <> delkey then iterate /* wrong component */ if arfile = "HIS" then do emsg = argrp":" "Delete-component not allowed when HIS present" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) return end if arfile = "CHK" then, if Pos( "ST=X",artext ) > 0 then do emsg = argrp": Delete-component not allowed for" ||, " transmitted elements." zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) return end dkeylist = arfile arseq ardate ":" dkeylist end /* forever */ /* if HIS or transmitted CHK, flow will not get here */ dkeylist = Strip( dkeylist ) dkeylist = Strip( dkeylist,,":" ) do while dkeylist <> "" parse var dkeylist arfile arseq ardate ":" dkeylist "TBGET" $tn$ /* populate ARGRP */ /* depending on ARFILE, alloc VSAM file, OPENIO, READ, DELETE, CLOSE, FREE */ if arfile = "CMP" then, call BIFDC_DROP_CMP /* -*/ else, if arfile = "CHK" then, call BIFDK_DROP_CHK /* -*/ /* delete table row */ end /* dkeylist */ return /*@ BIFD_DELETE_COMP */ /* Key of CMP is 'ARGRP', L=10 . ----------------------------------------------------------------- */ BIFDC_DROP_CMP: /*@ */ if branch then call BRANCH address TSO "ALLOC FI($VS) DA("ocompds") SHR REU" rxv_rc = RXVSAM("OPENIO","$VS","KSDS") rxv_rc = RXVSAM('READ','$VS',ARGRP,'AD0104') if noupdt = 0 then, rxv_rc = RXVSAM("DELETE","$VS",ARGRP) rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" call ZL_LOGMSG( "("BRANCH("ID")")", "Purged CMP" argrp ) address ISPEXEC "TBDELETE" $tn$ /* ice the row */ return /*@ BIFDC_DROP_CMP */ /* Key of CHK is 'ARGRP', L=10 . ----------------------------------------------------------------- */ BIFDK_DROP_CHK: /*@ */ if branch then call BRANCH address TSO "ALLOC FI($VS) DA("checkds") SHR REU" rxv_rc = RXVSAM("OPENIO","$VS","KSDS") rxv_rc = RXVSAM('READ','$VS',ARGRP,'AD0106') if noupdt = 0 then, rxv_rc = RXVSAM("DELETE","$VS",ARGRP) rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" call ZL_LOGMSG( "("BRANCH("ID")")", "Purged CHK" argrp ) address ISPEXEC "TBDELETE" $tn$ /* ice the row */ return /*@ BIFDK_DROP_CHK */ /* . ----------------------------------------------------------------- */ BIFO_OBS_COMP: /*@ */ if branch then call BRANCH address TSO parse var artext "APPL=" appl . /* establish application */ if appusers.appl = "" then, /* not yet set */ call BAB_CHECK_APPL /* read AD0102 for APPL -*/ authusrs = appusers.appl appusers.COMMON if WordPos( realuser,authusrs ) = 0 then do emsg = "User" realuser "not authorized for" appl"." zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) return end /* realuser not present */ /* Alloc CMP */ sw.0vcmp_not_found = 0 "ALLOC FI($VS) DA("ocompds") SHR REU" /* OPENUPDATE */ rxv_rc = RXVSAM("OPENIO","$VS","KSDS") /* Read w key */ rxv_rc = RXVSAM('READ','$VS',component,'AD0104') if rxv_rc > 0 then do /* ...oops */ sw.0vcmp_not_found = 1 sw.0error_found = 1 end else do parse var ad0104 appl 9 component 19 currver 29 bits 30 back call ZL_LOGMSG( "("BRANCH("ID")")" , "CMP:" ad0104 ) bits = X2B(C2X(bits)) end if sw.0vcmp_not_found then do address ISPEXEC emsg = "Component" thiskey "not found" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end /* Overlay high-order bit in byte 29 */ bits = Overlay( "1",bits ) bits = X2C( B2X( bits )) /* REWRITE */ ad0104 = Left(appl,8) ||, component ||, currver ||, bits ||, back rxv_rc = RXVSAM("REWRITE","$VS",component,"AD0104") if rxv_rc <> 0 then do ng_ct = ng_ct + 1 emsg = component "not rewritten, RC="rxv_rc zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end else do emsg = component "obsoleted." zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" artext = Space( "APPL="appl "VER="currver obstext.1,1 ) address ISPEXEC "TBMOD" $tn$ return /*@ BIFO_OBS_COMP */ /* . ----------------------------------------------------------------- */ BIK_ADJUST_KEY: /*@ */ if branch then call BRANCH address TSO if lkey > 9 then do if patternlist = "" then, call BAA_LOAD_PATTERNS /* identify type of data -*/ parse var thiskey 9 type 11 parse var pattern.type kl vl thiskey = Left( thiskey,kl )Copies( "*",vl )type end /* 10 */ else, if lkey > 6 then do thiskey = Left( thiskey,5 ) lkey = 5 end /* 7-9 */ return /*@ BIK_ADJUST_KEY */ /* Dismantle all LIBDEFs . ----------------------------------------------------------------- */ BIZ_EPILOG: /*@ */ if branch then call BRANCH address ISPEXEC dd = "" do Words(ddnlist) /* each LIBDEF DD */ parse value ddnlist dd with dd ddnlist $ddn = $ddn.dd /* PLIB322 <- PLIB */ "LIBDEF ISP"dd address TSO "FREE FI("$ddn")" end ddnlist = ddnlist dd return /*@ BIZ_EPILOG */ /* Update VCHK to show component no longer checked-out. If called from BI_, func=QUERY. In that case, ARDATE, ARSEQ and ARFILE (the key of the table) will also be set. TBGET the row and TBDELETE it. . AD0106: %DCL MAX_CHECKOUT CHAR; %MAX_CHECKOUT = '5'; 03 COMPONENT CHAR(10), /* 001 - 010 */ 03 #_OF_USERS FIXED BIN(15), /* 011 - 012 */ 03 CHECKOUT(MAX_CHECKOUT REFER (#_OF_USERS)), 05 USER_ID CHAR(8), /* 013 - 020 */ 05 DATE CHAR(8), /* 021 - 028 */ 05 NAME_CHECKED_OUT CHAR(10), /* 029 - 038 */ 05 NAME_TRANSMITTED CHAR(10), /* 039 - 048 */ 05 STATUS FIXED DEC(1); /* 049 - 049 */ . ----------------------------------------------------------------- */ BR_RLSE: /*@ */ if branch then call BRANCH address TSO if patternlist = "" then, /* not loaded */ call BAA_LOAD_PATTERNS /* identify type of data -*/ do Words(key) /* */ parse var key thiskey key /* isolate */ if Length(thiskey) <> 10 then do emsg = thiskey "length not 10" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) iterate end parse var thiskey 9 suff . /* TA4DZ PR */ if pattern.suff = "" then do emsg = suff "not supported" zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) iterate end /* convert 'thiskey' to a generic pattern */ parse var pattern.suff kl vl . component = Left(thiskey,kl)Copies("*",vl)suff /* TA4DZ***PR */ /* Open VCHK/Update */ "ALLOC FI($VS) DA("checkds") SHR REU" rxv_rc = RXVSAM("OPENIO","$VS","KSDS") /* Read component */ rxv_rc = RXVSAM('READ','$VS',component,'AD0106') if rxv_rc = 0 then do /* READ was OK */ call BRD_DROP_CKOUT /* -*/ end /* READ was OK */ else do emsg = "RXVSAM ended RC="rxv_rc "for key" thiskey zerrlm = zerrlm";" emsg call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end /* Close VCHK */ rxv_rc = RXVSAM("CLOSE","$VS") "FREE FI($VS)" end /* key */ if zerrlm <> "" then do zerrlm = Strip( zerrlm,"L",";" ) /* call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm) */ zerrsm = "" address ISPEXEC "SETMSG MSG(ISRZ002)" zerrlm = "" end return /*@ BR_RLSE */ /* . ----------------------------------------------------------------- */ BRD_DROP_CKOUT: /*@ */ if branch then call BRANCH address TSO parse var ad0106 component 11 userct 13 blk1, +37 blk2, +37 blk3, +37 blk4, +37 blk5 userct = c2x(userct) + 0 /* Find this user's checkout slot and compress to remove */ sw.0block_drop = 0 do zz = 1 to userct /* each checkout block */ if Left( Value('blk'zz) , 8) = thisuser then, do $rc = Value('blk'zz,"") /* zap this block */ sw.0block_drop = 1 call ZL_LOGMSG( "("BRANCH("ID")")" , "Dropped" $rc) end end /* zz */ zerrlm = "" /* Adjust # of users */ if sw.0block_drop then do userct = userct - 1 if func = "QUERY" then do /* This was called from a particular line on the display. The current position of the table is such that the TBDELETE can be done directly. */ address ISPEXEC "TBDELETE" $tn$ emsg = "Checkout for" component "obtained" ardate ||, "has been released" zerrlm = zerrlm";" emsg address ISPEXEC "SETMSG MSG(ISRZ002)" /* ? */ call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end end else do /* block not dropped */ emsg = "Release denied:" component "not checked-out by" thisuser zerrlm = zerrlm";" emsg address ISPEXEC "SETMSG MSG(ISRZ002)" /* ? */ call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) end zerrlm = "" /* If # of users = 0 DELETE */ if userct = 0 then do emsg = " Userct was zero; the record was purged." zerrlm = zerrlm";" emsg address ISPEXEC "SETMSG MSG(ISRZ002)" /* ? */ call ZL_LOGMSG( "("BRANCH("ID")")" emsg ) if noupdt = 0 then, rxv_rc = RXVSAM("DELETE","$VS",component) else say, 'RXVSAM("DELETE","$VS",'component') ' call ZL_LOGMSG( "("BRANCH("ID")")" , "RXVSAM DELETE" component) end /* userct = 0 */ /* If # of users > 0 REWRITE */ else do /* reconstruct */ userct = x2c(Right(userct,4,0)) /* 2-byte binary */ ad0106 = component || userct || , blk1 || blk2 || blk3 || blk4 || blk5 if noupdt = 0 then, rxv_rc = RXVSAM("REWRITE","$VS",component,"AD0106") else say, 'RXVSAM("REWRITE","$VS",'component'"AD0106") ' call ZL_LOGMSG( "("BRANCH("ID")")" , "RXVSAM REWRITE" ad0106) end zerrlm = "" return /*@ BRD_DROP_CKOUT */ /* Read the suspense-list and develop a list of all suspended checkouts. For the entire list, do a QUERY ..list.. (( NOHIST unless AUTORLSE; for AUTORLSE do a RLSE ..list.. . ----------------------------------------------------------------- */ BS_SUSP: /*@ */ bs_tv = trace() /* what setting at entry ? */ if branch then call BRANCH address TSO "ALLOC FI($RPT) DA('"reportds"(SUSPENSE)') SHR REU" "NEWSTACK" "EXECIO * DISKR $RPT (FINIS" "FREE FI($RPT)" susplist = "" do queued() pull 2 elem . 32 user . if thisuser = user then, /* same user */ susplist = susplist elem end /* queued */ "DELSTACK" rc = Trace("O"); rc = trace(bs_tv) if susplist <> "" then do /* there's work to do */ info = opts if altuser <> "" then, @au = "ASUSER" altuser else @au = "" $z = SWITCH("MYSUSP") /* remove from INFO */ $z = SWITCH("AUTORLSE") /* remove from INFO */ if sw.0AutoRel then, /* auto-release */ (exec_name) "RLSE" susplist @au "((" info else, (exec_name) "QUERY" susplist @au "(( NOHIST" info end /* susplist */ else do /* nothing in suspense */ zerrsm = "No data" zerrlm = "No elements were found in-suspense for user", thisuser address ISPEXEC "SETMSG MSG(ISRZ002)" call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm ) end return /*@ BS_SUSP */ /* Read the checkout_list (all checkouts) to find all rows for this user (invuser). Save all the keys to a list, then reinvoke NMAR NOHIST for the list. . ----------------------------------------------------------------- */ BU_INVENTORY: /*@ */ bu_tv = trace() /* what setting at entry ? */ if branch then call BRANCH address TSO "ALLOC FI($RPT) DA('"reportds"(CHKDOUT)') SHR REU" "NEWSTACK" "EXECIO * DISKR $RPT (FINIS" "FREE FI($RPT)" invlist = "" do queued() pull 2 elem . 39 user . if invuser = user then, /* same user */ invlist = invlist elem end /* queued */ "DELSTACK" rc = Trace("O"); rc = trace(bu_tv) if sw.0NoHist = 0 then, @noh = "" /* with history */ else, @noh = "HIST" /* no history */ if invlist <> "" then do /* there's work to do */ info = opts $z = SWITCH("MYSUSP") /* remove from INFO */ $z = SWITCH("AUTORLSE") $z = SWITCH("ADMIN") (exec_name) "QUERY" invlist "((" @noh info end /* susplist */ else do /* nothing in suspense */ zerrsm = "No data" zerrlm = "No elements were found in inventory for user", invuser address ISPEXEC "SETMSG MSG(ISRZ002)" call ZL_LOGMSG( "("BRANCH("ID")")" zerrlm ) end return /*@ BU_INVENTORY */ /* Parse any additional tokens in info. Abbreviations are allowed. . ----------------------------------------------------------------- */ LOCAL_PREINIT: /*@ customize opts */ address TSO sw.0exit_ISPF = SWITCH("RESTARTED") /* goes in LOCAL_PREINIT */ optlist = "NOHIST ADMIN MYSUSP AUTORLSE" worklist = info info = "" do Words( worklist ) /* every token */ parse var worklist tok worklist /* isolate */ sw.match = 0 do idx = 1 to Words( optlist ) if Abbrev( Word( optlist,idx ),tok,2 ) then do info = info Word( optlist,idx ) /* repl with expanded */ sw.match = 1 leave end end if sw.match = 0 then, info = info tok /* put it back */ end /* info */ sw.0NoHist = SWITCH("NOHIST") /* no HIStory */ sw.0Admin = SWITCH("ADMIN") sw.0MySUSP = SWITCH("MYSUSP") /* show only my suspended */ sw.0AutoRel = SWITCH("AUTORLSE") /* release all SUSP */ "NEWSTACK" "ICEUSER" pull specuid "DELSTACK" sw.0Spec = WordPos( Userid(),specuid) > 0 return /*@ LOCAL_PREINIT */ /* subroutines below LOCAL_PREINIT are not selected by SHOWFLOW */ /* . ----------------------------------------------------------------- */ ZB_SAVELOG: /*@ */ if branch then call BRANCH address TSO if Symbol("LOG#") = "LIT" then return /* not yet set */ "ALLOC FI($LOG) DA("logdsn") REU" vb4k.0 "EXECIO" log# "DISKW $LOG (STEM LOG. FINIS" "FREE FI($LOG)" return /*@ ZB_SAVELOG */ /* . ----------------------------------------------------------------- */ ZL_LOGMSG: Procedure expose, /*@ */ (tk_globalvars) log. log# rc = Trace("O") address TSO parse arg msgtext parse value log#+1 msgtext with, zz log.zz 1 log# . if monitor then say, msgtext return /*@ ZL_LOGMSG */ /* Parse out the embedded components at the back of the source code. . ----------------------------------------------------------------- */ DEIMBED: Procedure expose, /*@ */ (tk_globalvars) ddnlist $ddn. daid. address TSO address ISPEXEC "VGET ZSCREENW" fb80po.0 = "NEW UNIT(VIO) SPACE(5 5) TRACKS DIR(40)", "RECFM(F B) LRECL("zscreenw") BLKSIZE(0)" parse value "" with ddnlist $ddn. daid. lastln = sourceline() currln = lastln /* */ if Left(sourceline(currln),2) <> "*/" then return currln = currln - 1 /* previous line */ "NEWSTACK" address ISPEXEC do while sourceline(currln) <> "/*" text = sourceline(currln) /* save with a short name ! */ if Left(text,3) = ")))" then do /* package the queue */ parse var text ")))" ddn mbr . /* PLIB PANL001 maybe */ if Pos(ddn,ddnlist) = 0 then do /* doesn't exist */ ddnlist = ddnlist ddn /* keep track */ $ddn = ddn || Random(999) $ddn.ddn = $ddn address TSO "ALLOC FI("$ddn")" fb80po.0 "LMINIT DATAID(DAID) DDNAME("$ddn")" daid.ddn = daid end daid = daid.ddn "LMOPEN DATAID("daid") OPTION(OUTPUT)" do queued() parse pull line "LMPUT DATAID("daid") MODE(INVAR) DATALOC(LINE)" , "DATALEN("zscreenw")" end "LMMADD DATAID("daid") MEMBER("mbr")" "LMCLOSE DATAID("daid")" end /* package the queue */ else push text /* onto the top of the stack */ currln = currln - 1 /* previous line */ end /* while */ address TSO "DELSTACK" return /*@ DEIMBED */ /* Find where code was run from. It assumes cataloged data sets. Original by Doug Nadel With SWA code lifted from Gilbert Saint-flour's SWAREQ exec . ----------------------------------------------------------------- */ FIND_ORIGIN: Procedure /*@ */ answer="* UNKNOWN *" /* assume disaster */ Parse Source . . name dd ds . /* get known info */ Call listdsi(dd "FILE") /* get 1st ddname from file */ Numeric digits 10 /* allow up to 7FFFFFFF */ If name = "?" Then /* if sequential exec */ answer="'"ds"'" /* use info from parse source */ Else /* now test for members */ If sysdsn("'"sysdsname"("name")'")="OK" Then /* if in 1st ds */ answer="'"sysdsname"("name")'" /* go no further */ Else /* hooboy! Lets have some fun!*/ Do /* scan tiot for the ddname */ tiotptr=24+ptr(12+ptr(ptr(ptr(16)))) /* get ddname array */ tioelngh=c2d(stg(tiotptr,1)) /* nength of 1st entry */ Do Until tioelngh=0 | tioeddnm = dd /* scan until dd found */ tioeddnm=strip(stg(tiotptr+4,8)) /* get ddname from tiot */ If tioeddnm <> dd Then /* if not a match */ tiotptr=tiotptr+tioelngh /* advance to next entry */ tioelngh=c2d(stg(tiotptr,1)) /* length of next entry */ End If dd=tioeddnm Then, /* if we found it, loop through the data sets doing an swareq for each one to get the dsname */ Do Until tioelngh=0 | stg(4+tiotptr,1)<> " " tioejfcb=stg(tiotptr+12,3) jfcb=swareq(tioejfcb) /* convert SVA to 31-bit addr */ dsn=strip(stg(jfcb,44)) /* dsname JFCBDSNM */ vol=storage(d2x(jfcb+118),6) /* volser JFCBVOLS (not used) */ If sysdsn("'"dsn"("name")'")='OK' Then, /* found it? */ Leave /* we is some happy campers! */ tiotptr=tiotptr+tioelngh /* get next entry */ tioelngh=c2d(stg(tiotptr,1)) /* get entry length */ End answer="'"dsn"("name")'" /* assume we found it */ End Return answer /*@ FIND_ORIGIN */ /* . ----------------------------------------------------------------- */ ptr: Return c2d(storage(d2x(Arg(1)),4)) /*@ */ /* . ----------------------------------------------------------------- */ stg: Return storage(d2x(Arg(1)),Arg(2)) /*@ */ /* . ----------------------------------------------------------------- */ 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 = c2d(storage(21c,4)) /* TCB PSATOLD */ 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 /*@ SWAREQ */ /* . ----------------------------------------------------------------- */ HELP: /*@ */ address TSO;"CLEAR" ; say "" if helpmsg <> "" then do ; say helpmsg; say ""; end ex_nam = Left(exec_name,8) /* predictable size */ call LOCAL_PREINIT /* for more opts -*/ say " "ex_nam" Direct access to the Application Repository " say " " say " Syntax: "ex_nam" (Required unless MYSUSP or USER)" say " (Required unless MYSUSP or USER)" say " (Required for ADD)" say " " say " ACTIVE (QUERY only)" if sw.0Spec then do say " (*)" end say " (( NOhist " if sw.0Spec then do say " ADmin (*)" end say " MYsusp " say " AUtorlse " say " " say " function specifies the task to be done. Functions supported:" say " "supported_functions say " " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " keylist identifies the keys for which (function) is to be " say " performed. " say " QUERY will accept short (partial) keys " say " ADD must have full keys " say " CKOUT must have full keys " say " RLSE must have full keys " say " DIR If no application-id is" say " provided, a scrollable list of all known " say " applications is displayed. " say " " say " dispusr identifies the user for which a display is to be " say " performed. All elements with an active checkout by " say " this user will be shown. " say " " say " ACTIVE restricts the QUERY display to components which are " say " not obsolete. " say " " "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " " say " NOhist suppresses the display of history records. " say " " say " MYsusp restricts the display to only those items which are " say " in a suspended state. " say " " say " AUtorlse (only with MYSUSP) automatically releases all " say " suspended checkouts. " if sw.0Spec then, do say " " say " usrid specifies an alternate TSO userid for which (*)" say " operations are to be performed. (*)" say " " say " ADmin puts the caller into 'special' mode. (*)" end "NEWSTACK"; pull ; "CLEAR" ; "DELSTACK" say " Debugging tools provided include: " say " " say " MONITOR: displays key information throughout processing. " say " " say " NOUPDT: by-pass all update logic. " 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 */ /* ))) PLIB ARDISP )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) CAPS(ON) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) )BODY EXPAND(||) WIDTH(&ZSCREENW) %|-| Application Repository Component Detail +|-| %Command ===>_ZCMD %Scroll ===>_ZAMT+ /-- U=Checkout R=Release F=Fetch/FireProt O=Obsolete A=display App / +V Date Component Type Details )MODEL _z!ardate +@argrp +@z +@artext )INIT .ZVARS = '(SEL ARFILE)' .HELP = ARDISPH )REINIT )PROC IF (.PFKEY = 'PF05') &PFKEY = 'F5' .RESP = END )END ))) PLIB ARDISPH )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) } AREA(SCRL) EXTEND(ON) )BODY EXPAND(||) WIDTH(&ZSCREENW) %TUTORIAL |-| Application Repository Component Detail |-| TUTORIAL %Next Selection ===>_ZCMD }block } } } } } } } } } } } } } )AREA BLOCK DEPTH(23) + + Panel%ARDISP+displays all known detail for the requested keys + as found in the Application Repository. + + %DATE +is the activity date for Checkout records and + History records. + + %COMPONENT +is the A/R generic component name. + + %TYPE +is CMP (Owned Components) + HIS (Clearance History) + CHK (Current Checkouts) + + %DETAILS +displays the available detail for the entry. This + detail varies by TYPE. + + ---------------------------------------------- + + Line-commands are supported to + + %U+- Check out a component. This may only be issued on a Component + (CMP) line. + + %R+- Release a check-out. This may only be issued on a Check-out + (CHK) line for your own userid. + + %F+- Begin a FIREHIST session for this component. FIREHIST may be + used to retrieve source from FireProtect directly to a library + of your choice. + + %A+- View the Application Profile. This shows who may transmit + code for this element. Only valid on a 'CMP' line. + + %O+- Obsolete a Component. This may only be issued on a Component + (CMP) line. +(@tmtag+) )PROC )END ))) PLIB APDISP )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(LOW) CAPS(ON) @ TYPE(TEXT) INTENS(HIGH) COLOR(YELLOW) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) { TYPE(&APIO) INTENS(LOW) )BODY EXPAND(||) WIDTH(&ZSCREENW) @|-|% Application Data for !appl @|-| %COMMAND ===>_ZCMD %SCROLL ===>_ZAMT+ + + !appname + + Status:!obstext +Application Prefix:!apppref + + Support Manager:{appsptmg +SQA:{appsqa + !sptn + !sqan + + Customers Production Development {cus1 !cus1n {prd1 !prd1n {dev1 !dev1n {cus2 !cus2n {prd2 !prd2n {dev2 !dev2n {cus3 !cus3n {prd3 !prd3n {dev3 !dev3n {cus4 !cus4n {prd4 !prd4n {dev4 !dev4n {cus5 !cus5n {prd5 !prd5n {dev5 !dev5n {cus6 !cus6n {prd6 !prd6n {dev6 !dev6n {cus7 !cus7n {prd7 !prd7n {dev7 !dev7n {cus8 !cus8n {prd8 !prd8n {dev8 !dev8n + )INIT .HELP = APDISPH )PROC )END ))) PLIB APDISPH )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) )BODY EXPAND(||) WIDTH(&ZSCREENW) %TUTORIAL |-| Application Data for !appl |-| TUTORIAL %Next Selection ===>_ZCMD + + This panel displays the name, description, and status of the selected + application, along with the userids of the people who are authorized to work + on the application. + + Up to eight (8) userids can be assigned to each of Customer, Production, and + Development categories. The utility of having a userid in any of these + categories is not well-documented. )PROC )END ))) PLIB APLIST )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) { TYPE(INPUT) INTENS(HIGH) CAPS(ON) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) )BODY EXPAND(||) WIDTH(&ZSCREENW) %|-| Application List +|-| %Command ===>_ZCMD %Scroll ===>_ZAMT+ + APPL Application description )MODEL {z!appl @obs@appname )INIT .ZVARS = '(SEL)' .HELP = APLISTH )REINIT )PROC )END ))) PLIB APLISTH )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) )BODY EXPAND(||) WIDTH(&ZSCREENW) %TUTORIAL |-| Application List |-| TUTORIAL %Next Selection ===>_ZCMD + This panel presents a scrollable list of the known applications referenced by the Application Repository. It is presented in response to a 'DIR' request without a specified application. Select any application(s) with any non-blank character. Applications indicated with '*' are obsolete. )PROC )END ))) PLIB DSPINV )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) )BODY EXPAND(||) WIDTH(&ZSCREENW) %|-| Inventory for Application!appl +|-| %Command ===>_ZCMD %Scroll ===>_ZAMT+ + Components for application!appname )MODEL !xcmp )INIT .HELP = DSPINVH )REINIT )PROC )END ))) PLIB DSPINVH )ATTR % TYPE(TEXT) INTENS(HIGH) SKIP(ON) + TYPE(TEXT) INTENS(LOW) SKIP(ON) _ TYPE(INPUT) INTENS(HIGH) ! TYPE(OUTPUT) INTENS(HIGH) SKIP(ON) @ TYPE(OUTPUT) INTENS(LOW) SKIP(ON) )BODY EXPAND(||) WIDTH(&ZSCREENW) %TUTORIAL |-| Inventory for an Application |-| TUTORIAL %Next Selection ===>_ZCMD + This scrollable but not selectable table displays all the components which are associated with the selected application. )PROC )END */