| Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/5.13.5/Fatal.pm |
| Statements | Executed 455 statements in 5.60ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 2 | 1 | 1 | 1.46ms | 2.21ms | Fatal::_make_fatal |
| 1 | 1 | 1 | 1.18ms | 2.68ms | Fatal::BEGIN@7 |
| 5 | 1 | 1 | 138µs | 138µs | Fatal::_one_invocation |
| 2 | 1 | 1 | 122µs | 265µs | Fatal::_write_invocation |
| 2 | 1 | 1 | 113µs | 152µs | Fatal::fill_protos |
| 1 | 1 | 1 | 106µs | 2.33ms | Fatal::import |
| 2 | 1 | 1 | 81µs | 81µs | Fatal::_install_subs |
| 21 | 6 | 1 | 37µs | 37µs | Fatal::CORE:subst (opcode) |
| 18 | 6 | 1 | 30µs | 30µs | Fatal::CORE:match (opcode) |
| 1 | 1 | 1 | 30µs | 30µs | Fatal::BEGIN@3 |
| 1 | 1 | 1 | 19µs | 77µs | Fatal::BEGIN@27 |
| 1 | 1 | 1 | 15µs | 19µs | Fatal::BEGIN@385 |
| 1 | 1 | 1 | 14µs | 90µs | Fatal::BEGIN@10 |
| 1 | 1 | 1 | 13µs | 18µs | Fatal::BEGIN@5 |
| 1 | 1 | 1 | 13µs | 84µs | Fatal::BEGIN@4 |
| 1 | 1 | 1 | 12µs | 36µs | Fatal::BEGIN@1096 |
| 1 | 1 | 1 | 12µs | 38µs | Fatal::BEGIN@364 |
| 1 | 1 | 1 | 12µs | 34µs | Fatal::BEGIN@8 |
| 1 | 1 | 1 | 11µs | 70µs | Fatal::BEGIN@13 |
| 1 | 1 | 1 | 11µs | 67µs | Fatal::BEGIN@40 |
| 1 | 1 | 1 | 11µs | 16µs | Fatal::BEGIN@369 |
| 1 | 1 | 1 | 11µs | 20µs | Fatal::BEGIN@6 |
| 1 | 1 | 1 | 10µs | 68µs | Fatal::BEGIN@25 |
| 1 | 1 | 1 | 10µs | 65µs | Fatal::BEGIN@16 |
| 1 | 1 | 1 | 10µs | 66µs | Fatal::BEGIN@17 |
| 1 | 1 | 1 | 10µs | 65µs | Fatal::BEGIN@14 |
| 1 | 1 | 1 | 10µs | 65µs | Fatal::BEGIN@12 |
| 1 | 1 | 1 | 10µs | 76µs | Fatal::BEGIN@21 |
| 1 | 1 | 1 | 10µs | 65µs | Fatal::BEGIN@18 |
| 1 | 1 | 1 | 10µs | 71µs | Fatal::BEGIN@33 |
| 1 | 1 | 1 | 10µs | 66µs | Fatal::BEGIN@19 |
| 1 | 1 | 1 | 10µs | 69µs | Fatal::BEGIN@23 |
| 1 | 1 | 1 | 9µs | 67µs | Fatal::BEGIN@29 |
| 1 | 1 | 1 | 9µs | 65µs | Fatal::BEGIN@35 |
| 1 | 1 | 1 | 9µs | 67µs | Fatal::BEGIN@22 |
| 1 | 1 | 1 | 9µs | 66µs | Fatal::BEGIN@31 |
| 1 | 1 | 1 | 9µs | 65µs | Fatal::BEGIN@20 |
| 1 | 1 | 1 | 9µs | 9µs | autodie::Scope::Guard::new |
| 0 | 0 | 0 | 0s | 0s | Fatal::__ANON__[:324] |
| 0 | 0 | 0 | 0s | 0s | Fatal::_autocroak |
| 0 | 0 | 0 | 0s | 0s | Fatal::_expand_tag |
| 0 | 0 | 0 | 0s | 0s | Fatal::exception_class |
| 0 | 0 | 0 | 0s | 0s | Fatal::one_invocation |
| 0 | 0 | 0 | 0s | 0s | Fatal::throw |
| 0 | 0 | 0 | 0s | 0s | Fatal::unimport |
| 0 | 0 | 0 | 0s | 0s | Fatal::write_invocation |
| 0 | 0 | 0 | 0s | 0s | autodie::Scope::Guard::DESTROY |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Fatal; | ||||
| 2 | |||||
| 3 | 2 | 35µs | 1 | 30µs | # spent 30µs within Fatal::BEGIN@3 which was called:
# once (30µs+0s) by autodie::BEGIN@6 at line 3 # spent 30µs making 1 call to Fatal::BEGIN@3 |
| 4 | 2 | 30µs | 2 | 155µs | # spent 84µs (13+71) within Fatal::BEGIN@4 which was called:
# once (13µs+71µs) by autodie::BEGIN@6 at line 4 # spent 84µs making 1 call to Fatal::BEGIN@4
# spent 71µs making 1 call to Exporter::import |
| 5 | 2 | 24µs | 2 | 23µs | # spent 18µs (13+5) within Fatal::BEGIN@5 which was called:
# once (13µs+5µs) by autodie::BEGIN@6 at line 5 # spent 18µs making 1 call to Fatal::BEGIN@5
# spent 5µs making 1 call to strict::import |
| 6 | 2 | 23µs | 2 | 29µs | # spent 20µs (11+9) within Fatal::BEGIN@6 which was called:
# once (11µs+9µs) by autodie::BEGIN@6 at line 6 # spent 20µs making 1 call to Fatal::BEGIN@6
# spent 9µs making 1 call to warnings::import |
| 7 | 2 | 158µs | 1 | 2.68ms | # spent 2.68ms (1.18+1.50) within Fatal::BEGIN@7 which was called:
# once (1.18ms+1.50ms) by autodie::BEGIN@6 at line 7 # spent 2.68ms making 1 call to Fatal::BEGIN@7 |
| 8 | 2 | 32µs | 2 | 56µs | # spent 34µs (12+22) within Fatal::BEGIN@8 which was called:
# once (12µs+22µs) by autodie::BEGIN@6 at line 8 # spent 34µs making 1 call to Fatal::BEGIN@8
# spent 22µs making 1 call to Config::import |
| 9 | |||||
| 10 | 2 | 32µs | 2 | 166µs | # spent 90µs (14+76) within Fatal::BEGIN@10 which was called:
# once (14µs+76µs) by autodie::BEGIN@6 at line 10 # spent 90µs making 1 call to Fatal::BEGIN@10
# spent 76µs making 1 call to constant::import |
| 11 | |||||
| 12 | 2 | 29µs | 2 | 120µs | # spent 65µs (10+55) within Fatal::BEGIN@12 which was called:
# once (10µs+55µs) by autodie::BEGIN@6 at line 12 # spent 65µs making 1 call to Fatal::BEGIN@12
# spent 55µs making 1 call to constant::import |
| 13 | 2 | 28µs | 2 | 128µs | # spent 70µs (11+58) within Fatal::BEGIN@13 which was called:
# once (11µs+58µs) by autodie::BEGIN@6 at line 13 # spent 70µs making 1 call to Fatal::BEGIN@13
# spent 58µs making 1 call to constant::import |
| 14 | 2 | 28µs | 2 | 120µs | # spent 65µs (10+55) within Fatal::BEGIN@14 which was called:
# once (10µs+55µs) by autodie::BEGIN@6 at line 14 # spent 65µs making 1 call to Fatal::BEGIN@14
# spent 55µs making 1 call to constant::import |
| 15 | |||||
| 16 | 2 | 40µs | 2 | 119µs | # spent 65µs (10+54) within Fatal::BEGIN@16 which was called:
# once (10µs+54µs) by autodie::BEGIN@6 at line 16 # spent 65µs making 1 call to Fatal::BEGIN@16
# spent 54µs making 1 call to constant::import |
| 17 | 2 | 33µs | 2 | 123µs | # spent 66µs (10+56) within Fatal::BEGIN@17 which was called:
# once (10µs+56µs) by autodie::BEGIN@6 at line 17 # spent 66µs making 1 call to Fatal::BEGIN@17
# spent 56µs making 1 call to constant::import |
| 18 | 2 | 33µs | 2 | 121µs | # spent 65µs (10+56) within Fatal::BEGIN@18 which was called:
# once (10µs+56µs) by autodie::BEGIN@6 at line 18 # spent 65µs making 1 call to Fatal::BEGIN@18
# spent 56µs making 1 call to constant::import |
| 19 | 2 | 26µs | 2 | 122µs | # spent 66µs (10+56) within Fatal::BEGIN@19 which was called:
# once (10µs+56µs) by autodie::BEGIN@6 at line 19 # spent 66µs making 1 call to Fatal::BEGIN@19
# spent 56µs making 1 call to constant::import |
| 20 | 2 | 26µs | 2 | 121µs | # spent 65µs (9+56) within Fatal::BEGIN@20 which was called:
# once (9µs+56µs) by autodie::BEGIN@6 at line 20 # spent 65µs making 1 call to Fatal::BEGIN@20
# spent 56µs making 1 call to constant::import |
| 21 | 2 | 32µs | 2 | 142µs | # spent 76µs (10+66) within Fatal::BEGIN@21 which was called:
# once (10µs+66µs) by autodie::BEGIN@6 at line 21 # spent 76µs making 1 call to Fatal::BEGIN@21
# spent 66µs making 1 call to constant::import |
| 22 | 2 | 32µs | 2 | 125µs | # spent 67µs (9+58) within Fatal::BEGIN@22 which was called:
# once (9µs+58µs) by autodie::BEGIN@6 at line 22 # spent 67µs making 1 call to Fatal::BEGIN@22
# spent 58µs making 1 call to constant::import |
| 23 | 2 | 27µs | 2 | 129µs | # spent 69µs (10+60) within Fatal::BEGIN@23 which was called:
# once (10µs+60µs) by autodie::BEGIN@6 at line 23 # spent 69µs making 1 call to Fatal::BEGIN@23
# spent 60µs making 1 call to constant::import |
| 24 | |||||
| 25 | 2 | 36µs | 2 | 126µs | # spent 68µs (10+58) within Fatal::BEGIN@25 which was called:
# once (10µs+58µs) by autodie::BEGIN@6 at line 25 # spent 68µs making 1 call to Fatal::BEGIN@25
# spent 58µs making 1 call to constant::import |
| 26 | |||||
| 27 | 2 | 28µs | 2 | 134µs | # spent 77µs (19+58) within Fatal::BEGIN@27 which was called:
# once (19µs+58µs) by autodie::BEGIN@6 at line 27 # spent 77µs making 1 call to Fatal::BEGIN@27
# spent 58µs making 1 call to constant::import |
| 28 | |||||
| 29 | 2 | 26µs | 2 | 124µs | # spent 67µs (9+57) within Fatal::BEGIN@29 which was called:
# once (9µs+57µs) by autodie::BEGIN@6 at line 29 # spent 67µs making 1 call to Fatal::BEGIN@29
# spent 57µs making 1 call to constant::import |
| 30 | |||||
| 31 | 2 | 27µs | 2 | 122µs | # spent 66µs (9+56) within Fatal::BEGIN@31 which was called:
# once (9µs+56µs) by autodie::BEGIN@6 at line 31 # spent 66µs making 1 call to Fatal::BEGIN@31
# spent 56µs making 1 call to constant::import |
| 32 | |||||
| 33 | 2 | 29µs | 2 | 131µs | # spent 71µs (10+61) within Fatal::BEGIN@33 which was called:
# once (10µs+61µs) by autodie::BEGIN@6 at line 33 # spent 71µs making 1 call to Fatal::BEGIN@33
# spent 61µs making 1 call to constant::import |
| 34 | |||||
| 35 | 2 | 32µs | 2 | 120µs | # spent 65µs (9+55) within Fatal::BEGIN@35 which was called:
# once (9µs+55µs) by autodie::BEGIN@6 at line 35 # spent 65µs making 1 call to Fatal::BEGIN@35
# spent 55µs making 1 call to constant::import |
| 36 | |||||
| 37 | # Older versions of IPC::System::Simple don't support all the | ||||
| 38 | # features we need. | ||||
| 39 | |||||
| 40 | 2 | 731µs | 2 | 123µs | # spent 67µs (11+56) within Fatal::BEGIN@40 which was called:
# once (11µs+56µs) by autodie::BEGIN@6 at line 40 # spent 67µs making 1 call to Fatal::BEGIN@40
# spent 56µs making 1 call to constant::import |
| 41 | |||||
| 42 | # All the Fatal/autodie modules share the same version number. | ||||
| 43 | 1 | 1µs | our $VERSION = '2.10'; | ||
| 44 | |||||
| 45 | 1 | 1µs | our $Debug ||= 0; | ||
| 46 | |||||
| 47 | # EWOULDBLOCK values for systems that don't supply their own. | ||||
| 48 | # Even though this is defined with our, that's to help our | ||||
| 49 | # test code. Please don't rely upon this variable existing in | ||||
| 50 | # the future. | ||||
| 51 | |||||
| 52 | 1 | 3µs | our %_EWOULDBLOCK = ( | ||
| 53 | MSWin32 => 33, | ||||
| 54 | ); | ||||
| 55 | |||||
| 56 | # the linux parisc port has separate EAGAIN and EWOULDBLOCK, | ||||
| 57 | # and the kernel returns EAGAIN | ||||
| 58 | 1 | 17µs | 2 | 11µs | my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; # spent 7µs making 1 call to Config::FETCH
# spent 4µs making 1 call to Fatal::CORE:match |
| 59 | |||||
| 60 | # We have some tags that can be passed in for use with import. | ||||
| 61 | # These are all assumed to be CORE:: | ||||
| 62 | |||||
| 63 | 1 | 29µs | my %TAGS = ( | ||
| 64 | ':io' => [qw(:dbm :file :filesys :ipc :socket | ||||
| 65 | read seek sysread syswrite sysseek )], | ||||
| 66 | ':dbm' => [qw(dbmopen dbmclose)], | ||||
| 67 | ':file' => [qw(open close flock sysopen fcntl fileno binmode | ||||
| 68 | ioctl truncate chmod)], | ||||
| 69 | ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir | ||||
| 70 | symlink rmdir readlink umask)], | ||||
| 71 | ':ipc' => [qw(:msg :semaphore :shm pipe)], | ||||
| 72 | ':msg' => [qw(msgctl msgget msgrcv msgsnd)], | ||||
| 73 | ':threads' => [qw(fork)], | ||||
| 74 | ':semaphore'=>[qw(semctl semget semop)], | ||||
| 75 | ':shm' => [qw(shmctl shmget shmread)], | ||||
| 76 | ':system' => [qw(system exec)], | ||||
| 77 | |||||
| 78 | # Can we use qw(getpeername getsockname)? What do they do on failure? | ||||
| 79 | # TODO - Can socket return false? | ||||
| 80 | ':socket' => [qw(accept bind connect getsockopt listen recv send | ||||
| 81 | setsockopt shutdown socketpair)], | ||||
| 82 | |||||
| 83 | # Our defaults don't include system(), because it depends upon | ||||
| 84 | # an optional module, and it breaks the exotic form. | ||||
| 85 | # | ||||
| 86 | # This *may* change in the future. I'd love IPC::System::Simple | ||||
| 87 | # to be a dependency rather than a recommendation, and hence for | ||||
| 88 | # system() to be autodying by default. | ||||
| 89 | |||||
| 90 | ':default' => [qw(:io :threads)], | ||||
| 91 | |||||
| 92 | # Everything in v2.07 and brefore. This was :default less chmod. | ||||
| 93 | ':v207' => [qw(:threads :dbm :filesys :ipc :socket read seek sysread | ||||
| 94 | syswrite sysseek open close flock sysopen fcntl fileno | ||||
| 95 | binmode ioctl truncate)], | ||||
| 96 | |||||
| 97 | # Version specific tags. These allow someone to specify | ||||
| 98 | # use autodie qw(:1.994) and know exactly what they'll get. | ||||
| 99 | |||||
| 100 | ':1.994' => [qw(:v207)], | ||||
| 101 | ':1.995' => [qw(:v207)], | ||||
| 102 | ':1.996' => [qw(:v207)], | ||||
| 103 | ':1.997' => [qw(:v207)], | ||||
| 104 | ':1.998' => [qw(:v207)], | ||||
| 105 | ':1.999' => [qw(:v207)], | ||||
| 106 | ':1.999_01' => [qw(:v207)], | ||||
| 107 | ':2.00' => [qw(:v207)], | ||||
| 108 | ':2.01' => [qw(:v207)], | ||||
| 109 | ':2.02' => [qw(:v207)], | ||||
| 110 | ':2.03' => [qw(:v207)], | ||||
| 111 | ':2.04' => [qw(:v207)], | ||||
| 112 | ':2.05' => [qw(:v207)], | ||||
| 113 | ':2.06' => [qw(:v207)], | ||||
| 114 | ':2.06_01' => [qw(:v207)], | ||||
| 115 | ':2.07' => [qw(:v207)], # Last release without chmod | ||||
| 116 | ':2.08' => [qw(:default)], | ||||
| 117 | ':2.09' => [qw(:default)], | ||||
| 118 | ':2.10' => [qw(:default)], | ||||
| 119 | ); | ||||
| 120 | |||||
| 121 | # chmod was only introduced in 2.07 | ||||
| 122 | |||||
| 123 | 1 | 11µs | $TAGS{':all'} = [ keys %TAGS ]; | ||
| 124 | |||||
| 125 | # This hash contains subroutines for which we should | ||||
| 126 | # subroutine() // die() rather than subroutine() || die() | ||||
| 127 | |||||
| 128 | 1 | 1µs | my %Use_defined_or; | ||
| 129 | |||||
| 130 | # CORE::open returns undef on failure. It can legitimately return | ||||
| 131 | # 0 on success, eg: open(my $fh, '-|') || exec(...); | ||||
| 132 | |||||
| 133 | 1 | 5µs | @Use_defined_or{qw( | ||
| 134 | CORE::fork | ||||
| 135 | CORE::recv | ||||
| 136 | CORE::send | ||||
| 137 | CORE::open | ||||
| 138 | CORE::fileno | ||||
| 139 | CORE::read | ||||
| 140 | CORE::readlink | ||||
| 141 | CORE::sysread | ||||
| 142 | CORE::syswrite | ||||
| 143 | CORE::sysseek | ||||
| 144 | CORE::umask | ||||
| 145 | )} = (); | ||||
| 146 | |||||
| 147 | # Cached_fatalised_sub caches the various versions of our | ||||
| 148 | # fatalised subs as they're produced. This means we don't | ||||
| 149 | # have to build our own replacement of CORE::open and friends | ||||
| 150 | # for every single package that wants to use them. | ||||
| 151 | |||||
| 152 | 1 | 1µs | my %Cached_fatalised_sub = (); | ||
| 153 | |||||
| 154 | # Every time we're called with package scope, we record the subroutine | ||||
| 155 | # (including package or CORE::) in %Package_Fatal. This allows us | ||||
| 156 | # to detect illegal combinations of autodie and Fatal, and makes sure | ||||
| 157 | # we don't accidently make a Fatal function autodying (which isn't | ||||
| 158 | # very useful). | ||||
| 159 | |||||
| 160 | 1 | 1µs | my %Package_Fatal = (); | ||
| 161 | |||||
| 162 | # The first time we're called with a user-sub, we cache it here. | ||||
| 163 | # In the case of a "no autodie ..." we put back the cached copy. | ||||
| 164 | |||||
| 165 | 1 | 1µs | my %Original_user_sub = (); | ||
| 166 | |||||
| 167 | # Is_fatalised_sub simply records a big map of fatalised subroutine | ||||
| 168 | # refs. It means we can avoid repeating work, or fatalising something | ||||
| 169 | # we've already processed. | ||||
| 170 | |||||
| 171 | 1 | 800ns | my %Is_fatalised_sub = (); | ||
| 172 | 1 | 7µs | 1 | 17µs | tie %Is_fatalised_sub, 'Tie::RefHash'; # spent 17µs making 1 call to Tie::RefHash::TIEHASH |
| 173 | |||||
| 174 | # We use our package in a few hash-keys. Having it in a scalar is | ||||
| 175 | # convenient. The "guard $PACKAGE" string is used as a key when | ||||
| 176 | # setting up lexical guards. | ||||
| 177 | |||||
| 178 | 1 | 1µs | my $PACKAGE = __PACKAGE__; | ||
| 179 | 1 | 2µs | my $PACKAGE_GUARD = "guard $PACKAGE"; | ||
| 180 | 1 | 1µs | my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' | ||
| 181 | |||||
| 182 | # Here's where all the magic happens when someone write 'use Fatal' | ||||
| 183 | # or 'use autodie'. | ||||
| 184 | |||||
| 185 | # spent 2.33ms (106µs+2.22) within Fatal::import which was called:
# once (106µs+2.22ms) by Hailo::BEGIN@4 at line 58 of autodie.pm | ||||
| 186 | 15 | 32µs | my $class = shift(@_); | ||
| 187 | my @original_args = @_; | ||||
| 188 | my $void = 0; | ||||
| 189 | my $lexical = 0; | ||||
| 190 | my $insist_hints = 0; | ||||
| 191 | |||||
| 192 | my ($pkg, $filename) = caller(); | ||||
| 193 | |||||
| 194 | @_ or return; # 'use Fatal' is a no-op. | ||||
| 195 | |||||
| 196 | # If we see the :lexical flag, then _all_ arguments are | ||||
| 197 | # changed lexically | ||||
| 198 | |||||
| 199 | 4 | 5µs | if ($_[0] eq LEXICAL_TAG) { | ||
| 200 | $lexical = 1; | ||||
| 201 | shift @_; | ||||
| 202 | |||||
| 203 | # If we see no arguments and :lexical, we assume they | ||||
| 204 | # wanted ':default'. | ||||
| 205 | |||||
| 206 | if (@_ == 0) { | ||||
| 207 | push(@_, ':default'); | ||||
| 208 | } | ||||
| 209 | |||||
| 210 | # Don't allow :lexical with :void, it's needlessly confusing. | ||||
| 211 | if ( grep { $_ eq VOID_TAG } @_ ) { | ||||
| 212 | croak(ERROR_VOID_LEX); | ||||
| 213 | } | ||||
| 214 | } | ||||
| 215 | |||||
| 216 | if ( grep { $_ eq LEXICAL_TAG } @_ ) { | ||||
| 217 | # If we see the lexical tag as the non-first argument, complain. | ||||
| 218 | croak(ERROR_LEX_FIRST); | ||||
| 219 | } | ||||
| 220 | |||||
| 221 | my @fatalise_these = @_; | ||||
| 222 | |||||
| 223 | # Thiese subs will get unloaded at the end of lexical scope. | ||||
| 224 | my %unload_later; | ||||
| 225 | |||||
| 226 | # This hash helps us track if we've alredy done work. | ||||
| 227 | my %done_this; | ||||
| 228 | |||||
| 229 | # NB: we're using while/shift rather than foreach, since | ||||
| 230 | # we'll be modifying the array as we walk through it. | ||||
| 231 | |||||
| 232 | 2 | 5µs | while (my $func = shift @fatalise_these) { | ||
| 233 | |||||
| 234 | 20 | 51µs | if ($func eq VOID_TAG) { | ||
| 235 | |||||
| 236 | # When we see :void, set the void flag. | ||||
| 237 | $void = 1; | ||||
| 238 | |||||
| 239 | } elsif ($func eq INSIST_TAG) { | ||||
| 240 | |||||
| 241 | $insist_hints = 1; | ||||
| 242 | |||||
| 243 | } elsif (exists $TAGS{$func}) { | ||||
| 244 | |||||
| 245 | # When it's a tag, expand it. | ||||
| 246 | push(@fatalise_these, @{ $TAGS{$func} }); | ||||
| 247 | |||||
| 248 | } else { | ||||
| 249 | |||||
| 250 | # Otherwise, fatalise it. | ||||
| 251 | |||||
| 252 | # Check to see if there's an insist flag at the front. | ||||
| 253 | # If so, remove it, and insist we have hints for this sub. | ||||
| 254 | my $insist_this; | ||||
| 255 | |||||
| 256 | 2 | 3µs | if ($func =~ s/^!//) { # spent 3µs making 2 calls to Fatal::CORE:subst, avg 2µs/call | ||
| 257 | $insist_this = 1; | ||||
| 258 | } | ||||
| 259 | |||||
| 260 | # TODO: Even if we've already fatalised, we should | ||||
| 261 | # check we've done it with hints (if $insist_hints). | ||||
| 262 | |||||
| 263 | # If we've already made something fatal this call, | ||||
| 264 | # then don't do it twice. | ||||
| 265 | |||||
| 266 | next if $done_this{$func}; | ||||
| 267 | |||||
| 268 | # We're going to make a subroutine fatalistic. | ||||
| 269 | # However if we're being invoked with 'use Fatal qw(x)' | ||||
| 270 | # and we've already been called with 'no autodie qw(x)' | ||||
| 271 | # in the same scope, we consider this to be an error. | ||||
| 272 | # Mixing Fatal and autodie effects was considered to be | ||||
| 273 | # needlessly confusing on p5p. | ||||
| 274 | |||||
| 275 | my $sub = $func; | ||||
| 276 | 2 | 3µs | $sub = "${pkg}::$sub" unless $sub =~ /::/; # spent 3µs making 2 calls to Fatal::CORE:match, avg 1µs/call | ||
| 277 | |||||
| 278 | # If we're being called as Fatal, and we've previously | ||||
| 279 | # had a 'no X' in scope for the subroutine, then complain | ||||
| 280 | # bitterly. | ||||
| 281 | |||||
| 282 | if (! $lexical and $^H{$NO_PACKAGE}{$sub}) { | ||||
| 283 | croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func)); | ||||
| 284 | } | ||||
| 285 | |||||
| 286 | # We're not being used in a confusing way, so make | ||||
| 287 | # the sub fatal. Note that _make_fatal returns the | ||||
| 288 | # old (original) version of the sub, or undef for | ||||
| 289 | # built-ins. | ||||
| 290 | |||||
| 291 | 2 | 2.21ms | my $sub_ref = $class->_make_fatal( # spent 2.21ms making 2 calls to Fatal::_make_fatal, avg 1.10ms/call | ||
| 292 | $func, $pkg, $void, $lexical, $filename, | ||||
| 293 | ( $insist_this || $insist_hints ) | ||||
| 294 | ); | ||||
| 295 | |||||
| 296 | $done_this{$func}++; | ||||
| 297 | |||||
| 298 | $Original_user_sub{$sub} ||= $sub_ref; | ||||
| 299 | |||||
| 300 | # If we're making lexical changes, we need to arrange | ||||
| 301 | # for them to be cleaned at the end of our scope, so | ||||
| 302 | # record them here. | ||||
| 303 | |||||
| 304 | $unload_later{$func} = $sub_ref if $lexical; | ||||
| 305 | } | ||||
| 306 | } | ||||
| 307 | |||||
| 308 | 3 | 17µs | if ($lexical) { | ||
| 309 | |||||
| 310 | # Dark magic to have autodie work under 5.8 | ||||
| 311 | # Copied from namespace::clean, that copied it from | ||||
| 312 | # autobox, that found it on an ancient scroll written | ||||
| 313 | # in blood. | ||||
| 314 | |||||
| 315 | # This magic bit causes %^H to be lexically scoped. | ||||
| 316 | |||||
| 317 | $^H |= 0x020000; | ||||
| 318 | |||||
| 319 | # Our package guard gets invoked when we leave our lexical | ||||
| 320 | # scope. | ||||
| 321 | |||||
| 322 | push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub { | ||||
| 323 | $class->_install_subs($pkg, \%unload_later); | ||||
| 324 | 1 | 9µs | })); # spent 9µs making 1 call to autodie::Scope::Guard::new | ||
| 325 | |||||
| 326 | # To allow others to determine when autodie was in scope, | ||||
| 327 | # and with what arguments, we also set a %^H hint which | ||||
| 328 | # is how we were called. | ||||
| 329 | |||||
| 330 | # This feature should be considered EXPERIMENTAL, and | ||||
| 331 | # may change without notice. Please e-mail pjf@cpan.org | ||||
| 332 | # if you're actually using it. | ||||
| 333 | |||||
| 334 | $^H{autodie} = "$PACKAGE @original_args"; | ||||
| 335 | |||||
| 336 | } | ||||
| 337 | |||||
| 338 | return; | ||||
| 339 | |||||
| 340 | } | ||||
| 341 | |||||
| 342 | # The code here is originally lifted from namespace::clean, | ||||
| 343 | # by Robert "phaylon" Sedlacek. | ||||
| 344 | # | ||||
| 345 | # It's been redesigned after feedback from ikegami on perlmonks. | ||||
| 346 | # See http://perlmonks.org/?node_id=693338 . Ikegami rocks. | ||||
| 347 | # | ||||
| 348 | # Given a package, and hash of (subname => subref) pairs, | ||||
| 349 | # we install the given subroutines into the package. If | ||||
| 350 | # a subref is undef, the subroutine is removed. Otherwise | ||||
| 351 | # it replaces any existing subs which were already there. | ||||
| 352 | |||||
| 353 | # spent 81µs within Fatal::_install_subs which was called 2 times, avg 40µs/call:
# 2 times (81µs+0s) by Fatal::_make_fatal at line 1198, avg 40µs/call | ||||
| 354 | 8 | 30µs | my ($class, $pkg, $subs_to_reinstate) = @_; | ||
| 355 | |||||
| 356 | my $pkg_sym = "${pkg}::"; | ||||
| 357 | |||||
| 358 | 10 | 24µs | while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) { | ||
| 359 | |||||
| 360 | my $full_path = $pkg_sym.$sub_name; | ||||
| 361 | |||||
| 362 | # Copy symbols across to temp area. | ||||
| 363 | |||||
| 364 | 2 | 36µs | 2 | 63µs | # spent 38µs (12+26) within Fatal::BEGIN@364 which was called:
# once (12µs+26µs) by autodie::BEGIN@6 at line 364 # spent 38µs making 1 call to Fatal::BEGIN@364
# spent 26µs making 1 call to strict::unimport |
| 365 | |||||
| 366 | local *__tmp = *{ $full_path }; | ||||
| 367 | |||||
| 368 | # Nuke the old glob. | ||||
| 369 | 4 | 69µs | 2 | 20µs | # spent 16µs (11+5) within Fatal::BEGIN@369 which was called:
# once (11µs+5µs) by autodie::BEGIN@6 at line 369 # spent 16µs making 1 call to Fatal::BEGIN@369
# spent 5µs making 1 call to strict::unimport |
| 370 | |||||
| 371 | # Copy innocent bystanders back. Note that we lose | ||||
| 372 | # formats; it seems that Perl versions up to 5.10.0 | ||||
| 373 | # have a bug which causes copying formats to end up in | ||||
| 374 | # the scalar slot. Thanks to Ben Morrow for spotting this. | ||||
| 375 | |||||
| 376 | foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) { | ||||
| 377 | 10 | 23µs | next unless defined *__tmp{ $slot }; | ||
| 378 | *{ $full_path } = *__tmp{ $slot }; | ||||
| 379 | } | ||||
| 380 | |||||
| 381 | # Put back the old sub (if there was one). | ||||
| 382 | |||||
| 383 | 2 | 4µs | if ($sub_ref) { | ||
| 384 | |||||
| 385 | 2 | 1.90ms | 2 | 24µs | # spent 19µs (15+5) within Fatal::BEGIN@385 which was called:
# once (15µs+5µs) by autodie::BEGIN@6 at line 385 # spent 19µs making 1 call to Fatal::BEGIN@385
# spent 5µs making 1 call to strict::unimport |
| 386 | *{ $pkg_sym . $sub_name } = $sub_ref; | ||||
| 387 | } | ||||
| 388 | } | ||||
| 389 | |||||
| 390 | return; | ||||
| 391 | } | ||||
| 392 | |||||
| 393 | sub unimport { | ||||
| 394 | my $class = shift; | ||||
| 395 | |||||
| 396 | # Calling "no Fatal" must start with ":lexical" | ||||
| 397 | if ($_[0] ne LEXICAL_TAG) { | ||||
| 398 | croak(sprintf(ERROR_NO_LEX,$class)); | ||||
| 399 | } | ||||
| 400 | |||||
| 401 | shift @_; # Remove :lexical | ||||
| 402 | |||||
| 403 | my $pkg = (caller)[0]; | ||||
| 404 | |||||
| 405 | # If we've been called with arguments, then the developer | ||||
| 406 | # has explicitly stated 'no autodie qw(blah)', | ||||
| 407 | # in which case, we disable Fatalistic behaviour for 'blah'. | ||||
| 408 | |||||
| 409 | my @unimport_these = @_ ? @_ : ':all'; | ||||
| 410 | |||||
| 411 | while (my $symbol = shift @unimport_these) { | ||||
| 412 | |||||
| 413 | if ($symbol =~ /^:/) { | ||||
| 414 | |||||
| 415 | # Looks like a tag! Expand it! | ||||
| 416 | push(@unimport_these, @{ $TAGS{$symbol} }); | ||||
| 417 | |||||
| 418 | next; | ||||
| 419 | } | ||||
| 420 | |||||
| 421 | my $sub = $symbol; | ||||
| 422 | $sub = "${pkg}::$sub" unless $sub =~ /::/; | ||||
| 423 | |||||
| 424 | # If 'blah' was already enabled with Fatal (which has package | ||||
| 425 | # scope) then, this is considered an error. | ||||
| 426 | |||||
| 427 | if (exists $Package_Fatal{$sub}) { | ||||
| 428 | croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol)); | ||||
| 429 | } | ||||
| 430 | |||||
| 431 | # Record 'no autodie qw($sub)' as being in effect. | ||||
| 432 | # This is to catch conflicting semantics elsewhere | ||||
| 433 | # (eg, mixing Fatal with no autodie) | ||||
| 434 | |||||
| 435 | $^H{$NO_PACKAGE}{$sub} = 1; | ||||
| 436 | |||||
| 437 | if (my $original_sub = $Original_user_sub{$sub}) { | ||||
| 438 | # Hey, we've got an original one of these, put it back. | ||||
| 439 | $class->_install_subs($pkg, { $symbol => $original_sub }); | ||||
| 440 | next; | ||||
| 441 | } | ||||
| 442 | |||||
| 443 | # We don't have an original copy of the sub, on the assumption | ||||
| 444 | # it's core (or doesn't exist), we'll just nuke it. | ||||
| 445 | |||||
| 446 | $class->_install_subs($pkg,{ $symbol => undef }); | ||||
| 447 | |||||
| 448 | } | ||||
| 449 | |||||
| 450 | return; | ||||
| 451 | |||||
| 452 | } | ||||
| 453 | |||||
| 454 | # TODO - This is rather terribly inefficient right now. | ||||
| 455 | |||||
| 456 | # NB: Perl::Critic's dump-autodie-tag-contents depends upon this | ||||
| 457 | # continuing to work. | ||||
| 458 | |||||
| 459 | { | ||||
| 460 | 2 | 3µs | my %tag_cache; | ||
| 461 | |||||
| 462 | sub _expand_tag { | ||||
| 463 | my ($class, $tag) = @_; | ||||
| 464 | |||||
| 465 | if (my $cached = $tag_cache{$tag}) { | ||||
| 466 | return $cached; | ||||
| 467 | } | ||||
| 468 | |||||
| 469 | if (not exists $TAGS{$tag}) { | ||||
| 470 | croak "Invalid exception class $tag"; | ||||
| 471 | } | ||||
| 472 | |||||
| 473 | my @to_process = @{$TAGS{$tag}}; | ||||
| 474 | |||||
| 475 | my @taglist = (); | ||||
| 476 | |||||
| 477 | while (my $item = shift @to_process) { | ||||
| 478 | if ($item =~ /^:/) { | ||||
| 479 | # Expand :tags | ||||
| 480 | push(@to_process, @{$TAGS{$item}} ); | ||||
| 481 | } | ||||
| 482 | else { | ||||
| 483 | push(@taglist, "CORE::$item"); | ||||
| 484 | } | ||||
| 485 | } | ||||
| 486 | |||||
| 487 | $tag_cache{$tag} = \@taglist; | ||||
| 488 | |||||
| 489 | return \@taglist; | ||||
| 490 | |||||
| 491 | } | ||||
| 492 | |||||
| 493 | } | ||||
| 494 | |||||
| 495 | # This code is from the original Fatal. It scares me. | ||||
| 496 | # It is 100% compatible with the 5.10.0 Fatal module, right down | ||||
| 497 | # to the scary 'XXXX' comment. ;) | ||||
| 498 | |||||
| 499 | # spent 152µs (113+39) within Fatal::fill_protos which was called 2 times, avg 76µs/call:
# 2 times (113µs+39µs) by Fatal::_make_fatal at line 1081, avg 76µs/call | ||||
| 500 | 10 | 32µs | my $proto = shift; | ||
| 501 | my ($n, $isref, @out, @out1, $seen_semi) = -1; | ||||
| 502 | 7 | 11µs | while ($proto =~ /\S/) { # spent 11µs making 7 calls to Fatal::CORE:match, avg 2µs/call | ||
| 503 | 29 | 122µs | $n++; | ||
| 504 | push(@out1,[$n,@out]) if $seen_semi; | ||||
| 505 | 6 | 7µs | push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; # spent 7µs making 6 calls to Fatal::CORE:subst, avg 1µs/call | ||
| 506 | 6 | 10µs | push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//; # spent 10µs making 6 calls to Fatal::CORE:subst, avg 2µs/call | ||
| 507 | 3 | 7µs | push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; # spent 7µs making 3 calls to Fatal::CORE:subst, avg 2µs/call | ||
| 508 | 2 | 4µs | $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? # spent 4µs making 2 calls to Fatal::CORE:subst, avg 2µs/call | ||
| 509 | die "Internal error: Unknown prototype letters: \"$proto\""; | ||||
| 510 | } | ||||
| 511 | push(@out1,[$n+1,@out]); | ||||
| 512 | return @out1; | ||||
| 513 | } | ||||
| 514 | |||||
| 515 | # This is a backwards compatible version of _write_invocation. It's | ||||
| 516 | # recommended you don't use it. | ||||
| 517 | |||||
| 518 | sub write_invocation { | ||||
| 519 | my ($core, $call, $name, $void, @args) = @_; | ||||
| 520 | |||||
| 521 | return Fatal->_write_invocation( | ||||
| 522 | $core, $call, $name, $void, | ||||
| 523 | 0, # Lexical flag | ||||
| 524 | undef, # Sub, unused in legacy mode | ||||
| 525 | undef, # Subref, unused in legacy mode. | ||||
| 526 | @args | ||||
| 527 | ); | ||||
| 528 | } | ||||
| 529 | |||||
| 530 | # This version of _write_invocation is used internally. It's not | ||||
| 531 | # recommended you call it from external code, as the interface WILL | ||||
| 532 | # change in the future. | ||||
| 533 | |||||
| 534 | # spent 265µs (122+144) within Fatal::_write_invocation which was called 2 times, avg 133µs/call:
# 2 times (122µs+144µs) by Fatal::_make_fatal at line 1082, avg 133µs/call | ||||
| 535 | |||||
| 536 | 4 | 8µs | my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_; | ||
| 537 | |||||
| 538 | 10 | 30µs | if (@argvs == 1) { # No optional arguments | ||
| 539 | |||||
| 540 | my @argv = @{$argvs[0]}; | ||||
| 541 | shift @argv; | ||||
| 542 | |||||
| 543 | return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); | ||||
| 544 | |||||
| 545 | } else { | ||||
| 546 | my $else = "\t"; | ||||
| 547 | my (@out, @argv, $n); | ||||
| 548 | while (@argvs) { | ||||
| 549 | 35 | 87µs | @argv = @{shift @argvs}; | ||
| 550 | $n = shift @argv; | ||||
| 551 | |||||
| 552 | my $condition = "\@_ == $n"; | ||||
| 553 | |||||
| 554 | 4 | 6µs | if (@argv and $argv[-1] =~ /#_/) { # spent 6µs making 4 calls to Fatal::CORE:match, avg 2µs/call | ||
| 555 | # This argv ends with '@' in the prototype, so it matches | ||||
| 556 | # any number of args >= the number of expressions in the | ||||
| 557 | # argv. | ||||
| 558 | $condition = "\@_ >= $n"; | ||||
| 559 | } | ||||
| 560 | |||||
| 561 | push @out, "${else}if ($condition) {\n"; | ||||
| 562 | |||||
| 563 | $else = "\t} els"; | ||||
| 564 | |||||
| 565 | 5 | 138µs | push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); # spent 138µs making 5 calls to Fatal::_one_invocation, avg 28µs/call | ||
| 566 | } | ||||
| 567 | push @out, qq[ | ||||
| 568 | } | ||||
| 569 | die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments"; | ||||
| 570 | ]; | ||||
| 571 | |||||
| 572 | return join '', @out; | ||||
| 573 | } | ||||
| 574 | } | ||||
| 575 | |||||
| 576 | |||||
| 577 | # This is a slim interface to ensure backward compatibility with | ||||
| 578 | # anyone doing very foolish things with old versions of Fatal. | ||||
| 579 | |||||
| 580 | sub one_invocation { | ||||
| 581 | my ($core, $call, $name, $void, @argv) = @_; | ||||
| 582 | |||||
| 583 | return Fatal->_one_invocation( | ||||
| 584 | $core, $call, $name, $void, | ||||
| 585 | undef, # Sub. Unused in back-compat mode. | ||||
| 586 | 1, # Back-compat flag | ||||
| 587 | undef, # Subref, unused in back-compat mode. | ||||
| 588 | @argv | ||||
| 589 | ); | ||||
| 590 | |||||
| 591 | } | ||||
| 592 | |||||
| 593 | # This is the internal interface that generates code. | ||||
| 594 | # NOTE: This interface WILL change in the future. Please do not | ||||
| 595 | # call this subroutine directly. | ||||
| 596 | |||||
| 597 | # TODO: Whatever's calling this code has already looked up hints. Pass | ||||
| 598 | # them in, rather than look them up a second time. | ||||
| 599 | |||||
| 600 | # spent 138µs within Fatal::_one_invocation which was called 5 times, avg 28µs/call:
# 5 times (138µs+0s) by Fatal::_write_invocation at line 565, avg 28µs/call | ||||
| 601 | 85 | 135µs | my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_; | ||
| 602 | |||||
| 603 | |||||
| 604 | # If someone is calling us directly (a child class perhaps?) then | ||||
| 605 | # they could try to mix void without enabling backwards | ||||
| 606 | # compatibility. We just don't support this at all, so we gripe | ||||
| 607 | # about it rather than doing something unwise. | ||||
| 608 | |||||
| 609 | if ($void and not $back_compat) { | ||||
| 610 | Carp::confess("Internal error: :void mode not supported with $class"); | ||||
| 611 | } | ||||
| 612 | |||||
| 613 | # @argv only contains the results of the in-built prototype | ||||
| 614 | # function, and is therefore safe to interpolate in the | ||||
| 615 | # code generators below. | ||||
| 616 | |||||
| 617 | # TODO - The following clobbers context, but that's what the | ||||
| 618 | # old Fatal did. Do we care? | ||||
| 619 | |||||
| 620 | if ($back_compat) { | ||||
| 621 | |||||
| 622 | # Use Fatal qw(system) will never be supported. It generated | ||||
| 623 | # a compile-time error with legacy Fatal, and there's no reason | ||||
| 624 | # to support it when autodie does a better job. | ||||
| 625 | |||||
| 626 | if ($call eq 'CORE::system') { | ||||
| 627 | return q{ | ||||
| 628 | croak("UNIMPLEMENTED: use Fatal qw(system) not supported."); | ||||
| 629 | }; | ||||
| 630 | } | ||||
| 631 | |||||
| 632 | local $" = ', '; | ||||
| 633 | |||||
| 634 | if ($void) { | ||||
| 635 | return qq/return (defined wantarray)?$call(@argv): | ||||
| 636 | $call(@argv) || Carp::croak("Can't $name(\@_)/ . | ||||
| 637 | ($core ? ': $!' : ', \$! is \"$!\"') . '")' | ||||
| 638 | } else { | ||||
| 639 | return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . | ||||
| 640 | ($core ? ': $!' : ', \$! is \"$!\"') . '")'; | ||||
| 641 | } | ||||
| 642 | } | ||||
| 643 | |||||
| 644 | # The name of our original function is: | ||||
| 645 | # $call if the function is CORE | ||||
| 646 | # $sub if our function is non-CORE | ||||
| 647 | |||||
| 648 | # The reason for this is that $call is what we're actualling | ||||
| 649 | # calling. For our core functions, this is always | ||||
| 650 | # CORE::something. However for user-defined subs, we're about to | ||||
| 651 | # replace whatever it is that we're calling; as such, we actually | ||||
| 652 | # calling a subroutine ref. | ||||
| 653 | |||||
| 654 | my $human_sub_name = $core ? $call : $sub; | ||||
| 655 | |||||
| 656 | # Should we be testing to see if our result is defined, or | ||||
| 657 | # just true? | ||||
| 658 | |||||
| 659 | my $use_defined_or; | ||||
| 660 | |||||
| 661 | my $hints; # All user-sub hints, including list hints. | ||||
| 662 | |||||
| 663 | if ( $core ) { | ||||
| 664 | |||||
| 665 | # Core hints are built into autodie. | ||||
| 666 | |||||
| 667 | $use_defined_or = exists ( $Use_defined_or{$call} ); | ||||
| 668 | |||||
| 669 | } | ||||
| 670 | else { | ||||
| 671 | |||||
| 672 | # User sub hints are looked up using autodie::hints, | ||||
| 673 | # since users may wish to add their own hints. | ||||
| 674 | |||||
| 675 | require autodie::hints; | ||||
| 676 | |||||
| 677 | $hints = autodie::hints->get_hints_for( $sref ); | ||||
| 678 | |||||
| 679 | # We'll look up the sub's fullname. This means we | ||||
| 680 | # get better reports of where it came from in our | ||||
| 681 | # error messages, rather than what imported it. | ||||
| 682 | |||||
| 683 | $human_sub_name = autodie::hints->sub_fullname( $sref ); | ||||
| 684 | |||||
| 685 | } | ||||
| 686 | |||||
| 687 | # Checks for special core subs. | ||||
| 688 | |||||
| 689 | if ($call eq 'CORE::system') { | ||||
| 690 | |||||
| 691 | # Leverage IPC::System::Simple if we're making an autodying | ||||
| 692 | # system. | ||||
| 693 | |||||
| 694 | local $" = ", "; | ||||
| 695 | |||||
| 696 | # We need to stash $@ into $E, rather than using | ||||
| 697 | # local $@ for the whole sub. If we don't then | ||||
| 698 | # any exceptions from internal errors in autodie/Fatal | ||||
| 699 | # will mysteriously disappear before propogating | ||||
| 700 | # upwards. | ||||
| 701 | |||||
| 702 | return qq{ | ||||
| 703 | my \$retval; | ||||
| 704 | my \$E; | ||||
| 705 | |||||
| 706 | |||||
| 707 | { | ||||
| 708 | local \$@; | ||||
| 709 | |||||
| 710 | eval { | ||||
| 711 | \$retval = IPC::System::Simple::system(@argv); | ||||
| 712 | }; | ||||
| 713 | |||||
| 714 | \$E = \$@; | ||||
| 715 | } | ||||
| 716 | |||||
| 717 | if (\$E) { | ||||
| 718 | |||||
| 719 | # TODO - This can't be overridden in child | ||||
| 720 | # classes! | ||||
| 721 | |||||
| 722 | die autodie::exception::system->new( | ||||
| 723 | function => q{CORE::system}, args => [ @argv ], | ||||
| 724 | message => "\$E", errno => \$!, | ||||
| 725 | ); | ||||
| 726 | } | ||||
| 727 | |||||
| 728 | return \$retval; | ||||
| 729 | }; | ||||
| 730 | |||||
| 731 | } | ||||
| 732 | |||||
| 733 | local $" = ', '; | ||||
| 734 | |||||
| 735 | # If we're going to throw an exception, here's the code to use. | ||||
| 736 | my $die = qq{ | ||||
| 737 | die $class->throw( | ||||
| 738 | function => q{$human_sub_name}, args => [ @argv ], | ||||
| 739 | pragma => q{$class}, errno => \$!, | ||||
| 740 | context => \$context, return => \$retval, | ||||
| 741 | eval_error => \$@ | ||||
| 742 | ) | ||||
| 743 | }; | ||||
| 744 | |||||
| 745 | if ($call eq 'CORE::flock') { | ||||
| 746 | |||||
| 747 | # flock needs special treatment. When it fails with | ||||
| 748 | # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just | ||||
| 749 | # means we couldn't get the lock right now. | ||||
| 750 | |||||
| 751 | require POSIX; # For POSIX::EWOULDBLOCK | ||||
| 752 | |||||
| 753 | local $@; # Don't blat anyone else's $@. | ||||
| 754 | |||||
| 755 | # Ensure that our vendor supports EWOULDBLOCK. If they | ||||
| 756 | # don't (eg, Windows), then we use known values for its | ||||
| 757 | # equivalent on other systems. | ||||
| 758 | |||||
| 759 | my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } | ||||
| 760 | || $_EWOULDBLOCK{$^O} | ||||
| 761 | || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); | ||||
| 762 | my $EAGAIN = $EWOULDBLOCK; | ||||
| 763 | if ($try_EAGAIN) { | ||||
| 764 | $EAGAIN = eval { POSIX::EAGAIN(); } | ||||
| 765 | || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); | ||||
| 766 | } | ||||
| 767 | |||||
| 768 | require Fcntl; # For Fcntl::LOCK_NB | ||||
| 769 | |||||
| 770 | return qq{ | ||||
| 771 | |||||
| 772 | my \$context = wantarray() ? "list" : "scalar"; | ||||
| 773 | |||||
| 774 | # Try to flock. If successful, return it immediately. | ||||
| 775 | |||||
| 776 | my \$retval = $call(@argv); | ||||
| 777 | return \$retval if \$retval; | ||||
| 778 | |||||
| 779 | # If we failed, but we're using LOCK_NB and | ||||
| 780 | # returned EWOULDBLOCK, it's not a real error. | ||||
| 781 | |||||
| 782 | if (\$_[1] & Fcntl::LOCK_NB() and | ||||
| 783 | (\$! == $EWOULDBLOCK or | ||||
| 784 | ($try_EAGAIN and \$! == $EAGAIN ))) { | ||||
| 785 | return \$retval; | ||||
| 786 | } | ||||
| 787 | |||||
| 788 | # Otherwise, we failed. Die noisily. | ||||
| 789 | |||||
| 790 | $die; | ||||
| 791 | |||||
| 792 | }; | ||||
| 793 | } | ||||
| 794 | |||||
| 795 | # AFAIK everything that can be given an unopned filehandle | ||||
| 796 | # will fail if it tries to use it, so we don't really need | ||||
| 797 | # the 'unopened' warning class here. Especially since they | ||||
| 798 | # then report the wrong line number. | ||||
| 799 | |||||
| 800 | # Other warnings are disabled because they produce excessive | ||||
| 801 | # complaints from smart-match hints under 5.10.1. | ||||
| 802 | |||||
| 803 | my $code = qq[ | ||||
| 804 | no warnings qw(unopened uninitialized numeric); | ||||
| 805 | |||||
| 806 | if (wantarray) { | ||||
| 807 | my \@results = $call(@argv); | ||||
| 808 | my \$retval = \\\@results; | ||||
| 809 | my \$context = "list"; | ||||
| 810 | |||||
| 811 | ]; | ||||
| 812 | |||||
| 813 | 5 | 8µs | if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { | ||
| 814 | |||||
| 815 | # NB: Subroutine hints are passed as a full list. | ||||
| 816 | # This differs from the 5.10.0 smart-match behaviour, | ||||
| 817 | # but means that context unaware subroutines can use | ||||
| 818 | # the same hints in both list and scalar context. | ||||
| 819 | |||||
| 820 | $code .= qq{ | ||||
| 821 | if ( \$hints->{list}->(\@results) ) { $die }; | ||||
| 822 | }; | ||||
| 823 | } | ||||
| 824 | elsif ( PERL510 and $hints ) { | ||||
| 825 | $code .= qq{ | ||||
| 826 | if ( \@results ~~ \$hints->{list} ) { $die }; | ||||
| 827 | }; | ||||
| 828 | } | ||||
| 829 | elsif ( $hints ) { | ||||
| 830 | croak sprintf(ERROR_58_HINTS, 'list', $sub); | ||||
| 831 | } | ||||
| 832 | else { | ||||
| 833 | $code .= qq{ | ||||
| 834 | # An empty list, or a single undef is failure | ||||
| 835 | if (! \@results or (\@results == 1 and ! defined \$results[0])) { | ||||
| 836 | $die; | ||||
| 837 | } | ||||
| 838 | } | ||||
| 839 | } | ||||
| 840 | |||||
| 841 | # Tidy up the end of our wantarray call. | ||||
| 842 | |||||
| 843 | $code .= qq[ | ||||
| 844 | return \@results; | ||||
| 845 | } | ||||
| 846 | ]; | ||||
| 847 | |||||
| 848 | |||||
| 849 | # Otherwise, we're in scalar context. | ||||
| 850 | # We're never in a void context, since we have to look | ||||
| 851 | # at the result. | ||||
| 852 | |||||
| 853 | $code .= qq{ | ||||
| 854 | my \$retval = $call(@argv); | ||||
| 855 | my \$context = "scalar"; | ||||
| 856 | }; | ||||
| 857 | |||||
| 858 | if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { | ||||
| 859 | |||||
| 860 | # We always call code refs directly, since that always | ||||
| 861 | # works in 5.8.x, and always works in 5.10.1 | ||||
| 862 | |||||
| 863 | return $code .= qq{ | ||||
| 864 | if ( \$hints->{scalar}->(\$retval) ) { $die }; | ||||
| 865 | return \$retval; | ||||
| 866 | }; | ||||
| 867 | |||||
| 868 | } | ||||
| 869 | elsif (PERL510 and $hints) { | ||||
| 870 | return $code . qq{ | ||||
| 871 | |||||
| 872 | if ( \$retval ~~ \$hints->{scalar} ) { $die }; | ||||
| 873 | |||||
| 874 | return \$retval; | ||||
| 875 | }; | ||||
| 876 | } | ||||
| 877 | elsif ( $hints ) { | ||||
| 878 | croak sprintf(ERROR_58_HINTS, 'scalar', $sub); | ||||
| 879 | } | ||||
| 880 | |||||
| 881 | return $code . | ||||
| 882 | ( $use_defined_or ? qq{ | ||||
| 883 | |||||
| 884 | $die if not defined \$retval; | ||||
| 885 | |||||
| 886 | return \$retval; | ||||
| 887 | |||||
| 888 | } : qq{ | ||||
| 889 | |||||
| 890 | return \$retval || $die; | ||||
| 891 | |||||
| 892 | } ) ; | ||||
| 893 | |||||
| 894 | } | ||||
| 895 | |||||
| 896 | # This returns the old copy of the sub, so we can | ||||
| 897 | # put it back at end of scope. | ||||
| 898 | |||||
| 899 | # TODO : Check to make sure prototypes are restored correctly. | ||||
| 900 | |||||
| 901 | # TODO: Taking a huge list of arguments is awful. Rewriting to | ||||
| 902 | # take a hash would be lovely. | ||||
| 903 | |||||
| 904 | # TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 | ||||
| 905 | |||||
| 906 | # spent 2.21ms (1.46+745µs) within Fatal::_make_fatal which was called 2 times, avg 1.10ms/call:
# 2 times (1.46ms+745µs) by Fatal::import at line 291, avg 1.10ms/call | ||||
| 907 | 54 | 150µs | my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_; | ||
| 908 | my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints); | ||||
| 909 | my $ini = $sub; | ||||
| 910 | |||||
| 911 | 2 | 2µs | $sub = "${pkg}::$sub" unless $sub =~ /::/; # spent 2µs making 2 calls to Fatal::CORE:match, avg 1µs/call | ||
| 912 | |||||
| 913 | # Figure if we're using lexical or package semantics and | ||||
| 914 | # twiddle the appropriate bits. | ||||
| 915 | |||||
| 916 | if (not $lexical) { | ||||
| 917 | $Package_Fatal{$sub} = 1; | ||||
| 918 | } | ||||
| 919 | |||||
| 920 | # TODO - We *should* be able to do skipping, since we know when | ||||
| 921 | # we've lexicalised / unlexicalised a subroutine. | ||||
| 922 | |||||
| 923 | $name = $sub; | ||||
| 924 | 2 | 6µs | $name =~ s/.*::// or $name =~ s/^&//; # spent 6µs making 2 calls to Fatal::CORE:subst, avg 3µs/call | ||
| 925 | |||||
| 926 | warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; | ||||
| 927 | 2 | 4µs | croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; # spent 4µs making 2 calls to Fatal::CORE:match, avg 2µs/call | ||
| 928 | |||||
| 929 | 12 | 14µs | if (defined(&$sub)) { # user subroutine | ||
| 930 | |||||
| 931 | # NOTE: Previously we would localise $@ at this point, so | ||||
| 932 | # the following calls to eval {} wouldn't interfere with anything | ||||
| 933 | # that's already in $@. Unfortunately, it would also stop | ||||
| 934 | # any of our croaks from triggering(!), which is even worse. | ||||
| 935 | |||||
| 936 | # This could be something that we've fatalised that | ||||
| 937 | # was in core. | ||||
| 938 | |||||
| 939 | if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) { | ||||
| 940 | |||||
| 941 | # Something we previously made Fatal that was core. | ||||
| 942 | # This is safe to replace with an autodying to core | ||||
| 943 | # version. | ||||
| 944 | |||||
| 945 | $core = 1; | ||||
| 946 | $call = "CORE::$name"; | ||||
| 947 | $proto = prototype $call; | ||||
| 948 | |||||
| 949 | # We return our $sref from this subroutine later | ||||
| 950 | # on, indicating this subroutine should be placed | ||||
| 951 | # back when we're finished. | ||||
| 952 | |||||
| 953 | $sref = \&$sub; | ||||
| 954 | |||||
| 955 | } else { | ||||
| 956 | |||||
| 957 | # If this is something we've already fatalised or played with, | ||||
| 958 | # then look-up the name of the original sub for the rest of | ||||
| 959 | # our processing. | ||||
| 960 | |||||
| 961 | $sub = $Is_fatalised_sub{\&$sub} || $sub; | ||||
| 962 | |||||
| 963 | # A regular user sub, or a user sub wrapping a | ||||
| 964 | # core sub. | ||||
| 965 | |||||
| 966 | $sref = \&$sub; | ||||
| 967 | $proto = prototype $sref; | ||||
| 968 | $call = '&$sref'; | ||||
| 969 | require autodie::hints; | ||||
| 970 | |||||
| 971 | $hints = autodie::hints->get_hints_for( $sref ); | ||||
| 972 | |||||
| 973 | # If we've insisted on hints, but don't have them, then | ||||
| 974 | # bail out! | ||||
| 975 | |||||
| 976 | if ($insist and not $hints) { | ||||
| 977 | croak(sprintf(ERROR_NOHINTS, $name)); | ||||
| 978 | } | ||||
| 979 | |||||
| 980 | # Otherwise, use the default hints if we don't have | ||||
| 981 | # any. | ||||
| 982 | |||||
| 983 | $hints ||= autodie::hints::DEFAULT_HINTS(); | ||||
| 984 | |||||
| 985 | } | ||||
| 986 | |||||
| 987 | } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { | ||||
| 988 | # Stray user subroutine | ||||
| 989 | croak(sprintf(ERROR_NOTSUB,$sub)); | ||||
| 990 | |||||
| 991 | } elsif ($name eq 'system') { | ||||
| 992 | |||||
| 993 | # If we're fatalising system, then we need to load | ||||
| 994 | # helper code. | ||||
| 995 | |||||
| 996 | # The business with $E is to avoid clobbering our caller's | ||||
| 997 | # $@, and to avoid $@ being localised when we croak. | ||||
| 998 | |||||
| 999 | my $E; | ||||
| 1000 | |||||
| 1001 | { | ||||
| 1002 | local $@; | ||||
| 1003 | |||||
| 1004 | eval { | ||||
| 1005 | require IPC::System::Simple; # Only load it if we need it. | ||||
| 1006 | require autodie::exception::system; | ||||
| 1007 | }; | ||||
| 1008 | $E = $@; | ||||
| 1009 | } | ||||
| 1010 | |||||
| 1011 | if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; } | ||||
| 1012 | |||||
| 1013 | # Make sure we're using a recent version of ISS that actually | ||||
| 1014 | # support fatalised system. | ||||
| 1015 | if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) { | ||||
| 1016 | croak sprintf( | ||||
| 1017 | ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER, | ||||
| 1018 | $IPC::System::Simple::VERSION | ||||
| 1019 | ); | ||||
| 1020 | } | ||||
| 1021 | |||||
| 1022 | $call = 'CORE::system'; | ||||
| 1023 | $name = 'system'; | ||||
| 1024 | $core = 1; | ||||
| 1025 | |||||
| 1026 | } elsif ($name eq 'exec') { | ||||
| 1027 | # Exec doesn't have a prototype. We don't care. This | ||||
| 1028 | # breaks the exotic form with lexical scope, and gives | ||||
| 1029 | # the regular form a "do or die" beaviour as expected. | ||||
| 1030 | |||||
| 1031 | $call = 'CORE::exec'; | ||||
| 1032 | $name = 'exec'; | ||||
| 1033 | $core = 1; | ||||
| 1034 | |||||
| 1035 | } else { # CORE subroutine | ||||
| 1036 | my $E; | ||||
| 1037 | { | ||||
| 1038 | 6 | 10µs | local $@; | ||
| 1039 | 2 | 18µs | $proto = eval { prototype "CORE::$name" }; | ||
| 1040 | $E = $@; | ||||
| 1041 | } | ||||
| 1042 | croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; | ||||
| 1043 | croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; | ||||
| 1044 | $core = 1; | ||||
| 1045 | $call = "CORE::$name"; | ||||
| 1046 | } | ||||
| 1047 | |||||
| 1048 | if (defined $proto) { | ||||
| 1049 | $real_proto = " ($proto)"; | ||||
| 1050 | } else { | ||||
| 1051 | $real_proto = ''; | ||||
| 1052 | $proto = '@'; | ||||
| 1053 | } | ||||
| 1054 | |||||
| 1055 | my $true_name = $core ? $call : $sub; | ||||
| 1056 | |||||
| 1057 | # TODO: This caching works, but I don't like using $void and | ||||
| 1058 | # $lexical as keys. In particular, I suspect our code may end up | ||||
| 1059 | # wrapping already wrapped code when autodie and Fatal are used | ||||
| 1060 | # together. | ||||
| 1061 | |||||
| 1062 | # NB: We must use '$sub' (the name plus package) and not | ||||
| 1063 | # just '$name' (the short name) here. Failing to do so | ||||
| 1064 | # results code that's in the wrong package, and hence has | ||||
| 1065 | # access to the wrong package filehandles. | ||||
| 1066 | |||||
| 1067 | if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) { | ||||
| 1068 | $class->_install_subs($pkg, { $name => $subref }); | ||||
| 1069 | return $sref; | ||||
| 1070 | } | ||||
| 1071 | |||||
| 1072 | $code = qq[ | ||||
| 1073 | sub$real_proto { | ||||
| 1074 | local(\$", \$!) = (', ', 0); # TODO - Why do we do this? | ||||
| 1075 | ]; | ||||
| 1076 | |||||
| 1077 | # Don't have perl whine if exec fails, since we'll be handling | ||||
| 1078 | # the exception now. | ||||
| 1079 | $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; | ||||
| 1080 | |||||
| 1081 | 2 | 152µs | my @protos = fill_protos($proto); # spent 152µs making 2 calls to Fatal::fill_protos, avg 76µs/call | ||
| 1082 | 2 | 265µs | $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos); # spent 265µs making 2 calls to Fatal::_write_invocation, avg 133µs/call | ||
| 1083 | $code .= "}\n"; | ||||
| 1084 | warn $code if $Debug; | ||||
| 1085 | |||||
| 1086 | # I thought that changing package was a monumental waste of | ||||
| 1087 | # time for CORE subs, since they'll always be the same. However | ||||
| 1088 | # that's not the case, since they may refer to package-based | ||||
| 1089 | # filehandles (eg, with open). | ||||
| 1090 | # | ||||
| 1091 | # There is potential to more aggressively cache core subs | ||||
| 1092 | # that we know will never want to interact with package variables | ||||
| 1093 | # and filehandles. | ||||
| 1094 | |||||
| 1095 | { | ||||
| 1096 | 2 | 543µs | 2 | 60µs | # spent 36µs (12+24) within Fatal::BEGIN@1096 which was called:
# once (12µs+24µs) by autodie::BEGIN@6 at line 1096 # spent 36µs making 1 call to Fatal::BEGIN@1096
# spent 24µs making 1 call to strict::unimport |
| 1097 | |||||
| 1098 | 6 | 8µs | my $E; | ||
| 1099 | |||||
| 1100 | { | ||||
| 1101 | 6 | 178µs | local $@; | ||
| 1102 | $code = eval("package $pkg; require Carp; $code"); ## no critic # spent 596µs executing statements in string eval # includes 72µs spent executing 4 calls to 4 subs defined therein. # spent 267µs executing statements in string eval # includes 27µs spent executing 2 calls to 3 subs defined therein. | ||||
| 1103 | $E = $@; | ||||
| 1104 | } | ||||
| 1105 | |||||
| 1106 | if (not $code) { | ||||
| 1107 | croak("Internal error in autodie/Fatal processing $true_name: $E"); | ||||
| 1108 | |||||
| 1109 | } | ||||
| 1110 | } | ||||
| 1111 | |||||
| 1112 | # Now we need to wrap our fatalised sub inside an itty bitty | ||||
| 1113 | # closure, which can detect if we've leaked into another file. | ||||
| 1114 | # Luckily, we only need to do this for lexical (autodie) | ||||
| 1115 | # subs. Fatal subs can leak all they want, it's considered | ||||
| 1116 | # a "feature" (or at least backwards compatible). | ||||
| 1117 | |||||
| 1118 | # TODO: Cache our leak guards! | ||||
| 1119 | |||||
| 1120 | # TODO: This is pretty hairy code. A lot more tests would | ||||
| 1121 | # be really nice for this. | ||||
| 1122 | |||||
| 1123 | my $leak_guard; | ||||
| 1124 | |||||
| 1125 | 12 | 22µs | if ($lexical) { | ||
| 1126 | |||||
| 1127 | $leak_guard = qq< | ||||
| 1128 | package $pkg; | ||||
| 1129 | |||||
| 1130 | sub$real_proto { | ||||
| 1131 | |||||
| 1132 | # If we're inside a string eval, we can end up with a | ||||
| 1133 | # whacky filename. The following code allows autodie | ||||
| 1134 | # to propagate correctly into string evals. | ||||
| 1135 | |||||
| 1136 | my \$caller_level = 0; | ||||
| 1137 | |||||
| 1138 | my \$caller; | ||||
| 1139 | |||||
| 1140 | while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) { | ||||
| 1141 | |||||
| 1142 | # If our filename is actually an eval, and we | ||||
| 1143 | # reach it, then go to our autodying code immediatately. | ||||
| 1144 | |||||
| 1145 | goto &\$code if (\$caller eq \$filename); | ||||
| 1146 | \$caller_level++; | ||||
| 1147 | } | ||||
| 1148 | |||||
| 1149 | # We're now out of the eval stack. | ||||
| 1150 | |||||
| 1151 | # If we're called from the correct file, then use the | ||||
| 1152 | # autodying code. | ||||
| 1153 | goto &\$code if ((caller \$caller_level)[1] eq \$filename); | ||||
| 1154 | |||||
| 1155 | # Oh bother, we've leaked into another file. Call the | ||||
| 1156 | # original code. Note that \$sref may actually be a | ||||
| 1157 | # reference to a Fatalised version of a core built-in. | ||||
| 1158 | # That's okay, because Fatal *always* leaks between files. | ||||
| 1159 | |||||
| 1160 | goto &\$sref if \$sref; | ||||
| 1161 | >; | ||||
| 1162 | |||||
| 1163 | |||||
| 1164 | # If we're here, it must have been a core subroutine called. | ||||
| 1165 | # Warning: The following code may disturb some viewers. | ||||
| 1166 | |||||
| 1167 | # TODO: It should be possible to combine this with | ||||
| 1168 | # write_invocation(). | ||||
| 1169 | |||||
| 1170 | foreach my $proto (@protos) { | ||||
| 1171 | 15 | 33µs | local $" = ", "; # So @args is formatted correctly. | ||
| 1172 | my ($count, @args) = @$proto; | ||||
| 1173 | $leak_guard .= qq< | ||||
| 1174 | if (\@_ == $count) { | ||||
| 1175 | return $call(@args); | ||||
| 1176 | } | ||||
| 1177 | >; | ||||
| 1178 | } | ||||
| 1179 | |||||
| 1180 | $leak_guard .= qq< Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; | ||||
| 1181 | |||||
| 1182 | # warn "$leak_guard\n"; | ||||
| 1183 | |||||
| 1184 | my $E; | ||||
| 1185 | { | ||||
| 1186 | 6 | 296µs | local $@; | ||
| 1187 | |||||
| 1188 | $leak_guard = eval $leak_guard; ## no critic # spent 39µs executing statements in string eval # includes 27µs spent executing 1 call to 1 sub defined therein. # spent 5µs executing statements in string eval | ||||
| 1189 | |||||
| 1190 | $E = $@; | ||||
| 1191 | } | ||||
| 1192 | |||||
| 1193 | die "Internal error in $class: Leak-guard installation failure: $E" if $E; | ||||
| 1194 | } | ||||
| 1195 | |||||
| 1196 | my $installed_sub = $leak_guard || $code; | ||||
| 1197 | |||||
| 1198 | 2 | 81µs | $class->_install_subs($pkg, { $name => $installed_sub }); # spent 81µs making 2 calls to Fatal::_install_subs, avg 40µs/call | ||
| 1199 | |||||
| 1200 | $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub; | ||||
| 1201 | |||||
| 1202 | # Cache that we've now overriddent this sub. If we get called | ||||
| 1203 | # again, we may need to find that find subroutine again (eg, for hints). | ||||
| 1204 | |||||
| 1205 | 1 | 4µs | 2 | 32µs | $Is_fatalised_sub{$installed_sub} = $sref; # spent 32µs making 2 calls to Tie::RefHash::STORE, avg 16µs/call |
| 1206 | |||||
| 1207 | return $sref; | ||||
| 1208 | |||||
| 1209 | } | ||||
| 1210 | |||||
| 1211 | # This subroutine exists primarily so that child classes can override | ||||
| 1212 | # it to point to their own exception class. Doing this is significantly | ||||
| 1213 | # less complex than overriding throw() | ||||
| 1214 | |||||
| 1215 | sub exception_class { return "autodie::exception" }; | ||||
| 1216 | |||||
| 1217 | { | ||||
| 1218 | 3 | 3µs | my %exception_class_for; | ||
| 1219 | my %class_loaded; | ||||
| 1220 | |||||
| 1221 | sub throw { | ||||
| 1222 | my ($class, @args) = @_; | ||||
| 1223 | |||||
| 1224 | # Find our exception class if we need it. | ||||
| 1225 | my $exception_class = | ||||
| 1226 | $exception_class_for{$class} ||= $class->exception_class; | ||||
| 1227 | |||||
| 1228 | if (not $class_loaded{$exception_class}) { | ||||
| 1229 | if ($exception_class =~ /[^\w:']/) { | ||||
| 1230 | confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons."; | ||||
| 1231 | } | ||||
| 1232 | |||||
| 1233 | # Alas, Perl does turn barewords into modules unless they're | ||||
| 1234 | # actually barewords. As such, we're left doing a string eval | ||||
| 1235 | # to make sure we load our file correctly. | ||||
| 1236 | |||||
| 1237 | my $E; | ||||
| 1238 | |||||
| 1239 | { | ||||
| 1240 | local $@; # We can't clobber $@, it's wrong! | ||||
| 1241 | eval "require $exception_class"; ## no critic | ||||
| 1242 | $E = $@; # Save $E despite ending our local. | ||||
| 1243 | } | ||||
| 1244 | |||||
| 1245 | # We need quotes around $@ to make sure it's stringified | ||||
| 1246 | # while still in scope. Without them, we run the risk of | ||||
| 1247 | # $@ having been cleared by us exiting the local() block. | ||||
| 1248 | |||||
| 1249 | confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E; | ||||
| 1250 | |||||
| 1251 | $class_loaded{$exception_class}++; | ||||
| 1252 | |||||
| 1253 | } | ||||
| 1254 | |||||
| 1255 | return $exception_class->new(@args); | ||||
| 1256 | } | ||||
| 1257 | } | ||||
| 1258 | |||||
| 1259 | # For some reason, dying while replacing our subs doesn't | ||||
| 1260 | # kill our calling program. It simply stops the loading of | ||||
| 1261 | # autodie and keeps going with everything else. The _autocroak | ||||
| 1262 | # sub allows us to die with a vegence. It should *only* ever be | ||||
| 1263 | # used for serious internal errors, since the results of it can't | ||||
| 1264 | # be captured. | ||||
| 1265 | |||||
| 1266 | sub _autocroak { | ||||
| 1267 | warn Carp::longmess(@_); | ||||
| 1268 | exit(255); # Ugh! | ||||
| 1269 | } | ||||
| 1270 | |||||
| 1271 | package autodie::Scope::Guard; | ||||
| 1272 | |||||
| 1273 | # This code schedules the cleanup of subroutines at the end of | ||||
| 1274 | # scope. It's directly inspired by chocolateboy's excellent | ||||
| 1275 | # Scope::Guard module. | ||||
| 1276 | |||||
| 1277 | # spent 9µs within autodie::Scope::Guard::new which was called:
# once (9µs+0s) by Fatal::import at line 324 | ||||
| 1278 | 2 | 11µs | my ($class, $handler) = @_; | ||
| 1279 | |||||
| 1280 | return bless $handler, $class; | ||||
| 1281 | } | ||||
| 1282 | |||||
| 1283 | sub DESTROY { | ||||
| 1284 | my ($self) = @_; | ||||
| 1285 | |||||
| 1286 | $self->(); | ||||
| 1287 | } | ||||
| 1288 | |||||
| 1289 | 1 | 23µs | 1; | ||
| 1290 | |||||
| 1291 | __END__ | ||||
# spent 30µs within Fatal::CORE:match which was called 18 times, avg 2µs/call:
# 7 times (11µs+0s) by Fatal::fill_protos at line 502, avg 2µs/call
# 4 times (6µs+0s) by Fatal::_write_invocation at line 554, avg 2µs/call
# 2 times (4µs+0s) by Fatal::_make_fatal at line 927, avg 2µs/call
# 2 times (3µs+0s) by Fatal::import at line 276, avg 1µs/call
# 2 times (2µs+0s) by Fatal::_make_fatal at line 911, avg 1µs/call
# once (4µs+0s) by autodie::BEGIN@6 at line 58 | |||||
# spent 37µs within Fatal::CORE:subst which was called 21 times, avg 2µs/call:
# 6 times (10µs+0s) by Fatal::fill_protos at line 506, avg 2µs/call
# 6 times (7µs+0s) by Fatal::fill_protos at line 505, avg 1µs/call
# 3 times (7µs+0s) by Fatal::fill_protos at line 507, avg 2µs/call
# 2 times (6µs+0s) by Fatal::_make_fatal at line 924, avg 3µs/call
# 2 times (4µs+0s) by Fatal::fill_protos at line 508, avg 2µs/call
# 2 times (3µs+0s) by Fatal::import at line 256, avg 2µs/call |