view release on metacpan or search on metacpan
lib/App/NDTools/Test.pm view on Meta::CPAN
sub t_ab_cmp {
return "GOT: " . t_dump(shift) . "\nEXP: " . t_dump(shift);
}
sub t_dir {
my $tfile = shift || (caller)[1];
substr($tfile, 0, length($tfile) - 1) . "d";
}
sub t_dump {
return Data::Dumper->new([shift])->Terse(1)->Sortkeys(1)->Quotekeys(0)->Indent(0)->Deepcopy(1)->Dump();
view release on metacpan or search on metacpan
lib/App/Netdisco/Worker/Plugin.pm view on Meta::CPAN
my $workerconf = (ref $first eq 'HASH' ? $first : {});
my $code = (ref $first eq 'CODE' ? $first : $second);
return error "bad param to register_worker"
unless ((ref sub {} eq ref $code) and (ref {} eq ref $workerconf));
my $package = (caller)[0];
($workerconf->{package} = $package) =~ s/^App::Netdisco::Worker::Plugin:://;
if ($package =~ m/Plugin::(\w+)(?:::(\w+))?/) {
$workerconf->{action} ||= lc($1);
$workerconf->{namespace} ||= lc($2) if $2;
}
view release on metacpan or search on metacpan
lib/App/Packager.pm view on Meta::CPAN
}
push( @syms, $_ );
}
if ( $rsc ) {
my $pkg = (caller)[0];
no strict 'refs';
*{ $pkg . "::" . $rsc } = \&getresource;
}
# Dispatch to super.
view release on metacpan or search on metacpan
lib/App/RPi/EnvUI/API.pm view on Meta::CPAN
return $api if defined $api;
}
my $self = bless {}, shift;
my $caller = (caller)[0];
$self->_args(@_, caller => $caller);
warn "API in test mode\n" if $self->testing;
$self->_init;
view release on metacpan or search on metacpan
local/lib/perl5/Net/SFTP/Foreign/Compat.pm view on Meta::CPAN
for my $method (@forbidden) {
my $super = "SUPER::$method";
no strict 'refs';
*{$method} = sub {
unless (index((caller)[0], "Net::SFTP::Foreign") == 0) {
croak "Method '$method' is not available from " . __PACKAGE__
. ", use the real Net::SFTP::Foreign if you want it!";
}
shift->$super(@_);
};
view release on metacpan or search on metacpan
lib/App/Stash.pm view on Meta::CPAN
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
unless ( $self->application ) {
my $caller = (caller)[0];
$self->application($caller);
}
unless ( $self->directory ) {
my $dir = dir( home(), "." . $self->_clean( $self->application ));
view release on metacpan or search on metacpan
lib/App/Wallflower.pm view on Meta::CPAN
],
);
sub new_with_options {
my ( $class, $args ) = @_;
my $input = (caller)[1];
$args ||= [];
# save previous configuration
my $save = Getopt::Long::Configure();
view release on metacpan or search on metacpan
lib/App/cpanminus/fatscript.pm view on Meta::CPAN
my $pkg = ref $self || $self;
return ${pkg}->VERSION($wanted);
}
sub heavy_export_tags {
_push_tags((caller)[0], "EXPORT", \@_);
}
sub heavy_export_ok_tags {
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
1;
EXPORTER_HEAVY
view release on metacpan or search on metacpan
t/t_TestCommon.pm view on Meta::CPAN
# This is only visible with using "perl -Ilib t/xxx.t"
# not with 'prove -l' and so mostly pointless!
sub t_ok($;$) {
my ($isok, $test_label) = @_;
my $lno = (caller)[2];
$test_label = ($test_label//"") . " (line $lno)";
@_ = ( $isok, $test_label );
goto &Test2::V0::ok; # show caller's line number
}
sub ok_with_lineno($;$) { goto &t_ok };
sub t_is($$;$) {
my ($got, $exp, $test_label) = @_;
my $lno = (caller)[2];
$test_label = ($test_label//$exp//"undef") . " (line $lno)";
@_ = ( $got, $exp, $test_label );
goto &Test2::V0::is; # show caller's line number
}
sub is_with_lineno($$;$) { goto &t_is }
sub t_like($$;$) {
my ($got, $exp, $test_label) = @_;
my $lno = (caller)[2];
$test_label = ($test_label//$exp) . " (line $lno)";
@_ = ( $got, $exp, $test_label );
goto &Test2::V0::like; # show caller's line number
}
sub like_with_lineno($$;$) { goto &t_like }
sub _mycheck_end($$$) {
my ($errmsg, $test_label, $ok_only_if_failed) = @_;
return
if $ok_only_if_failed && !$errmsg;
my $lno = (caller)[2];
&Test2::V0::diag("**********\n${errmsg}***********\n") if $errmsg;
@_ = ( !$errmsg, $test_label );
goto &ok_with_lineno;
}
view release on metacpan or search on metacpan
bin/plx-packed view on Meta::CPAN
$fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER';
package Exporter;require 5.006;our$Debug=0;our$ExportLevel=0;our$Verbose ||=0;our$VERSION='5.70';our (%Cache);sub as_heavy {require Exporter::Heavy;my$c=(caller(1))[3];$c =~ s/.*:://;\&{"Exporter::Heavy::heavy_$c"}}sub export {goto &{as_heavy()}}...
EXPORTER
$fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_HEAVY';
package Exporter::Heavy;use strict;no strict 'refs';require Exporter;our$VERSION=$Exporter::VERSION;sub _rebuild_cache {my ($pkg,$exports,$cache)=@_;s/^&// foreach @$exports;@{$cache}{@$exports}=(1)x @$exports;my$ok=\@{"${pkg}::EXPORT_OK"};if (@$...
EXPORTER_HEAVY
$fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD';
use strict;use warnings;package File::pushd;our$VERSION='1.009';our@EXPORT=qw(pushd tempd);our@ISA=qw(Exporter);use Exporter;use Carp;use Cwd qw(getcwd abs_path);use File::Path qw(rmtree);use File::Temp qw();use File::Spec;use overload q{""}=>sub...
FILE_PUSHD
view release on metacpan or search on metacpan
script/cdif view on Meta::CPAN
}
sub eval {
print STDERR &unctrl($_[0]), "\n" x ($_[0] !~ /\n$/) if $_[1] || $debug{e};
CORE::eval shift;
die sprintf("eval failed in file %s on line %s\n$@", (caller)[1,2]) if $@;
}
######################################################################
=head1 NAME
view release on metacpan or search on metacpan
lib/AppleII/Disk.pm view on Meta::CPAN
$data .= $pad x ($length - length($data))
if (length($pad) and length($data) < $length);
unless (length($data) == $length) {
local $Carp::CarpLevel = $Carp::CarpLevel;
++$Carp::CarpLevel if (caller)[0] =~ /^AppleII::Disk::/;
croak(sprintf("Data block is %d bytes",length($data)));
}
$data;
} # end AppleII::Disk::pad_block
view release on metacpan or search on metacpan
lib/Earabic.pm view on Meta::CPAN
elsif (defined $_[1]) {
return $_[1] . '::' . $name;
}
else {
return (caller)[0] . '::' . $name;
}
}
sub qualify_to_ref ($;$) {
if (defined $_[1]) {
no strict qw(refs);
return \*{ qualify $_[0], $_[1] };
}
else {
no strict qw(refs);
return \*{ qualify $_[0], (caller)[0] };
}
}
}
# P.714 29.2.39. flock
view release on metacpan or search on metacpan
lib/Archive/Zip/Parser/Exception.pm view on Meta::CPAN
use strict;
use Carp;
sub _croak {
my ( $self, $error_message ) = @_;
my $caller_package = (caller)[0];
croak "[$caller_package] $error_message";
}
1;
view release on metacpan or search on metacpan
lib/Array/Iterator.pm view on Meta::CPAN
=cut
# We need to alter this so it's an lvalue
sub _current_index : lvalue {
(UNIVERSAL::isa((caller)[0], __PACKAGE__))
|| die 'Illegal Operation: This method can only be called by a subclass';
$_[0]->{_current_index}
}
=head2 _iteratee
lib/Array/Iterator.pm view on Meta::CPAN
=cut
# This we should never need to alter so we don't make it a lvalue
sub _iteratee {
(UNIVERSAL::isa((caller)[0], __PACKAGE__))
|| die 'Illegal Operation: This method can only be called by a subclass';
$_[0]->{_iteratee}
}
# we move this from a private method
# to a protected one, and check our access
# as well
sub _getItem {
(UNIVERSAL::isa((caller)[0], __PACKAGE__)) || die 'Illegal Operation: This method can only be called by a subclass';
my ($self, $iteratee, $index) = @_;
return $iteratee->[$index];
}
lib/Array/Iterator.pm view on Meta::CPAN
sub _get_item { my $self = shift; $self->_getItem(@_) }
# we need to alter this so it's an lvalue
sub _iterated : lvalue {
(UNIVERSAL::isa((caller)[0], __PACKAGE__))
|| die 'Illegal Operation: This method can only be called by a subclass';
$_[0]->{_iterated}
}
=head2 iterated
view release on metacpan or search on metacpan
#------------------------------------------------------------------------------
# Utilities
sub test_getline {
my($text, $file, $line_nr) = @_;
my $caller_line_nr = (caller)[2];
my $test_name = "[line $caller_line_nr]";
my $line = $pp->getline;
isa_ok $line, 'Asm::Preproc::Line';
Asm::Preproc::Line->new($text, $file, $line_nr),
"$test_name line";
}
sub test_eof {
my $caller_line_nr = (caller)[2];
my $test_name = "[line $caller_line_nr]";
for (1..2) {
my $line = $pp->getline;
is $line, undef, "$test_name eof";
view release on metacpan or search on metacpan
lib/AtExit.pm view on Meta::CPAN
unless (ref $exit_sub) {
## Caller gave us a sub name instead of a sub reference.
## Need to make sure we have the callers package prefix
## prepended if one wasn't given.
my $pkg = '';
$pkg = (caller)[0] . "::" unless $exit_sub =~ /::/o;
## Now turn the sub name into a hard sub reference.
$exit_sub = eval "\\&$pkg$exit_sub";
undef $exit_sub if ($@);
}
view release on metacpan or search on metacpan
lib/Attribute/Abstract.pm view on Meta::CPAN
sub UNIVERSAL::Abstract :ATTR(CODE) {
my ($pkg, $symbol) = @_;
no strict 'refs';
my $sub = $pkg . '::' . *{$symbol}{NAME};
*{$sub} = sub {
my ($file, $line) = (caller)[1,2];
die "call to abstract method $sub at $file line $line.\n";
};
}
"Rosebud"; # for MARCEL's sake, not 1 -- dankogai
view release on metacpan or search on metacpan
@ISA = qw(DynaLoader);
__PACKAGE__->bootstrap($VERSION);
if ((caller)[0] eq 'Xmms') {
eval join '', <DATA>;
print $@ if $@;
unless (defined &Xmms::is_cpl) {
*Xmms::is_cpl = sub {0};
}
view release on metacpan or search on metacpan
t/roundtrip/test.pl view on Meta::CPAN
# The tests in lib run in a temporary subdirectory of t, and always
# pass in a list of "programs" to run
@prgs = @_;
} else {
# The tests below t run in t and pass in a file handle. In theory we
# can pass (caller)[1] as the second argument to report errors with
# the filename of our caller, as the handle is always DATA. However,
# line numbers in DATA count from the __END__ token, so will be wrong.
# Which is more confusing than not providing line numbers. So, for now,
# don't provide line numbers. No obvious clean solution - one hack
# would be to seek DATA back to the start and read to the __END__ token,
view release on metacpan or search on metacpan
return $msg;
}
sub d {
warn format_msg( (caller)[1,2], @_ );
}
sub d_to {
my $fh = shift;
print $fh format_msg( (caller)[1,2], @_ );
}
sub d_to_string {
format_msg( (caller)[1,2], @_ );
}
=head1 LIMITATIONS
view release on metacpan or search on metacpan
lib/Backup/EZ.pm view on Meta::CPAN
sub _debug {
my $self = shift;
my $msg = shift;
my $line = (caller)[2];
openlog "ezbackup", $self->{syslog_option}, LOG_SYSLOG;
syslog LOG_DEBUG, "($line) $msg";
closelog;
}
view release on metacpan or search on metacpan
lib/Beekeeper/Client.pm view on Meta::CPAN
sub accept_notifications {
my ($self, %args) = @_;
my ($file, $line) = (caller)[1,2];
my $at = "at $file line $line\n";
my $callbacks = $self->{_CLIENT}->{callbacks};
foreach my $fq_meth (keys %args) {
lib/Beekeeper/Client.pm view on Meta::CPAN
sub stop_accepting_notifications {
my ($self, @methods) = @_;
my ($file, $line) = (caller)[1,2];
my $at = "at $file line $line\n";
croak "No method specified" unless @methods;
foreach my $fq_meth (@methods) {
view release on metacpan or search on metacpan
lib/BerkeleyDB/Easy/Common.pm view on Meta::CPAN
# specification, generate a BerkeleyDB.pm wrapper function. Otherwise, make
# a simple object accessor.
#
sub _install {
my ($self, $name, $spec) = @_;
my ($pack, $file, $line) = (caller)[0..2];
DEBUG and $self->_debug(qq(Installing method stub: $name));
my $stub = sub {
my $code = $spec
lib/BerkeleyDB/Easy/Common.pm view on Meta::CPAN
# file and line number of our caller, the site of the template definition.
# (Internal method, used by _generate and _accessor)
#
sub _lines {
my $self = shift;
my ($file, $line) = (caller)[1..2];
join qq(# line $line $file(EVAL)\n),
map { (my $ln = $_) =~ s/\s*$/\n/; $ln }
grep $_, @_;
}
view release on metacpan or search on metacpan
lib/Ebig5.pm view on Meta::CPAN
elsif (defined $_[1]) {
return $_[1] . '::' . $name;
}
else {
return (caller)[0] . '::' . $name;
}
}
sub qualify_to_ref ($;$) {
if (defined $_[1]) {
no strict qw(refs);
return \*{ qualify $_[0], $_[1] };
}
else {
no strict qw(refs);
return \*{ qualify $_[0], (caller)[0] };
}
}
}
# P.714 29.2.39. flock
view release on metacpan or search on metacpan
lib/Ebig5hkscs.pm view on Meta::CPAN
elsif (defined $_[1]) {
return $_[1] . '::' . $name;
}
else {
return (caller)[0] . '::' . $name;
}
}
sub qualify_to_ref ($;$) {
if (defined $_[1]) {
no strict qw(refs);
return \*{ qualify $_[0], $_[1] };
}
else {
no strict qw(refs);
return \*{ qualify $_[0], (caller)[0] };
}
}
}
# P.714 29.2.39. flock
view release on metacpan or search on metacpan
lib/BingoX/Carbon.pm view on Meta::CPAN
=cut
sub import {
my $self = shift;
my $myclass = ref($self) || $self;
my $class = (caller)[0];
my @args = @_;
warn "BingoX::Carbon: import: class=$class: @args myclass=$myclass" if ($debug);
## Initialize special content and date field methods
no strict 'refs';
view release on metacpan or search on metacpan
lib/Bitcoin/Crypto/Helpers.pm view on Meta::CPAN
{
my ($msg) = @_;
return if $warned{$msg};
$warned{$msg} = 1;
local @CARP_NOT = ((caller)[0]);
carp($msg);
}
sub pad_hex
{
view release on metacpan or search on metacpan
lib/Bot/BasicBot/CommandBot.pm view on Meta::CPAN
my %command;
my %autocommand;
sub command {
(caller)[0]->declare_command(@_);
}
sub autocommand {
(caller)[0]->declare_autocommand(@_);
}
sub declare_autocommand {
my ($package, $sub) = @_;
$autocommand{$package} = $sub;
lib/Bot/BasicBot/CommandBot.pm view on Meta::CPAN
This can be helpful if you don't want to put all your commands in the same
module - you can declare them all on the same package.
sub import {
my $caller = (caller)[0];
$caller->declare_command(...);
}
=head2 autocommand
view release on metacpan or search on metacpan
lib/Bot/Cobalt/Core/ContextMeta/Ignore.pm view on Meta::CPAN
around add => sub {
my $orig = shift;
my ($self, $context, $mask, $reason, $addedby) = @_;
my ($pkg, $line) = (caller)[0,2];
confess "Missing arguments in ignore add()"
unless defined $context and defined $mask;
$mask = normalize_mask($mask);