D
Dodger
Hiya, all,
I've been racking my brain on how to get values and references of all
the variables in the caller's package.
Basically, the situation I have is that there's a sort of proxy-
requirer method that's taking up a fair amount of overhead. I'd love
to just get rid of it, but the whole thing is pretty old and massive
and has a lot of code, not all of which I have access to, and the
thing is there because different modules may be require-d in depending
on those settings.
One of the other problems is that some of the coders have decided to
go ahead and call this thing numberous times even when they don't need
to. Rather than try and hunt down every instance of someone calling
for Foo when they already have a Foo object, i wanted to be able to
look into the symbol table for the caller, find all the variables
there, and check to see if any of the scalars are, in fact, already a
Foo, and, if so, just to return that and do nothing else. This would
bypass the need to check to make sure it's the right *kind* of Foo
because the first time a Foo was grabbed it would be and the
environment doesn't change at runtime. It's safe to trust the former
Foo is the right kind of Foo.
Now I've been able to grab the list of variables back easily enough
with:
my $ppst;
print "Getting symbol table of caller $pkg<br/>\n";
my $getcaller = '$ppst = \%' . $pkg . '::';
print "About to eval $getcaller<br>\n";
eval $getcaller;
print "eval error: $@<br>\n" if $@;
for my $stk (sort {lc $a cmp lc $b} keys %{$ppst}) {
...
}
But the problem is I can't get a ref out of those things, or a value,
or anything. I've tried *foo{THING} syntax, I've tried turning off
strict refs in the block, the works. Everything is acting undef
(unless I do eval '$varcopy = *' . $pkg . '::' . $stk . '{SCALAR}' --
that annoyingly returns an anonymous scalar ref every time and the
perldocs seem to be vague on why or even if they should.
Anyway, thanks in advance for any advice/info/explanation of what I
may be doing wrong...
Here's the current sandbox code (I keep changing it though):
my ($pkg, $filename, $line, $subroutine, $hasargs,
$wantarray, $evaltext, $is_require, $hints, $bitmask) = caller(1);
print <<"EOF";
Called package_setup on $package<br/>
<pre>
Caller:
package: $pkg
Filename: $filename
Line: $line
Subroutine: $subroutine
Has args? $hasargs
Wantarray? $wantarray
Eval text: $evaltext
is require? $is_require
hints: $hints
bitmask: $bitmask
</pre>
EOF
if (grep /$package/, keys %INC) {
print "<b>Already loaded as:</b><br/><br/>";
print " ---- $_<br/>" for sort {lc $a cmp lc $b} grep /
$package/, keys %INC;
print "<br/><br/>\n";
my $ppst;
print "Getting symbol table of caller $pkg<br/>\n";
my $getcaller = '$ppst = \%' . $pkg . '::';
print "About to eval $getcaller<br>\n";
eval $getcaller;
print "eval error: $@<br>\n" if $@;
for my $stk (sort {lc $a cmp lc $b} keys %{$ppst}) {
no strict 'refs';
# print "Checking $stk<br/>\n";
our $varcopy;
*varcopy = ${$pkg.'::'.$stk} or next;
if (ref $varcopy) {
my $reftype = ref $varcopy;
print "Caller $pkg has a ref $stk, type $reftype<br/>
\n";
}
else {
my $val;
print "value of \$${pkg}::$stk == $varcopy<br/>\n";
}
}
print "<hr/>\n";
}
else {
print "Not yet loaded<hr/><br/><br/>\n";
}
I've been racking my brain on how to get values and references of all
the variables in the caller's package.
Basically, the situation I have is that there's a sort of proxy-
requirer method that's taking up a fair amount of overhead. I'd love
to just get rid of it, but the whole thing is pretty old and massive
and has a lot of code, not all of which I have access to, and the
thing is there because different modules may be require-d in depending
on those settings.
One of the other problems is that some of the coders have decided to
go ahead and call this thing numberous times even when they don't need
to. Rather than try and hunt down every instance of someone calling
for Foo when they already have a Foo object, i wanted to be able to
look into the symbol table for the caller, find all the variables
there, and check to see if any of the scalars are, in fact, already a
Foo, and, if so, just to return that and do nothing else. This would
bypass the need to check to make sure it's the right *kind* of Foo
because the first time a Foo was grabbed it would be and the
environment doesn't change at runtime. It's safe to trust the former
Foo is the right kind of Foo.
Now I've been able to grab the list of variables back easily enough
with:
my $ppst;
print "Getting symbol table of caller $pkg<br/>\n";
my $getcaller = '$ppst = \%' . $pkg . '::';
print "About to eval $getcaller<br>\n";
eval $getcaller;
print "eval error: $@<br>\n" if $@;
for my $stk (sort {lc $a cmp lc $b} keys %{$ppst}) {
...
}
But the problem is I can't get a ref out of those things, or a value,
or anything. I've tried *foo{THING} syntax, I've tried turning off
strict refs in the block, the works. Everything is acting undef
(unless I do eval '$varcopy = *' . $pkg . '::' . $stk . '{SCALAR}' --
that annoyingly returns an anonymous scalar ref every time and the
perldocs seem to be vague on why or even if they should.
Anyway, thanks in advance for any advice/info/explanation of what I
may be doing wrong...
Here's the current sandbox code (I keep changing it though):
my ($pkg, $filename, $line, $subroutine, $hasargs,
$wantarray, $evaltext, $is_require, $hints, $bitmask) = caller(1);
print <<"EOF";
Called package_setup on $package<br/>
<pre>
Caller:
package: $pkg
Filename: $filename
Line: $line
Subroutine: $subroutine
Has args? $hasargs
Wantarray? $wantarray
Eval text: $evaltext
is require? $is_require
hints: $hints
bitmask: $bitmask
</pre>
EOF
if (grep /$package/, keys %INC) {
print "<b>Already loaded as:</b><br/><br/>";
print " ---- $_<br/>" for sort {lc $a cmp lc $b} grep /
$package/, keys %INC;
print "<br/><br/>\n";
my $ppst;
print "Getting symbol table of caller $pkg<br/>\n";
my $getcaller = '$ppst = \%' . $pkg . '::';
print "About to eval $getcaller<br>\n";
eval $getcaller;
print "eval error: $@<br>\n" if $@;
for my $stk (sort {lc $a cmp lc $b} keys %{$ppst}) {
no strict 'refs';
# print "Checking $stk<br/>\n";
our $varcopy;
*varcopy = ${$pkg.'::'.$stk} or next;
if (ref $varcopy) {
my $reftype = ref $varcopy;
print "Caller $pkg has a ref $stk, type $reftype<br/>
\n";
}
else {
my $val;
print "value of \$${pkg}::$stk == $varcopy<br/>\n";
}
}
print "<hr/>\n";
}
else {
print "Not yet loaded<hr/><br/><br/>\n";
}