Beefy Boxes and Bandwidth Generously Provided by pair Networks
Problems? Is your data what you think it is?
 
PerlMonks  

XSUBs, caller(), packages, and tied scalars

by patcat88 (Deacon)
on Apr 19, 2011 at 21:44 UTC ( #900236=perlquestion: print w/ replies, xml ) Need Help??
patcat88 has asked for the wisdom of the Perl Monks concerning the following question:

I am trying to use caller() inside a tied scalar that is a hash slice of a blessed hash, to avoid spurious fetches to the hash slice, such as from looking into the hash from outside the package ("$obj->{'inside'}) and from step through debuggers fetching the tied scalar. Stopping the debugger FETCHes is the most important thing.

It seems that method XSUBs (getValue()) have the caller package be where they are called, not their actual package. It seems like a bug to me. Perl methods (look at getValueWrap() and getValuePurePerl()) have the caller package that is their actual package. Not the package of where they were called from. If the method XSUB is called from a Perl method, it gets the correct package of its caller (the Perl method), see getValueWrap(). I'm not sure I'm describing the problem using the right words.

In the test script, "$res = $o->getValue();" should return 5, the 5 comes from the tied scalar if the call passes the caller test in the tied scalar. It doesn't unless its called through from "$res = $o->getValueWrap();" because of the bug I'm suggesting. Ive tested the bug exists on Perl v5.12.2 and Perl v5.10.0, on windows xp.

I wondering how to fix the situation, other than not using tied scalars. Is trying to use CopSTASHPV CopSTASHPV_set on PL_curcop to swap the package name with the correct one, then after getting the {'value'} hash slice, swap it back, safe or sane, in every XSUB? I have no idea what I can use CopSTASHPV CopSTASHPV_set on other than PL_curcop. I can't find any decent documentation on what PL_curcop even is.

The output of t.pl
C:\Documents and Settings\Owner\Desktop\calltest>perl t.pl attempting to go inside obj $VAR1 = [ [ "main", "t.pl", 9 ], [ "main", "t.pl", 9, "calltest::tied::FETCH", 1, "", undef, undef, 1794, "UUUUUUUUUUUU\5", undef ], [] ]; FETCH: bad caller "main" returning undef on going inside obj $res is not defined attempting to XS getValue $VAR1 = [ [ "main", "t.pl", 12 ], [ "main", "t.pl", 12, "calltest::tied::FETCH", 1, "", undef, undef, 1794, "UUUUUUUUUUUU\5", undef ], [] ]; FETCH: bad caller "main" returning undef Use of uninitialized value in subroutine entry at t.pl line 12. from getValue value is 0, package is main on XS getValue $res is not defined attempting to getValueWrap $VAR1 = [ [ "calltest", "calltest.pm", 36 ], [ "calltest", "calltest.pm", 36, "calltest::tied::FETCH", 1, "", undef, undef, 132610, "UUUUUUUUUUUU\5", { "feature_say" => 1, "feature_state" => 1, "feature_switch" => 1 } ], [ "main", "t.pl", 15, "calltest::getValueWrap", 1, "", undef, undef, 1794, "UUUUUUUUUUUU\5", undef ] ]; FETCH: good caller "calltest" returning 5 from getValue value is 5, package is calltest on getValueWrap $res is defined and is 5 using getValuePurePerl attempting to getValuePurePerl $VAR1 = [ [ "calltest", "calltest.pm", 39 ], [ "calltest", "calltest.pm", 39, "calltest::tied::FETCH", 1, "", undef, undef, 132610, "UUUUUUUUUUUU\5", { "feature_say" => 1, "feature_state" => 1, "feature_switch" => 1 } ], [ "main", "t.pl", 23, "calltest::getValuePurePerl", 1, "", undef, undef, 1794, "UUUUUUUUUUUU\5", undef ] ]; FETCH: good caller "calltest" returning 5 from getValuePurePerl value is 5 on getValuePurePerl $res is defined and is 5 C:\Documents and Settings\Owner\Desktop\calltest>
Here is what a FETCH from the debugger looks like with t.pl
$VAR1 = [ [ "DB::DbgrProperties", "C:\\Program Files\\ActiveState Komodo IDE 4\\lib\\support +\\dbgp\\perllib/DB/DbgrProperties.pm", 462 ], [ "DB::DbgrProperties", "C:\\Program Files\\ActiveState Komodo IDE 4\\lib\\support +\\dbgp\\perllib/DB/DbgrProperties.pm", 462, "calltest::tied::FETCH", 1, 0, undef, undef, 0, "\0\0\0\0\0\0\0\0\0\0\0\0", undef ], [ "DB::DbgrProperties", "C:\\Program Files\\ActiveState Komodo IDE 4\\lib\\support +\\dbgp\\perllib/DB/DbgrProperties.pm", 616, "DB::DbgrProperties::getFullPropertyInfoByValue", 1, 0, undef, undef, 256, "\0\0\0\0\0\0\0\0\0\0\0\0", undef ] ]; FETCH: bad caller "DB::DbgrProperties" returning undef
Here are the files that makeup calltest PM.

this is calltest.xs
#include "EXTERN.h" #include "perl.h" #include "XSUB.h" MODULE = calltest PACKAGE = calltest void hello( ) CODE: printf("hello"); void getValue( self ) SV * self PPCODE: if (SvROK(self) && SvTYPE(SvRV(self))==SVt_PVHV) self = SvRV(self); else Perl_croak(aTHX_ "%s: %s is not a hash reference", "calltest::getValue", "self"); if(!(self = (SV *)hv_fetch((HV *)self, "value", sizeof("value")-1, +0))){ self = NULL; Perl_croak(aTHX_ "hash has no value slice????"); } else {self = (SV *)SvUV(*((SV **)self));} printf("from getValue value is %u, package is %s\n", self, CopSTAS +HPV(PL_curcop)); if(self) XSRETURN_UV((UV)self); else XSRETURN_UNDEF;
calltest.pm
package calltest; use 5.010000; use strict; use warnings; use calltest::tied; require Exporter; our @ISA = qw(Exporter); # Items to export into callers namespace by default. Note: do not expo +rt # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # This allows declaration use calltest ':all'; # If you do not need this, moving things directly into @EXPORT or @EXP +ORT_OK # will save memory. our %EXPORT_TAGS = ( 'all' => [ qw( ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( ); our $VERSION = '0.01'; require XSLoader; XSLoader::load('calltest', $VERSION); # Preloaded methods go here. sub getValueWrap { return $_[0]->getValue(); } sub getValuePurePerl { my $val = $_[0]->{'value'}; print "from getValuePurePerl value is $val \n"; return $val; } sub new { my $self = {}; bless($self, $_[0]); tie($self->{'value'}, 'calltest::tied', $self); return $self; } 1; __END__
tied.pm
package calltest::tied; use 5.010000; use strict; use warnings; use Data::Dumper; use Scalar::Util qw( weaken ); require Exporter; our @ISA = qw(Exporter); # Items to export into callers namespace by default. Note: do not expo +rt # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # This allows declaration use calltest ':all'; # If you do not need this, moving things directly into @EXPORT or @EXP +ORT_OK # will save memory. our %EXPORT_TAGS = ( 'all' => [ qw( ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( ); our $VERSION = '0.01'; sub hello2 { print "h2\n"; } # Preloaded methods go here. sub TIESCALAR { my $class = shift; my $self = {'calltestObj' => shift}; weaken($self->{'calltestObj'}); return bless($self, $class); } sub FETCH { my $self = shift; print Dumper([[caller()],[caller(0)],[caller(1)]]); if((caller())[0] ne "calltest") { print "FETCH: bad caller \"".(caller())[0]."\" returning und +ef\n"; return undef } else { print "FETCH: good caller \"".(caller())[0]."\" returning 5\ +n"; } my $newvalue = 5; my $newSelf = {'calltestObj' => $self->{'calltestObj'}}; untie($newSelf->{'calltestObj'}->{'value'}); $newSelf->{'calltestObj'}->{'value'} = $newvalue; return $newvalue; } sub STORE { my $self = shift; my $newSelf = {'calltestObj' => $self->{'calltestObj'}}; untie($newSelf->{'calltestObj'}->{'value'}); $newSelf->{'calltestObj'}->{'value'} = $_[0]; return $_[0]; } sub UNTIE { my $self = shift; } 1; __END__
makefile.pl
use 5.010000; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'calltest', VERSION_FROM => 'calltest.pm', # finds $VERSION PREREQ_PM => {}, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'calltest.pm', # retrieve abstract from modul +e AUTHOR => 'A. U. Thor <a.u.thor@a.galaxy.far.far.away>' +) : ()), LIBS => [''], # e.g., '-lm' DEFINE => '', # e.g., '-DHAVE_SOMETHING' INC => '-I.', # e.g., '-I. -I/usr/include/other' # Un-comment this if you add C files to link with later: # OBJECT => '$(O_FILES)', # link all the C files too PM => {'calltest.pm' => '$(INST_LIBDIR)/calltest/calltest.pm', ' +tied.pm' => '$(INST_LIBDIR)/calltest/tied.pm'} );

Comment on XSUBs, caller(), packages, and tied scalars
Select or Download Code

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://900236]
Approved by Argel
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (10)
As of 2014-07-11 02:51 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    When choosing user names for websites, I prefer to use:








    Results (217 votes), past polls