line
stmt
bran
cond
sub
pod
time
code
1
#!/usr/bin/perl -c
2
3
package Exception::Base;
4
5
=head1 NAME
6
7
Exception::Base - Lightweight exceptions
8
9
=head1 SYNOPSIS
10
11
# Use module and create needed exceptions
12
use Exception::Base
13
'Exception::Runtime', # create new module
14
'Exception::System', # load existing module
15
'Exception::IO', => {
16
isa => 'Exception::System' }, # create new based on existing
17
'Exception::FileNotFound' => {
18
isa => 'Exception::IO', # create new based on previous
19
message => 'File not found', # override default message
20
has => [ 'filename' ], # define new rw attribute
21
string_attributes => [ 'message', 'filename' ],
22
}; # output message and filename
23
24
# eval is used as "try" block
25
eval {
26
open my $file, '/etc/passwd'
27
or Exception::FileNotFound->throw(
28
message=>'Something wrong',
29
filename=>'/etc/passwd');
30
};
31
# syntax for Perl >= 5.10
32
use feature 'switch';
33
if ($@) {
34
given (my $e = Exception::Base->catch) {
35
when ($e->isa('Exception::IO')) { warn "IO problem"; }
36
when ($e->isa('Exception::Eval')) { warn "eval died"; }
37
when ($e->isa('Exception::Runtime')) { warn "some runtime was caught"; }
38
when ($e->matches({value=>9})) { warn "something happened"; }
39
when ($e->matches(qr/^Error/)) { warn "some error based on regex"; }
40
default { $e->throw; } # rethrow the exception
41
}
42
}
43
# standard syntax for older Perl
44
if ($@) {
45
my $e = Exception::Base->catch; # convert $@ into exception
46
if ($e->isa('Exception::IO')) { warn "IO problem"; }
47
elsif ($e->isa('Exception::Eval')) { warn "eval died"; }
48
elsif ($e->isa('Exception::Runtime')) { warn "some runtime was caught"; }
49
elsif ($e->matches({value=>9})) { warn "something happened"; }
50
elsif ($e->matches(qr/^Error/)) { warn "some error based on regex"; }
51
else { $e->throw; } # rethrow the exception
52
}
53
54
# $@ has to be recovered ASAP!
55
eval { die "this die will be caught" };
56
my $e = Exception::Base->catch;
57
eval { die "this die will be ignored" };
58
if ($e) {
59
(...)
60
}
61
62
# the exception can be thrown later
63
my $e = Exception::Base->new;
64
# (...)
65
$e->throw;
66
67
# ignore our package in stack trace
68
package My::Package;
69
use Exception::Base '+ignore_package' => __PACKAGE__;
70
71
# define new exception in separate module
72
package Exception::My;
73
use Exception::Base (__PACKAGE__) => {
74
has => ['myattr'],
75
};
76
77
# run Perl with changed verbosity for debugging purposes
78
$ perl -MException::Base=verbosity,4 script.pl
79
80
=head1 DESCRIPTION
81
82
This class implements a fully OO exception mechanism similar to
83
L or L. It provides a simple interface
84
allowing programmers to declare exception classes. These classes can be
85
thrown and caught. Each uncaught exception prints full stack trace if the
86
default verbosity is increased for debugging purposes.
87
88
The features of C:
89
90
=over 2
91
92
=item *
93
94
fast implementation of the exception class
95
96
=item *
97
98
fully OO without closures and source code filtering
99
100
=item *
101
102
does not mess with C<$SIG{__DIE__}> and C<$SIG{__WARN__}>
103
104
=item *
105
106
no external run-time modules dependencies, requires core Perl modules only
107
108
=item *
109
110
the default behavior of exception class can be changed globally or just for
111
the thrown exception
112
113
=item *
114
115
matching the exception by class, message or other attributes
116
117
=item *
118
119
matching with string, regex or closure function
120
121
=item *
122
123
creating automatically the derived exception classes (L
124
interface)
125
126
=item *
127
128
easily expendable, see L class for example
129
130
=item *
131
132
prints just an error message or dumps full stack trace
133
134
=item *
135
136
can propagate (rethrow) an exception
137
138
=item *
139
140
can ignore some packages for stack trace output
141
142
=item *
143
144
some defaults (i.e. verbosity) can be different for different exceptions
145
146
=back
147
148
=for readme stop
149
150
=cut
151
152
1
1
3170
use 5.006;
1
3
1
42
153
154
1
1
5
use strict;
1
2
1
240
155
1
1
23
use warnings;
1
2
1
164
156
157
our $VERSION = '0.25';
158
159
## no critic qw(ProhibitConstantPragma RequireArgUnpacking RequireCarping RequireCheckingReturnValueOfEval RequireInitializationForLocalVars)
160
161
# Safe operations on symbol stash
162
BEGIN {
163
1
1
3
eval {
164
1
6
require Symbol;
165
1
6
Symbol::qualify_to_ref('Symbol::qualify_to_ref');
166
};
167
1
50
22
if (not $@) {
168
1
115
*_qualify_to_ref = \*Symbol::qualify_to_ref;
169
}
170
else {
171
1
1
5
*_qualify_to_ref = sub ($;) { no strict 'refs'; \*{ $_[0] } };
1
2
1
58
0
0
0
0
0
0
172
};
173
};
174
175
176
# Use weaken ref on stack if available
177
BEGIN {
178
1
1
3
eval {
179
1
5
require Scalar::Util;
180
1
10
my $ref = \1;
181
1
6
Scalar::Util::weaken($ref);
182
};
183
1
50
5
if (not $@) {
184
1
92
*_HAVE_SCALAR_UTIL_WEAKEN = sub () { !! 1 };
185
}
186
else {
187
0
0
*_HAVE_SCALAR_UTIL_WEAKEN = sub () { !! 0 };
188
};
189
};
190
191
192
BEGIN {
193
1
1
64
my %OVERLOADS = (fallback => 1);
194
195
=head1 OVERLOADS
196
197
=over
198
199
=item Boolean context
200
201
True value. See C method.
202
203
eval { Exception::Base->throw( message=>"Message", value=>123 ) };
204
if ($@) {
205
# the exception object is always true
206
}
207
208
=cut
209
210
1
2
$OVERLOADS{'bool'} = 'to_bool';
211
212
=item Numeric context
213
214
Content of attribute pointed by C attribute. See
215
C method.
216
217
eval { Exception::Base->throw( message=>"Message", value=>123 ) };
218
print 0+$@; # 123
219
220
=cut
221
222
1
2
$OVERLOADS{'0+'} = 'to_number';
223
224
=item String context
225
226
Content of attribute which is combined from C attributes
227
with additional information, depended on C setting. See
228
C method.
229
230
eval { Exception::Base->throw( message=>"Message", value=>123 ) };
231
print "$@"; # "Message at -e line 1.\n"
232
233
=cut
234
235
1
2
$OVERLOADS{'""'} = 'to_string';
236
237
=item "~~"
238
239
Smart matching operator. See C method.
240
241
eval { Exception::Base->throw( message=>"Message", value=>123 ) };
242
print "Message" ~~ $@; # 1
243
print qr/message/i ~~ $@; # 1
244
print ['Exception::Base'] ~~ $@; # 1
245
print 123 ~~ $@; # 1
246
print {message=>"Message", value=>123} ~~ $@; # 1
247
248
Warning: The smart operator requires that the exception object is a second
249
argument.
250
251
=back
252
253
=cut
254
255
1
50
7
$OVERLOADS{'~~'} = 'matches' if ($] >= 5.010);
256
257
1
1
6
use overload;
1
9
1
9
258
1
6
overload->import(%OVERLOADS);
259
};
260
261
262
# Constant regexp for numerify value check
263
1
1
178
use constant _RE_NUM_INT => qr/^[+-]?\d+$/;
1
2
1
485
264
265
266
=head1 CONSTANTS
267
268
=over
269
270
=item ATTRS
271
272
Declaration of class attributes as reference to hash.
273
274
The attributes are listed as I => {I}, where I is a
275
list of attribute properties:
276
277
=over
278
279
=item is
280
281
Can be 'rw' for read-write attributes or 'ro' for read-only attributes. The
282
attribute is read-only and does not have an accessor created if 'is' property
283
is missed.
284
285
=item default
286
287
Optional property with the default value if the attribute value is not
288
defined.
289
290
=back
291
292
The read-write attributes can be set with C constructor. Read-only
293
attributes and unknown attributes are ignored.
294
295
The constant have to be defined in derived class if it brings additional
296
attributes.
297
298
package Exception::My;
299
use base 'Exception::Base';
300
301
# Define new class attributes
302
use constant ATTRS => {
303
%{Exception::Base->ATTRS}, # base's attributes have to be first
304
readonly => { is=>'ro' }, # new ro attribute
305
readwrite => { is=>'rw', default=>'blah' }, # new rw attribute
306
};
307
308
package main;
309
use Exception::Base ':all';
310
eval {
311
Exception::My->throw( readwrite => 2 );
312
};
313
if ($@) {
314
my $e = Exception::Base->catch;
315
print $e->readwrite; # = 2
316
print $e->defaults->{readwrite}; # = "blah"
317
}
318
319
=back
320
321
=cut
322
323
BEGIN {
324
1
1
2
my %ATTRS = ();
325
326
=head1 ATTRIBUTES
327
328
Class attributes are implemented as values of blessed hash. The attributes
329
are also available as accessors methods.
330
331
=over
332
333
=cut
334
335
=item message (rw, default: 'Unknown exception')
336
337
Contains the message of the exception. It is the part of the string
338
representing the exception object.
339
340
eval { Exception::Base->throw( message=>"Message" ); };
341
print $@->message if $@;
342
343
It can also be an array reference of strings and then the L
344
is used to get a message.
345
346
Exception::Base->throw( message => ["%s failed", __PACKAGE__] );
347
348
=cut
349
350
1
10
$ATTRS{message} = { is => 'rw', default => 'Unknown exception' };
351
352
=item value (rw, default: 0)
353
354
Contains the value which represents numeric value of the exception object in
355
numeric context.
356
357
eval { Exception::Base->throw( value=>2 ); };
358
print "Error 2" if $@ == 2;
359
360
=cut
361
362
1
4
$ATTRS{value} = { is => 'rw', default => 0 };
363
364
=item verbosity (rw, default: 2)
365
366
Contains the verbosity level of the exception object. It allows to change the
367
string representing the exception object. There are following levels of
368
verbosity:
369
370
=over 2
371
372
=item C<0>
373
374
Empty string
375
376
=item C<1>
377
378
Message
379
380
=item C<2>
381
382
Message at %s line %d.
383
384
The same as the standard output of die() function. It doesn't include
385
"at %s line %d." string if message ends with C<"\n"> character. This is
386
the default option.
387
388
=item C<3>
389
390
Class: Message at %s line %d
391
%c_ = %s::%s() called in package %s at %s line %d
392
...propagated in package %s at %s line %d.
393
...
394
395
The output contains full trace of error stack without first C
396
lines and those packages which are listed in C and
397
C settings.
398
399
=item S<4>
400
401
The output contains full trace of error stack. In this case the
402
C, C and C settings are meaning
403
only for first line of exception's message.
404
405
=back
406
407
If the verbosity is undef, then the default verbosity for exception objects is
408
used.
409
410
If the verbosity set with constructor (C or C) is lower than 3,
411
the full stack trace won't be collected.
412
413
If the verbosity is lower than 2, the full system data (time, pid, tid, uid,
414
euid, gid, egid) won't be collected.
415
416
This setting can be changed with import interface.
417
418
use Exception::Base verbosity => 4;
419
420
It can be also changed for Perl interpreter instance, i.e. for debugging
421
purposes.
422
423
sh$ perl -MException::Base=verbosity,4 script.pl
424
425
=cut
426
427
1
2
$ATTRS{verbosity} = { is => 'rw', default => 2 };
428
429
=item ignore_package (rw)
430
431
Contains the name (scalar or regexp) or names (as references array) of
432
packages which are ignored in error stack trace. It is useful if some package
433
throws an exception but this module shouldn't be listed in stack trace.
434
435
package My::Package;
436
use Exception::Base;
437
sub my_function {
438
do_something() or throw Exception::Base ignore_package=>__PACKAGE__;
439
throw Exception::Base ignore_package => [ "My", qr/^My::Modules::/ ];
440
}
441
442
This setting can be changed with import interface.
443
444
use Exception::Base ignore_package => __PACKAGE__;
445
446
=cut
447
448
1
5
$ATTRS{ignore_package} = { is => 'rw', default => [ ] };
449
450
=item ignore_class (rw)
451
452
Contains the name (scalar) or names (as references array) of packages which
453
are base classes for ignored packages in error stack trace. It means that
454
some packages will be ignored even the derived class was called.
455
456
package My::Package;
457
use Exception::Base;
458
Exception::Base->throw( ignore_class => "My::Base" );
459
460
This setting can be changed with import interface.
461
462
use Exception::Base ignore_class => "My::Base";
463
464
=cut
465
466
1
3
$ATTRS{ignore_class} = { is => 'rw', default => [ ] };
467
468
=item ignore_level (rw)
469
470
Contains the number of level on stack trace to ignore. It is useful if some
471
package throws an exception but this module shouldn't be listed in stack
472
trace. It can be used with or without I attribute.
473
474
# Convert warning into exception. The signal handler ignores itself.
475
use Exception::Base 'Exception::My::Warning';
476
$SIG{__WARN__} = sub {
477
Exception::My::Warning->throw( message => $_[0], ignore_level => 1 );
478
};
479
480
=cut
481
482
1
3
$ATTRS{ignore_level} = { is => 'rw', default => 0 };
483
484
=item time (ro)
485
486
Contains the timestamp of the thrown exception. Collected if the verbosity on
487
throwing exception was greater than 1.
488
489
eval { Exception::Base->throw( message=>"Message" ); };
490
print scalar localtime $@->time;
491
492
=cut
493
494
1
3
$ATTRS{time} = { is => 'ro' };
495
496
=item pid (ro)
497
498
Contains the PID of the Perl process at time of thrown exception. Collected
499
if the verbosity on throwing exception was greater than 1.
500
501
eval { Exception::Base->throw( message=>"Message" ); };
502
kill 10, $@->pid;
503
504
=cut
505
506
1
10
$ATTRS{pid} = { is => 'ro' };
507
508
=item tid (ro)
509
510
Contains the tid of the thread or undef if threads are not used. Collected
511
if the verbosity on throwing exception was greater than 1.
512
513
=cut
514
515
1
2
$ATTRS{tid} = { is => 'ro' };
516
517
=item uid (ro)
518
519
=cut
520
521
1
3
$ATTRS{uid} = { is => 'ro' };
522
523
=item euid (ro)
524
525
=cut
526
527
1
3
$ATTRS{euid} = { is => 'ro' };
528
529
530
=item gid (ro)
531
532
=cut
533
534
1
3
$ATTRS{gid} = { is => 'ro' };
535
536
=item egid (ro)
537
538
Contains the real and effective uid and gid of the Perl process at time of
539
thrown exception. Collected if the verbosity on throwing exception was
540
greater than 1.
541
542
=cut
543
544
1
3
$ATTRS{egid} = { is => 'ro' };
545
546
=item caller_stack (ro)
547
548
Contains the error stack as array of array with information about caller
549
functions. The first 8 elements of the array's row are the same as first 8
550
elements of the output of C function. Further elements are optional
551
and are the arguments of called function. Collected if the verbosity on
552
throwing exception was greater than 1. Contains only the first element of
553
caller stack if the verbosity was lower than 3.
554
555
If the arguments of called function are references and
556
C::weaken> function is available then reference is weakened.
557
558
eval { Exception::Base->throw( message=>"Message" ); };
559
($package, $filename, $line, $subroutine, $hasargs, $wantarray,
560
$evaltext, $is_require, @args) = $@->caller_stack->[0];
561
562
=cut
563
564
1
2
$ATTRS{caller_stack} = { is => 'ro' };
565
566
=item propagated_stack (ro)
567
568
Contains the array of array which is used for generating "...propagated at"
569
message. The elements of the array's row are the same as first 3 elements of
570
the output of C function.
571
572
=cut
573
574
1
3
$ATTRS{propagated_stack} = { is => 'ro' };
575
576
=item max_arg_len (rw, default: 64)
577
578
Contains the maximal length of argument for functions in backtrace output.
579
Zero means no limit for length.
580
581
sub a { Exception::Base->throw( max_arg_len=>5 ) }
582
a("123456789");
583
584
=cut
585
586
1
3
$ATTRS{max_arg_len} = { is => 'rw', default => 64 };
587
588
=item max_arg_nums (rw, default: 8)
589
590
Contains the maximal number of arguments for functions in backtrace output.
591
Zero means no limit for arguments.
592
593
sub a { Exception::Base->throw( max_arg_nums=>1 ) }
594
a(1,2,3);
595
596
=cut
597
598
1
3
$ATTRS{max_arg_nums} = { is => 'rw', default => 8 };
599
600
=item max_eval_len (rw, default: 0)
601
602
Contains the maximal length of eval strings in backtrace output. Zero means
603
no limit for length.
604
605
eval "Exception->throw( max_eval_len=>10 )";
606
print "$@";
607
608
=cut
609
610
1
4
$ATTRS{max_eval_len} = { is => 'rw', default => 0 };
611
612
=item defaults
613
614
Meta-attribute contains the list of default values.
615
616
my $e = Exception::Base->new;
617
print defined $e->{verbosity}
618
? $e->{verbosity}
619
: $e->{defaults}->{verbosity};
620
621
=cut
622
623
1
2
$ATTRS{defaults} = { };
624
625
=item default_attribute (default: 'message')
626
627
Meta-attribute contains the name of the default attribute. This attribute
628
will be set for one argument throw method. This attribute has meaning for
629
derived classes.
630
631
use Exception::Base 'Exception::My' => {
632
has => 'myattr',
633
default_attribute => 'myattr',
634
};
635
636
eval { Exception::My->throw("string") };
637
print $@->myattr; # "string"
638
639
=cut
640
641
1
2
$ATTRS{default_attribute} = { default => 'message' };
642
643
=item numeric_attribute (default: 'value')
644
645
Meta-attribute contains the name of the attribute which contains numeric value
646
of exception object. This attribute will be used for representing exception
647
in numeric context.
648
649
use Exception::Base 'Exception::My' => {
650
has => 'myattr',
651
numeric_attribute => 'myattr',
652
};
653
654
eval { Exception::My->throw(myattr=>123) };
655
print 0 + $@; # 123
656
657
=cut
658
659
1
2
$ATTRS{numeric_attribute} = { default => 'value' };
660
661
=item eval_attribute (default: 'message')
662
663
Meta-attribute contains the name of the attribute which is filled if error
664
stack is empty. This attribute will contain value of C<$@> variable. This
665
attribute has meaning for derived classes.
666
667
use Exception::Base 'Exception::My' => {
668
has => 'myattr',
669
eval_attribute => 'myattr'
670
};
671
672
eval { die "string" };
673
print $@->myattr; # "string"
674
675
=cut
676
677
1
3
$ATTRS{eval_attribute} = { default => 'message' };
678
679
=item string_attributes (default: ['message'])
680
681
Meta-attribute contains the array of names of attributes with defined value
682
which are joined to the string returned by C method. If none of
683
attributes are defined, the string is created from the first default value of
684
attributes listed in the opposite order.
685
686
use Exception::Base 'Exception::My' => {
687
has => 'myattr',
688
myattr => 'default',
689
string_attributes => ['message', 'myattr'],
690
};
691
692
eval { Exception::My->throw( message=>"string", myattr=>"foo" ) };
693
print $@->myattr; # "string: foo"
694
695
eval { Exception::My->throw() };
696
print $@->myattr; # "default"
697
698
=back
699
700
=cut
701
702
1
4
$ATTRS{string_attributes} = { default => [ 'message' ] };
703
704
1
95
623
*ATTRS = sub () { \%ATTRS };
95
2575
705
};
706
707
708
# Cache for class' ATTRS
709
my %Class_Attributes;
710
711
712
# Cache for class' defaults
713
my %Class_Defaults;
714
715
716
# Cache for $obj->isa(__PACKAGE__)
717
my %Isa_Package;
718
719
720
=head1 IMPORTS
721
722
=over
723
724
=item C' => I;>
725
726
Changes the default value for I. If the I name has no
727
special prefix, its default value is replaced with a new I.
728
729
use Exception::Base verbosity => 4;
730
731
If the I name starts with "C<+>" or "C<->" then the new I
732
is based on previous value:
733
734
=over
735
736
=item *
737
738
If the original I was a reference to array, the new I can
739
be included or removed from original array. Use array reference if you
740
need to add or remove more than one element.
741
742
use Exception::Base
743
"+ignore_packages" => [ __PACKAGE__, qr/^Moose::/ ],
744
"-ignore_class" => "My::Good::Class";
745
746
=item *
747
748
If the original I was a number, it will be incremented or
749
decremented by the new I.
750
751
use Exception::Base "+ignore_level" => 1;
752
753
=item *
754
755
If the original I was a string, the new I will be
756
included.
757
758
use Exception::Base "+message" => ": The incuded message";
759
760
=back
761
762
=item C', ...;>
763
764
Loads additional exception class module. If the module is not available,
765
creates the exception class automatically at compile time. The newly created
766
class will be based on C class.
767
768
use Exception::Base qw{ Exception::Custom Exception::SomethingWrong };
769
Exception::Custom->throw;
770
771
=item C' => { isa => I, version => I, ... };>
772
773
Loads additional exception class module. If the module's version is lower
774
than given parameter or the module can't be loaded, creates the exception
775
class automatically at compile time. The newly created class will be based on
776
given class and has the given $VERSION variable.
777
778
=over
779
780
=item isa
781
782
The newly created class will be based on given class.
783
784
use Exception::Base
785
'Exception::My',
786
'Exception::Nested' => { isa => 'Exception::My };
787
788
=item version
789
790
The class will be created only if the module's version is lower than given
791
parameter and will have the version given in the argument.
792
793
use Exception::Base
794
'Exception::My' => { version => 1.23 };
795
796
=item has
797
798
The class will contain new rw attribute (if parameter is a string) or new rw
799
attributes (if parameter is a reference to array of strings) or new rw or ro
800
attributes (if parameter is a reference to hash of array of strings with rw
801
and ro as hash key).
802
803
use Exception::Base
804
'Exception::Simple' => { has => 'field' },
805
'Exception::More' => { has => [ 'field1', 'field2' ] },
806
'Exception::Advanced' => { has => {
807
ro => [ 'field1', 'field2' ],
808
rw => [ 'field3' ]
809
} };
810
811
=item message
812
813
=item verbosity
814
815
=item max_arg_len
816
817
=item max_arg_nums
818
819
=item max_eval_len
820
821
=item I
822
823
The class will have the default property for the given attribute.
824
825
=back
826
827
use Exception::Base
828
'Exception::WithDefault' => { message => 'Default message' },
829
'Exception::Reason' => {
830
has => [ 'reason' ],
831
string_attributes => [ 'message', 'reason' ] };
832
833
=back
834
835
=cut
836
837
# Create additional exception packages
838
sub import {
839
54
54
20709
my $class = shift;
840
841
54
148
while (defined $_[0]) {
842
52
82
my $name = shift @_;
843
52
100
281
if ($name eq ':all') {
100
844
# do nothing for backward compatibility
845
}
846
elsif ($name =~ /^([+-]?)([a-z0-9_]+)$/) {
847
# Lower case: change default
848
21
55
my ($modifier, $key) = ($1, $2);
849
21
22
my $value = shift;
850
21
99
$class->_modify_default($key, $value, $modifier);
851
}
852
else {
853
# Try to use external module
854
30
55
my $param = {};
855
30
100
66
146
$param = shift @_ if defined $_[0] and ref $_[0] eq 'HASH';
856
857
30
100
85
my $version = defined $param->{version} ? $param->{version} : 0;
858
859
30
100
81
if (caller ne $name) {
860
29
100
48
next if eval { $name->VERSION($version) };
29
409
861
862
# Package is needed
863
{
864
27
43
local $SIG{__DIE__};
27
110
865
27
36
eval {
866
27
82
$class->_load_package($name, $version);
867
};
868
};
869
27
100
113
if ($@) {
870
# Die unless can't load module
871
26
100
103
if ($@ !~ /Can\'t locate/) {
872
3
15
Exception::Base->throw(
873
message => ["Can not load available %s class: %s", $name, $@],
874
verbosity => 1
875
);
876
};
877
}
878
else {
879
# Module is loaded: go to next
880
1
5
next;
881
};
882
};
883
884
24
50
56
next if $name eq __PACKAGE__;
885
886
# Package not found so it have to be created
887
24
100
54
if ($class ne __PACKAGE__) {
888
1
10
Exception::Base->throw(
889
message => ["Exceptions can only be created with %s class", __PACKAGE__],
890
verbosity => 1
891
);
892
};
893
23
66
$class->_make_exception($name, $version, $param);
894
}
895
}
896
897
45
4539
return $class;
898
};
899
900
901
=head1 CONSTRUCTORS
902
903
=over
904
905
=item new([%I])
906
907
Creates the exception object, which can be thrown later. The system data
908
attributes like C, C, C, C, C, C are not
909
filled.
910
911
If the key of the argument is read-write attribute, this attribute will be
912
filled. Otherwise, the argument will be ignored.
913
914
$e = Exception::Base->new(
915
message=>"Houston, we have a problem",
916
unknown_attr => "BIG"
917
);
918
print $e->{message};
919
920
The constructor reads the list of class attributes from ATTRS constant
921
function and stores it in the internal cache for performance reason. The
922
defaults values for the class are also stored in internal cache.
923
924
=item C-Ethrow([%I]])
925
926
Creates the exception object and immediately throws it with C system
927
function.
928
929
open my $fh, $file
930
or Exception::Base->throw( message=>"Can not open file: $file" );
931
932
The C is also exported as a function.
933
934
open my $fh, $file
935
or throw 'Exception::Base' => message=>"Can not open file: $file";
936
937
=back
938
939
The C can be also used as a method.
940
941
=cut
942
943
# Constructor
944
sub new {
945
72
72
1
23838
my ($self, %args) = @_;
946
947
72
66
293
my $class = ref $self || $self;
948
949
72
88
my $attributes;
950
my $defaults;
951
952
# Use cached value if available
953
72
100
177
if (not defined $Class_Attributes{$class}) {
954
22
97
$attributes = $Class_Attributes{$class} = $class->ATTRS;
955
286
709
$defaults = $Class_Defaults{$class} = {
956
522
883
map { $_ => $attributes->{$_}->{default} }
957
22
153
grep { defined $attributes->{$_}->{default} }
958
(keys %$attributes)
959
};
960
}
961
else {
962
50
79
$attributes = $Class_Attributes{$class};
963
50
92
$defaults = $Class_Defaults{$class};
964
};
965
966
72
175
my $e = {};
967
968
# If the attribute is rw, initialize its value. Otherwise: ignore.
969
1
1
7
no warnings 'uninitialized';
1
2
1
324
970
72
235
foreach my $key (keys %args) {
971
50
100
168
if ($attributes->{$key}->{is} eq 'rw') {
972
46
126
$e->{$key} = $args{$key};
973
};
974
};
975
976
# Defaults for this object
977
72
615
$e->{defaults} = { %$defaults };
978
979
72
766
bless $e => $class;
980
981
# Collect system data and eval error
982
72
256
$e->_collect_system_data;
983
984
72
316
return $e;
985
};
986
987
988
=head1 METHODS
989
990
=over
991
992
=item C<$obj>-Ethrow([%I])
993
994
Immediately throws exception object. It can be used for rethrowing existing
995
exception object. Additional arguments will override the attributes in
996
existing exception object.
997
998
$e = Exception::Base->new;
999
# (...)
1000
$e->throw( message=>"thrown exception with overridden message" );
1001
1002
eval { Exception::Base->throw( message=>"Problem", value=>1 ) };
1003
$@->throw if $@->value;
1004
1005
=item C<$obj>-Ethrow(I, [%I])
1006
1007
If the number of I list for arguments is odd, the first argument is a
1008
message. This message can be overridden by message from I list.
1009
1010
Exception::Base->throw( "Problem", message=>"More important" );
1011
eval { die "Bum!" };
1012
Exception::Base->throw( $@, message=>"New message" );
1013
1014
=item I-Ethrow($I, [%I])
1015
1016
Immediately rethrows an existing exception object as an other exception class.
1017
1018
eval { open $f, "w", "/etc/passwd" or Exception::System->throw };
1019
# convert Exception::System into Exception::Base
1020
Exception::Base->throw($@);
1021
1022
=cut
1023
1024
# Create the exception and throw it or rethrow existing
1025
sub throw {
1026
36
36
1
1043
my $self = shift;
1027
1028
36
66
152
my $class = ref $self || $self;
1029
1030
36
36
my $old_e;
1031
1032
36
100
70
if (not ref $self) {
1033
# CLASS->throw
1034
34
100
60
if (not ref $_[0]) {
1035
# Throw new exception
1036
33
100
78
if (scalar @_ % 2 == 0) {
1037
# Throw normal error
1038
30
130
die $self->new(@_);
1039
}
1040
else {
1041
# First argument is a default attribute; it can be overridden with normal args
1042
3
4
my $argument = shift;
1043
3
11
my $e = $self->new(@_);
1044
3
5
my $default_attribute = $e->{defaults}->{default_attribute};
1045
3
100
20
$e->{$default_attribute} = $argument if not defined $e->{$default_attribute};
1046
3
11
die $e;
1047
};
1048
}
1049
else {
1050
# First argument is an old exception
1051
1
2
$old_e = shift;
1052
};
1053
}
1054
else {
1055
# $e->throw
1056
2
4
$old_e = $self;
1057
};
1058
1059
# Rethrow old exception with replaced attributes
1060
1
1
6
no warnings 'uninitialized';
1
2
1
751
1061
3
8
my %args = @_;
1062
3
8
my $attrs = $old_e->ATTRS;
1063
3
10
foreach my $key (keys %args) {
1064
2
100
12
if ($attrs->{$key}->{is} eq 'rw') {
1065
1
4
$old_e->{$key} = $args{$key};
1066
};
1067
};
1068
3
9
$old_e->PROPAGATE;
1069
3
100
9
if (ref $old_e ne $class) {
1070
# Rebless old object for new class
1071
1
3
bless $old_e => $class;
1072
};
1073
1074
3
12
die $old_e;
1075
};
1076
1077
1078
=item I-Ecatch([$I])
1079
1080
The exception is recovered from I argument or C<$@> variable if
1081
I argument was empty. Then also C<$@> is replaced with empty string
1082
to avoid an endless loop.
1083
1084
The method returns an exception object if exception is caught or undefined
1085
value otherwise.
1086
1087
eval { Exception::Base->throw; };
1088
if ($@) {
1089
my $e = Exception::Base->catch;
1090
print $e->to_string;
1091
}
1092
1093
If the value is not empty and does not contain the C object,
1094
new exception object is created with class I and its message is based
1095
on previous value with removed C<" at file line 123."> string and the last end
1096
of line (LF).
1097
1098
eval { die "Died\n"; };
1099
my $e = Exception::Base->catch;
1100
print ref $e; # "Exception::Base"
1101
1102
=cut
1103
1104
# Recover $@ variable and return exception object
1105
sub catch {
1106
19
19
1
1039
my ($self) = @_;
1107
1108
19
66
80
my $class = ref $self || $self;
1109
1110
19
22
my $e;
1111
my $new_e;
1112
1113
1114
19
100
42
if (@_ > 1) {
1115
# Recover exception from argument
1116
1
3
$e = $_[1];
1117
}
1118
else {
1119
# Recover exception from $@ and clear it
1120
## no critic qw(RequireLocalizedPunctuationVars)
1121
18
21
$e = $@;
1122
18
27
$@ = '';
1123
};
1124
1125
19
100
66
67
if (ref $e and do { local $@; local $SIG{__DIE__}; eval { $e->isa(__PACKAGE__) } }) {
4
100
4
4
16
4
6
4
32
1126
# Caught exception
1127
3
6
$new_e = $e;
1128
}
1129
elsif ($e eq '') {
1130
# No error in $@
1131
2
4
$new_e = undef;
1132
}
1133
else {
1134
# New exception based on error from $@. Clean up the message.
1135
14
67
while ($e =~ s/\t\.\.\.propagated at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n$//s) { };
1136
14
89
$e =~ s/( at (?!.*\bat\b.*).* line \d+( thread \d+)?\.)?\n$//s;
1137
14
85
$new_e = $class->new;
1138
14
28
my $eval_attribute = $new_e->{defaults}->{eval_attribute};
1139
14
30
$new_e->{$eval_attribute} = $e;
1140
};
1141
1142
19
50
return $new_e;
1143
};
1144
1145
1146
=item matches(I)
1147
1148
Checks if the exception object matches the given argument.
1149
1150
The C method overloads C<~~> smart matching operator. Warning: The
1151
second argument for smart matching operator needs to be scalar.
1152
1153
If the argument is a reference to array, it is checked if the object is a
1154
given class.
1155
1156
use Exception::Base
1157
'Exception::Simple',
1158
'Exception::Complex' => { isa => 'Exception::Simple };
1159
eval { Exception::Complex->throw() };
1160
print $@->matches( ['Exception::Base'] ); # matches
1161
print $@->matches( ['Exception::Simple', 'Exception::X'] ); # matches
1162
print $@->matches( ['NullObject'] ); # doesn't
1163
1164
If the argument is a reference to hash, attributes of the exception
1165
object is matched.
1166
1167
eval { Exception::Base->throw( message=>"Message", value=>123 ) };
1168
print $@->matches( { message=>"Message" } ); # matches
1169
print $@->matches( { value=>123 } ); # matches
1170
print $@->matches( { message=>"Message", value=>45 } ); # doesn't
1171
1172
If the argument is a single string, regexp or code reference or is undefined,
1173
the default attribute of the exception object is matched (usually it is a
1174
"message" attribute).
1175
1176
eval { Exception::Base->throw( message=>"Message" ) };
1177
print $@->matches( "Message" ); # matches
1178
print $@->matches( qr/Message/ ); # matches
1179
print $@->matches( qr/[0-9]/ ); # doesn't
1180
print $@->matches( sub{/Message/} ); # matches
1181
print $@->matches( sub{0} ); # doesn't
1182
print $@->matches( undef ); # doesn't
1183
1184
If argument is a numeric value, the argument matches if C attribute
1185
matches.
1186
1187
eval { Exception::Base->throw( value=>123, message=>456 ) } );
1188
print $@->matches( 123 ); # matches
1189
print $@->matches( 456 ); # doesn't
1190
1191
If an attribute contains array reference, the array will be C-ed
1192
before matching.
1193
1194
eval { Exception::Base->throw( message=>["%s", "Message"] ) };
1195
print $@->matches( "Message" ); # matches
1196
print $@->matches( qr/Message/ ); # matches
1197
print $@->matches( qr/[0-9]/ ); # doesn't
1198
1199
The C method matches for special keywords:
1200
1201
=over
1202
1203
=item -isa
1204
1205
Matches if the object is a given class.
1206
1207
eval { Exception::Base->new( message=>"Message" ) };
1208
print $@->matches( { -isa=>"Exception::Base" } ); # matches
1209
print $@->matches( { -isa=>["X::Y", "Exception::Base"] } ); # matches
1210
1211
=item -has
1212
1213
Matches if the object has a given attribute.
1214
1215
eval { Exception::Base->new( message=>"Message" ) };
1216
print $@->matches( { -has=>"Message" } ); # matches
1217
1218
=item -default
1219
1220
Matches against the default attribute, usually the C attribute.
1221
1222
eval { Exception::Base->new( message=>"Message" ) };
1223
print $@->matches( { -default=>"Message" } ); # matches
1224
1225
=back
1226
1227
=cut
1228
1229
# Smart matching.
1230
sub matches { ## no critic qw(ProhibitExcessComplexity)
1231
159
159
1
5397
my ($self, $that) = @_;
1232
1233
159
182
my @args;
1234
1235
159
272
my $default_attribute = $self->{defaults}->{default_attribute};
1236
159
220
my $numeric_attribute = $self->{defaults}->{numeric_attribute};
1237
1238
159
100
100
762
if (ref $that eq 'ARRAY') {
100
100
100
100
100
1239
7
17
@args = ( '-isa' => $that );
1240
}
1241
elsif (ref $that eq 'HASH') {
1242
100
248
@args = %$that;
1243
}
1244
elsif (ref $that eq 'Regexp' or ref $that eq 'CODE' or not defined $that) {
1245
24
43
@args = ( $that );
1246
}
1247
elsif (ref $that) {
1248
3
15
return '';
1249
}
1250
elsif ($that =~ _RE_NUM_INT) {
1251
13
30
@args = ( $numeric_attribute => $that );
1252
}
1253
else {
1254
12
33
@args = ( $that );
1255
};
1256
1257
156
50
312
return '' unless @args;
1258
1259
# Odd number of arguments - first is default attribute
1260
156
100
335
if (scalar @args % 2 == 1) {
1261
36
52
my $val = shift @args;
1262
36
50
66
212
if (ref $val eq 'ARRAY') {
100
50
100
1263
0
0
my $arrret = 0;
1264
0
0
foreach my $arrval (@{ $val }) {
0
0
1265
0
0
0
0
if (not defined $arrval) {
0
0
1266
0
0
0
$arrret = 1 if not $self->_string_attributes;
1267
}
1268
elsif (not ref $arrval and $arrval =~ _RE_NUM_INT) {
1269
1
1
7
no warnings 'numeric', 'uninitialized';
1
2
1
198
1270
0
0
0
$arrret = 1 if $self->{$numeric_attribute} == $arrval;
1271
}
1272
elsif (not $self->_string_attributes) {
1273
0
0
next;
1274
}
1275
else {
1276
0
0
local $_ = join ': ', $self->_string_attributes;
1277
0
0
0
if (ref $arrval eq 'CODE') {
0
1278
0
0
0
$arrret = 1 if $arrval->();
1279
}
1280
elsif (ref $arrval eq 'Regexp') {
1281
0
0
0
$arrret = 1 if /$arrval/;
1282
}
1283
else {
1284
0
0
0
$arrret = 1 if $_ eq $arrval;
1285
};
1286
};
1287
0
0
0
last if $arrret;
1288
};
1289
# Fail unless at least one condition is true
1290
0
0
0
return '' if not $arrret;
1291
}
1292
elsif (not defined $val) {
1293
8
100
25
return '' if $self->_string_attributes;
1294
}
1295
elsif (not ref $val and $val =~ _RE_NUM_INT) {
1296
1
1
5
no warnings 'numeric', 'uninitialized';
1
22
1
585
1297
0
0
0
return '' if $self->{$numeric_attribute} != $val;
1298
}
1299
elsif (not $self->_string_attributes) {
1300
7
50
return '';
1301
}
1302
else {
1303
21
53
local $_ = join ': ', $self->_string_attributes;
1304
21
100
71
if (ref $val eq 'CODE') {
100
1305
6
100
19
return '' if not $val->();
1306
}
1307
elsif (ref $val eq 'Regexp') {
1308
6
100
54
return '' if not /$val/;
1309
}
1310
else {
1311
9
100
41
return '' if $_ ne $val;
1312
};
1313
};
1314
17
50
154
return 1 unless @args;
1315
};
1316
1317
120
231
my %args = @args;
1318
120
327
while (my($key,$val) = each %args) {
1319
126
100
11100
if ($key eq '-default') {
1320
6
9
$key = $default_attribute;
1321
};
1322
1323
## no critic qw(ProhibitCascadingIfElse)
1324
126
100
100
619
if ($key eq '-isa') {
100
100
100
100
100
1325
11
100
25
if (ref $val eq 'ARRAY') {
1326
9
18
my $arrret = 0;
1327
9
13
foreach my $arrval (@{ $val }) {
9
21
1328
21
50
42
next if not defined $arrval;
1329
21
100
979
$arrret = 1 if $self->isa($arrval);
1330
21
100
47
last if $arrret;
1331
};
1332
9
100
58
return '' if not $arrret;
1333
}
1334
else {
1335
2
100
22
return '' if not $self->isa($val);
1336
};
1337
}
1338
elsif ($key eq '-has') {
1339
4
100
10
if (ref $val eq 'ARRAY') {
1340
2
3
my $arrret = 0;
1341
2
5
foreach my $arrval (@{ $val }) {
2
4
1342
5
50
12
next if not defined $arrval;
1343
5
100
11
$arrret = 1 if exists $self->ATTRS->{$arrval};
1344
5
100
15
last if $arrret;
1345
};
1346
2
100
13
return '' if not $arrret;
1347
}
1348
else {
1349
2
100
6
return '' if not $self->ATTRS->{$val};
1350
};
1351
}
1352
elsif (ref $val eq 'ARRAY') {
1353
38
43
my $arrret = 0;
1354
38
39
foreach my $arrval (@{ $val }) {
38
66
1355
77
100
173
if (not defined $arrval) {
100
1356
17
100
40
$arrret = 1 if not defined $self->{$key};
1357
}
1358
elsif (not defined $self->{$key}) {
1359
24
28
next;
1360
}
1361
else {
1362
9
14
local $_ = ref $self->{$key} eq 'ARRAY'
1363
? sprintf(
1364
9
28
@{$self->{$key}}[0],
1365
36
100
79
@{$self->{$key}}[1..@{$self->{$key}}]
9
24
1366
)
1367
: $self->{$key};
1368
36
100
89
if (ref $arrval eq 'CODE') {
100
1369
8
100
24
$arrret = 1 if $arrval->();
1370
}
1371
elsif (ref $arrval eq 'Regexp') {
1372
12
100
4981
$arrret = 1 if /$arrval/;
1373
}
1374
else {
1375
16
100
37
$arrret = 1 if $_ eq $arrval;
1376
};
1377
};
1378
53
100
146
last if $arrret;
1379
};
1380
38
100
211
return '' if not $arrret;
1381
}
1382
elsif (not defined $val) {
1383
12
100
100
90
return '' if exists $self->{$key} && defined $self->{$key};
1384
}
1385
elsif (not ref $val and $val =~ _RE_NUM_INT) {
1386
1
1
5
no warnings 'numeric', 'uninitialized';
1
1
1
550
1387
17
100
202
return '' if $self->{$key} != $val;
1388
}
1389
elsif (not defined $self->{$key}) {
1390
10
56
return '';
1391
}
1392
else {
1393
10
19
local $_ = ref $self->{$key} eq 'ARRAY'
1394
? sprintf(
1395
10
35
@{$self->{$key}}[0],
1396
34
100
76
@{$self->{$key}}[1..@{$self->{$key}}]
10
23
1397
)
1398
: $self->{$key};
1399
1400
34
100
88
if (ref $val eq 'CODE') {
100
1401
12
100
27
return '' if not $val->();
1402
}
1403
elsif (ref $val eq 'Regexp') {
1404
12
100
129
return '' if not /$val/;
1405
}
1406
else {
1407
10
100
62
return '' if $_ ne $val;
1408
};
1409
};
1410
};
1411
1412
62
375
return 1;
1413
}
1414
1415
1416
=item to_string
1417
1418
Returns the string representation of exception object. It is called
1419
automatically if the exception object is used in string scalar context. The
1420
method can be used explicitly.
1421
1422
eval { Exception::Base->throw; };
1423
$@->{verbosity} = 1;
1424
print "$@";
1425
$@->verbosity = 4;
1426
print $@->to_string;
1427
1428
=cut
1429
1430
# Convert an exception to string
1431
sub to_string {
1432
58
58
1
718
my ($self) = @_;
1433
1434
58
100
178
my $verbosity = defined $self->{verbosity}
1435
? $self->{verbosity}
1436
: $self->{defaults}->{verbosity};
1437
1438
58
135
my $message = join ': ', $self->_string_attributes;
1439
1440
58
100
144
if ($message eq '') {
1441
4
6
foreach (reverse @{ $self->{defaults}->{string_attributes} }) {
4
11
1442
4
8
$message = $self->{defaults}->{$_};
1443
4
50
14
last if defined $message;
1444
};
1445
};
1446
1447
58
100
358
if ($verbosity == 1) {
100
100
1448
18
100
80
return $message if $message =~ /\n$/;
1449
1450
14
92
return $message . "\n";
1451
}
1452
elsif ($verbosity == 2) {
1453
20
100
64
return $message if $message =~ /\n$/;
1454
1455
19
62
my @stacktrace = $self->get_caller_stacktrace;
1456
19
144
return $message . $stacktrace[0] . ".\n";
1457
}
1458
elsif ($verbosity >= 3) {
1459
16
59
return ref($self) . ': ' . $message . $self->get_caller_stacktrace;
1460
};
1461
1462
4
22
return '';
1463
};
1464
1465
1466
=item to_number
1467
1468
Returns the numeric representation of exception object. It is called
1469
automatically if the exception object is used in numeric scalar context. The
1470
method can be used explicitly.
1471
1472
eval { Exception::Base->throw( value => 42 ); };
1473
print 0+$@; # 42
1474
print $@->to_number; # 42
1475
1476
=cut
1477
1478
# Convert an exception to number
1479
sub to_number {
1480
9
9
1
40
my ($self) = @_;
1481
1482
9
19
my $numeric_attribute = $self->{defaults}->{numeric_attribute};
1483
1484
1
1
6
no warnings 'numeric';
1
1
1
2361
1485
9
100
31
return 0+ $self->{$numeric_attribute} if defined $self->{$numeric_attribute};
1486
6
100
33
return 0+ $self->{defaults}->{$numeric_attribute} if defined $self->{defaults}->{$numeric_attribute};
1487
2
9
return 0;
1488
};
1489
1490
1491
=item to_bool
1492
1493
Returns the boolean representation of exception object. It is called
1494
automatically if the exception object is used in boolean context. The method
1495
can be used explicitly.
1496
1497
eval { Exception::Base->throw; };
1498
print "ok" if $@; # ok
1499
print "ok" if $@->to_bool; # ok
1500
1501
=cut
1502
1503
# Convert an exception to bool (always true)
1504
sub to_bool {
1505
1
1
1
27
return !! 1;
1506
};
1507
1508
1509
=item get_caller_stacktrace
1510
1511
Returns an array of strings or string with caller stack trace. It is
1512
implicitly used by C method.
1513
1514
=cut
1515
1516
# Stringify caller backtrace. Stolen from Carp
1517
sub get_caller_stacktrace {
1518
35
35
1
57
my ($self) = @_;
1519
1520
35
38
my @stacktrace;
1521
1522
35
65
my $tid_msg = '';
1523
35
50
86
$tid_msg = ' thread ' . $self->{tid} if $self->{tid};
1524
1525
35
100
90
my $verbosity = defined $self->{verbosity}
1526
? $self->{verbosity}
1527
: $self->{defaults}->{verbosity};
1528
1529
35
50
93
my $ignore_level = defined $self->{ignore_level}
100
1530
? $self->{ignore_level}
1531
: defined $self->{defaults}->{ignore_level}
1532
? $self->{defaults}->{ignore_level}
1533
: 0;
1534
1535
# Skip some packages for first line
1536
35
41
my $level = 0;
1537
35
107
while (my %c = $self->_caller_info($level++)) {
1538
79
100
340
next if $self->_skip_ignored_package($c{package});
1539
# Skip ignored levels
1540
36
100
86
if ($ignore_level > 0) {
1541
5
6
--$ignore_level;
1542
5
27
next;
1543
};
1544
31
50
33
322
push @stacktrace, sprintf " at %s line %s%s",
50
1545
defined $c{file} && $c{file} ne '' ? $c{file} : 'unknown',
1546
$c{line} || 0,
1547
$tid_msg;
1548
31
92
last;
1549
};
1550
# First line have to be filled even if everything was skipped
1551
35
100
114
if (not @stacktrace) {
1552
4
12
my %c = $self->_caller_info(0);
1553
4
100
66
58
push @stacktrace, sprintf " at %s line %s%s",
100
1554
defined $c{file} && $c{file} ne '' ? $c{file} : 'unknown',
1555
$c{line} || 0,
1556
$tid_msg;
1557
};
1558
35
100
86
if ($verbosity >= 3) {
1559
# Reset the stack trace level only if needed
1560
16
100
35
if ($verbosity >= 4) {
1561
4
14
$level = 0;
1562
};
1563
# Dump the caller stack
1564
16
48
while (my %c = $self->_caller_info($level++)) {
1565
24
50
66
72
next if $verbosity == 3 and $self->_skip_ignored_package($c{package});
1566
24
186
push @stacktrace, "\t$c{wantarray}$c{sub_name} called in package $c{package} at $c{file} line $c{line}";
1567
};
1568
# Dump the propagated stack
1569
16
22
foreach (@{ $self->{propagated_stack} }) {
16
47
1570
24
174
my ($package, $file, $line) = @$_;
1571
# Skip ignored package
1572
24
100
100
91
next if $verbosity <= 3 and $self->_skip_ignored_package($package);
1573
19
50
33
170
push @stacktrace, sprintf "\t...propagated in package %s at %s line %d.",
50
1574
$package,
1575
defined $file && $file ne '' ? $file : 'unknown',
1576
$line || 0;
1577
};
1578
};
1579
1580
35
100
237
return wantarray ? @stacktrace : join("\n", @stacktrace) . "\n";
1581
};
1582
1583
1584
=item PROPAGATE
1585
1586
Checks the caller stack and fills the C attribute. It is
1587
usually used if C system function was called without any arguments.
1588
1589
=cut
1590
1591
# Propagate exception if it is rethrown
1592
sub PROPAGATE {
1593
3
3
1
4
my ($self) = @_;
1594
1595
# Fill propagate stack
1596
3
4
my $level = 1;
1597
3
22
while (my @c = caller($level++)) {
1598
# Skip own package
1599
next if ! defined $Isa_Package{$c[0]}
1600
3
50
11
? $Isa_Package{$c[0]} = do { local $@; local $SIG{__DIE__}; eval { $c[0]->isa(__PACKAGE__) } }
0
50
0
0
0
0
0
0
0
1601
: $Isa_Package{$c[0]};
1602
# Collect the caller stack
1603
3
4
push @{ $self->{propagated_stack} }, [ @c[0..2] ];
3
11
1604
3
7
last;
1605
};
1606
1607
3
7
return $self;
1608
};
1609
1610
1611
# Return a list of values of default string attributes
1612
sub _string_attributes {
1613
115
115
468
my ($self) = @_;
1614
1615
111
100
100
513
return map { ref $_ eq 'ARRAY'
136
100
1113
1616
? sprintf(@$_[0], @$_[1..@$_])
1617
: $_ }
1618
136
329
grep { defined $_ and (ref $_ or $_ ne '') }
1619
115
359
map { $self->{$_} }
1620
115
131
@{ $self->{defaults}->{string_attributes} };
1621
};
1622
1623
1624
=item _collect_system_data
1625
1626
Collects system data and fills the attributes of exception object. This
1627
method is called automatically if exception if thrown or created by
1628
C constructor. It can be overridden by derived class.
1629
1630
package Exception::Special;
1631
use base 'Exception::Base';
1632
use constant ATTRS => {
1633
%{Exception::Base->ATTRS},
1634
'special' => { is => 'ro' },
1635
};
1636
sub _collect_system_data {
1637
my $self = shift;
1638
$self->SUPER::_collect_system_data(@_);
1639
$self->{special} = get_special_value();
1640
return $self;
1641
}
1642
BEGIN {
1643
__PACKAGE__->_make_accessors;
1644
}
1645
1;
1646
1647
Method returns the reference to the self object.
1648
1649
=cut
1650
1651
# Collect system data and fill the attributes and caller stack.
1652
sub _collect_system_data {
1653
73
73
117
my ($self) = @_;
1654
1655
# Collect system data only if verbosity is meaning
1656
73
100
1903
my $verbosity = defined $self->{verbosity} ? $self->{verbosity} : $self->{defaults}->{verbosity};
1657
73
100
180
if ($verbosity >= 2) {
1658
62
124
$self->{time} = CORE::time();
1659
62
50
152
$self->{tid} = threads->tid if defined &threads::tid;
1660
62
112
@{$self}{qw < pid uid euid gid egid >} =
62
1218
1661
( $$, $<, $>, $(, $) );
1662
1663
# Collect stack info
1664
62
112
my @caller_stack;
1665
62
78
my $level = 1;
1666
1667
## no critic qw(ProhibitMultiplePackages ProhibitPackageVars)
1668
62
81
while (my @c = do { package DB; caller($level++) }) {
102
1066
1669
# Skip own package
1670
102
100
9090
next if ! defined $Isa_Package{$c[0]} ? $Isa_Package{$c[0]} = do { local $@; local $SIG{__DIE__}; eval { $c[0]->isa(__PACKAGE__) } } : $Isa_Package{$c[0]};
3
100
6
3
14
3
6
3
39
1671
# Collect the caller stack
1672
62
141
my @args = @DB::args;
1673
62
124
if (_HAVE_SCALAR_UTIL_WEAKEN) {
1674
62
117
foreach (@args) {
1675
131
100
337
Scalar::Util::weaken($_) if ref $_;
1676
};
1677
};
1678
62
381
my @stacktrace_element = ( @c[0 .. 7], @args );
1679
62
118
push @caller_stack, \@stacktrace_element;
1680
# Collect only one entry if verbosity is lower than 3 and skip ignored packages
1681
62
50
33
363
last if $verbosity == 2 and not $self->_skip_ignored_package($stacktrace_element[0]);
1682
};
1683
62
234
$self->{caller_stack} = \@caller_stack;
1684
};
1685
1686
73
125
return $self;
1687
};
1688
1689
1690
# Check if package should be ignored
1691
sub _skip_ignored_package {
1692
185
185
495
my ($self, $package) = @_;
1693
1694
185
100
8082
my $ignore_package = defined $self->{ignore_package}
1695
? $self->{ignore_package}
1696
: $self->{defaults}->{ignore_package};
1697
1698
185
100
537
my $ignore_class = defined $self->{ignore_class}
1699
? $self->{ignore_class}
1700
: $self->{defaults}->{ignore_class};
1701
1702
185
50
518
if (defined $ignore_package) {
1703
185
100
491
if (ref $ignore_package eq 'ARRAY') {
1704
140
100
144
if (@{ $ignore_package }) {
140
455
1705
20
100
66
21
do { return 1 if defined $_ and (ref $_ eq 'Regexp' and $package =~ $_ or ref $_ ne 'Regexp' and $package eq $_) } foreach @{ $ignore_package };
20
33
43
40
580
1706
};
1707
}
1708
else {
1709
45
100
326
return 1 if ref $ignore_package eq 'Regexp' ? $package =~ $ignore_package : $package eq $ignore_package;
100
1710
};
1711
}
1712
147
50
301
if (defined $ignore_class) {
1713
147
100
285
if (ref $ignore_class eq 'ARRAY') {
1714
138
100
134
if (@{ $ignore_class }) {
138
468
1715
14
100
16
return 1 if grep { do { local $@; local $SIG{__DIE__}; eval { $package->isa($_) } } } @{ $ignore_class };
42
43
42
43
42
99
42
47
42
457
14
23
1716
};
1717
}
1718
else {
1719
9
100
10
return 1 if do { local $@; local $SIG{__DIE__}; eval { $package->isa($ignore_class) } };
9
11
9
27
9
13
9
141
1720
};
1721
};
1722
1723
133
748
return '';
1724
};
1725
1726
1727
# Return info about caller. Stolen from Carp
1728
sub _caller_info {
1729
160
160
239
my ($self, $i) = @_;
1730
160
186
my %call_info;
1731
160
229
my @call_info = ();
1732
1733
160
100
66
946
@call_info = @{ $self->{caller_stack}->[$i] }
138
443
1734
if defined $self->{caller_stack} and defined $self->{caller_stack}->[$i];
1735
1736
@call_info{
1737
160
965
qw{ package file line subroutine has_args wantarray evaltext is_require }
1738
} = @call_info[0..7];
1739
1740
160
100
528
unless (defined $call_info{package}) {
1741
22
103
return ();
1742
};
1743
1744
138
568
my $sub_name = $self->_get_subname(\%call_info);
1745
138
100
425
if ($call_info{has_args}) {
1746
74
196
my @args = map {$self->_format_arg($_)} @call_info[8..$#call_info];
307
9816
1747
74
100
551
my $max_arg_nums = defined $self->{max_arg_nums} ? $self->{max_arg_nums} : $self->{defaults}->{max_arg_nums};
1748
74
100
100
380
if ($max_arg_nums > 0 and $#args+1 > $max_arg_nums) {
1749
25
89
$#args = $max_arg_nums - 2;
1750
25
41
push @args, '...';
1751
};
1752
# Push the args onto the subroutine
1753
74
329
$sub_name .= '(' . join (', ', @args) . ')';
1754
}
1755
138
100
300
$call_info{file} = 'unknown' unless $call_info{file};
1756
138
100
580
$call_info{line} = 0 unless $call_info{line};
1757
138
308
$call_info{sub_name} = $sub_name;
1758
138
100
321
$call_info{wantarray} = $call_info{wantarray} ? '@_ = ' : '$_ = ';
1759
1760
138
100
2126
return wantarray() ? %call_info : \%call_info;
1761
};
1762
1763
1764
# Figures out the name of the sub/require/eval. Stolen from Carp
1765
sub _get_subname {
1766
146
146
205
my ($self, $info) = @_;
1767
146
100
588
if (defined($info->{evaltext})) {
1768
26
47
my $eval = $info->{evaltext};
1769
26
100
55
if ($info->{is_require}) {
1770
2
8
return "require $eval";
1771
}
1772
else {
1773
24
53
$eval =~ s/([\\\'])/\\$1/g;
1774
return
1775
24
100
89
"eval '" .
1776
$self->_str_len_trim($eval, defined $self->{max_eval_len} ? $self->{max_eval_len} : $self->{defaults}->{max_eval_len}) .
1777
"'";
1778
};
1779
};
1780
1781
120
100
418
return ($info->{subroutine} eq '(eval)') ? 'eval {...}' : $info->{subroutine};
1782
};
1783
1784
1785
# Transform an argument to a function into a string. Stolen from Carp
1786
sub _format_arg {
1787
327
327
516
my ($self, $arg) = @_;
1788
1789
327
100
656
return 'undef' if not defined $arg;
1790
1791
325
100
100
481
if (do { local $@; local $SIG{__DIE__}; eval { $arg->isa(__PACKAGE__) } } or ref $arg) {
325
354
325
1126
325
514
325
4620
1792
22
81
return q{"} . overload::StrVal($arg) . q{"};
1793
};
1794
1795
303
495
$arg =~ s/\\/\\\\/g;
1796
303
345
$arg =~ s/"/\\"/g;
1797
303
1082
$arg =~ s/`/\\`/g;
1798
303
100
1156
$arg = $self->_str_len_trim($arg, defined $self->{max_arg_len} ? $self->{max_arg_len} : $self->{defaults}->{max_arg_len});
1799
1800
303
100
1482
$arg = "\"$arg\"" unless $arg =~ /^-?[\d.]+\z/;
1801
1802
## no critic qw(ProhibitNoWarnings)
1803
1
1
9
no warnings 'once', 'utf8'; # can't disable critic for utf8...
1
3
1
793
1804
303
50
33
1062
if (not defined *utf8::is_utf{CODE} or utf8::is_utf8($arg)) {
1805
303
100
873
$arg = join('', map { $_ > 255
761
100
4915
1806
? sprintf("\\x{%04x}", $_)
1807
: chr($_) =~ /[[:cntrl:]]|[[:^ascii:]]/
1808
? sprintf("\\x{%02x}", $_)
1809
: chr($_)
1810
} unpack("U*", $arg));
1811
}
1812
else {
1813
0
0
$arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%02x}",ord($1))/eg;
0
0
1814
};
1815
1816
303
967
return $arg;
1817
};
1818
1819
1820
# If a string is too long, trims it with ... . Stolen from Carp
1821
sub _str_len_trim {
1822
369
369
771
my (undef, $str, $max) = @_;
1823
369
100
945
$max = 0 unless defined $max;
1824
369
100
100
1532
if ($max > 2 and $max < length($str)) {
1825
## no critic qw(ProhibitLvalueSubstr)
1826
66
127
substr($str, $max - 3) = '...';
1827
};
1828
1829
369
1101
return $str;
1830
};
1831
1832
1833
# Modify default values for ATTRS
1834
sub _modify_default {
1835
21
21
34
my ($self, $key, $value, $modifier) = @_;
1836
1837
21
33
72
my $class = ref $self || $self;
1838
1839
# Modify entry in ATTRS constant. Its elements are not constant.
1840
21
47
my $attributes = $class->ATTRS;
1841
1842
21
100
90
if (not exists $attributes->{$key}->{default}) {
1843
1
6
Exception::Base->throw(
1844
message => ["%s class does not implement default value for `%s' attribute", $class, $key],
1845
verbosity => 1
1846
);
1847
};
1848
1849
# Make a new anonymous hash reference for attribute
1850
20
22
$attributes->{$key} = { %{ $attributes->{$key} } };
20
71
1851
1852
# Modify default value of attribute
1853
20
100
52
if ($modifier eq '+') {
100
1854
7
14
my $old = $attributes->{$key}->{default};
1855
7
100
66
38
if (ref $old eq 'ARRAY' or ref $value eq 'Regexp') {
100
1856
5
50
12
my @new = ref $old eq 'ARRAY' ? @{ $old } : $old;
5
12
1857
5
100
11
foreach my $v (ref $value eq 'ARRAY' ? @{ $value } : $value) {
3
6
1858
9
50
27
next if grep { $v eq $_ } ref $old eq 'ARRAY' ? @{ $old } : $old;
28
100
43
9
10
1859
5
11
push @new, $v;
1860
};
1861
5
20
$attributes->{$key}->{default} = [ @new ];
1862
}
1863
elsif ($old =~ /^\d+$/) {
1864
1
3
$attributes->{$key}->{default} += $value;
1865
}
1866
else {
1867
1
3
$attributes->{$key}->{default} .= $value;
1868
};
1869
}
1870
elsif ($modifier eq '-') {
1871
6
12
my $old = $attributes->{$key}->{default};
1872
6
100
66
28
if (ref $old eq 'ARRAY' or ref $value eq 'Regexp') {
100
1873
4
50
9
my @new = ref $old eq 'ARRAY' ? @{ $old } : $old;
4
8
1874
4
100
10
foreach my $v (ref $value eq 'ARRAY' ? @{ $value } : $value) {
3
6
1875
7
10
@new = grep { $v ne $_ } @new;
20
32
1876
};
1877
4
13
$attributes->{$key}->{default} = [ @new ];
1878
}
1879
elsif ($old =~ /^\d+$/) {
1880
1
4
$attributes->{$key}->{default} -= $value;
1881
}
1882
else {
1883
1
3
$attributes->{$key}->{default} = $value;
1884
};
1885
}
1886
else {
1887
7
16
$attributes->{$key}->{default} = $value;
1888
};
1889
1890
# Redeclare constant
1891
{
1892
1
1
6
no warnings 'redefine';
1
3
1
186
20
24
1893
20
85
*{_qualify_to_ref("${class}::ATTRS")} = sub () {
1894
32
32
609
+{ %$attributes };
1895
20
57
};
1896
};
1897
1898
# Reset cache
1899
20
384
%Class_Attributes = %Class_Defaults = ();
1900
1901
20
707
return $self;
1902
};
1903
1904
1905
=item _make_accessors
1906
1907
Creates accessors for each attribute. This static method should be called in
1908
each derived class which defines new attributes.
1909
1910
package Exception::My;
1911
# (...)
1912
BEGIN {
1913
__PACKAGE__->_make_accessors;
1914
}
1915
1916
=cut
1917
1918
# Create accessors for this class
1919
sub _make_accessors {
1920
20
20
36
my ($self) = @_;
1921
1922
20
33
93
my $class = ref $self || $self;
1923
1924
1
1
6
no warnings 'uninitialized';
1
3
1
1402
1925
20
54
my $attributes = $class->ATTRS;
1926
20
54
foreach my $key (keys %{ $attributes }) {
20
102
1927
470
50
1238
next if ref $attributes->{$key} ne 'HASH';
1928
470
100
3874
if (not $class->can($key)) {
1929
128
100
339
next if not defined $attributes->{$key}->{is};
1930
28
100
61
if ($attributes->{$key}->{is} eq 'rw') {
1931
16
57
*{_qualify_to_ref($class . '::' . $key)} = sub :lvalue {
1932
16
100
16
267
@_ > 1 ? $_[0]->{$key} = $_[1]
1933
: $_[0]->{$key};
1934
16
58
};
1935
}
1936
else {
1937
12
52
*{_qualify_to_ref($class . '::' . $key)} = sub {
1938
4
4
109
$_[0]->{$key};
1939
12
65
};
1940
};
1941
};
1942
};
1943
1944
20
103
return $self;
1945
};
1946
1947
1948
=item package
1949
1950
Returns the package name of the subroutine which thrown an exception.
1951
1952
=item file
1953
1954
Returns the file name of the subroutine which thrown an exception.
1955
1956
=item line
1957
1958
Returns the line number for file of the subroutine which thrown an exception.
1959
1960
=item subroutine
1961
1962
Returns the subroutine name which thrown an exception.
1963
1964
=back
1965
1966
=cut
1967
1968
# Create caller_info() accessors for this class
1969
sub _make_caller_info_accessors {
1970
1
1
3
my ($self) = @_;
1971
1972
1
33
7
my $class = ref $self || $self;
1973
1974
1
3
foreach my $key (qw{ package file line subroutine }) {
1975
4
50
56
if (not $class->can($key)) {
1976
4
14
*{_qualify_to_ref($class . '::' . $key)} = sub {
1977
12
12
33
my $self = shift;
1978
12
50
38
my $ignore_level = defined $self->{ignore_level}
100
1979
? $self->{ignore_level}
1980
: defined $self->{defaults}->{ignore_level}
1981
? $self->{defaults}->{ignore_level}
1982
: 0;
1983
12
20
my $level = 0;
1984
12
30
while (my %c = $self->_caller_info($level++)) {
1985
24
100
65
next if $self->_skip_ignored_package($c{package});
1986
# Skip ignored levels
1987
20
100
49
if ($ignore_level > 0) {
1988
8
11
$ignore_level --;
1989
8
40
next;
1990
};
1991
12
96
return $c{$key};
1992
};
1993
4
44
};
1994
};
1995
};
1996
1997
1
124
return $self;
1998
};
1999
2000
2001
# Load another module without eval q{}
2002
sub _load_package {
2003
28
28
43
my ($class, $package, $version) = @_;
2004
2005
28
50
61
return unless $package;
2006
2007
28
56
my $file = $package . '.pm';
2008
28
123
$file =~ s{::}{/}g;
2009
2010
28
14382
require $file;
2011
2012
# Check version if first element on list is a version number.
2013
4
50
33
131
if (defined $version and $version =~ m/^\d/) {
2014
4
60
$package->VERSION($version);
2015
};
2016
2017
1
6
return $class;
2018
};
2019
2020
2021
# Create new exception class
2022
sub _make_exception {
2023
23
23
43
my ($class, $package, $version, $param) = @_;
2024
2025
23
50
51
return unless $package;
2026
2027
23
100
61
my $isa = defined $param->{isa} ? $param->{isa} : __PACKAGE__;
2028
23
100
56
$version = 0.01 if not $version;
2029
2030
23
100
81
my $has = defined $param->{has} ? $param->{has} : { rw => [ ], ro => [ ] };
2031
23
100
77
if (ref $has eq 'ARRAY') {
100
2032
3
17
$has = { rw => $has, ro => [ ] };
2033
}
2034
elsif (not ref $has) {
2035
2
9
$has = { rw => [ $has ], ro => [ ] };
2036
};
2037
23
43
foreach my $mode ('rw', 'ro') {
2038
46
100
136
if (not ref $has->{$mode}) {
2039
6
100
32
$has->{$mode} = [ defined $has->{$mode} ? $has->{$mode} : () ];
2040
};
2041
};
2042
2043
# Base class is needed
2044
23
100
28
if (not defined do { local $SIG{__DIE__}; eval { $isa->VERSION } }) {
23
69
23
41
23
286
2045
1
2
eval {
2046
1
3
$class->_load_package($isa);
2047
};
2048
1
50
5
if ($@) {
2049
1
6
Exception::Base->throw(
2050
message => ["Base class %s for class %s can not be found", $isa, $package],
2051
verbosity => 1
2052
);
2053
};
2054
};
2055
2056
# Handle defaults for object attributes
2057
22
58
my $attributes;
2058
{
2059
22
24
local $SIG{__DIE__};
22
54
2060
22
24
eval {
2061
22
53
$attributes = $isa->ATTRS;
2062
};
2063
};
2064
22
50
52
if ($@) {
2065
0
0
Exception::Base->throw(
2066
message => ["%s class is based on %s class which does not implement ATTRS", $package, $isa],
2067
verbosity => 1
2068
);
2069
};
2070
2071
# Create the hash with overridden attributes
2072
22
27
my %overridden_attributes;
2073
# Class => { has => { rw => [ "attr1", "attr2", "attr3", ... ], ro => [ "attr4", ... ] } }
2074
22
37
foreach my $mode ('rw', 'ro') {
2075
42
45
foreach my $attribute (@{ $has->{$mode} }) {
42
210
2076
12
100
66
133
if ($attribute =~ /^(isa|version|has)$/ or $isa->can($attribute)) {
2077
2
12
Exception::Base->throw(
2078
message => ["Attribute name `%s' can not be defined for %s class", $attribute, $package],
2079
);
2080
};
2081
10
51
$overridden_attributes{$attribute} = { is => $mode };
2082
};
2083
};
2084
# Class => { message => "overridden default", ... }
2085
20
25
foreach my $attribute (keys %{ $param }) {
20
57
2086
14
100
79
next if $attribute =~ /^(isa|version|has)$/;
2087
4
50
66
16
if (not exists $attributes->{$attribute}->{default}
2088
and not exists $overridden_attributes{$attribute})
2089
{
2090
1
6
Exception::Base->throw(
2091
message => ["%s class does not implement default value for `%s' attribute", $isa, $attribute],
2092
verbosity => 1
2093
);
2094
};
2095
3
6
$overridden_attributes{$attribute} = {};
2096
3
8
$overridden_attributes{$attribute}->{default} = $param->{$attribute};
2097
3
5
foreach my $property (keys %{ $attributes->{$attribute} }) {
3
9
2098
6
100
14
next if $property eq 'default';
2099
3
10
$overridden_attributes{$attribute}->{$property} = $attributes->{$attribute}->{$property};
2100
};
2101
};
2102
2103
# Create the new package
2104
## no critic qw(ProhibitCommaSeparatedStatements)
2105
19
41
*{_qualify_to_ref("${package}::VERSION")} = \$version;
19
91
2106
19
362
*{_qualify_to_ref("${package}::ISA")} = [ $isa ];
19
59
2107
19
60
*{_qualify_to_ref("${package}::ATTRS")} = sub () {
2108
43
43
51
+{ %{ $isa->ATTRS }, %overridden_attributes };
43
90
2109
19
381
};
2110
19
369
$package->_make_accessors;
2111
2112
19
96
return $class;
2113
};
2114
2115
2116
# Module initialization
2117
## no critic qw(ProtectPrivateSubs)
2118
BEGIN {
2119
1
1
6
__PACKAGE__->_make_accessors;
2120
1
4
__PACKAGE__->_make_caller_info_accessors;
2121
};
2122
2123
2124
1;
2125
2126
2127
=begin umlwiki
2128
2129
= Class Diagram =
2130
2131
[ <>
2132
Exception::Base
2133
-----------------------------------------------------------------------------
2134
+ignore_class : ArrayRef {new}
2135
+ignore_level : Int = 0 {new}
2136
+ignore_package : ArrayRef {new}
2137
+max_arg_len : Int = 64 {new}
2138
+max_arg_nums : Int = 8 {new}
2139
+max_eval_len : Int = 0 {new}
2140
+message : Str|ArrayRef[Str] = "Unknown exception" {new}
2141
+value : Int = 0 {new}
2142
+verbosity : Int = 2 {new}
2143
+caller_stack : ArrayRef
2144
+egid : Int
2145
+euid : Int
2146
+gid : Int
2147
+pid : Int
2148
+propagated_stack : ArrayRef
2149
+tid : Int
2150
+time : Int
2151
+uid : Int
2152
#defaults : HashRef
2153
#default_attribute : Str = "message"
2154
#numeric_attribute : Str = "value"
2155
#eval_attribute : Str = "message"
2156
#string_attributes : ArrayRef[Str] = ["message"]
2157
-----------------------------------------------------------------------------
2158
<> +new( args : Hash )
2159
<> +throw( args : Hash = undef )
2160
<> +throw( message : Str, args : Hash = undef )
2161
+catch() : Exception::Base
2162
+catch( variable : Any ) : Exception::Base
2163
+matches( that : Any ) : Bool {overload="~~"}
2164
+to_string() : Str {overload='""'}
2165
+to_number() : Num {overload="0+"}
2166
+to_bool() : Bool {overload="bool"}
2167
+get_caller_stacktrace() : Array[Str]|Str
2168
+PROPAGATE()
2169
#_collect_system_data()
2170
#_make_accessors() {init}
2171
#_make_caller_info_accessors() {init}
2172
<> +ATTRS() : HashRef ]
2173
2174
=end umlwiki
2175
2176
=head1 SEE ALSO
2177
2178
Repository: L
2179
2180
There are more implementation of exception objects available on CPAN. Please
2181
note that Perl has built-in implementation of pseudo-exceptions:
2182
2183
eval { die { message => "Pseudo-exception", package => __PACKAGE__,
2184
file => __FILE__, line => __LINE__ };
2185
};
2186
if ($@) {
2187
print $@->{message}, " at ", $@->{file}, " in line ", $@->{line}, ".\n";
2188
}
2189
2190
The more complex implementation of exception mechanism provides more features.
2191
2192
=over
2193
2194
=item L
2195
2196
Complete implementation of try/catch/finally/otherwise mechanism. Uses nested
2197
closures with a lot of syntactic sugar. It is slightly faster than
2198
C module for failure scenario and is much slower for success
2199
scenario. It doesn't provide a simple way to create user defined exceptions.
2200
It doesn't collect system data and stack trace on error.
2201
2202
=item L
2203
2204
More Perlish way to do OO exceptions. It is similar to C
2205
module and provides similar features but it is 10x slower for failure
2206
scenario.
2207
2208
=item L
2209
2210
Additional try/catch mechanism for L. It is 15x slower for
2211
success scenario.
2212
2213
=item L
2214
2215
Elegant OO exceptions similar to L and C.
2216
It might be missing some features found in C and
2217
L.
2218
2219
=item L
2220
2221
Not recommended. Abandoned. Modifies C<%SIG> handlers.
2222
2223
=item L
2224
2225
A module which gives new try/catch keywords without source filter.
2226
2227
=item L
2228
2229
Smaller, simpler and slower version of L module.
2230
2231
=back
2232
2233
The C does not depend on other modules like
2234
L and it is more powerful than L. Also it
2235
does not use closures as L and does not pollute namespace as
2236
L. It is also much faster than
2237
L and L for success scenario.
2238
2239
The C is compatible with syntax sugar modules like
2240
L and L.
2241
2242
The C is also a base class for enhanced classes:
2243
2244
=over
2245
2246
=item L
2247
2248
The exception class for system or library calls which modifies C<$!> variable.
2249
2250
=item L
2251
2252
The exception class for eval blocks with simple L. It can also
2253
handle L<$SIG{__DIE__}|perlvar/%SIG> hook and convert simple L
2254
into an exception object.
2255
2256
=item L
2257
2258
The exception class which handle L<$SIG{__WARN__}|pervar/%SIG> hook and
2259
convert simple L into an exception object.
2260
2261
=back
2262
2263
=head1 EXAMPLES
2264
2265
=head2 New exception classes
2266
2267
The C module allows to create new exception classes easily.
2268
You can use L interface or L module to do it.
2269
2270
The L interface allows to create new class with new
2271
read-write attributes.
2272
2273
package Exception::Simple;
2274
use Exception::Base (__PACKAGE__) => {
2275
has => qw{ reason method },
2276
string_attributes => qw{ message reason method },
2277
};
2278
2279
For more complex exceptions you can redefine C constant.
2280
2281
package Exception::Complex;
2282
use base 'Exception::Base';
2283
use constant ATTRS => {
2284
%{ Exception::Base->ATTRS }, # SUPER::ATTRS
2285
hostname => { is => 'ro' },
2286
string_attributes => qw{ hostname message },
2287
};
2288
sub _collect_system_data {
2289
my $self = shift;
2290
my $hostname = `hostname`;
2291
chomp $hostname;
2292
$self->{hostname} = $hostname;
2293
return $self->SUPER::_collect_system_data(@_);
2294
}
2295
2296
=head1 PERFORMANCE
2297
2298
There are two scenarios for L block: success or failure.
2299
Success scenario should have no penalty on speed. Failure scenario is usually
2300
more complex to handle and can be significantly slower.
2301
2302
Any other code than simple C is really slow and shouldn't be used if
2303
speed is important. It means that any module which provides try/catch syntax
2304
sugar should be avoided: L, L, L,
2305
L. Be careful because simple C has many gotchas which are
2306
described in L's documentation.
2307
2308
The C module was benchmarked with other implementations for
2309
simple try/catch scenario. The results
2310
(Perl 5.10.1 x86_64-linux-thread-multi) are following:
2311
2312
-----------------------------------------------------------------------
2313
| Module | Success sub/s | Failure sub/s |
2314
-----------------------------------------------------------------------
2315
| eval/die string | 3715708 | 408951 |
2316
-----------------------------------------------------------------------
2317
| eval/die object | 4563524 | 191664 |
2318
-----------------------------------------------------------------------
2319
| Exception::Base eval/if | 4903857 | 11291 |
2320
-----------------------------------------------------------------------
2321
| Exception::Base eval/if verbosity=1 | 4790762 | 18833 |
2322
-----------------------------------------------------------------------
2323
| Error | 117475 | 26694 |
2324
-----------------------------------------------------------------------
2325
| Class::Throwable | 4618545 | 12678 |
2326
-----------------------------------------------------------------------
2327
| Exception::Class | 643901 | 3493 |
2328
-----------------------------------------------------------------------
2329
| Exception::Class::TryCatch | 307825 | 3439 |
2330
-----------------------------------------------------------------------
2331
| TryCatch | 690784 | 294802 |
2332
-----------------------------------------------------------------------
2333
| Try::Tiny | 268780 | 158383 |
2334
-----------------------------------------------------------------------
2335
2336
The C module was written to be as fast as it is
2337
possible. It does not use internally i.e. accessor functions which are
2338
slower about 6 times than standard variables. It is slower than pure
2339
die/eval for success scenario because it is uses OO mechanisms which are slow
2340
in Perl. It can be a little faster if some features are disables, i.e. the
2341
stack trace and higher verbosity.
2342
2343
You can find the benchmark script in this package distribution.
2344
2345
=head1 BUGS
2346
2347
If you find the bug or want to implement new features, please report it at
2348
L
2349
2350
The code repository is available at
2351
L
2352
2353
=for readme continue
2354
2355
=head1 AUTHOR
2356
2357
Piotr Roszatycki
2358
2359
=head1 LICENSE
2360
2361
Copyright (c) 2007-2010, 2012-2013 Piotr Roszatycki .
2362
2363
This program is free software; you can redistribute it and/or modify it
2364
under the same terms as Perl itself.
2365
2366
See L