Parent procedures and f$environment
Jeff Cameron
F$ENVIRONMENT("PROCEDURE") returns the file specification of the currently
executing command procedure. That is cool!
F$ENVIRONMENT("DEPTH") returns the integer depth of nested DCL command
procedures.
Given that your depth is 6, how can you find the file specification of the
parent calling procedure (level 5), and it's parent (level 4), and on up the
tree to level 1?
Thank you in advance.
Jeff Cameron
Chris Sharman
Here it is, from here, to here - there may be a less mangled version
around somewhere, since I mangled this to suit myself.
Works on VAX & Alpha, could doubtless be easily made to work on Itanium.
Chris
$ vfy = f$verify('debug'+0)
$!
$! PROCEDURE: GET_CALLER.COM
$!
$! ABSTRACT:
$!
$! This code fragment obtains the name of the procedure which called this
$! procedure.
$!
$!From: Ken Bosward <bosward...@bhp.com.au>
$!Newsgroups: comp.os.vms
$!Subject: DCL Tricks
$!Date: Fri, 01 Nov 1996 12:35:58 +1000
$!Message-ID: <327962...@bhp.com.au>
$!
$! HISTORY:
$!
$! 15-MAY-1993 MDC Written by Michael Clay
$! 1-Nov-1996 Ken Bosward, clean up temporary file
$! 06-Nov-1996 Dave Cantor, shorten report code using !AC
$! Added nesting level
$! 20-JUL-2000 Chris Sharman, Alpha-ize (without breaking VAX),
$! add parms to suppress self (P1 boolean) &
$! make global symbols get_caller__N (if p1 or p2 =
S*),
$! where N=0 is this proc, 1 is calling proc, and
so on;
$! ie inverse of depth: self-relative seemed more use.
$!
$!-----------------------------------------------------------------------------
$ fac = f$parse(f$environment("procedure"),,,"name")
$ pid = f$getjpi(0,"pid")
$ temp = "sys$scratch:''fac'_''pid'.tmp"
$ on warning then goto FINISH
$ on control_y then goto FINISH
$!
$! Define known symbol values ...
$!
$ arch := 'f$getsyi("arch_name")'
$ vax = "!"
$ alpha = "!"
$ 'arch' :=
$ 'vax'ctl$ag_clidata = %x7FFE2A5C ! From SYS$SYSTEM:SYS.STB
$ 'alpha'ctl$ag_clidata = %x7ffce260
$ ppd$l_prc = %x00000008 ! From SYS$SYSTEM:DCLDEF.STB
$ idf_l_lnk = %x00000000 ! From SYS$SYSTEM:DCLDEF.STB
$ idf_l_filename = %x00000068 ! From SYS$SYSTEM:DCLDEF.STB
$!
$! Get value of PRC_L_IDFLNK from DCLDEF.STB (changes with version of
VMS) ...
$!
$ call fetchsym_'arch' dcldef prc_l_idflnk
$!
$! Traverse IDF list
$!
$ ppd = ctl$ag_clidata
$ prc = f$cvui(0,32,f$fao("!AD",4,ppd+ppd$l_prc))
$ idf = f$cvui(0,32,f$fao("!AD",4,prc+prc_l_idflnk))
$ lev = f$environment("depth")
$ baselev = lev
$ makesym = (f$ext(0,1,p1).eqs."S").or.(f$ext(0,1,p2).eqs."S")
$ if p1 then $ goto tonext
$next_filename:
$ if idf .eq. 0 then goto FINISH
$ procname = f$fao("!AC",f$cvui(0,32,f$fao("!AD",4,idf+idf_l_filename)))
$ if makesym
$ then get_caller__'f$str(baselev-lev) == procname
$ else write sys$output f$fao(" !2UL -> !AS",lev,procname)
$ endif
$tonext: idf = f$cvui(0,32,f$fao("!AD",4,idf+idf_l_lnk))
$ lev = lev - 1
$ goto next_filename
$!
$fetchsym_alpha: subroutine ! file sym
$ search sys$loadable_images:'p1'.stb 'p2' /exa/form=passall/out='temp'
$! record too big for dcl
$ set file/attr=(rfm:fix,mrs:8,lrl:8) 'temp' ! Quadword aligned (+2)
$ sym = " " + p2
$ sym[0,16] = 0
$ sym[16,8] = f$length(p2)
$ ver = 1
$ before = 3
$ after = (f$len(sym)-1)/8
$symloop: ! search for each quadword of the symbol in turn
$ sym8 = """"+f$ext(8*ver-8,8,sym)+""""
$ siz = f$len(sym8)-2
$ sea 'temp';'ver' &sym8
/key=(pos:1,siz:'siz')/exa/form=passall/win=('before','after')/out='temp'
$ ver = ver + 1
$ before = before + 1
$ after = after - 1
$ if after.ge.0 then $ goto symloop
$!
$ open/read temp 'temp'
$ read temp valquad
$ close temp
$ delete/nolog 'temp';*
$ 'p2' == f$cvui(16,32,valquad)
$ endsubroutine
$!
$fetchsym_vax: subroutine ! file sym
$ search sys$system:'p1'.stb 'p2' /exact/format=passall /output='temp'
$ open/read temp 'temp'
$ read temp symbols
$ close temp
$ delete/nolog 'temp';*
$ loc_sym = f$locate("''p2'",symbols)
$ 'p2' == f$cvui((loc_sym-5)*8,32,symbols)
$finish: endsubroutine
$!
$FINISH:
$ set noon
$ if f$type(prc_l_idflnk).nes."" then $ deletexx/sym/glo prc_l_idflnk
$ if f$trnlnm("TEMP").nes."" then close/nolog temp
$ if f$search(temp) .nes. "" then delete/nolog 'temp';*
VAXman-
I have a procedure here:
http://tmesis.com/symbol/using/PREVIOUS_PROCEDURE_NAME.COM;
that will get you the previous calling procedure name. In fact, this will
return the entire call stack.
It requires TMESIS SYMBOL to set the values for some DCL internal symbols
but you could look these up in DCLDEF.STB and hardcode them if necessary.
TMESIS SYMBOL can look these up on the fly making the procedure functional
on any version of VMS.
--
VAXman- A Bored Certified VMS Kernel Mode Hacker VAXman(at)TMESIS(dot)COM
"Well my son, life is like a beanstalk, isn't it?"
Galen
> but you could look these up in DCLDEF.STB and hardcode them if necessary.
Even looking them up in DCLDEF.STB could be scripted in DCL along these
lines, though in pure DCL it would probably look pretty clunky:
$ DCL_SYMBOL_NAMES := a,b,c,...
$ LINK/MAP/NOEXE SYS$LOADABLE_IMAGES:DCLDEF.STB
$ I = 0
$ LOOP:
$ NAME = F$EXTRACT(I, ",", DCL_SYMBOL_NAMES)
$ IF NAME .EQS. "," THEN GOTO LOOP_EXIT
$! <search map file for symbol name>
$! <extract symbol value from first line of search result>
$! <store value in appropriately named global symbol>
$ I = I + 1
$ GOTO LOOP
$ EXIT_LOOP:
Using a tool like gawk would make this much easier to write.
Galen
David J Dachtera
I think that may have been in my DCL wish list from a while back:
$ symbol = F$ENVIRONMENT( "PROCEDURE"[, depth] )
--
David J Dachtera
dba DJE Systems
http://www.djesys.com/
Unofficial OpenVMS Hobbyist Support Page:
http://www.djesys.com/vms/support/
Unofficial Affordable OpenVMS Home Page:
http://www.djesys.com/vms/soho/
Unofficial OpenVMS-IA32 Home Page:
http://www.djesys.com/vms/ia32/
Coming soon:
Unofficial OpenVMS Marketing Home Page