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
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" }
view release on metacpan or search on metacpan
lib/Devel/Examine/Subs.pm view on Meta::CPAN
? $INC{'Devel/Examine/Subs/Engine.pm'}
: 'lib/Devel/Examine/Subs/Engine.pm';
},
);
my $caller = (caller)[1];
open my $fh, '<', $caller
or confess "can't open the caller file $caller: $!";
my $code_found = 0;
view release on metacpan or search on metacpan
lib/Devel/Leak/Cb.pm view on Meta::CPAN
$LASTNAME = $_[0];
return 1;
}
sub wrapper (&) {
$DEF{int $_[0]} = [ $_[0], (caller)[0..2], $LASTNAME ];
weaken($DEF{int $_[0]}[0]);
subname($DEF{int $_[0]}[1].'::cb.'.$LASTNAME => $_[0]) if $LASTNAME;
$LASTNAME = undef;
return bless $_[0],'__cb__';
}
view release on metacpan or search on metacpan
lib/Devel/MaintBlead.pm view on Meta::CPAN
Thank you for your attention.
SORRY
my $line= (caller)[2];
eval <<"BYEBYE" or print STDERR $@;
#line $line $0
require $REQUIRED;
BYEBYE
exit 1;
view release on metacpan or search on metacpan
Messenger.pm view on Meta::CPAN
chomp($message[$#message]) if (substr($end, -1, 1) eq "\n");
&$output($file, $begin, ($pre ? &$pre(caller) : ''), @message, $end);
};
# export subroutine
if ($global) {
#my $caller = (caller)[0];
foreach my $pkg (sort grep { $_ ne 'Devel/Messenger.pm' } 'main', keys %INC) {
(my $module = $pkg) =~ s/\.pm$//;
$module =~ s/\//::/g;
if (defined(&{"$module\::note"})) {
no strict 'refs';
view release on metacpan or search on metacpan
t/lib/NYTProfTest.pm view on Meta::CPAN
$extra_options = {};
}
# obtain group from file name
my $group;
if ((caller)[1] =~ /([^\/\\]+)\.t$/) {
$group = $1;
} else {
croak "Can't determine test group";
}
view release on metacpan or search on metacpan
t/lib/SizemeTest.pm view on Meta::CPAN
}
push @steps, [ $action, @args ];
}
# obtain group from file name
my $group = ((caller)[1] =~ /([^\/\\]+)\.t$/) ? $1
: croak "Can't determine test group";
# .smt is "SizeMe Token" file
my $smt_file_old = "$group.smt";
my $smt_file_new = "$smt_file_old\-new.smt";
view release on metacpan or search on metacpan
lib/Devel/TraceUse.pm view on Meta::CPAN
CORE::require($arg);
};
}
# initialize the tree of require calls
my $root = (caller)[1];
# keys in %TRACE:
# - ranked: modules load attemps in chronological order
# - loaded_by: track "filename"s loaded by "filepath" (value from %INC)
# - used: track loaded modules by "filename" (parameter to require)
view release on metacpan or search on metacpan
lib/Devel/Trepan/DB/SelfLoader.pm view on Meta::CPAN
$@ = $save;
defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
goto &$AUTOLOAD
}
sub load_stubs { shift->_load_stubs((caller)[0]) }
sub _load_stubs {
# $endlines is used by Devel::SelfStubber to capture lines after __END__
my($self, $callpack, $endlines) = @_;
no strict "refs";
view release on metacpan or search on metacpan
lib/Devel/Util.pm view on Meta::CPAN
sprintf("%dm%.3fs", int($d/60), $d - 60*int($d/60))
};
sub dt (&;$) {
require Time::HiRes;
my $block = shift;
my $name = shift || sprintf 'dt at %s line %d', (caller)[1,2];
my ($t_elapsed_0, $t_elapsed_1, $t_user_0, $t_user_1, $t_sys_0, $t_sys_1);
my @ret;
my $ret;
($t_user_0, $t_sys_0) = times;
view release on metacpan or search on metacpan
lib/Dist/HomeDir.pm view on Meta::CPAN
This module was inspired by Catalyst::Utils->home() to obtain the root
directory for obtaining application code and self-contained support data in
directories relative to the distribution root. It does this by returning a
L<Path::Tiny> object which has a very nice interface. However
Catalyst::Utils->home only works for perl classes. This works for class
files and perl scripts via examining C<(caller)[1]> and thus should
B<never> be used in code that will be instaled via a cpan client or other
package manager.
Sometimes support libaries will also live in the C<t/lib> directory and the
C<script/lib> directory. C<dist_home> will ignore these C<lib> directories