view release on metacpan or search on metacpan
lib/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
t/05-cipher.t view on Meta::CPAN
_check_it($ciph1, $ciph2);
}
sub _check_it {
my($ciph1, $ciph2) = @_;
my $line = (caller)[2];
ok($ciph1, "First argument was true from line $line");
ok($ciph2, "Second argument was true from line $line");
my($enc, $dec);
$enc = $ciph1->encrypt(_checkbytes());
$dec = $ciph2->decrypt($enc);
view release on metacpan or search on metacpan
lib/Net/Telnet/Netgear.pm view on Meta::CPAN
my $self = shift;
# If this method is being called from this package and it has '-callparent' as the first arg,
# then execute the implementation of the superclass. This is a work-around, because
# unfortunately $self->SUPER::$method does not work. :(
return $self->SUPER::open (splice @_, 1)
if (caller)[0] eq __PACKAGE__ && @_ > 0 && $_[0] eq -callparent;
# Call our magical method.
_open_method ($self, "open", @_);
}
sub fhopen
lib/Net/Telnet/Netgear.pm view on Meta::CPAN
my $self = shift;
# If this method is being called from this package and it has '-callparent' as the first arg,
# then execute the implementation of the superclass. This is a work-around, because
# unfortunately $self->SUPER::$method does not work. :(
return $self->SUPER::fhopen (splice @_, 1)
if (caller)[0] eq __PACKAGE__ && @_ > 0 && $_[0] eq -callparent;
# Call our magical method.
_open_method ($self, "fhopen", @_);
}
sub apply_netgear_defaults
view release on metacpan or search on metacpan
lib/Netx/WebRadio/Station/Shoutcast.pm view on Meta::CPAN
=cut
sub disconnected {
my $self = shift;
warn "disconnected " . (caller)[0] . " " . (caller)[2] . "\n";
return 0;
}
=head1 BUGS
view release on metacpan or search on metacpan
lib/Nile.pm view on Meta::CPAN
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sub detect_app_path {
my ($self, $script) = @_;
$script ||= (caller)[1];
my ($vol, $dirs, $name) = File::Spec->splitpath(File::Spec->rel2abs($script));
if (-d (my $fulldir = File::Spec->catdir($dirs, $name))) {
$dirs = $fulldir;
view release on metacpan or search on metacpan
lib/Number/Phone/FR.pm view on Meta::CPAN
eval "require $class; 1" or croak "$@\n";
$class->isa(__PACKAGE__) or croak "$class is not a valid class";
}
} else {
#croak "unexpected arguments for import" if @_;
my $pkg = (caller)[0];
croak "$class is private" unless $pkg =~ m/^Number::Phone(?:::|$)/;
$pkg2impl{$pkg} = $class;
}
}
view release on metacpan or search on metacpan
lib/Number/RGB.pm view on Meta::CPAN
our @CARP_NOT = ('Attribute::Handlers', __PACKAGE__);
$Carp::Internal{'attributes'}++; # no idea why doesn't work in @CARP_NOT
sub import {
my $class = shift;
my $caller = (caller)[0];
eval qq[
package $caller;
use Attribute::Handlers;
sub RGB :ATTR(RAWDATA) { goto &$class\::RGB }
package $class;
view release on metacpan or search on metacpan
LL_Array.pm view on Meta::CPAN
$VERSION = '0.1504';
my %exported;
sub import {
my($p, $f, $tr, $P, @e, $renew) = ( shift, (caller)[1], {}, (caller(0))[0] );
for my $sym (@_) {
$tr{$1} = $2, $tr_c .= $1, $rx = qr/[$tr_c]/, next
if $sym =~ /^:(\w)=(\w)$/;
push @e, $sym and next if $sym =~ /^\d/; # Somebody required a Version
my $Sym = $sym; # Some values may be read-only
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
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
lib/OWL/Config.pm view on Meta::CPAN
# imports names into the caller's namespace as global variables;
# adapted from the same method in Config::Simple
sub import_names {
shift;
my $namespace = @_ ? shift : (caller)[0];
return if $namespace eq 'OWL::Config';
no strict 'refs';
no warnings; # avoid "Useless use of a variable..."
while ( my ($key, $value) = each %Config ) {
view release on metacpan or search on metacpan
if ($ok) {
print("ok $id - $name\n");
} else {
print("not ok $id - $name\n");
printf("# Failed test at line %d\n", (caller)[2]);
print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
}
return ($ok);
}
if ($ok) {
print("ok $id - $name\n");
} else {
print("not ok $id - $name\n");
printf("# Failed test at line %d\n", (caller)[2]);
print("# got: $got\n");
print("# expected: $expected\n");
print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
}
if ($ok) {
print("ok $id - $name\n");
} else {
print("not ok $id - $name\n");
printf("# Failed test at line %d\n", (caller)[2]);
print("# got: $got\n");
print("# expected: $expected\n");
print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
}
if ($ok) {
print("ok $id - $name\n");
} else {
print("not ok $id - $name\n");
printf("# Failed test at line %d\n", (caller)[2]);
print("# got: $g_err\n");
print("# expected: $e_err\n");
print(STDERR "# FAIL: $name\n") if (! exists($ENV{'PERL_CORE'}));
}
view release on metacpan or search on metacpan
hax/make_argcheck_ops.c.inc view on Meta::CPAN
#define make_croak_op(message) S_make_croak_op(aTHX_ message)
static OP *S_make_croak_op(pTHX_ SV *message)
{
#if HAVE_PERL_VERSION(5, 22, 0)
sv_catpvs(message, " at %s line %d.\n");
/* die sprintf($message, (caller)[1,2]) */
return op_convert_list(OP_DIE, 0,
op_convert_list(OP_SPRINTF, 0,
op_append_list(OP_LIST,
newSVOP(OP_CONST, 0, message),
newSLICEOP(0,
view release on metacpan or search on metacpan
OpenPlugin/Application.pm view on Meta::CPAN
# CGI.pm. Otherwise, it just passes the request onto OpenPlugin.
sub param {
my $self = shift;
my @params = @_;
if( (caller)[0] eq "CGI::Application" ) {
return $self->SUPER::param->get_incoming( @params );
}
else {
return $self->SUPER::param( @params );
}
OpenPlugin/Application.pm view on Meta::CPAN
# CGI.pm. Otherwise, it just passes the request onto OpenPlugin.
sub header {
my $self = shift;
my @params = @_;
if( (caller)[0] eq "CGI::Application" ) {
return $self->SUPER::httpheader->send_outgoing( @params );
}
else {
return $self->SUPER::httpheader( @params );
}
view release on metacpan or search on metacpan
t/lib/Line/Storage.pm view on Meta::CPAN
my %lines;
sub remember_line {
my ($name) = @_;
die "$name already taken" if $lines{$name};
$lines{$name} = (caller)[2];
return;
}
sub recall_line {
my ($name) = @_;
view release on metacpan or search on metacpan
lib/OurNet/BBS/Utils.pm view on Meta::CPAN
sub locate {
my ($file, $path) = @_;
unless ($path) {
$path = (caller)[0];
$path =~ s|::\w+$||;
}
$path =~ s|::|/|g;
view release on metacpan or search on metacpan
sub ops($) { my $p = shift; my $c = ref $p || $p;
bless $p = {};
use Carp qw(croak);
my $caller = (caller)[0];
my $args = $_[0];
croak "ops takes a hash to pass arguments" unless HASH $args;
foreach (sort keys %$args) {
if (defined $_dflts{$_}) { $p->{$_} = $args->{$_} }
else {
view release on metacpan or search on metacpan
t/data/lib/Myfile.pm view on Meta::CPAN
use strict;
use warnings;
use Cwd;
sub from_caller { Cwd::realpath(_from_caller()) }
sub _from_caller { (caller)[1] }
sub from_file { Cwd::realpath(__FILE__) }
1;
view release on metacpan or search on metacpan
PApp/XML.pm view on Meta::CPAN
my $self = shift;
my $dom = shift;
my $temp = bless {
attr => {@_},
}, PApp::XML::Template::;
my $package = (caller)[0];
$temp->{code} = $temp->_dom2sub($dom, $self, $package);
delete $temp->{attr}{special};
view release on metacpan or search on metacpan
lib/PDF/Boxer/Role/SizePosition.pm view on Meta::CPAN
sub move{
my ($self, $x, $y) = @_;
return if
($self->margin_left && $self->margin_left == $x)
&& ($self->margin_top && $self->margin_top == $y);
warn $self->name." move $x, $y from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_left => $x, margin_top => $y });
}
sub set_width{
my ($self, $arg) = @_;
return if $self->width && $self->width == $arg;
warn $self->name." set width $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ width => $arg });
}
sub set_margin_width{
my ($self, $arg) = @_;
return if $self->margin_width && $self->margin_width == $arg;
warn $self->name." set margin_width $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_width => $arg });
}
sub set_height{
my ($self, $arg) = @_;
return if $self->height && $self->height == $arg;
warn $self->name." set height $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ height => $arg });
}
sub set_margin_height{
my ($self, $arg) = @_;
return if $self->margin_height && $self->margin_height == $arg;
warn $self->name." set margin_height $arg from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_height => $arg });
}
sub set_size{
my ($self, $x, $y) = @_;
return if
($self->width && $self->width == $x)
&& ($self->height && $self->height == $y);
warn $self->name." size $x, $y from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ width => $x, height => $y });
}
sub set_margin_size{
my ($self, $x, $y) = @_;
return if $self->margin_width == $x && $self->margin_height == $y;
warn $self->name." size $x, $y from ".join('-',(caller)[0,2])."\n" if $self->debug && $self->name;
$self->adjust({ margin_width => $x, margin_height => $y });
}
sub child_height_set{};
sub child_width_set{};
view release on metacpan or search on metacpan
# 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
lib/PDL/Demos.pm view on Meta::CPAN
defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
}
sub act($) {
local $SIG{__DIE__} = \&Carp::confess;
actnw($_[0], (caller)[0]);
my $prompt = "---- (press enter)";
defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
}
sub _eval_pkg {
lib/PDL/Demos.pm view on Meta::CPAN
local $SIG{__DIE__} = \&Carp::confess;
my ($script, $pack) = @_;
print "---- Code:";
print $script;
print "---- Output:\n";
_eval_pkg($script, $pack // (caller)[0]);
print "----\n";
print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@;
}
my ($searched, @found);
view release on metacpan or search on metacpan
Basic/SourceFilter/FilterUtilCall.pm view on Meta::CPAN
# and one to an import file.
# --CED 5-Nov-2007
#
sub import {
my ($class) = @_;
($file,$offset) = (caller)[1,2]; # for error reporting
$offset++;
## Parse class name into a regexp suitable for filtration
my $terminator = terminator_regexp($class);
view release on metacpan or search on metacpan
Demos/Screen.pm view on Meta::CPAN
my $script = $_[0];
$script =~ s/^(\s*)output/$1print/mg;
print "---- Code:";
print $script;
print "---- Output:\n";
my $pack = (caller)[0];
# eval "package $pack; use PDLA; $_[0]";
eval "package $pack; use PDLA; $_[0]";
print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@;
my $prompt = "---- (press enter)";
defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
Demos/Screen.pm view on Meta::CPAN
my $script = $_[0];
$script =~ s/^(\s*)output/$1print/mg;
print "---- Code:";
print $script;
print "---- Output:\n";
my $pack = (caller)[0];
# eval "package $pack; use PDLA; $_[0]";
eval "package $pack; use PDLA; $_[0]";
print "----\n";
print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@;
}
view release on metacpan or search on metacpan
Basic/SourceFilter/FilterUtilCall.pm view on Meta::CPAN
# and one to an import file.
# --CED 5-Nov-2007
#
sub import {
my ($class) = @_;
($file,$offset) = (caller)[1,2]; # for error reporting
$offset++;
## Parse class name into a regexp suitable for filtration
my $terminator = terminator_regexp($class);
view release on metacpan or search on metacpan
PGP/Pipe.pm view on Meta::CPAN
$args =~ s/%p/$self->{PGPPATH}/g;
$args =~ s/%r/$self->{PGPPATH}\/$self->{Keyring}/g; # PGP::Keyring
$args =~ s/%k/0x$self->{Keyid}/g; # PGP::Key
# Put the file descriptors in the callers package
$fin = (caller)[0] . "::$in";
$fout = (caller)[0] . "::$out";
$ferr = (caller)[0] . "::$err";
Debug ("PGP::Exec=$self->{PGPexec} $baseopts $args");
# just to make sure that PGPPATH is exported!
$ENV{PGPPATH} = $self->{PGPPATH};
view release on metacpan or search on metacpan
basiclib/Exporter.pm-txt view on Meta::CPAN
goto &heavy_export;
}
sub export_tags {
require Exporter::Heavy;
_push_tags((caller)[0], "EXPORT", \@_);
}
sub export_ok_tags {
require Exporter::Heavy;
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
view release on metacpan or search on metacpan
basiclib/Exporter.pm-txt view on Meta::CPAN
goto &heavy_export;
}
sub export_tags {
require Exporter::Heavy;
_push_tags((caller)[0], "EXPORT", \@_);
}
sub export_ok_tags {
require Exporter::Heavy;
_push_tags((caller)[0], "EXPORT_OK", \@_);
}
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
view release on metacpan or search on metacpan
}
# Sends the headers waiting in %PLP::Script::header
sub sendheaders () {
local $\; # reset print behaviour if triggered by say()
$PLP::sentheaders ||= [ caller 1 ? (caller 1)[1, 2] : (caller)[1, 2] ];
print STDOUT "Content-Type: text/plain\n\n" if $PLP::DEBUG & 2;
while (my ($header, $values) = each %PLP::Script::header) {
print STDOUT "$header: $_\n" for split /\n/, $values;
}
print STDOUT "\n";
view release on metacpan or search on metacpan
lib/PMLTQ/Command.pm view on Meta::CPAN
sub extract_usage {
my $self = shift;
open my $handle, '>', \my $output;
pod2usage( -exitval => 'NOEXIT', -input => (caller)[1], -output => $handle );
$output =~ s/\n$//;
return $output;
}