view release on metacpan or search on metacpan
lib/Moo/Role.pm view on Meta::CPAN
while ((my $pack, $file) = caller($lvl++)) {
if ($pack ne __PACKAGE__ && $pack ne 'Role::Tiny' && !$pack->isa($me)) {
last;
}
}
_set_loaded($new_name, $file || (caller)[1]);
return $new_name;
}
sub _gen_apply_defaults_for {
lib/Moo/Role.pm view on Meta::CPAN
sub apply_roles_to_object {
my ($me, $object, @roles) = @_;
my $new = $me->SUPER::apply_roles_to_object($object, @roles);
my $class = ref $new;
_set_loaded($class, (caller)[1]);
if (!exists $APPLY_DEFAULTS{$class}) {
$APPLY_DEFAULTS{$class} = $me->_gen_apply_defaults_for($class, @roles);
}
if (my $apply_defaults = $APPLY_DEFAULTS{$class}) {
view release on metacpan or search on metacpan
lib/MooX/Role/Parameterized.pm view on Meta::CPAN
"unable to apply parameterized role: not an MooX::Role::Parameterized"
if !__PACKAGE__->is_role($role);
$args = [$args] if ref($args) ne ref( [] );
my $target = defined( $extra{target} ) ? $extra{target} : (caller)[0];
if ( exists $INFO{$role}
&& exists $INFO{$role}{code_for}
&& ref $INFO{$role}{code_for} eq "CODE" )
{
lib/MooX/Role/Parameterized.pm view on Meta::CPAN
Moo::Role->apply_roles_to_package( $target, $role );
}
sub role(&) { ##no critic (Subroutines::ProhibitSubroutinePrototypes)
my $package = (caller)[0];
$INFO{$package} ||= { is_role => 1 };
croak "role subroutine called multiple times on '$package'"
if exists $INFO{$package}{code_for};
$INFO{$package}{code_for} = shift;
}
sub parameter {
my $package = (caller)[0];
$INFO{$package} ||= { is_role => 1 };
push @{ $INFO{$package}{parameters_definition} ||= [] }, \@_;
}
lib/MooX/Role/Parameterized.pm view on Meta::CPAN
sub build_apply_roles_to_package {
my ( $klass, $orig ) = @_;
return sub {
my $target = (caller)[0];
while (@_) {
my $role = shift;
eval { use_module($role) };
view release on metacpan or search on metacpan
lib/Class/MOP/Class.pm view on Meta::CPAN
sub make_immutable {
my ( $self, @args ) = @_;
return $self unless $self->is_mutable;
my ($file, $line) = (caller)[1..2];
$self->_initialize_immutable(
file => $file,
line => $line,
$self->_immutable_options(@args),
view release on metacpan or search on metacpan
inc/Class/MOP/Class.pm view on Meta::CPAN
sub make_immutable {
my ( $self, @args ) = @_;
return $self unless $self->is_mutable;
my ($file, $line) = (caller)[1..2];
$self->_initialize_immutable(
file => $file,
line => $line,
$self->_immutable_options(@args),
view release on metacpan or search on metacpan
lib/Mouse/Meta/Module.pm view on Meta::CPAN
my $serial_id = $self->{anon_serial_id};
return if !$serial_id;
# XXX: cleaning stash with threads causes panic/SEGV on legacy perls.
if(exists $INC{'threads.pm'}) {
# (caller)[2] indicates the caller's line number,
# which is zero when the current thread is joining (destroying).
return if( (caller)[2] == 0);
}
# clean up mortal anonymous class stuff
# @ISA is a magical variable, so we must clear it manually.
view release on metacpan or search on metacpan
lib/Mousse.pm view on Meta::CPAN
my $serial_id = $self->{anon_serial_id};
return if !$serial_id;
# XXX: cleaning stash with threads causes panic/SEGV on legacy perls.
if(exists $INC{'threads.pm'}) {
# (caller)[2] indicates the caller's line number,
# which is zero when the current thread is joining (destroying).
return if( (caller)[2] == 0);
}
# clean up mortal anonymous class stuff
# @ISA is a magical variable, so we must clear it manually.
view release on metacpan or search on metacpan
lib/Multi/Dispatch.pm view on Meta::CPAN
my $redispatcher = '$' . join q{}, map { ('a'..'z', 'A'..'Z')[rand 52] } 1..20;
# Enable warnings for this module class...
warnings->import('Multi::Dispatch');
Keyword::Simple::define multi => gen_handler_for('multi', (caller)[0]);
Keyword::Simple::define multimethod => gen_handler_for('multimethod', (caller)[0]);
}
sub _annotate {
my ($package, $file) = @_;
lib/Multi/Dispatch.pm view on Meta::CPAN
my @failures;
</VERBOSE>
<DEBUG>
warn sprintf "\nDispatching call to <NAME>("
. join(', ', map({Data::Dump::dump($_)} @_))
. ") at %s line %s\\n", (caller)[1,2];
</DEBUG>
while (my $variant = shift @variants) {
# Skip variants that can't possibly work...
<VERBOSE>
# Extract the debugging information...
lib/Multi/Dispatch.pm view on Meta::CPAN
<VERBOSE>
if (1 == grep /-->/, @failures) {
die sprintf( "Can't call <NAME>(%s)\\n"
. "at %s line %s\\n",
join(', ', map({Data::Dump::dump($_)} @_)),
(caller)[1,2]), map { s/SKIPPED: //r } grep /-->/, @failures;
}
</VERBOSE>
die sprintf( "No suitable variant for call to <KEYWORD> <NAME>()\\n"
. "with arguments: (%s)\\n"
. "at %s line %s\\n",
join(', ', map({Data::Dump::dump($_)} @_)),
(caller)[1,2]) <VERBOSE>, @failures</VERBOSE>;
} =~ s{ <VERBOSE> (.*?) </VERBOSE> }{ $arg{verbose} ? $1 : q{} }egxmsr
=~ s{ <DEBUG> (.*?) </DEBUG> }{ $arg{debug} ? $1 : q{} }egxmsr
=~ s{ <VARIANT_CODE> }{ $arg{invocant} ? q{$_[0]->${\$variant->{code}}(@_[1..$#_])}
: q{&{$variant->{code}}} }egxmsr
view release on metacpan or search on metacpan
t/Nagios-Monitoring-Plugin-Range.t view on Meta::CPAN
sub test_expected {
my $r = shift;
my $expected = shift;
foreach (sort {$a<=>$b} keys %$expected) {
is $r->check_range($_), $expected->{$_},
" $_ should " . ($expected->{$_} ? 'not ' : '') . "be in the range (line ".(caller)[2].")";
}
}
test_expected( $r, $expected );
view release on metacpan or search on metacpan
inc/Compat.pm view on Meta::CPAN
VERSION
=cut
# Dirty hack so Test::ConsistentVersion passes
sub VERSION {
return (caller)[0] eq 'Test::ConsistentVersion'
? '0.57'
: $VERSION;
}
my %packages = (
view release on metacpan or search on metacpan
MIBLoadOrder.pm view on Meta::CPAN
sub _myprintf {
return unless $DEBUG;
my $_format = shift;
my ($_pkg, $_line) = (caller)[0,2];
my $_func = (caller(1))[3];
$_pkg =~ s/.+://;
$_func =~ s/.+://;
printf("%s: %s: [%s]: $_format", $_pkg, $_func, $_line, @_);
view release on metacpan or search on metacpan
lib/Net/DirectConnect/filelist.pm view on Meta::CPAN
$self->share_add_file( $full, $tth ), $self->share_changed()
if !$self->{'file_recv_filelist'} and !$self->{'no_auto_share_downloaded'}; # unless $self->{'no_auto_share_downloaded'};
#TODO $self->{db}->insert_hash( 'filelist', $f ) if !$self->{no_sql} and $f->{tth};
;
};
$self->filelist_load() unless $standalone; # (caller)[0] ~~ __PACKAGE__;
#$self->log('initok');
return $self;
}
eval q{ #do
use lib '../..';
view release on metacpan or search on metacpan
lib/Net/FullAuto/FA_Core.pm view on Meta::CPAN
"but a cache key is not defined");
}
}
} elsif ((-1==index $caller,'mirror') &&
(-1==index $caller,'login_retry')) {
my $time_out='$' . (caller)[0] . '::timeout';
$time_out= eval $time_out;
if ($@ || $time_out!~/^[1-9]+/) {
$timeout=30;
} else { $timeout=$time_out }
} else { print "FOUR\n";$timeout=30 }
lib/Net/FullAuto/FA_Core.pm view on Meta::CPAN
handle_error("A cache object exists, ".
"but a cache key is not defined");
}
}
} else {
my $tst='$' . (caller)[0] . '::test';
$tst= eval $tst;
$tst||=0;
if ($@ || $tst!~/^[1-9]+/) {
$Net::FullAuto::FA_Core::test=0;
} else { $Net::FullAuto::FA_Core::test=$tst }
lib/Net/FullAuto/FA_Core.pm view on Meta::CPAN
{
if (defined $_[0] && $_[0]=~/^\d+$/) {
$timeout=$_[0];
} else {
my $time_out='$' . (caller)[0] . '::timeout';
$time_out= eval $time_out;
$time_out||=30;
if ($@ || $time_out!~/^[1-9]+/) {
$timeout=30;
} else { $timeout=$time_out }
} $test=0;$prod=0;
###################################
# The following are being set if
# found defined in Term::Menus
my $log_='$' . (caller)[0] . '::log';
$log_= eval $log_;
$log_=0 if $@ || !$log_;
my $tosspass_='$' . (caller)[0] . '::tosspass';
$tosspass_= eval $tosspass_;
$tosspass_=0 if $@ || !$tosspass_;
## end Term::Menus defs ###########
my $fhtimeout='X';
my $fatimeout=$timeout;
my $tst='$' . (caller)[0] . '::test';
$tst=eval $tst;
$test=$tst if !$@ || $tst=~/^[1-9]+/;
my $_connect='connect_ssh_telnet';
if (exists $Hosts{"__Master_${$}__"}{'Local'}) {
my $loc=$Hosts{"__Master_${$}__"}{'Local'};
lib/Net/FullAuto/FA_Core.pm view on Meta::CPAN
}
} else {
@RCM_Link=('ssh','telnet');
$Hosts{"__Master_${$}__"}{'Local'}=$_connect;
}
$email_defaults='%' . (caller)[0] . '::email_defaults';
%email_defaults=eval $email_defaults;
if ($@) {
$email_defaults=0;
%email_defaults=();
} else { $email_defaults=1 }
my $email_addresses='%' . (caller)[0] . '::email_addresses';
%email_addresses=eval $email_addresses;
%email_addresses=() if $@;
my $test_caller=(caller)[0];
$custom_code_module_file='$' . (caller)[0] . '::fa_code';
$custom_code_module_file=eval $custom_code_module_file;
if ($@) {
my $die="Cannot Locate the \"FullAuto Custom Code\" "
."perl module (.pm) file\n < original "
."default name 'fa_code.pm' >\n\n $@";
lib/Net/FullAuto/FA_Core.pm view on Meta::CPAN
$dot=1;
} elsif ($_[1] eq '__dotdot__') {
$dotdot=1;
}
}
my $caller=(caller)[2];
my $hostlabel=$self->{_hostlabel}->[0];
my ($ip,$hostname,$use,$ms_share,$ms_domain,
$cmd_cnct,$ftr_cnct,$login_id,$su_id,$chmod,
$owner,$group,$sdtimeout,$transfer_dir,$uname,
$ping,$password,$proxy,$identityfile,$spawn,
lib/Net/FullAuto/FA_Core.pm view on Meta::CPAN
print "WHAT IS CACHE=$cache\n" if $cache;
print "KEYS=",(join " | ",keys %{$cache}),"\n" if $cache;
#print $Net::FullAuto::FA_Core::LOG "CACHEEEEEEEEEEEEEEEEEEEEEEEEEE=",$cache->{'key'},"\n";
($caller,$cline)=(caller)[1,2];
if (ref $args{DestHost} eq 'ARRAY') {
@dhostlabels=@{$args{DestHost}};
} elsif (4<length $args{DestHost} && unpack('a5',$args{DestHost})
eq 'ARRAY') {
&Net::FullAuto::FA_Core::handle_error(
view release on metacpan or search on metacpan
lib/Net/IEC104.pm view on Meta::CPAN
sub DEBUG {
my $d = shift;
if ( $debug >= $d ) {
print @_;
if ( $d < 0 ) {
printf "<-- at %s:%s", (caller)[ 1, 2 ];
}
unless ( $_[$#_] =~ /\s$/ ) {
print "\n";
}
}
view release on metacpan or search on metacpan
# check for fully qualified name
if ( $fh !~ /'|::/ ) {
print STDDBG "$fh is not fully qualified\n" if $DEBUG;
# get our current package
my $mypkg = (caller)[0];
print STDDBG "We are package $mypkg\n" if $DEBUG;
# search for calling package
my $depth = 1;
my $otherpkg;
view release on metacpan or search on metacpan
lib/Net/MQTT/Simple.pm view on Meta::CPAN
$server or return;
$global = $class->new($server);
no strict 'refs';
*{ (caller)[0] . "::publish" } = \&publish;
*{ (caller)[0] . "::retain" } = \&retain;
*{ (caller)[0] . "::mqtt_get" } = \&get;
}
sub new {
my ($class, $server, $sockopts) = @_;
@_ == 2 or @_ == 3 or _croak "Wrong number of arguments for $class->new";
view release on metacpan or search on metacpan
lib/Net/SC.pm view on Meta::CPAN
local $_;
unless ( exists $self->{ 'CFG_' . uc($section) } ) {
$self->log_error("Use unknown configuration variable : `$section'");
return undef;
} elsif ( uc($section) eq 'CHAIN_DATA' and (caller)[0] ne __PACKAGE__ ) {
#
# íÁÌÅÎØËÁÑ ËÕÞËÁ ÓÏÌÏÍËÉ, ÏÔ ÉÚÍÅÎÅÎÉÑ ÄÁÎÎÙÈ ËÏÎÆÉÇÕÒÁÃÉÏÎÎÏÇÏ ÆÁÊÌÁ...
#
return $self->{ 'CFG_' . uc($section) };
} else {
lib/Net/SC.pm view on Meta::CPAN
#
# syslogd
#
if ( ref $self and $self->configure( 'SYSLOG' ) and $^O !~ /[Ww]in32/ ) {
foreach ( @_ ) {
syslog( 'debug', '%s [ %d ]', $_, (caller)[-1] ) unless /^\s*$/;
}
return 1;
}
#
# ÷ÓÅ ÏÓÔÁÌØÎÏÅ
lib/Net/SC.pm view on Meta::CPAN
if ( ref $self and $self->configure( 'SYSLOG' ) and $^O !~ /[Ww]in32/ ) {
#
# syslogd
#
foreach ( @_ ) {
syslog( 'warning', '%s [ %d ]', $_, (caller)[-1] ) unless /^\s*$/;
}
} elsif ( ref $self and
$self->configure( 'SYSLOG' ) and
defined $self->configure( 'LOG_FH' ) ) {
#
lib/Net/SC.pm view on Meta::CPAN
} elsif ( not defined ( $sym = $self->configure( 'LOG_FH' ) ) ) {
$sym = \*STDERR;
}
my_flock ( $sym, LOCK_EX );
foreach ( @_ ) {
printf $sym "%2.2d/%2.2d %2.2d:%2.2d:%2.2d [ %5.5d : %d ] : %s\n",(localtime(time))[3,4,2,1,0], $$, (caller)[-1], $_ unless /^\s*$/;
}
my_flock ( $sym, LOCK_UN );
}
return 1;
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
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;