require './test.pl';
}
+use warnings;
+no warnings "once";
+
+my $Is_VMS = $^O eq 'VMS';
+
use Carp qw(carp cluck croak confess);
-plan tests => 19;
+BEGIN {
+ plan tests => 56;
-ok 1;
+ # This test must be run at BEGIN time, because code later in this file
+ # sets CORE::GLOBAL::caller
+ ok !exists $CORE::GLOBAL::{caller},
+ "Loading doesn't create CORE::GLOBAL::caller"
+}
{ local $SIG{__WARN__} = sub {
like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' };
ok(1);
# test for caller_info API
-my $eval = "use Carp::Heavy; return Carp::caller_info(0);";
+my $eval = "use Carp; return Carp::caller_info(0);";
my %info = eval($eval);
is($info{sub_name}, "eval '$eval'", 'caller_info API');
-# test for '...::CARP_NOT used only once' warning from Carp::Heavy
+# test for '...::CARP_NOT used only once' warning from Carp
my $warning;
eval {
BEGIN {
- $^W = 1;
local $SIG{__WARN__} =
sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } }
}
package Z;
BEGIN { eval { Carp::croak() } }
};
-ok !$warning, q/'...::CARP_NOT used only once' warning from Carp::Heavy/;
+ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
+
+# Test the location of error messages.
+like(A::short(), qr/^Error at C/, "Short messages skip carped package");
+
+{
+ local @C::ISA = "D";
+ like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
+}
+
+{
+ local @D::ISA = "C";
+ like(A::short(), qr/^Error at B/, "Short messages skip inheritance");
+}
+
+{
+ local @D::ISA = "B";
+ local @B::ISA = "C";
+ like(A::short(), qr/^Error at A/, "Inheritance is transitive");
+}
+
+{
+ local @B::ISA = "D";
+ local @C::ISA = "B";
+ like(A::short(), qr/^Error at A/, "Inheritance is transitive");
+}
+
+{
+ local @C::CARP_NOT = "D";
+ like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
+}
+
+{
+ local @D::CARP_NOT = "C";
+ like(A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT");
+}
+
+{
+ local @D::CARP_NOT = "B";
+ local @B::CARP_NOT = "C";
+ like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
+}
+
+{
+ local @B::CARP_NOT = "D";
+ local @C::CARP_NOT = "B";
+ like(A::short(), qr/^Error at A/, "\@CARP_NOT is transitive");
+}
+
+{
+ local @D::ISA = "C";
+ local @D::CARP_NOT = "B";
+ like(A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance");
+}
+
+{
+ local @D::ISA = "B";
+ local @D::CARP_NOT = "C";
+ like(A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance");
+}
+
+# %Carp::Internal
+{
+ local $Carp::Internal{C} = 1;
+ like(A::short(), qr/^Error at B/, "Short doesn't report Internal");
+}
+
+{
+ local $Carp::Internal{D} = 1;
+ like(A::long(), qr/^Error at C/, "Long doesn't report Internal");
+}
+
+# %Carp::CarpInternal
+{
+ local $Carp::CarpInternal{D} = 1;
+ like(A::short(), qr/^Error at B/
+ , "Short doesn't report calls to CarpInternal");
+}
+{
+ local $Carp::CarpInternal{D} = 1;
+ like(A::long(), qr/^Error at C/, "Long doesn't report CarpInternal");
+}
# tests for global variables
sub x { carp @_ }
main::w(1);
}
}
+
+{
+ local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
+
+ # Check that croak() and confess() don't clobber $!
+ runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
+ stderr => 1);
+
+ is($?>>8, 42, 'croak() doesn\'t clobber $!');
+
+ runperl(prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
+ stderr => 1);
+
+ is($?>>8, 42, 'confess() doesn\'t clobber $!');
+}
+
+# undef used to be incorrectly reported as the string "undef"
+sub cluck_undef {
+
+local $SIG{__WARN__} = sub {
+ like $_[0], qr/^Bang! at.+\b(?i:carp\.t) line \d+\n\tmain::cluck_undef\(0, 'undef', 2, undef, 4\) called at.+\b(?i:carp\.t) line \d+$/, "cluck doesn't quote undef" };
+
+cluck "Bang!"
+
+}
+
+cluck_undef (0, "undef", 2, undef, 4);
+
+# check that Carp respects CORE::GLOBAL::caller override after Carp
+# has been compiled
+for my $bodge_job (2, 1, 0) {
+ print '# ', ($bodge_job ? 'Not ' : ''), "setting \@DB::args in caller override\n";
+ if ($bodge_job == 1) {
+ require B;
+ print "# required B\n";
+ }
+ my $accum = '';
+ local *CORE::GLOBAL::caller = sub {
+ local *__ANON__="fakecaller";
+ my @c=CORE::caller(@_);
+ $c[0] ||= 'undef';
+ $accum .= "@c[0..3]\n";
+ if (!$bodge_job && CORE::caller() eq 'DB') {
+ package DB;
+ return CORE::caller(($_[0]||0)+1);
+ } else {
+ return CORE::caller(($_[0]||0)+1);
+ }
+ };
+ eval "scalar caller()";
+ like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in eval");
+ $accum = '';
+ my $got = A::long(42);
+ like( $accum, qr/main::fakecaller/, "test CORE::GLOBAL::caller override in Carp");
+ my $package = 'A';
+ my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
+ my $warning = $bodge_job ?
+ "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E"
+ : '';
+ for (0..2) {
+ my $previous_package = $package;
+ ++$package;
+ like( $got, qr/${package}::long\($warning\) called at $previous_package line 7/, "Correct arguments for $package" );
+ }
+ my $arg = $bodge_job ? $warning : 42;
+ like( $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
+ 'Correct arguments for A' );
+}
+
+eval <<'EOT';
+no warnings 'redefine';
+sub CORE::GLOBAL::caller {
+ my $height = $_[0];
+ $height++;
+ return CORE::caller($height);
+}
+EOT
+
+my $got = A::long(42);
+
+like( $got, qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
+ 'Correct arguments for A' );
+
+# New tests go here
+
+# line 1 "A"
+package A;
+sub short {
+ B::short();
+}
+
+sub long {
+ B::long();
+}
+
+# line 1 "B"
+package B;
+sub short {
+ C::short();
+}
+
+sub long {
+ C::long();
+}
+
+# line 1 "C"
+package C;
+sub short {
+ D::short();
+}
+
+sub long {
+ D::long();
+}
+
+# line 1 "D"
+package D;
+sub short {
+ eval{ Carp::croak("Error") };
+ return $@;
+}
+
+sub long {
+ eval{ Carp::confess("Error") };
+ return $@;
+}
+
+# Put new tests at "new tests go here"
+__END__
https://perl5.git.perl.org / perl5.git / blobdiff