view release on metacpan or search on metacpan
lib/Ecyrillic.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/DB/Evented.pm view on Meta::CPAN
for my $method_name ( qw(selectrow_hashref selectcol_arrayref selectall_hashref selectall_arrayref) ) {
no strict 'refs';
*{$method_name} = sub {
my $self = shift;
my ($sql, $key_field, $attr, @args) = (shift, ($method_name eq 'selectall_hashref' ? (shift) : (undef)), shift, @_);
$self->_add_to_queue($sql, $attr, $key_field, @args, $method_name, (caller)[1,2]);
};
}
# TODO: Investigate if this is the bet way to handle this.
# The child processes are technically held by AnyEvent::DBI
view release on metacpan or search on metacpan
t/80proxy.t view on Meta::CPAN
$result;
}
sub Test ($;$) {
my($ok, $msg) = @_;
$msg = ($msg) ? " ($msg)" : "";
my $line = (caller)[2];
++$numTest;
($ok) ? print "ok $numTest at line $line\n" : print "not ok $numTest\n";
warn "# failed test $numTest at line ".(caller)[2]."$msg\n" unless $ok;
++$failed_tests unless $ok;
return $ok;
}
}
view release on metacpan or search on metacpan
lib/DBIx/Class/Helper/ResultSet/IgnoreWantarray.pm view on Meta::CPAN
use parent 'DBIx::Class::ResultSet';
sub search :DBIC_method_is_indirect_sugar{
$_[0]->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense')
if !defined wantarray && (caller)[0] !~ /^\QDBIx::Class::/;
shift->search_rs(@_);
}
1;
view release on metacpan or search on metacpan
lib/DBIx/Class/Schema/Loader.pm view on Meta::CPAN
sub import {
my $self = shift;
return if !@_;
my $cpkg = (caller)[0];
foreach my $opt (@_) {
if($opt =~ m{^dump_to_dir:(.*)$}) {
$self->dump_to_dir($1)
}
view release on metacpan or search on metacpan
lib/DBIx/Class/ResultSet.pm view on Meta::CPAN
# turn may be called in void context due to some braindead
# overload or whatever else the user decided to be clever
# at this particular day. Thus limit the exception to
# external code calls only
$self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense')
if (caller)[0] !~ /^\QDBIx::Class::/;
return ();
}
}
view release on metacpan or search on metacpan
ProcedureCall.pm view on Meta::CPAN
}
sub import {
my $class = shift;
my $caller = (caller)[0];
no strict 'refs';
foreach (@_) {
my ($name, @attr) = split ':';
my @err = grep { not exists $__known_attributes{lc $_} } @attr;
view release on metacpan or search on metacpan
lib/DBIx/Simple.pm view on Meta::CPAN
return shift->{dbh}->last_insert_id(@_);
}
sub disconnect {
my ($self) = @_;
$self->_die(sprintf($err_cause, "$self->disconnect", (caller)[1, 2]));
return 1;
}
sub DESTROY {
my ($self) = @_;
$self->_die(sprintf($err_cause, "$self->DESTROY", (caller)[1, 2]));
}
### public methods wrapping SQL::Abstract
for my $method (qw/select insert update delete/) {
lib/DBIx/Simple.pm view on Meta::CPAN
sub finish {
$_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
my ($self) = @_;
$self->_die(
sprintf($err_cause, "$self->finish", (caller)[1, 2])
);
}
sub DESTROY {
return if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
my ($self) = @_;
$self->_die(
sprintf($err_cause, "$self->DESTROY", (caller)[1, 2])
);
}
1;
view release on metacpan or search on metacpan
lib/DBM/Deep/Storage/File.pm view on Meta::CPAN
if(tell($fh) > $len + 2 ** (8 * $self->{byte_size}) - 1) {
die("DBM::Deep: too much data, try a bigger pack_size\n");
}
if ( DEBUG ) {
my $caller = join ':', (caller)[0,2];
warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
}
print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
lib/DBM/Deep/Storage/File.pm view on Meta::CPAN
if ( defined $loc ) {
seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
}
if ( DEBUG ) {
my $caller = join ':', (caller)[0,2];
warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
}
my $buffer;
read( $fh, $buffer, $size);
view release on metacpan or search on metacpan
lib/Dancer/Plugin/Resource.pm view on Meta::CPAN
my ($resource, %options) = @_;
my $params = ':id';
my ($old_prefix, $parent_prefix);
unless ($options{skip_prepare_serializer} || ((caller)[1] =~ /^(?:t|xt)/)) {
prepare_serializer_for_format;
}
# if this resource is a nested child resource, manage the prefix
$old_prefix = Dancer::App->current->prefix || '';
view release on metacpan or search on metacpan
lib/Dancer.pm view on Meta::CPAN
# private code
# FIXME handle previous usage of load_app with multiple app names
sub _load_app {
my ($app_name, %options) = @_;
my $script = (caller)[1];
Dancer::Logger::core("loading application $app_name");
# set the application
my $app = Dancer::App->set_running_app($app_name);
view release on metacpan or search on metacpan
lib/Dash/Leak.pm view on Meta::CPAN
our %CBS;
sub import{
my $class = shift;
my $caller = caller;
my $cb = shift if @_;
check("use $class from @{[ (caller)[1,2] ]}",$cb ? $cb : ()) if DEBUG;
if (DEBUG and $cb) {
$FIRST ||= $cb;
$CBS{$caller} = $cb;
}
Devel::Declare->setup_for(
view release on metacpan or search on metacpan
lib/DashProfiler/Auto.pm view on Meta::CPAN
croak "DashProfile::Auto doesn't support explicit imports"
if @_;
local $DashProfiler::Import::ExportLevel = $DashProfiler::Import::ExportLevel + 1;
my $caller_file = (caller)[1];
$caller_file =~ s:.*[/\\]::; # delete everything upto and including the last slash or backslash
$class->SUPER::import( auto_profiler => [ $caller_file ] );
}
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
lib/Data/Debug.pm view on Meta::CPAN
} else {
if (! $ENV{'CONTENT_TYPED'}) {
print "Content-Type: $type\r\n\r\n";
$ENV{'CONTENT_TYPED'} = '';
}
$ENV{'CONTENT_TYPED'} .= sprintf("%s, %d\n", (caller)[1,2]);
}
}
sub _html_quote {
my $value = shift;
view release on metacpan or search on metacpan
lib/Data/Domain/SemanticAdapter.pm view on Meta::CPAN
}
# mirror the Data::Semantic::Name namespace classes
sub install_shortcuts {
my %map = @_;
my $call_pkg = (caller)[0];
while (my ($domain, $class) = each %map) {
no strict 'refs';
my $domain_class_name = "Data::Domain::$class";
$domain_class_name->require;
*{"${call_pkg}::${domain}"} = sub { $domain_class_name->new(@_) };
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/Data/FeatureFactory.pm view on Meta::CPAN
use Carp;
use File::Basename;
use Scalar::Util;
our $VERSION = '0.0405';
my $PATH = &{ sub { return dirname( (caller)[1] ) } };
my $OPEN_OPTIONS;
our $CURRENT_FEATURE;
my %KNOWN_FORMATS = map {;$_=>1} qw/binary normal numeric/;
# check if perl can open files in utf8
lib/Data/FeatureFactory.pm view on Meta::CPAN
$self->{'features'} = [];
my %feat_named;
$self->{'feat_named'} = \%feat_named;
my @featkeys;
$self->{'featkeys'} = \@featkeys;
$self->{'caller_path'} = dirname( (caller)[1] );
my %supported_option = ( map {;$_=>1} qw(code default format label name postproc range type values values_file) );
my %accepted_option = ( map {;$_=>1} qw(cat2num cat2num_dyna num2cat num2cat_dyna num_values_fh values_ordered) );
# parse the @features array
view release on metacpan or search on metacpan
Iterator.pm view on Meta::CPAN
($stack, $seen, $context) = ($me->_get_context($context))[0..2];
defined ($stack) ? ($stack ? do {$me->{'stack'} = $stack;
$me->{'_seen'} = $seen;}
: do {my @r = $me->_path (@_);
unless (defined @r) {
warn $me->{'err'}.=sprintf (" at %s line %s", (caller)[1,2])."\n";
return;
}
return wantarray ? @r : $r[1]}
)
: do {warn $me->{'err'}.=sprintf (" at %s line %s", (caller)[1,2])."\n";
return};
$me->{'level'} = $#{$me->{'stack'}};
my @res = $me->_handle_item ($stack, $seen, $me->{'contexts'}, $context);
(@{$me}{'path','val','key','level','vref','ppath','parent'}) = @res;
if ($me->{'err'}) {
warn $me->{'err'} .= sprintf (" at %s line %s", (caller)[1,2])."\n";
}
return wantarray ? (defined ($me->{'key'}) ? (@{$me}{'path','val','key','level','vref','ppath','parent'}) : ())
: (defined ($me->{'key'}) || undef);
}
Iterator.pm view on Meta::CPAN
my $path = defined ($_[0]) ? shift : '';
my @_keys;
$me->{'err'} = undef;
my ($elem, $context) = $me->_get_item ($path);
warn ($me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n") && return
unless defined $elem;
my $stack = [[ $me->_init($elem), '' ]];
my $seen = {};
my $contexts = {};
$seen->{${$stack->[0]}[-2]} = $context;
while ( my $key = ($me->_handle_item ($stack, $seen, $contexts, $context))[0]) {
warn $me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n" if $me->{'err'};
push @_keys, $key;
}
return wantarray ? @_keys : scalar @_keys
}
Iterator.pm view on Meta::CPAN
my $path = defined ($_[0]) ? shift : '';
my @_vals;
$me->{'err'} = undef;
my ($elem, $context) = $me->_get_item ($path);
warn ($me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n") && return
unless defined $elem;
my $stack = [[ $me->_init($elem, length ($path) ? 1 : 0), '' ]];
my $seen = {};
my $contexts = {};
$seen->{${$stack->[0]}[-2]} = $context;
my ($key, $val) ;
while ( ($key, $val) = ($me->_handle_item($stack, $seen, $contexts, $context))[0, 1] ) {
warn $me->{'err'}.sprintf(" at %s line %s", (caller)[1,2])."\n" if $me->{'err'};
push @_vals, $val;
}
return wantarray ? @_vals : scalar @_vals
}
view release on metacpan or search on metacpan
t/ExtUtils/SVDmaker/Test.pm view on Meta::CPAN
local($\, $,); # guard against -l and other things that screw with
# print
_reset_globals();
_read_program( (caller)[1] );
my $max=0;
while (@_) {
my ($k,$v) = splice(@_, 0, 2);
if ($k =~ /^test(s)?$/) { $max = $v; }
view release on metacpan or search on metacpan
lib/Database/Abstraction.pm view on Meta::CPAN
# Read the data into memory or establish a connection to the database file.
# column_names allows the column names to be overridden on CSV files
sub _open
{
if(!UNIVERSAL::isa((caller)[0], __PACKAGE__)) {
Carp::croak('Illegal Operation: This method can only be called by a subclass');
}
my $self = shift;
my $params = Params::Get::get_params(undef, @_);
view release on metacpan or search on metacpan
lib/DateTime/Calendar/Chinese.pm view on Meta::CPAN
my($class, $start, $end) = @_;
if (DEBUG) {
print STDERR
">>>> prior_leap_month\n",
"caller: ", join(':', (caller)[1, 2]), "\n",
"start: ", $start, "\n",
"end: ", $end, "\n",
"<<<<\n";
}
view release on metacpan or search on metacpan
lib/DateTime/Format/Builder.pm view on Meta::CPAN
1;
}
sub import {
my $class = shift;
$class->create_class( @_, class => (caller)[0] ) if @_;
}
sub create_class {
my $class = shift;
my %args = validate(
@_,
{
class => { type => SCALAR, default => (caller)[0] },
version => { type => SCALAR, optional => 1 },
verbose => { type => SCALAR | GLOBREF | GLOB, optional => 1 },
parsers => { type => HASHREF },
groups => { type => HASHREF, optional => 1 },
constructor =>
view release on metacpan or search on metacpan
t/Devel-Arena.t view on Meta::CPAN
> $stats->{PVX}{normal}{total} + $stats->{PVX}{normal}{'length'});
ok($stats->{PVX}{'shared hash key'}{allocated} == 0) if $] >= 5.008;
sub oryx () {
# Our filename
(caller)[1];
}
sub klortho ($@%) {
}
ok($stats->{types}{PVCV}{prototypes}{''}, qr/^\d+$/);
view release on metacpan or search on metacpan
lib/Devel/Caller/Perl.pm view on Meta::CPAN
package Devel::Caller::Perl;
use DB;
$Devel::Caller::Perl::VERSION = '1.4';
sub import {
*{(caller)[0].'::called_args'} = \&called_args
if $_[1] eq 'called_args';
}
sub called_args { &DB::called_args }
1;
view release on metacpan or search on metacpan
t/lib/TestHelper.pm view on Meta::CPAN
}
sub ok_breakpoint {
my %params = @_;
my($file, $from_line) = (caller)[1, 2];
$params{file} = $file unless exists ($params{file});
my $bp_line = $params{line};
my $subtest = sub {
my @bp = Devel::Chitin::Breakpoint->get(%params);
t/lib/TestHelper.pm view on Meta::CPAN
}
};
}
sub ok_at_end {
my $from_line = (caller)[2];
my $test = sub {
context_do {
my $ctx = shift;
$ctx->ok($AT_END, "at_end($from_line)");
t/lib/TestHelper.pm view on Meta::CPAN
push @TEST_QUEUE, $test;
}
sub ok_breakable {
my($file, $line) = @_;
my $from_line = (caller)[2];
my $test = sub {
context_do {
my $ctx = shift;
$ctx->ok( __PACKAGE__->is_breakable($file, $line), "${file}:${line} is breakable");
t/lib/TestHelper.pm view on Meta::CPAN
sub ok_set_action {
my $comment = pop;
my %params = @_;
$params{file} = (caller)[1] unless exists $params{file};
my $test = sub {
context_do {
my $ctx = shift;
$ctx->ok( Devel::Chitin::Action->new(%params), $comment);
t/lib/TestHelper.pm view on Meta::CPAN
sub ok_set_breakpoint {
my $comment = pop;
my %params = @_;
$params{file} = (caller)[1] unless exists $params{file};
my $test = sub {
context_do {
my $ctx = shift;
$ctx->ok( Devel::Chitin::Breakpoint->new(%params), $comment);
view release on metacpan or search on metacpan
t/lib/lib/archive.pm view on Meta::CPAN
sub import {
my $class = shift;
my %cache;
( my $acdir = dirname( rel2abs( (caller)[1] ) ) ) =~ s!\\!/!g;
for my $entry (@_) {
my $is_url = $entry =~ /$is_url/;
my $arcs = $is_url ? _get_url($entry) : _get_files( $entry, $acdir );
for my $arc (@$arcs) {
view release on metacpan or search on metacpan
t/lib/lib/archive.pm view on Meta::CPAN
sub import {
my $class = shift;
my %cache;
( my $acdir = dirname( rel2abs( (caller)[1] ) ) ) =~ s!\\!/!g;
for my $entry (@_) {
my $is_url = $entry =~ /$is_url/;
my $arcs = $is_url ? _get_url($entry) : _get_files( $entry, $acdir );
for my $arc (@$arcs) {
view release on metacpan or search on metacpan
lib/Devel/DebugHooks.pm view on Meta::CPAN
sub emit {
my( $name ) = ( shift );
print $DB::OUT "Emit event '$name' from ", (caller)[1,2], "\n" if DB::state( 'ddd' );
# Get subscribers for the event
my $ev; {
no strict 'refs';
$ev = defined &{ "${name}_info" }