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
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
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
$USE_OUR_ST = 0;
sub import{
no strict 'refs';
my $pkg = shift;
my $callpkg = caller();
if (my ($flag) = @_){ # we have an arg
if ($flag eq ":FIELDS"){
# import everything available
@_ = (@{"$pkg\::EXPORT"}, @{"$pkg\::EXPORT_OK"});
$USE_OUR_ST = 1;
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/BZ/Client/API.pm view on Meta::CPAN
# Move stuff here so we dont do it over and over
sub _create {
my(undef, $client, $methodName, $params, $key) = @_;
$key ||= 'id';
my $sub = ( caller(1) )[3];
$client->log('debug', $sub . ': Running');
my $result = __PACKAGE__->api_call($client, $methodName, $params);
my $id = $result->{$key};
__PACKAGE__->error($client, "Invalid reply by server, expected $methodName $key.")
unless $id;
lib/BZ/Client/API.pm view on Meta::CPAN
return $id
}
sub _returns_array {
my(undef, $client, $methodName, $params, $key) = @_;
my $sub = ( caller(1) )[3];
$client->log('debug',$sub . ': Running');
my $result = __PACKAGE__->api_call($client, $methodName, $params);
my $foo = $result->{$key};
__PACKAGE__->error($client, "Invalid reply by server, expected array of $methodName details")
unless ($foo and 'ARRAY' eq ref $foo);
view release on metacpan or search on metacpan
lib/Badger/Base.pm view on Meta::CPAN
map {
my $name = $_;
$name => sub {
my $self = shift;
my $ref = ref $self || $self;
my ($pkg, $file, $line, $sub) = caller(0);
$sub = (caller(1))[3]; # subroutine the caller was called from
$sub =~ s/(.*):://;
my $msg = @_ ? join(BLANK, SPACE, @_) : BLANK;
return $self->error_msg( $name => "$sub()$msg", "for $ref in $file at line $line" );
};
}
view release on metacpan or search on metacpan
lib/Banal/Mini/Utils.pm view on Meta::CPAN
#######################################
sub msg(@) { # Message text builder to be used in error output (warn, die, ...)
#######################################
my $o = blessed ($_[0]) ? shift : caller();
state $pfx = eval { $o->_msg_pfx(@_) } // '';
join ('', $pfx, @_, "\n")
}
lib/Banal/Mini/Utils.pm view on Meta::CPAN
# NO LUCK with any invocation.
# At this point, '$@' would normally be set to a true value by the last failed eval.
if (@e) {
my @emsg = map { $_->{msg} } @e;
my $name = (caller(0))[3]; # The name of this particular subroutine.
croak "$name : Failed to sucessfully invoke any of the given code blocks!\n"
. "Here's the list of all errors:\n\n @emsg"
}
return;
}
view release on metacpan or search on metacpan
lib/Banal/Util/Mini.pm view on Meta::CPAN
#######################################
sub msg(@) { # Message text builder to be used in error output (warn, die, ...)
#######################################
my $o = blessed ($_[0]) ? shift : caller();
state $pfx = eval { $o->_msg_pfx(@_) } // '';
join ('', $pfx, @_, "\n")
}
lib/Banal/Util/Mini.pm view on Meta::CPAN
# NO LUCK with any invocation.
# At this point, '$@' would normally be set to a true value by the last failed eval.
if (@e) {
my @emsg = map { $_->{msg} } @e;
my $name = (caller(0))[3]; # The name of this particular subroutine.
croak "$name : Failed to sucessfully invoke any of the given code blocks!\n"
. "Here's the list of all errors:\n\n @emsg"
}
return;
}
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/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/Basic/Coercion/XS.xs view on Meta::CPAN
hv_store(hash, "name", 4, type, 0);
hv_store(hash, "coerce", 6, (SV*)coerce, 0);
return sv_bless(newRV_noinc((SV*)hash), gv_stashsv(newSVpv("Basic::Coercion::XS", 19), 0));
}
char *get_caller(void) {
dTHX;
char *callr = HvNAME((HV*)CopSTASH(PL_curcop));
return callr;
}
lib/Basic/Coercion/XS.xs view on Meta::CPAN
RETVAL
void
import( ...)
CODE:
char *pkg = get_caller();
STRLEN retlen;
int i = 1;
for (i = 1; i < items; i++) {
char * ex = SvPV(ST(i), retlen);
int name_len = strlen(pkg) + retlen + 3;
view release on metacpan or search on metacpan
lib/Basic/Types/XS.xs view on Meta::CPAN
}
return 0;
}
char *get_caller(void) {
dTHX;
char *callr = HvNAME((HV*)CopSTASH(PL_curcop));
return callr;
}
lib/Basic/Types/XS.xs view on Meta::CPAN
RETVAL
void
import( ...)
CODE:
char *pkg = get_caller();
STRLEN retlen;
int i = 1;
for (i = 1; i < items; i++) {
char * ex = SvPV(ST(i), retlen);
char name [strlen(pkg) + 2 + retlen];
view release on metacpan or search on metacpan
lib/Basset/Object.pm view on Meta::CPAN
my @verbose_caller = ("Package: ", "Filename: ", "Line number: ", "Subroutine: ", "Has Args? : ",
"Want array? : ", "Evaltext: ", "Is require? : ");
push @verbose_caller, ("Hints: ", "Bitmask: ") if $] >= 5.006; #5.6 has a more verbose caller stack.
while (my @caller = caller($caller_count++)){
$caller_stack .= "\t---------\n";
foreach (0..$#caller){
my $callvalue = defined $caller[$_] ? $caller[$_] : '';
$caller_stack .= "\t\t$verbose_caller[$_]$callvalue\n";# if $caller[$_];
};
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
lib/Beagle/Util.pm view on Meta::CPAN
# I got error: "Goto undefined subroutine &die" on windows strawberry 5.12.2
# &CORE::die doesn't help
*CORE::GLOBAL::die = sub {
# goto &die unless ( caller() )[0] =~ /^Beagle::/;
return die @_ unless ( caller() )[0] =~ /^Beagle::/;
@_ = map { encode( locale => $_ ) } @_;
return confess @_ if enabled_devel();
# we want to show user the line info if there is nothing to print
lib/Beagle/Util.pm view on Meta::CPAN
};
*CORE::GLOBAL::warn = sub {
# interesting, I get warn if use goto &warn:
# Goto undefined subroutine &Beagle::Util::warn
# goto &warn unless (caller())[0] =~ /^Beagle::/;
return warn @_ unless ( caller() )[0] =~ /^Beagle::/;
@_ = grep { defined } @_;
# we want to show user the line info if there is nothing to print
push @_, newline() if @_;
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';
}
sub _running_under {
my $thing = shift;
print <<"END_MESSAGE";
view release on metacpan or search on metacpan
lib/Beekeeper/Client.pm view on Meta::CPAN
sub __create_response_topic {
my $self = shift;
my $client = $self->{_CLIENT};
my ($file, $line) = (caller(2))[1,2];
my $at = "at $file line $line\n";
# Subscribe to an exclusive topic for receiving RPC responses
my $response_topic = 'priv/' . $self->{_BUS}->{client_id};
view release on metacpan or search on metacpan
lib/Bench.pm view on Meta::CPAN
}
sub import {
_set_start_time;
no strict 'refs';
my $caller = caller();
*{"$caller\::bench"} = \&bench;
}
sub _fmt_num {
my ($num, $unit, $nsig) = @_;
view release on metacpan or search on metacpan
lib/Bencher/Scenario/Caller.pm view on Meta::CPAN
use 5.010001;
use strict;
use warnings;
our $scenario = {
summary => 'Benchmark some variations of caller()',
participants => [
{
name => 'CORE::caller() (scalar)',
code_template => 'CORE::caller()',
},
{
name => 'CORE::caller() (list)',
code_template => 'CORE::caller()',
result_is_list => 1,
},
{
name => 'CORE::caller(0)',
code_template => 'CORE::caller(0)',
result_is_list => 1,
},
{
name => 'CORE::caller(1)',
code_template => 'CORE::caller(1)',
result_is_list => 1,
},
{
name => 'CORE::caller(2)',
code_template => 'CORE::caller(2)',
result_is_list => 1,
},
{
name => 'Devel::Caller::Util::caller(0)',
module => 'Devel::Caller::Util',
code_template => 'Devel::Caller::Util::caller(0)',
result_is_list => 1,
},
{
name => 'Devel::Caller::Util::caller(1)',
module => 'Devel::Caller::Util',
code_template => 'Devel::Caller::Util::caller(1)',
result_is_list => 1,
},
{
name => 'Devel::Caller::Util::caller(2)',
module => 'Devel::Caller::Util',
code_template => 'Devel::Caller::Util::caller(2)',
result_is_list => 1,
},
{
name => 'Devel::Caller::Util::caller(0) with-args',
module => 'Devel::Caller::Util',
code_template => 'Devel::Caller::Util::caller(0, 1)',
result_is_list => 1,
},
{
name => 'Devel::Caller::Util::caller(0) with-packages-to-ignore=re',
module => 'Devel::Caller::Util',
code_template => 'Devel::Caller::Util::caller(0, 0, qr/^Bencher::Scenario$/)',
result_is_list => 1,
},
],
};
1;
# ABSTRACT: Benchmark some variations of caller()
__END__
=pod
=encoding UTF-8
=head1 NAME
Bencher::Scenario::Caller - Benchmark some variations of caller()
=head1 VERSION
This document describes version 0.001 of Bencher::Scenario::Caller (from Perl distribution Bencher-Scenario-Caller), released on 2019-04-14.
lib/Bencher/Scenario/Caller.pm view on Meta::CPAN
=head1 BENCHMARK PARTICIPANTS
=over
=item * CORE::caller() (scalar) (perl_code)
Code template:
CORE::caller()
=item * CORE::caller() (list) (perl_code)
Code template:
CORE::caller()
=item * CORE::caller(0) (perl_code)
Code template:
CORE::caller(0)
=item * CORE::caller(1) (perl_code)
Code template:
CORE::caller(1)
=item * CORE::caller(2) (perl_code)
Code template:
CORE::caller(2)
=item * Devel::Caller::Util::caller(0) (perl_code)
Code template:
Devel::Caller::Util::caller(0)
=item * Devel::Caller::Util::caller(1) (perl_code)
Code template:
Devel::Caller::Util::caller(1)
=item * Devel::Caller::Util::caller(2) (perl_code)
Code template:
Devel::Caller::Util::caller(2)
=item * Devel::Caller::Util::caller(0) with-args (perl_code)
Code template:
Devel::Caller::Util::caller(0, 1)
=item * Devel::Caller::Util::caller(0) with-packages-to-ignore=re (perl_code)
Code template:
Devel::Caller::Util::caller(0, 0, qr/^Bencher::Scenario$/)
=back
lib/Bencher/Scenario/Caller.pm view on Meta::CPAN
#table1#
+-----------------------------------------------------------+-----------+-----------+------------+---------+---------+
| participant | rate (/s) | time (μs) | vs_slowest | errors | samples |
+-----------------------------------------------------------+-----------+-----------+------------+---------+---------+
| Devel::Caller::Util::caller(2) | 100000 | 9.7 | 1 | 9.8e-09 | 21 |
| Devel::Caller::Util::caller(1) | 150000 | 6.8 | 1.4 | 1e-08 | 20 |
| Devel::Caller::Util::caller(0) with-args | 230000 | 4.3 | 2.3 | 8.3e-09 | 20 |
| Devel::Caller::Util::caller(0) with-packages-to-ignore=re | 200000 | 4 | 2 | 2e-07 | 20 |
| Devel::Caller::Util::caller(0) | 280000 | 3.6 | 2.7 | 2.1e-08 | 20 |
| CORE::caller(1) | 23000000 | 0.043 | 230 | 2.9e-10 | 20 |
| CORE::caller(0) | 24000000 | 0.042 | 230 | 1e-10 | 22 |
| CORE::caller(2) | 25000000 | 0.04 | 240 | 5.8e-11 | 20 |
| CORE::caller() (scalar) | 25000000 | 0.039 | 250 | 1.2e-10 | 20 |
| CORE::caller() (list) | 27000000 | 0.038 | 260 | 2.4e-10 | 24 |
+-----------------------------------------------------------+-----------+-----------+------------+---------+---------+
Benchmark module startup overhead (C<< bencher -m Caller --module-startup >>):
view release on metacpan or search on metacpan
lib/Benchmark/Confirm.pm view on Meta::CPAN
croak "negative loopcount $n" if $n<0;
confess usage unless defined $c;
my($t0, $t1, $td); # before, after, difference
# find package of caller so we can execute code there
my($curpack) = caller(0);
my($i, $pack)= 0;
while (($pack) = caller(++$i)) {
last if $pack ne $curpack;
}
my ($subcode, $subref, $confirmref);
if (ref $c eq 'CODE') {
view release on metacpan or search on metacpan
data/t/recipes/meta_privateorpublic_methodmetaclass.t view on Meta::CPAN
my $package = $self->package_name;
my $real_body = $self->body;
my $body = sub {
die "The $package\::$name method is private"
unless ( scalar caller() ) eq $package;
goto &{$real_body};
};
$self->{body} = $body;
view release on metacpan or search on metacpan
Harness/Handler.pm view on Meta::CPAN
sub ArgumentsXXX {
my $self = shift;
return $self unless ref($self);
return $self unless $self->{_outFH};
$self->_PrintT('-Arguments', caller(1));
my $i = 1;
for ( @_ ) {
my $obj = ref($_)?$_:\$_;
my ($nm, $sz) = (ref($_), Devel::Size::total_size($_));
Harness/Handler.pm view on Meta::CPAN
my $pckg = $_[0];
my $pckgName = "$pckg";
$pckgName =~ s{=?(ARRAY|HASH|SCALAR).*$}{};
my $pckgType = $1;
$self->_PrintT("-$pckgType $pckgName", caller(1));
$self->OnObject(@_);
$self->_PrintT_();
return $self;
}
Harness/Handler.pm view on Meta::CPAN
# USAGE: Harness::NamedVariables('name1' => $variable1 [, 'name1' => $variable2 ])
sub NamedVariables {
my $self = ref($_[0])?shift:$Benchmark::Harness::Harness;
return $self unless ref($self);
$self->_PrintT(undef, caller(1));
my $i = 1;
while ( @_ ) {
my ($nm, $sz) = (shift, Devel::Size::total_size(shift));
$nm = $i unless $nm; $i += 1;
view release on metacpan or search on metacpan
lib/Benchmark/MCE.pm view on Meta::CPAN
sub _package_ver {
my $pkg = __PACKAGE__;
my $ver = $VERSION;
my $caller = caller(0);
for (my $i = 0; $i < 5; $i++) {
my $caller = caller($i) or last;
if ($caller eq 'Benchmark::DKbench') {
$pkg = $caller;
$ver = eval {$caller->VERSION} || '';
last;
}
view release on metacpan or search on metacpan
share/PerlCritic/Critic/Policy.pm view on Meta::CPAN
#-----------------------------------------------------------------------------
sub violation { ## no critic (ArgUnpacking)
my ( $self, $desc, $expl, $elem ) = @_;
# HACK!! Use goto instead of an explicit call because P::C::V::new() uses caller()
my $sev = $self->get_severity();
@_ = ('Perl::Critic::Violation', $desc, $expl, $elem, $sev );
goto &Perl::Critic::Violation::new;
}
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
lib/Benchmark/Thread/Size.pm view on Meta::CPAN
# Initialize the key list
shift;
my %param;
my $times = '';
my $oneliner = (join( ' ',caller() ) eq 'main - 0');
my $refonly = $oneliner;
my @key;
# While there are keys to be obtained
# If it is the times setting
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 {