1#!/usr/bin/env perl
2use strict;
3use warnings;
4use Test::More tests => 15;
5
6use Carp;
7
8{
9    my $sub = eval <<'EVAL';
10package Die;
11sub {
12#line 1 foo
13    die "blah";
14}
15EVAL
16    ok(!$@);
17    eval { $sub->() };
18    like($@, qr/^blah at foo line 1/);
19    {
20        no strict 'refs';
21        delete ${'::'}{'Die::'};
22    }
23    eval { $sub->() };
24    like($@, qr/^blah at foo line 1/);
25}
26
27{
28    my $sub = eval <<'EVAL';
29package Confess;
30sub {
31#line 1 foo
32    Carp::confess("blah");
33}
34EVAL
35    ok(!$@);
36    eval { $sub->() };
37    like($@, qr/^blah at foo line 1/);
38    {
39        no strict 'refs';
40        delete ${'::'}{'Confess::'};
41    }
42    eval { $sub->() };
43    like($@, qr/^blah at foo line 1/);
44}
45
46{
47    my $sub = eval <<'EVAL';
48package CroakHelper;
49sub x {
50    Carp::croak("blah");
51}
52package Croak;
53sub {
54#line 1 foo
55    CroakHelper::x();
56}
57EVAL
58    ok(!$@);
59    eval { $sub->() };
60    like($@, qr/^blah at foo line 1/);
61    {
62        no strict 'refs';
63        delete ${'::'}{'Croak::'};
64    }
65    eval { $sub->() };
66    like($@, qr/^blah at foo line 1/);
67    {
68        no strict 'refs';
69        delete ${'::'}{'CroakHelper::'};
70    }
71    eval { $sub->() };
72    like($@, qr/^blah at foo line 1/);
73}
74
75{
76    # the amount of information available and how it is displayed varies quite
77    # a bit depending on the version of perl (specifically, what caller returns
78    # in that version), so there is a bit of fiddling around required to handle
79    # that
80    my $unknown_pat = qr/__ANON__::/;
81    $unknown_pat = qr/$unknown_pat|\(unknown\)/
82        if $] < 5.014;
83
84    my $sub = eval <<'EVAL';
85package SubHelper;
86sub x {
87    Carp::confess("blah");
88}
89package Sub;
90sub {
91#line 1 foo
92    SubHelper::x();
93}
94EVAL
95    ok(!$@);
96    eval { $sub->() };
97    unlike($@, qr/$unknown_pat/);
98    {
99        no strict 'refs';
100        delete ${'::'}{'Sub::'};
101    }
102    eval { $sub->() };
103    like($@, qr/$unknown_pat|Sub::/);
104    unlike($@, qr/$unknown_pat.*$unknown_pat/s);
105    {
106        no strict 'refs';
107        delete ${'::'}{'SubHelper::'};
108    }
109    eval { $sub->() };
110    like($@, qr/(?:$unknown_pat|SubHelper::).*(?:$unknown_pat|Sub::)/s);
111}
112