view release on metacpan or search on metacpan
t/runtests_die.t view on Meta::CPAN
package main;
use Test::Builder::Tester tests => 1;
$ENV{TEST_VERBOSE}=0;
my $filename = sub { return (caller)[1] }->();
my $identifier = ($Test::More::VERSION < 0.88) ? 'object' : 'thing';
test_out( qr/not ok 1 - (?:The $identifier|undef) isa '?Object'?\n/);
test_err( "# Failed test ($filename at line 15)");
test_err( "# (in Foo->test_object)" );
view release on metacpan or search on metacpan
lib/Test/Effects.pm view on Meta::CPAN
$expected->{$option} = $NULL_VALUE_FOR{$option};
}
}
# Ensure there's a description...
$desc //= sprintf "Testing effects_ok() at %s line %d", (caller)[1,2];
# Are we echoing this test???
my $is_terse
= exists $expected->{'VERBOSE'} ? !$expected->{'VERBOSE'}
: !$lexical_hint{'Test::Effects::VERBOSE'};
view release on metacpan or search on metacpan
t/lives_and.t view on Meta::CPAN
sub works {return shift};
sub dies { die 'oops' };
my $die_line = __LINE__ - 1;
my $filename = sub { return (caller)[1] }->();
lives_and {is works(42), 42} 'lives_and, no_exception & success';
test_out('not ok 1 - lives_and, no_exception & failure');
test_fail(+3);
view release on metacpan or search on metacpan
lib/Test/Group/Tester.pm view on Meta::CPAN
=cut
sub want_test {
my ($type, $name, @diag) = @_;
my $call_line = (caller)[2];
$type =~ /^(pass|fail|skip)\z/i or croak
"want_test type=[$type], need pass|fail|skip";
$type = lc $1;
lib/Test/Group/Tester.pm view on Meta::CPAN
sub fail_diag {
wantarray or croak "fail_diag needs a list context";
my ($test_name, $from_test_builder, $line, $file) = @_;
$file ||= (caller)[1];
my @diag;
if ($from_test_builder and $ENV{HARNESS_ACTIVE}) {
# Test::Builder adds a blank diag line for a failed test
view release on metacpan or search on metacpan
sub my_open (*@) {
if ($useOrigOpen) {
if ( defined( $_[0] ) ) {
use Symbol qw();
my $handle = Symbol::qualify( $_[0], (caller)[0] );
no strict 'refs';
if ( @_ == 1 ) {
return CORE::open($handle);
}
elsif ( @_ == 2 ) {
view release on metacpan or search on metacpan
lib/Test/Kwalitee.pm view on Meta::CPAN
# this setting is internal and for this distribution only - there is
# no reason for you to need to circumvent this check in any other context.
# Please DO NOT enable this test to run for users, as it can fail
# unexpectedly as parts of the toolchain changes!
unless $ENV{_KWALITEE_NO_WARN} or $ENV{AUTHOR_TESTING} or $ENV{RELEASE_TESTING}
or (caller)[1] =~ m{^(?:\.[/\\])?xt\b}
or ((caller)[0]->isa(__PACKAGE__) and (caller(1))[1] =~ m{^(?:\.[/\\])?xt\b});
my @run_tests = grep { /^[^-]/ } @tests;
my @skip_tests = map { s/^-//; $_ } grep { /^-/ } @tests;
# These don't really work unless you have a tarball, so skip them
view release on metacpan or search on metacpan
lib/Test/Lib.pm view on Meta::CPAN
sub import {
my $class = shift;
my $dir = shift;
if (! defined $dir) {
my $file = File::Spec->rel2abs((caller)[1]);
$dir = File::Spec->catpath((File::Spec->splitpath($file))[0,1], '');
}
for my $i (0..5) {
my $tdir = File::Spec->catdir($dir, (File::Spec->updir) x $i);
my $abs_path = Cwd::abs_path($tdir);
view release on metacpan or search on metacpan
lib/Test/Log/Log4perl.pm view on Meta::CPAN
};
return;
}
sub _cur_filename { (caller)[1] }
1;
package Log::Log4perl::Logger::IgnoreAll;
use base qw(Log::Log4perl::Logger);
view release on metacpan or search on metacpan
lib/Test/Log4perl.pm view on Meta::CPAN
};
return;
}
sub _cur_filename { (caller)[1] }
1;
package Log::Log4perl::Logger::IgnoreAll;
use base qw(Log::Log4perl::Logger);
view release on metacpan or search on metacpan
lib/Test/Modern.pm view on Meta::CPAN
} @_;
push @_, @EXPORT if $symbols == 0;
my $globals = ref($_[0]) eq 'HASH' ? shift() : {};
$globals->{into_file} = (caller)[1] unless ref($globals->{into});
unshift @_, $me, $globals;
goto \&Exporter::Tiny::import;
}
view release on metacpan or search on metacpan
lib/Test/More/Bash.pm view on Meta::CPAN
has test => ();
has bash => ();
sub import {
my $test_file = (caller)[1];
# Allow this generated test to pass:
return if $test_file =~ m{000-compile-modules.t$};
__PACKAGE__->new(
view release on metacpan or search on metacpan
lib/Test/Ratchet.pm view on Meta::CPAN
}
sub clank($) {
my $subref = shift;
my $caller = sprintf "%s, line %s", (caller)[1,2];
my $clank = rec { my $rec = shift; delete $Test::Ratchet::Clank::CLANK{ refaddr $rec }; &$subref };
$Test::Ratchet::Clank::CLANK{refaddr $clank} = $caller;
bless $clank, "Test::Ratchet::Clank";
}
view release on metacpan or search on metacpan
t/Legacy/overload.t view on Meta::CPAN
package main;
local $SIG{__DIE__} = sub {
my($call_file, $call_line) = (caller)[1,2];
fail("SIGDIE accidentally called");
diag("From $call_file at $call_line");
};
my $obj = Overloaded->new('foo', 42);
view release on metacpan or search on metacpan
t/Test/Tech/V001024/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;
for (my $x=0; $x < @_; $x+=2) {
my ($k,$v) = @_[$x,$x+1];
if ($k =~ /^test(s)?$/) { $max = $v; }
view release on metacpan or search on metacpan
t/02parse.t view on Meta::CPAN
{
# Set the global variables
undef $fmt;
undef %data;
$fmt = Text::FixedLengthMultiline->new(@_);
isa_ok($fmt, 'Text::FixedLengthMultiline', 'Line '.(caller)[2]);
return $fmt;
}
# Parse a line and test the result
# 2 tests
sub test_parse()
{
my ($line, $expected_data, $expected_result) = @_;
my $test_name = 'Line ' . ((caller)[2]) . ' parsing result for: '.(defined $line ? "<$line>" : 'undef');
is($fmt->parse_line($line, \%data), $expected_result, $test_name);
is_deeply(\%data, $expected_data, $test_name);
}
&new_fmt(format => [ 'col1' => 6 ]);
view release on metacpan or search on metacpan
t/macrodir.t view on Meta::CPAN
#------------------------------------------------------------------------------
# run one test
sub run_test {
my($opts) = @_;
$opts->{caller_line} = (caller)[2];
# set flags
for ($opts->{-args}) {
$opts->{-verbose} = /-v\b|--verbose\b/ ? 1 : 0;
view release on metacpan or search on metacpan
lib/Text/Md2Inao/Builder/DSL.pm view on Meta::CPAN
use parent qw/Exporter/;
our @EXPORT = qw/case/;
sub case ($&) {
my ($select, $code) = @_;
my $class = (caller)[0];
my $self = $class->new;
for (split ",", $select) {
s/\s+//g;
$self->dispatch_table->{$_} = $code;
}
view release on metacpan or search on metacpan
lib/Text/Reform.pm view on Meta::CPAN
}
elsif (defined wantarray) # CONTEXT BEING CAPTURED
{
$_[0]->{_prev} = { %std_config };
$_[0]->{_used} = 0;
$_[0]->{_line} = join " line ", (caller)[1..2];;
%{$_[0]} = %std_config = (%std_config, %{$_[0]});
fix_config(%std_config);
return bless $_[0], 'FormOpt';
}
else # PERMANENT RESET
{
$_[0]->{_used} = 1;
$_[0]->{_line} = join " line ", (caller)[1..2];;
%std_config = (%std_config, %{$_[0]});
fix_config(%std_config);
return;
}
}
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/Tie/EncryptedHash.pm view on Meta::CPAN
}
sub FETCH # ($self, $key)
{
my ($self, $key) = @_;
my $entry = _access($self,$key,(caller)[0..1]);
return $entry if $entry;
}
sub STORE # ($self, $key, $value)
{
my ($self, $key, $value) = @_;
my $entry = _access($self,$key,(caller)[0..1],$value);
return $entry if $entry;
}
sub DELETE # ($self, $key)
{
my ($self, $key) = @_;
return _access($self,$key,(caller)[0..1],'',1);
}
sub CLEAR # ($self)
{
my ($self) = @_;
lib/Tie/EncryptedHash.pm view on Meta::CPAN
}
sub EXISTS # ($self, $key)
{
my ($self, $key) = @_;
my @context = (caller)[0..1];
return _access($self,$key,@context) ? 1 : '';
}
sub FIRSTKEY # ($self)
{
lib/Tie/EncryptedHash.pm view on Meta::CPAN
}
sub NEXTKEY # ($self)
{
my $self = $_[0]; my $key;
my @context = (caller)[0..1];
while (defined($key = CORE::each %{$self})) {
last if eval { _access($self,$key,@context) }
}
return $key;
}
view release on metacpan or search on metacpan
t/Tie/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
InSecureHash.pm view on Meta::CPAN
}
sub FETCH # ($self, $key)
{
my ($self, $key) = @_;
my $entry = _access($self,$key,(caller)[0..1]);
return $$entry if $entry;
return;
}
sub STORE # ($self, $key, $value)
{
my ($self, $key, $value) = @_;
my $entry = _access($self,$key,(caller)[0..1]);
return $$entry = $value if $entry;
return;
}
sub DELETE # ($self, $key)
{
my ($self, $key) = @_;
return _access($self,$key,(caller)[0..1],'DELETE');
}
sub CLEAR # ($self)
{
my ($self) = @_;
InSecureHash.pm view on Meta::CPAN
}
sub EXISTS # ($self, $key)
{
my ($self, $key) = @_;
my @context = (caller)[0..1];
eval { _access($self,$key,@context); 1 } ? 1 : '';
}
sub FIRSTKEY # ($self)
{
InSecureHash.pm view on Meta::CPAN
sub NEXTKEY # ($self)
{
my $self = $_[0];
my $key;
my @context = (caller)[0..1];
while (defined($key = each %{$self->{fullkeys}}))
{
last if eval { _access($self,$key,@context) };
}
return $key;
view release on metacpan or search on metacpan
lib/Tie/SecureHash.pm view on Meta::CPAN
sub FETCH { # ($self, $key)
my ($self, $key) = @_;
my $entry;
if (! $dangerous) {
$entry = _access($self,$key,(caller)[0..1]);
} elsif ($key =~ /::/) {
$entry = \$self->{fullkeys}->{$key};
} else {
my $caller = (caller)[0];
$entry = $self->_dangerous_access($key, $caller, 'FETCH');
}
return $$entry if $entry;
return;
}
sub STORE { # ($self, $key, $value)
my ($self, $key, $value) = @_;
my $entry;
if (! $dangerous) {
$entry = _access($self,$key,(caller)[0..1]);
} elsif ($key =~ /::/) {
$self->{fullkeys}->{$key} = $value;
$entry = \$self->{fullkeys}->{$key};
} else {
my $caller = (caller)[0];
$entry = $self->_dangerous_access($key,$caller, 'STORE');
}
return $$entry = $value if $entry;
return;
}
sub DELETE { # ($self, $key)
my ($self, $key) = @_;
if (! $dangerous) {
return _access($self,$key,(caller)[0..1],'DELETE');
}
elsif ($key =~ /::/) {
delete $self->{fullkeys}->{$key};
}
else {
my $caller = (caller)[0];
return $self->_dangerous_access($key, $caller, 'DELETE');
}
}
lib/Tie/SecureHash.pm view on Meta::CPAN
sub EXISTS # ($self, $key)
{
my ($self, $key) = @_;
if (! $dangerous) {
my @context = (caller)[0..1];
eval { _access($self,$key,@context); 1 } ? 1 : '';
}
elsif ($key =~ /::/) {
return exists $self->{fullkeys}->{$key};
}
else {
my $caller = (caller)[0];
_complain($self, $key, $caller, 'EXISTS') if $strict;
return exists $self->{fullkeys}->{"$caller::$key"};
}
}
lib/Tie/SecureHash.pm view on Meta::CPAN
my $self = $_[0];
if ($dangerous) {
return CORE::each %{$self->{fullkeys}};
}
my $key;
my @context = (caller)[0..1];
while (defined($key = CORE::each %{$self->{fullkeys}})) {
last if eval { _access($self,$key,@context) };
carp "Attempt to iterate inaccessible key '$key' will be unsafe in 'fast' mode. Use explicit keys" if $ENV{UNSAFE_WARN};
}
view release on metacpan or search on metacpan
lib/Tie/Trace.pm view on Meta::CPAN
my @options = @_;
my $var_name;
eval{
$var_name = PadWalker::var_name(1, $s);
};
my $pkg = defined $var_name ? (caller)[0] : undef;
my $tied_value = tie $s_type eq 'SCALAR' ? $$s : $s_type eq 'ARRAY' ? @$s : %$s, "Tie::Trace", var => $var_name, pkg => $pkg, @options;
local $QUIET = 1;
if($s_type eq 'SCALAR'){
$$s = $s_;
lib/Tie/Trace.pm view on Meta::CPAN
sub SPLICE{
my $self = shift;
my $sz = @{$self->{storage}};
my $off = @_ ? shift : 0;
my $fetchsize = $self->FETCHSIZE;
my $caller_pkg = (caller)[0];
my $func = "";
if($caller_pkg eq "Tie::Trace::Array"){
$func = (caller 1)[3];
$func =~s/^Tie::Trace::Array:://;
}
view release on metacpan or search on metacpan
lib/Time/List/Constant.pm view on Meta::CPAN
use Data::Util qw/install_subroutine/;
sub import {
my ($self, @kinds) = @_;
my $caller = (caller)[0];
install_subroutine( $caller,
DAY => sub{1},
MONTH => sub{2},
WEEK => sub{3},
HOUR => sub{4},
view release on metacpan or search on metacpan
map($params{$_}++,@_,@EXPORT);
if (delete $params{':override'}) {
$class->export('CORE::GLOBAL', keys %params);
}
else {
$class->export((caller)[0], keys %params);
}
}
## Methods ##
view release on metacpan or search on metacpan
lib/Time/Piece/Adaptive.pm view on Meta::CPAN
{
$class->_export ('CORE::GLOBAL', keys %params);
}
else
{
$class->_export((caller)[0], keys %params);
}
}
view release on metacpan or search on metacpan
}
} else {
die "No opttable array ref or getopt hash ref";
}
$self->{'caller'} = (caller)[0];
$self->{'filename'} = delete $a{'-filename'};
$self->{'nosafe'} = delete $a{'-nosafe'};
$self->{'useerrordialog'} = delete $a{'-useerrordialog'};
die "Unrecognized arguments: " . join(" ", %a) if %a;
view release on metacpan or search on metacpan
lib/Tk/TextVi.pm view on Meta::CPAN
$w->{VI_PENDING} = '';
$w->{VI_REPLACE_CHARS} = '';
$w->tagRemove( 'sel', '1.0', 'end' );
# XXX: Hack
if( (caller)[0] eq 'Tk::TextVi' ) {
$w->{VI_FLAGS} |= F_STAT;
}
else {
# TODO: this is broken
$w->Callback( '-statuscommand', $w->{VI_MODE}, $w->{VI_PENDING} );
lib/Tk/TextVi.pm view on Meta::CPAN
die "Tk::TextVi internal state corrupted";
}
# Does the UI need to update?
# XXX: HACK
if( (caller)[0] ne 'Tk::TextVi' ) {
$w->Callback( '-statuscommand',
$w->viMode,
$w->{VI_PENDING} ) if( $w->{VI_FLAGS} & F_STAT );
$w->Callback( '-messagecommand' ) if $w->{VI_FLAGS} & F_MSG ;
$w->Callback( '-errorcommand' ) if $w->{VI_FLAGS} & F_ERR ;
view release on metacpan or search on metacpan
Event/Event/IO.pm view on Meta::CPAN
my ($widget,$file,$mode,$cb) = @_;
my $imode = imode($mode);
unless (ref $file)
{
no strict 'refs';
$file = Symbol::qualify($file,(caller)[0]);
$file = \*{$file};
}
my $obj = tied(*$file);
unless ($obj && $obj->isa('Tk::Event::IO'))
{