r6852 - in /branches/upstream/libdevel-caller-perl: ./ current/ current/lib/ current/lib/Devel/ current/t/
sukria at users.alioth.debian.org
sukria at users.alioth.debian.org
Fri Aug 17 18:02:44 UTC 2007
Author: sukria
Date: Fri Aug 17 18:02:44 2007
New Revision: 6852
URL: http://svn.debian.org/wsvn/?sc=1&rev=6852
Log:
[svn-inject] Installing original source of libdevel-caller-perl
Added:
branches/upstream/libdevel-caller-perl/
branches/upstream/libdevel-caller-perl/current/
branches/upstream/libdevel-caller-perl/current/Build.PL
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/README
branches/upstream/libdevel-caller-perl/current/lib/
branches/upstream/libdevel-caller-perl/current/lib/Devel/
branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm
branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.xs
branches/upstream/libdevel-caller-perl/current/t/
branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t
Added: branches/upstream/libdevel-caller-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/Build.PL?rev=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/Build.PL (added)
+++ branches/upstream/libdevel-caller-perl/current/Build.PL Fri Aug 17 18:02:44 2007
@@ -1,0 +1,15 @@
+use strict;
+use Module::Build;
+
+Module::Build->new(
+ module_name => "Devel::Caller",
+ license => 'perl',
+ build_requires => {
+ 'Test::More' => 0,
+ },
+ requires => {
+ 'PadWalker' => '0.08',
+ },
+ create_makefile_pl => 'passthrough',
+ )
+ ->create_build_script;
Added: branches/upstream/libdevel-caller-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/Changes?rev=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/Changes (added)
+++ branches/upstream/libdevel-caller-perl/current/Changes Fri Aug 17 18:02:44 2007
@@ -1,0 +1,39 @@
+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.
+
+0.10 Wednesday 5th July, 2006
+ Use strlen rather than playing with SvLEN/SvCUR to determine
+ the length of identifiers in the pad. It's a theoretical
+ segfault waiting to happen, but one that isn't tickled by the
+ current test suite. Fixes failures under perl 5.8.8 as
+ reported by clkao.
+
+0.09 Sunday 5th October, 2003
+ Split Changes out from HISTORY pod section.
+ Port to Module::Build
+ We can now determine constant values in called_with.
+ Partial fixes for http://rt.cpan.org/NoAuth/Bug.html?id=2878
+
+0.08 2003-03-28
+ Added caller_vars as a synonym for called_with
+ Added caller_args
+
+0.07 2002-11-21
+ Fix to called_as_method from Rafael Garcia-Suarez to handle
+ $foo->$method() calls.
+
+0.06 2002-11-20
+ Added called_as_method routine
+
+0.05 2002-07-25
+ Fix a segfault under ithreads.
+ Cleaned up some development cruft that leaked out while
+ rushing.
+
+0.04 2002-07-01
+ Decode glob params too.
+
+0.03 2002-04-02
+ Refactored to share the upcontext code from PadWalker 0.08
+
Added: branches/upstream/libdevel-caller-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/MANIFEST?rev=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/MANIFEST (added)
+++ branches/upstream/libdevel-caller-perl/current/MANIFEST Fri Aug 17 18:02:44 2007
@@ -1,0 +1,9 @@
+README
+MANIFEST
+META.yml
+Changes
+Build.PL
+Makefile.PL
+lib/Devel/Caller.pm
+lib/Devel/Caller.xs
+t/Devel-Caller.t
Added: branches/upstream/libdevel-caller-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/META.yml?rev=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/META.yml (added)
+++ branches/upstream/libdevel-caller-perl/current/META.yml Fri Aug 17 18:02:44 2007
@@ -1,0 +1,21 @@
+---
+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
+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
Added: branches/upstream/libdevel-caller-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/Makefile.PL?rev=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/Makefile.PL (added)
+++ branches/upstream/libdevel-caller-perl/current/Makefile.PL Fri Aug 17 18:02:44 2007
@@ -1,0 +1,31 @@
+# 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
+ }
+ 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/README
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/README?rev=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/README (added)
+++ branches/upstream/libdevel-caller-perl/current/README Fri Aug 17 18:02:44 2007
@@ -1,0 +1,77 @@
+README for Devel::Caller 0.11
+
+=head1 NAME
+
+Devel::Caller - meatier versions of C<caller>
+
+=head1 SYNOPSIS
+
+ use Devel::Caller qw(caller_cv);
+ $foo = sub { print "huzzah\n" if $foo == caller_cv(0) };
+ $foo->(); # prints huzzah
+
+ use Devel::Caller qw(called_with);
+ sub foo { print called_with(0,1); }
+ foo( my @foo ); # should print '@foo'
+
+
+=head1 DEPENDENCIES
+
+This module has external dependencies on the following modules:
+
+ PadWalker 0.08
+
+=head1 INSTALLATION
+
+ perl Build.PL
+ perl Build test
+
+and if all goes well
+
+ perl Build install
+
+=head1 HISTORY
+
+What changed over the last 3 revisions
+
+=over
+
+=item 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.
+
+
+=item 0.10 Wednesday 5th July, 2006
+
+ Use strlen rather than playing with SvLEN/SvCUR to determine
+ the length of identifiers in the pad. It's a theoretical
+ segfault waiting to happen, but one that isn't tickled by the
+ current test suite. Fixes failures under perl 5.8.8 as
+ reported by clkao.
+
+
+=item 0.09 Sunday 5th October, 2003
+
+ Split Changes out from HISTORY pod section.
+ Port to Module::Build
+ We can now determine constant values in called_with.
+ Partial fixes for http://rt.cpan.org/NoAuth/Bug.html?id=2878
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc/caller>, L<PadWalker>, L<Devel::Peek>
+
+=head1 AUTHOR
+
+Richard Clamp <richardc at unixbeard.net> with close reference to
+PadWalker by Robin Houston
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002, 2003, 2006 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.
+
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=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm (added)
+++ branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.pm Fri Aug 17 18:02:44 2007
@@ -1,0 +1,161 @@
+package Devel::Caller;
+require DynaLoader;
+require Exporter;
+
+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;
+
+sub caller_args {
+ my $level = shift;
+ package DB;
+ () = caller( $level + 1 );
+ 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
+
+Devel::Caller - meatier versions of C<caller>
+
+=head1 SYNOPSIS
+
+ use Devel::Caller qw(caller_cv);
+ $foo = sub { print "huzzah\n" if $foo == caller_cv(0) };
+ $foo->(); # prints huzzah
+
+ use Devel::Caller qw(called_with);
+ sub foo { print called_with(0,1); }
+ foo( my @foo ); # should print '@foo'
+
+=head1 DESCRIPTION
+
+=over
+
+=item caller_cv($level)
+
+C<caller_cv> gives you the coderef of the subroutine being invoked at
+the call frame indicated by the value of $level
+
+=item caller_args($level)
+
+Returns the arguments passed into the caller at level $level
+
+=item caller_vars( $level, $names )
+=item called_with($level, $names)
+
+C<called_with> returns a list of references to the original arguments
+to the subroutine at $level. if $names is true, the names of the
+variables will be returned instead
+
+constants are returned as C<undef> in both cases
+
+=item called_as_method($level)
+
+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>
+
+The deparsing of the optree perfomed by called_with is fairly simple-minded
+and so a bit flaky.
+
+=over
+
+=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.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<perlfunc/caller>, L<PadWalker>, L<Devel::Peek>
+
+=head1 AUTHOR
+
+Richard Clamp <richardc at unixbeard.net> with close reference to
+PadWalker by Robin Houston
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002, 2003, 2006 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
Added: branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.xs
URL: http://svn.debian.org/wsvn/branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.xs?rev=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.xs (added)
+++ branches/upstream/libdevel-caller-perl/current/lib/Devel/Caller.xs Fri Aug 17 18:02:44 2007
@@ -1,0 +1,257 @@
+/* -*- C -*- */
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifndef pTHX_ /* 5.005_03 */
+#define pTHX_
+#define aTHX_
+#define OPGV(o) o->op_gv
+#define PL_op_name op_name
+#define OP_METHOD_NAMED OP_METHOD
+#else /* newer than 5.005_03 */
+#define GVOP OP
+#define OPGV cGVOPx_gv
+#endif
+
+/* OP_NAME is missing under 5.00503 and 5.6.1 */
+#ifndef OP_NAME
+#define OP_NAME(o) PL_op_name[o->op_type]
+#endif
+
+#define WORK_DAMN_YOU 0
+
+SV*
+glob_out(char sigil, GVOP* op, I32 want_name)
+{
+ GV* gv = OPGV(op);
+ SV* ret;
+
+#if WORK_DAMN_YOU
+ printf("%c op:%x defgv:%x gv:%x want_name:%d padix:%d\n",
+ sigil, op, PL_defgv, gv, want_name, cPADOPx(op)->op_padix );
+#endif
+
+#if defined(USE_ITHREADS) && (PERL_VERSION == 8)
+ /* for 5.8 gv will be garbage causing a segfault. bah */
+ if (want_name) {
+ return sv_2mortal(newSVpvf(""));
+ }
+ return sv_2mortal(newSVsv(&PL_sv_undef));
+#else
+ if (want_name) {
+ return sv_2mortal(newSVpvf("%c%s::%s", sigil,
+ HvNAME(GvSTASH(gv)),
+ GvNAME(gv)));
+ }
+
+ switch(sigil) {
+ case '$': ret = (SV*) GvSV(gv); break;
+ case '@': ret = (SV*) GvAV(gv); break;
+ case '%': ret = (SV*) GvHV(gv); break;
+ case '*': ret = (SV*) GvEGV(gv); break;
+ }
+ return sv_2mortal(newRV_inc(ret));
+#endif
+}
+
+
+/* scan forward to the ENTERSUB and figure out which PUSHMARK is the
+ * one that precedes the arguments for that sub */
+
+static
+OP *
+scan_forward(OP *op) {
+ AV* markstack = newAV();
+ SV *sv;
+
+ if (op->op_type != OP_PUSHMARK)
+ croak("was expecting a pushmark, not a '%s'", OP_NAME(op));
+
+ for (; op && op->op_type != OP_ENTERSUB; op = op->op_next) {
+#if WORK_DAMN_YOU
+ printf("SCAN op %x %s next %x sibling %x targ %d\n",
+ op, OP_NAME(op), op->op_next, op->op_sibling, op->op_targ);
+#endif
+ switch (op->op_type) {
+ case OP_PUSHMARK:
+#if WORK_DAMN_YOU
+ printf("SCAN PUSH %x\n", op);
+#endif
+ av_push( markstack, sv_2mortal(newSViv( (IV) op)) );
+ break;
+ /* ops that consume marks */
+#if WORK_DAMN_YOU
+ printf("SCAN POP %x\n", op);
+#endif
+ av_pop( markstack );
+
+ break;
+ }
+ }
+#if WORK_DAMN_YOU
+ printf("SCAN END\n");
+#endif
+
+ sv = av_pop(markstack);
+ return (OP*) SvIV(sv);
+}
+
+
+MODULE = Devel::Caller PACKAGE = Devel::Caller
+
+void
+_called_with(context, cv_ref, want_names)
+SV *context;
+SV *cv_ref;
+I32 want_names;
+ PREINIT:
+ PERL_CONTEXT* cx = (PERL_CONTEXT*) SvIV(context);
+ CV *cv = SvROK(cv_ref) ? (CV*) SvRV(cv_ref) : 0;
+ AV* padn = cv ? (AV*) AvARRAY(CvPADLIST(cv))[0] : PL_comppad_name;
+ AV* padv = cv ? (AV*) AvARRAY(CvPADLIST(cv))[1] : PL_comppad;
+ SV** oldpad;
+ OP* op, *prev_op;
+ int skip_next = 0;
+ GV* gv;
+
+ PPCODE:
+{
+ /* hacky hacky hacky. under ithreads GVs are stored in PL_curpad
+ * which moves about some. Here we temporarily pretend we were
+ * back in olden times, which is where we're looking */
+ oldpad = PL_curpad;
+ PL_curpad = AvARRAY(padv);
+#if WORK_DAMN_YOU
+ printf("cx %x %d cv %x pad %x %x\n", cx, cx->cx_type, cv, padn, padv);
+#endif
+ /* a lot of this blind derefs, hope it goes ok */
+ /* (hackily) deparse the subroutine invocation */
+
+ op = cx->blk_oldcop->op_next;
+ op = scan_forward( op );
+ if (op->op_type != OP_PUSHMARK)
+ croak("was expecting a pushmark, not a '%s'", OP_NAME(op));
+
+ while ((prev_op = op) && (op = op->op_next) && (op->op_type != OP_ENTERSUB)) {
+#if WORK_DAMN_YOU
+ printf("op %x %s next %x sibling %x targ %d\n",
+ op, OP_NAME(op), op->op_next, op->op_sibling, op->op_targ);
+#endif
+ switch (op->op_type) {
+ case OP_PUSHMARK:
+ /* if it's a pushmark there's a probably a sub-operation brewing,
+ like P( my @foo = @bar ); so turn off capturing for now. */
+ skip_next = !skip_next;
+#if WORK_DAMN_YOU
+ printf("PUSHMARK skip_next %d\n", skip_next);
+#endif
+ break;
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+#define VARIABLE_PREAMBLE \
+ if (op->op_next->op_next->op_type == OP_SASSIGN) { \
+ /* so it's an assign coming up. cancel the skipping */ \
+ skip_next = 0; \
+ /* and ignore this value */ \
+ break; \
+ } \
+ if (skip_next) break;
+#if WORK_DAMN_YOU
+ printf("PAD skip_next %d\n", skip_next);
+#endif
+ VARIABLE_PREAMBLE;
+
+ if (want_names) {
+ SV* sv = *av_fetch(padn, op->op_targ, 0);
+ /* XXX ignore SvLEN, as it's just freaky and wrong for
+ things in the pad */
+ I32 len = strlen( SvPVX(sv) );
+#if WORK_DAMN_YOU
+ printf("sv %x SvCUR %d SvLEN %d len %d\n", sv, SvCUR(sv), SvLEN(sv), len);
+#endif
+ XPUSHs(sv_2mortal(newSVpvn(SvPVX(sv), len)));
+ }
+ else
+ XPUSHs(sv_2mortal(newRV_inc(*av_fetch(padv, op->op_targ, 0))));
+ break;
+ case OP_GV:
+ break;
+ case OP_GVSV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ case OP_RV2GV:
+#if WORK_DAMN_YOU
+ printf("GV skip_next %d\n", skip_next);
+#endif
+ VARIABLE_PREAMBLE;
+ switch (op->op_type) {
+ case OP_GVSV:
+ XPUSHs(glob_out('$', (GVOP*) op, want_names)); break;
+ case OP_RV2AV:
+ XPUSHs(glob_out('@', (GVOP*) prev_op, want_names)); break;
+ case OP_RV2HV:
+ XPUSHs(glob_out('%', (GVOP*) prev_op, want_names)); break;
+ case OP_RV2GV:
+ XPUSHs(glob_out('*', (GVOP*) prev_op, want_names)); break;
+ }
+ break;
+ case OP_CONST:
+#if WORK_DAMN_YOU
+ printf("CONST skip_next %d op->op_\n", skip_next);
+#endif
+
+ VARIABLE_PREAMBLE;
+
+ /* XXX are all const ops svs? it seems that way from
+ * looking at Perl_fold_constant in op.c */
+ if (want_names)
+ XPUSHs(&PL_sv_undef);
+ else
+ XPUSHs(cSVOPx_sv(op));
+
+ break;
+ }
+ }
+ PL_curpad = oldpad; /* see hacky hacky hacky note above */
+}
+
+
+SV*
+_context_cv(context)
+SV* context;
+ CODE:
+ PERL_CONTEXT *cx = (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
+
+
+void
+_called_as_method (context)
+SV* context;
+PPCODE:
+{
+ PERL_CONTEXT* cx = (PERL_CONTEXT*) SvIV(context);
+ OP* op, *prev_op;
+
+ op = cx->blk_oldcop->op_next;
+ if (op->op_type != OP_PUSHMARK)
+ croak("was expecting a pushmark, not a '%s'", OP_NAME(op));
+ while ((prev_op = op) && (op = op->op_next) && (op->op_type != OP_ENTERSUB)) {
+ if (op->op_type == OP_METHOD_NAMED || op->op_type == OP_METHOD) {
+ XPUSHs(sv_2mortal(newSViv(1)));
+ return;
+ }
+ }
+}
Added: 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=6852&op=file
==============================================================================
--- branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t (added)
+++ branches/upstream/libdevel-caller-perl/current/t/Devel-Caller.t Fri Aug 17 18:02:44 2007
@@ -1,0 +1,201 @@
+#!perl -w
+use strict;
+use Test::More tests => 72;
+
+BEGIN { use_ok( 'Devel::Caller', qw( caller_cv caller_args caller_vars called_with called_as_method ) ) }
+
+package CV;
+use Test::More;
+
+my $cv;
+$cv = sub {
+ is( ::caller_cv(0), $cv, "caller_cv" );
+};
+$cv->();
+
+sub foo { bar(my $bar) }
+sub bar { baz(my $baz) }
+sub baz { check(my $check) }
+sub check {
+ my $i = 0;
+ for (qw( check baz bar foo )) {
+ is( ::caller_cv($i), \&{"CV::$_"}, "caller_cv $i is $_" );
+ is_deeply( [::called_with($i,1)], [ "\$$_" ], "called_with $i is \$$_" );
+ ++$i;
+ }
+}
+foo(my $foo);
+
+package main;
+
+my (@foo, %foo);
+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" );
+}
+called_lex($foo, @foo, %foo);
+
+sub called_lex_names {
+ my @called = called_with(0, 1);
+ is( @called, 3, "right count");
+ is( $called[0], '$foo', "with lexical name \$foo" );
+ is( $called[1], '@foo', "with lexical name \@foo" );
+ is( $called[2], '%foo', "with lexical name \%foo" );
+}
+called_lex_names($foo, @foo, %foo);
+
+# called_with muddied with assignments
+my @expect;
+my $what;
+sub called_assign {
+ is_deeply([ called_with(0, 1) ], \@expect,
+ "$what called_assign(".join(', ', map { $_ || "undef"} @expect).")");
+}
+
+$what = 'constant';
+{
+ my $foo;
+ @expect = undef; called_assign('foo');
+ @expect = (undef, '$foo'); called_assign('foo', $foo);
+ @expect = (undef, '$foo'); called_assign(['foo'], $foo);
+}
+
+$what = 'lexical create';
+{ # test scalars
+ @expect = qw( $bar ); called_assign(my $bar = q(some value));
+ @expect = qw( $baz ); called_assign(my $baz = $foo);
+ @expect = qw( $quux $bar ); called_assign(my $quux = $foo, $bar);
+}
+{ # same again for arrays
+ @expect = qw( @bar ); called_assign(my @bar = qw(some values));
+ @expect = qw( @baz ); called_assign(my @baz = @foo);
+ @expect = qw( @quux @bar ); called_assign(my @quux = @foo, @bar);
+ @expect = qw( @flange ); called_assign(my @flange = (@foo, @bar));
+}
+{ # and again for hashes
+ @expect = qw( %bar ); called_assign(my %bar = qw(some values));
+ @expect = qw( %baz ); called_assign(my %baz = %foo);
+ @expect = qw( %quux %bar ); called_assign(my %quux = %foo, %bar);
+ @expect = qw( %flange ); called_assign(my %flange = (%foo, %bar));
+}
+
+$what = 'lexical prexist';
+{ # test scalars
+ my ($bar, $baz, $quux);
+ @expect = qw( $bar ); called_assign($bar = q(some value));
+ @expect = qw( $baz ); called_assign($baz = $foo);
+ @expect = qw( $quux $bar ); called_assign($quux = $foo, $bar);
+}
+{ # same again for arrays
+ my (@bar, @baz, @quux, @flange);
+ @expect = qw( @bar ); called_assign(@bar = qw(some values));
+ @expect = qw( @baz ); called_assign(@baz = @foo);
+ @expect = qw( @quux @bar ); called_assign(@quux = @foo, @bar);
+ @expect = qw( @flange ); called_assign(@flange = (@foo, @bar));
+}
+{ # and again for hashes
+ my (%bar, %baz, %quux, %flange);
+ @expect = qw( %bar ); called_assign(%bar = qw(some values));
+ @expect = qw( %baz ); called_assign(%baz = %foo);
+ @expect = qw( %quux %bar ); called_assign(%quux = %foo, %bar);
+ @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);
+ is( scalar @called, 3, "right count");
+ is( $called[0], \$quux, "with \$quux" );
+ is( $called[1], \@quux, "with \@quux" );
+ is( $called[2], \%quux, "with \%quux" );
+}
+called($quux, @quux, %quux);
+
+
+sub called_names {
+ my @called = called_with(0, 1);
+ is( scalar @called, 3, "right count");
+ is( $called[0], '$main::quux', "with name 0" );
+ is( $called[1], '@main::quux', "with name 1" );
+ is( $called[2], '%main::quux', "with name 2" );
+}
+
+called_names($quux, @quux, %quux);
+sub called_globs {
+ my @called = called_with(0, 1);
+ is( scalar @called, 3, "right count");
+ is( $called[0], '*main::STDIN', "with name 0" );
+ is( $called[1], '*main::STDOUT', "with name 1" );
+ is( $called[2], '*main::STDERR', "with name 2" );
+}
+
+called_globs(*STDIN, *STDOUT, *STDERR);
+
+package T;
+$what = 'package';
+*called_assign = \&::called_assign;
+
+{ # test scalars
+ use vars qw( $bar $baz $quux );
+ @expect = qw( $T::bar ); called_assign($bar = q(a value));
+ @expect = qw( $T::baz ); called_assign($baz = $foo);
+ @expect = qw( $T::quux $T::bar ); called_assign($quux = $foo, $bar);
+}
+{ # same again for arrays
+ use vars qw( @bar @baz @quux @flange );
+ {
+ local $::TODO = "splitops under 5.00503"
+ if $] < 5.006;
+ @expect = qw( @T::bar ); called_assign(@bar = qw(some values));
+ }
+ @expect = qw( @T::baz ); called_assign(@baz = @foo);
+ @expect = qw( @T::quux @T::bar ); called_assign(@quux = @foo, @bar);
+ @expect = qw( @T::flange ); called_assign(@flange = (@foo, @bar));
+}
+{ # and again for hashes
+ use vars qw( %bar %baz %quux %flange );
+ @expect = qw( %T::bar ); called_assign(%bar = qw(1 2));
+ @expect = qw( %T::baz ); called_assign(%baz = %foo);
+ @expect = qw( %T::quux %T::bar ); called_assign(%quux = %foo, %bar);
+ @expect = qw( %T::flange ); called_assign(%flange = (%foo, %bar));
+}
+
+local $::TODO = undef; # ithreads
+
+package main;
+# were we called as a method or a sub
+my $called;
+sub maybe_method {
+ is( called_as_method(), $called, "called_as_method" );
+}
+maybe_method();
+$called = 1;
+main->maybe_method();
+my $name = 'maybe_method';
+main->$name();
+
+
+sub args {
+ is_deeply( \@_, [ caller_args(0) ] );
+}
+
+args('foo', 'bar');
+
+# rt.cpan.org 2878
+my $coy = rand 6;
+print "# cunning coy tests\n";
+real( $coy, $coy );
+print "# concat\n";
+
+print "# print ", real( $coy, $coy ), "\n";
+
+sub real {
+ is_deeply( [ called_with(0,1) ], [qw( $coy $coy )], 'real( $coy, $coy )' );
+}
More information about the Pkg-perl-cvs-commits
mailing list