r11827 - in /branches/upstream/libdevel-caller-perl/current: ._Caller.xs ._Changes Build.PL Caller.xs Changes MANIFEST META.yml Makefile.PL README lib/Devel/._Caller.pm lib/Devel/Caller.pm lib/Devel/Caller.xs t/Devel-Caller.t
tincho-guest at users.alioth.debian.org
tincho-guest at users.alioth.debian.org
Sat Dec 29 00:46:52 UTC 2007
Author: tincho-guest
Date: Sat Dec 29 00:46:52 2007
New Revision: 11827
URL: http://svn.debian.org/wsvn/?sc=1&rev=11827
Log:
[svn-upgrade] Integrating new upstream version, libdevel-caller-perl (2.02)
Added:
branches/upstream/libdevel-caller-perl/current/._Caller.xs (with props)
branches/upstream/libdevel-caller-perl/current/._Changes (with props)
branches/upstream/libdevel-caller-perl/current/Caller.xs
branches/upstream/libdevel-caller-perl/current/lib/Devel/._Caller.pm (with props)
Removed:
branches/upstream/libdevel-caller-perl/current/Build.PL
branches/upstream/libdevel-caller-perl/current/README
branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.xs
Modified:
branches/upstream/libdevel-caller-perl/current/Changes
branches/upstream/libdevel-caller-perl/current/MANIFEST
branches/upstream/libdevel-caller-perl/current/META.yml
branches/upstream/libdevel-caller-perl/current/Makefile.PL
branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm
branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t
Added: branches/upstream/libdevel-caller-perl/current/._Caller.xs
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/._Caller.xs?rev=11827&op=file
==============================================================================
Binary file - no diff available.
Propchange: branches/upstream/libdevel-caller-perl/current/._Caller.xs
------------------------------------------------------------------------------
svn:mime-type = application/octet-stream
Added: branches/upstream/libdevel-caller-perl/current/._Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/._Changes?rev=11827&op=file
==============================================================================
Binary file - no diff available.
Propchange: branches/upstream/libdevel-caller-perl/current/._Changes
------------------------------------------------------------------------------
svn:mime-type = application/octet-stream
Added: branches/upstream/libdevel-caller-perl/current/Caller.xs
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/Caller.xs?rev=11827&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/Caller.xs (added)
+++ branches/upstream/libdevel-caller-perl/current/Caller.xs Sat Dec 29 00:46:52 2007
@@ -1,0 +1,37 @@
+/* -*- C -*- */
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+MODULE = Devel::Caller PACKAGE = Devel::Caller
+
+SV*
+_context_cv(context)
+SV* context;
+ CODE:
+ PERL_CONTEXT *cx = INT2PTR(PERL_CONTEXT *, SvIV(context));
+ CV *cur_cv;
+
+ if (cx->cx_type != CXt_SUB)
+ croak("cx_type is %d not CXt_SUB\n", cx->cx_type);
+
+ cur_cv = cx->blk_sub.cv;
+ if (!cur_cv)
+ croak("Context has no CV!\n");
+
+ RETVAL = (SV*) newRV_inc( (SV*) cur_cv );
+ OUTPUT:
+ RETVAL
+
+SV*
+_context_op(context)
+SV* context;
+ CODE:
+ PERL_CONTEXT *cx = INT2PTR(PERL_CONTEXT*, SvIV(context));
+ OP *op = cx->blk_oldcop->op_next;
+ SV *rv = newSV(0);
+ sv_setref_iv(rv, "B::OP", PTR2IV(op));
+ RETVAL = rv;
+ OUTPUT:
+ RETVAL
+
Modified: branches/upstream/libdevel-caller-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/Changes?rev=11827&op=diff
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/Changes (original)
+++ branches/upstream/libdevel-caller-perl/current/Changes Sat Dec 29 00:46:52 2007
@@ -1,3 +1,15 @@
+2.02 Friday 28th December, 2007
+ Make use of INT2PTR macro for great justice! (or 64-bit stuff,
+ it's hard to tell)
+
+2.01 Thursday 27th December, 2007
+ Translated the XS and C into perl using B. Though the perl looks
+ much like C this gives a chance to make it more perlish in the future.
+ There's a tiny bit of XS left to expose some internals to perl space.
+
+ Dropped compatibilty for older perls (PadWalker doesn't work
+ there anyway)
+
0.11 Sunday 9th July, 2006
Fudge around the segfaults in 5.8.x ithreaded builds by
not looking up what the package variable is.
Modified: branches/upstream/libdevel-caller-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/MANIFEST?rev=11827&op=diff
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/MANIFEST (original)
+++ branches/upstream/libdevel-caller-perl/current/MANIFEST Sat Dec 29 00:46:52 2007
@@ -1,9 +1,7 @@
-README
MANIFEST
-META.yml
Changes
-Build.PL
Makefile.PL
lib/Devel/Caller.pm
-lib/Devel/Caller.xs
+Caller.xs
t/Devel-Caller.t
+META.yml Module meta-data (added by MakeMaker)
Modified: branches/upstream/libdevel-caller-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/META.yml?rev=11827&op=diff
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/META.yml (original)
+++ branches/upstream/libdevel-caller-perl/current/META.yml Sat Dec 29 00:46:52 2007
@@ -1,21 +1,12 @@
----
-name: Devel-Caller
-version: 0.11
-author:
- - |-
- Richard Clamp <richardc at unixbeard.net> with close reference to
- PadWalker by Robin Houston
-abstract: meatier versions of C<caller>
-license: perl
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Devel-Caller
+version: 2.02
+version_from: lib/Devel/Caller.pm
+installdirs: site
requires:
- PadWalker: 0.08
-build_requires:
- Test::More: 0
-provides:
- DB:
- file: lib/Devel/Caller.pm
- version: 0.11
- Devel::Caller:
- file: lib/Devel/Caller.pm
- version: 0.11
-generated_by: Module::Build version 0.25
+ PadWalker: 0.08
+ Test::More: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.30
Modified: branches/upstream/libdevel-caller-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/Makefile.PL?rev=11827&op=diff
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/Makefile.PL (original)
+++ branches/upstream/libdevel-caller-perl/current/Makefile.PL Sat Dec 29 00:46:52 2007
@@ -1,31 +1,12 @@
-# Note: this file was auto-generated by Module::Build::Compat version 0.03
-
- unless (eval "use Module::Build::Compat 0.02; 1" ) {
- print "This module requires Module::Build to install itself.\n";
-
- require ExtUtils::MakeMaker;
- my $yn = ExtUtils::MakeMaker::prompt
- (' Install Module::Build now from CPAN?', 'y');
-
- unless ($yn =~ /^y/i) {
- die " *** Cannot install without Module::Build. Exiting ...\n";
- }
-
- require Cwd;
- require File::Spec;
- require CPAN;
-
- # Save this 'cause CPAN will chdir all over the place.
- my $cwd = Cwd::cwd();
- my $makefile = File::Spec->rel2abs($0);
-
- CPAN::Shell->install('Module::Build::Compat')
- or die " *** Cannot install without Module::Build. Exiting ...\n";
-
- chdir $cwd or die "Cannot chdir() back to $cwd: $!";
- exec $^X, $makefile, @ARGV; # Redo now that we have Module::Build
+#!perl
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ 'NAME' => 'Devel::Caller',
+ 'VERSION_FROM' => 'lib/Devel/Caller.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => 0,
+ 'PadWalker' => '0.08'
}
- use lib '_build/lib';
- Module::Build::Compat->run_build_pl(args => \@ARGV);
- require Module::Build;
- Module::Build::Compat->write_makefile(build_class => 'Module::Build');
+);
Added: branches/upstream/libdevel-caller-perl/current/lib/Devel/._Caller.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/lib/Devel/._Caller.pm?rev=11827&op=file
==============================================================================
Binary file - no diff available.
Propchange: branches/upstream/libdevel-caller-perl/current/lib/Devel/._Caller.pm
------------------------------------------------------------------------------
svn:mime-type = application/octet-stream
Modified: branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm?rev=11827&op=diff
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm (original)
+++ branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm Sat Dec 29 00:46:52 2007
@@ -1,17 +1,157 @@
+use strict;
package Devel::Caller;
-require DynaLoader;
-require Exporter;
-
+use warnings;
+use B;
use PadWalker ();
-
-require 5.005003;
-
- at ISA = qw(Exporter DynaLoader);
- at EXPORT_OK = qw( caller_cv caller_args caller_vars called_with called_as_method );
-
-$VERSION = '0.11';
-
-bootstrap Devel::Caller $VERSION;
+use XSLoader;
+use base qw( Exporter );
+use 5.008;
+
+our $VERSION = '2.02';
+XSLoader::load __PACKAGE__, $VERSION;
+
+our @EXPORT_OK = qw( caller_cv caller_args caller_vars called_with called_as_method );
+
+sub caller_cv {
+ my $level = shift;
+ my $cx = PadWalker::_upcontext($level + 1);
+ return unless $cx;
+ return _context_cv($cx);
+}
+
+our $DEBUG = 0;
+
+sub scan_forward {
+ my $op = shift;
+ die "was expecting a pushmark, not a " . $op->name
+ if ($op->name ne "pushmark");
+
+ my @stack;
+ for (; $op && $op->name ne 'entersub'; $op = $op->next) {
+ print "SCAN op $op ", $op->name, "\n" if $DEBUG;
+ if ($op->name eq "pushmark") {
+ print "push $op\n" if $DEBUG;
+ push @stack, $op;
+ }
+ elsif (0) { # op consumes a mark
+ print "pop\n" if $DEBUG;
+ pop @stack;
+ }
+ }
+ return pop @stack;
+}
+
+*caller_vars = \&called_with;
+sub called_with {
+ my $level = shift;
+ my $want_names = shift;
+
+ my $op = _context_op( PadWalker::_upcontext( $level + 1 ));
+ my $cv = caller_cv( $level + 2 );
+ my $pad = $cv ? B::svref_2object( $cv )->PADLIST : B::comppadlist;
+ my $padn = $pad->ARRAYelt( 0 );
+ my $padv = $pad->ARRAYelt( 1 );
+
+ print $op->name, "\n" if $DEBUG;
+ $op = scan_forward( $op );
+ print $op->name, "\n" if $DEBUG;
+
+ my @return;
+ my ($prev, $skip);
+ $skip = 0;
+ while (($prev = $op) && ($op = $op->next) && ($op->name ne "entersub")) {
+ print "op $op ", $op->name, "\n" if $DEBUG;
+ if ($op->name eq "pushmark") {
+ $skip = !$skip;
+ }
+ elsif ($op->name =~ "pad(sv|av|hv)") {
+ next if $skip;
+ print "PAD skip:$skip\n" if $DEBUG;
+
+ if ($op->next->next->name eq "sassign") {
+ $skip = 0;
+ next;
+ }
+
+ print "targ: ", $op->targ, "\n" if $DEBUG;
+ my $name = $padn->ARRAYelt( $op->targ )->PVX;
+ my $value = $padv->ARRAYelt( $op->targ )->object_2svref;
+ push @return, $want_names ? $name : $value;
+ next;
+ }
+ elsif ($op->name eq "gv") {
+ next;
+ }
+ elsif ($op->name =~ /gvsv|rv2(av|hv|gv)/) {
+ print "GV skip:$skip\n" if $DEBUG;
+
+ if ($op->next->next->name eq "sassign") {
+ $skip = 0;
+ print "skipped\n" if $DEBUG;
+ next;
+ }
+
+ my $consider = ($op->name eq "gvsv") ? $op : $prev;
+ my $gv = $consider->gv;
+ print "consider: $consider ", $consider->name, " gv $gv\n"
+ if $DEBUG;
+ if (ref $consider eq 'B::PADOP') {
+ print "GV is really a padgv\n" if $DEBUG;
+ $gv = $padv->ARRAYelt( $consider->padix );
+ print "NEW GV $gv\n" if $DEBUG;
+ }
+
+ if ($want_names) {
+ my %sigils = (
+ "gvsv" => '$',
+ "rv2av" => '@',
+ "rv2hv" => '%',
+ "rv2gv" => '*',
+ );
+
+ push @return, $sigils{ $op->name } . $gv->STASH->NAME . "::" . $gv->SAFENAME;
+ }
+ else {
+ my %slots = (
+ "gvsv" => 'SCALAR',
+ "rv2av" => 'ARRAY',
+ "rv2hv" => 'HASH',
+ "rv2gv" => 'GLOB',
+ );
+ push @return, *{ $gv->object_2svref }{ $slots{ $op->name} };
+ }
+
+ next;
+ }
+ elsif ($op->name eq "const") {
+ print "const $op skip:$skip\n" if $DEBUG;
+ if ($op->next->next->name eq "sassign") {
+ $skip = 0;
+ next;
+ }
+
+ push @return, $want_names ? undef : $op->sv;
+ next;
+ }
+ }
+ return @return;
+}
+
+
+sub called_as_method {
+ my $level = shift || 0;
+ my $op = _context_op( PadWalker::_upcontext( $level + 1 ));
+
+ print "called_as_method: $op\n" if $DEBUG;
+ die "was expecting a pushmark, not a ". $op->name
+ unless $op->name eq "pushmark";
+ while (($op = $op->next) && ($op->name ne "entersub")) {
+ print "method: ", $op->name, "\n" if $DEBUG;
+ return 1 if $op->name =~ /^method(?:_named)?$/;
+ }
+ return;
+}
+
sub caller_args {
my $level = shift;
@@ -20,35 +160,9 @@
return @DB::args
}
-*caller_vars = called_with;
-sub called_with {
- my $level = shift;
- my $names = shift || 0;
-
- my $cx = PadWalker::_upcontext($level + 1);
- return unless $cx;
-
- my $cv = caller_cv($level + 2);
- _called_with($cx, $cv, $names);
-}
-
-sub caller_cv {
- my $level = shift;
- my $cx = PadWalker::_upcontext($level + 1);
- return unless $cx;
- return _context_cv($cx);
-}
-
-
-sub called_as_method {
- my $level = shift || 0;
- my $cx = PadWalker::_upcontext($level + 1);
- return unless $cx;
- _called_as_method($cx);
-}
-
1;
__END__
+
=head1 NAME
@@ -91,8 +205,8 @@
C<called_as_method> returns true if the subroutine at $level was
called as a method.
+
=head1 BUGS
-
All of these routines are susceptible to the same limitations as
C<caller> as described in L<perlfunc/caller>
@@ -104,44 +218,11 @@
=item
-The code is currently inaccurate in this case:
-
- print foo( $bar ), baz( $quux );
-
-When returning answers about the invocation of baz it will mistakenly
-return the answers for the invocation of foo so you'll see '$bar'
-where you expected '$quux'.
-
-A workaround is to rewrite the code like so:
-
- print foo( $bar );
- print bar( $baz );
-
-A more correct fix is left as a TODO item.
-
-=item
-
-Under perl 5.005_03
-
- use vars qw/@bar/;
- foo( @bar = qw( some value ) );
-
-will not deparse correctly as it generates real split ops rather than
-optimising it into a constant assignment at compile time as in later
-releases of perl.
-
-=item
-
-On perl 5.8.x compiled with ithreads it's not currently supported to
-retrieve package variables from the past. Instead the empty string is
-returned for the name, and undef is returned when the value is
-requested.
-
-Though crappy, this is an improvement on causing your application to
-segfault.
+As a version 2.0 of Devel::Caller we no longer maintain compatibility with
+versions of perl earlier than 5.8.2. Older versions continue to be available
+from CPAN and backpan.
=back
-
=head1 SEE ALSO
@@ -154,8 +235,9 @@
=head1 COPYRIGHT
-Copyright (c) 2002, 2003, 2006 Richard Clamp. All Rights Reserved.
+Copyright (c) 2002, 2003, 2006, 2007 Richard Clamp. All Rights Reserved.
This module is free software. It may be used, redistributed and/or
modified under the same terms as Perl itself.
=cut
+
Modified: branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t?rev=11827&op=diff
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t (original)
+++ branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t Sat Dec 29 00:46:52 2007
@@ -32,7 +32,6 @@
sub called_lex {
my @called = called_with(0);
is( scalar @called, 3, "right count");
- local $TODO = "pad reorg broke this" if $] >= 5.008001;
is( $called[0], \$foo, "with lexical \$foo" );
is( $called[1], \@foo, "with lexical \@foo" );
is( $called[2], \%foo, "with lexical \%foo" );
@@ -105,9 +104,6 @@
@expect = qw( %flange ); called_assign(%flange = (%foo, %bar));
}
-use Config;
-local $TODO = "ithreads support for globs in 5.008 is bugged to heck"
- if $] > 5.008 && $Config{useithreads};
use vars qw( $quux @quux %quux );
sub called {
my @called = caller_vars(0);
@@ -167,7 +163,6 @@
@expect = qw( %T::flange ); called_assign(%flange = (%foo, %bar));
}
-local $::TODO = undef; # ithreads
package main;
# were we called as a method or a sub
More information about the Pkg-perl-cvs-commits
mailing list