view release on metacpan or search on metacpan
lib/Attribute/Lexical.pm view on Meta::CPAN
=head1 SYNOPSIS
use Attribute::Lexical "CODE:Funky" => \&funky_attr_handler;
sub thingy :Funky { ... }
$handler = Attribute::Lexical->handler_for_caller([caller(0)],
"CODE:Funky");
=head1 DESCRIPTION
This module manages attributes that can be attached to subroutine and
lib/Attribute/Lexical.pm view on Meta::CPAN
use if !_KLUDGE_FAKE_MRO, "mro";
our $VERSION = "0.005";
# Hints stored in %^H only maintain referenceful structure during the
# compilation phase. Copies of %^H that are accessible via caller(),
# which we need in order to support runtime use of the lexical state,
# flatten all values to plain strings. So %interned_handler permanently
# holds references to all handler functions seen, keyed by the string
# form of the reference.
my %interned_handler;
lib/Attribute/Lexical.pm view on Meta::CPAN
my $invocant = shift(@_);
my $target = shift(@_);
my @unhandled;
my @caller;
for(my $i = 0; ; $i++) {
@caller = caller($i);
if(!@caller || $caller[3] =~ /::BEGIN\z/) {
# Strangely not called via attributes::import.
# No idea of the relevant lexical environment,
# so don't handle any attributes.
ALL_UNHANDLED:
lib/Attribute/Lexical.pm view on Meta::CPAN
}
if($caller[3] eq "attributes::import") {
if(Attribute::Lexical::_KLUDGE_RUNTIME_HINTS) {
# On earlier perls we can only get lexical
# hints during compilation, because %^H
# isn't shown by caller(). In that case,
# we check here that the attributes are
# being applied as part of compilation,
# indicated by attributes::import being
# called directly from a BEGIN block.
# If it's called elsewhere, including
# indirectly from within a BEGIN
# block, then it's a runtime attribute
# application, which we can't handle.
my @nextcall = caller($i+1);
unless(@nextcall &&
$nextcall[3] =~ /::BEGIN\z/) {
goto ALL_UNHANDLED;
}
}
lib/Attribute/Lexical.pm view on Meta::CPAN
([A-Za-z_][0-9A-Za-z_]*)
(?:\((.*)\))?
\z/sx);
if(defined($ident) && defined(my $handler = (
Attribute::Lexical::_KLUDGE_RUNTIME_HINTS ?
# %^H is not available through caller() on
# earlier perls. In that case, if called
# during compilation, we can kludge by
# looking at the current compilation %^H.
Attribute::Lexical->handler_for_compilation(
"$type:$ident")
:
Attribute::Lexical->handler_for_caller(
\@caller, "$type:$ident")
))) {
$handler->($target, $ident, $arg, \@caller);
} else {
push @unhandled, $attr;
lib/Attribute/Lexical.pm view on Meta::CPAN
All these methods are meant to be invoked on the C<Attribute::Lexical>
package.
=over
=item Attribute::Lexical->handler_for_caller(CALLER, NAME)
Looks up the attribute named I<NAME> (e.g., "B<CODE:Funky>")
according to the lexical declarations prevailing in a specified place.
I<CALLER> must be a reference to an array of the form returned by
the L<caller|perlfunc/caller> function, describing the lexical site
lib/Attribute/Lexical.pm view on Meta::CPAN
don't make lexical state available at runtime.
=cut
BEGIN { unless(_KLUDGE_RUNTIME_HINTS) { eval q{
sub handler { shift->handler_for_caller([caller(0)], @_) }
1; } or die $@; } }
=item Attribute::Lexical->handler_for_compilation(NAME)
Looks up the attribute named I<NAME> (e.g., "B<CODE:Funky>") according to
view release on metacpan or search on metacpan
t/lib/Test/Builder.pm view on Meta::CPAN
=cut
sub todo {
my($self, $pack) = @_;
$pack = $pack || $self->exported_to || $self->caller(1);
no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
=item B<caller>
my $package = $Test->caller;
my($pack, $file, $line) = $Test->caller;
my($pack, $file, $line) = $Test->caller($height);
Like the normal caller(), except it reports according to your level().
=cut
sub caller {
my($self, $height) = @_;
$height ||= 0;
my @caller = CORE::caller($self->level + $height + 1);
return wantarray ? @caller : $caller[0];
}
=back
t/lib/Test/Builder.pm view on Meta::CPAN
# We don't want to muck with death in an eval, but $^S isn't
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
# with it. Instead, we use caller. This also means it runs under
# 5.004!
my $in_eval = 0;
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
$in_eval = 1 if $sub =~ /^\(eval\)/;
}
$Test_Died = 1 unless $in_eval;
};
view release on metacpan or search on metacpan
lib/Attribute/Tie.pm view on Meta::CPAN
# Anything else
eval qq{ require Tie::$mod2tie };
return $MOD2TIE{$mod2tie} = 'Tie::'.$mod2tie unless $@;
# Report Failure and die
my ( $pkg, $file, $line ) = caller(4);
die "Neither $mod2tie nor Tie::$mod2tie is available",
" at $file line $line\n";
}
sub error {
my ( $ref, $mod2tie, @tiearg ) = @_;
my ( $pkg, $file, $line ) = caller(4);
my $s = $SIGIL{ ref $ref };
die "tie(", join( ", ", $s . ref $ref, qq('$mod2tie'), @tiearg ),
") failed : $! at $file line $line\n";
}
view release on metacpan or search on metacpan
lib/Attribute/Method.pm view on Meta::CPAN
'%' => {},
);
sub import {
my ( $class, @vars ) = @_;
my $pkg = caller();
push @vars, '$self';
for my $var (@vars) {
my $sigil = substr( $var, 0, 1, '' );
no strict 'refs';
*{ $pkg . '::' . $var } = $sigil2ref{$sigil};
view release on metacpan or search on metacpan
sub crit { my $self = shift; return $self->log('crit', @_); }
sub warn { my $self = shift; return $self->log('warn', @_); }
sub log {
my $self = shift;
my @caller = caller(2);
# print "caller line is ".$caller[2]."\n";
# ($package, $filename, $line, $subroutine, $hasargs,
# $wantarray, $evaltext, $is_require, $hints, $bitmask)
if (defined $self->{Log}) {
&{$self->{Log}}(@_, @caller);
view release on metacpan or search on metacpan
sub crit { my $self = shift; return $self->log('crit', @_); }
sub warn { my $self = shift; return $self->log('warn', @_); }
sub log {
my $self = shift;
my @caller = caller(2);
# print "caller line is ".$caller[2]."\n";
# ($package, $filename, $line, $subroutine, $hasargs,
# $wantarray, $evaltext, $is_require, $hints, $bitmask)
if (defined $self->{Log}) {
&{$self->{Log}}(@_, @caller);
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
ccstack = top_si->si_cxstack;
cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0)
return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
count++;
if (!count--)
break;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
cx = &ccstack[dbcxix];
}
return cx;
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
@found;
}
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
1;
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
lib/Audio/Nama.pm view on Meta::CPAN
waitpid $pid, 1;
} @pids;
}
sub cleanup_exit {
logsub((caller(0))[3]);
remove_riff_header_stubs();
trigger_rec_cleanup_hooks();
# for each process:
# - SIGINT (1st time)
# - allow time to close down
view release on metacpan or search on metacpan
ccstack = top_si->si_cxstack;
cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0)
return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
count++;
if (!count--)
break;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
cx = &ccstack[dbcxix];
}
return cx;
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
view release on metacpan or search on metacpan
lib/Audit/DBI.pm view on Meta::CPAN
$args{'event_time'} ||= time();
# Store the file and line of the caller, unless they were passed in.
if ( !defined( $args{'file'} ) || !defined( $args{'line'} ) )
{
my ( $file, $line ) = ( caller() )[1,2];
$file =~ s|.*/||;
$args{'file'} = $file
if !defined( $args{'file'} );
$args{'line'} = $line
if !defined( $args{'line'} );
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
return (@Existing, @Missing);
}
sub _running_under {
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
lib/Authen/NZRealMe.pm view on Meta::CPAN
if($opt->{conf_dir}) {
$opt->{conf_dir} =~ s{/\z}{};
return $opt->{conf_dir} if -d $opt->{conf_dir};
die "Directory does not exist: $opt->{conf_dir}";
}
my $cmnd = (caller(1))[3];
$cmnd =~ s/^.*::_dispatch_//;
$cmnd =~ s/_/-/g;
die "$cmnd command needs --conf-dir option\n";
}
view release on metacpan or search on metacpan
ccstack = top_si->si_cxstack;
cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0)
return NULL;
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
count++;
if (!count--)
break;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
/* caller() should not report the automatic calls to &DB::sub */
if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
cx = &ccstack[dbcxix];
}
return cx;
view release on metacpan or search on metacpan
lib/Authen/PluggableCaptcha/Helpers.pm view on Meta::CPAN
# make sure we were called with the requisite args
my @check_requireds= qw( kw_args__ref requires_array__ref error_message );
foreach my $check_required ( @check_requireds ) {
if ( !defined $kw_args{ $check_required } ) {
die "Missing required element in _check_requires [ " . ( join ',' , caller(1) ) . ' ]';
}
}
# then check to make sure we have the right args
foreach my $required ( @{$kw_args{'requires_array__ref'}} ) {
if ( ! defined $kw_args{'kw_args__ref'}{$required} ) {
die (
sprintf( $kw_args{'error_message'} , $required )
.
( ' [' . ( join ',' , caller(1) ) . ' ]' )
);
}
}
return 1;
}
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
view release on metacpan or search on metacpan
inc/ExtUtils/AutoInstall.pm view on Meta::CPAN
chdir $cwd;
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
# CPAN.pm is non-reentrant, so check if we're under it and have no CPANPLUS
sub _check_lock {
return unless @Missing;
view release on metacpan or search on metacpan
lib/AutoCode/AccessorMaker.pm view on Meta::CPAN
}
}
# This method is only invoked by make_scalar_accessor and make_array_accessor
# While subroutine defined the argument of those two method abovementioned.
# This most hacky part is caller(2); that mean the first immedicate package
# after this Module.
sub __accessor_to_glob {
my ($self, $accessor, $pkg)=@_;
defined $accessor or $self->throw("method_name needed as 2nd arg");
my $singular = (ref($accessor) eq 'ARRAY')? $accessor->[0]: $accessor;
# According to the specification of AutoCode, upper letter are not allowed
# in the names of methods which are automatically generated by this system.
$self->throw("'$singular' method name must match /^$VALID_ACCESSOR_NAME\$/")
unless $singular =~ /^$VALID_ACCESSOR_NAME$/;
if(0){ # For debug
print "$_\t". (caller($_))[0]."\n" foreach(0..3);
$self->throw("");
}
$pkg ||= (caller(2))[0]; # This line will definitely assign a value.
# This typeglob is meaningful for both scalar and array accessors.
# For scalar, it means the same as the real typeglob;
# for array, there is no such method with exact method, but a symbol for
# these three methods.