perl: update our ancient copy of Error.pm
The Error.pm shipped with Git as a fallback if there was no Error.pm on the system was released in April 2006. There's been dozens of releases since then, the latest at August 7, 2017. Let's update to that. I don't know of anything we need from this new release or which this fixes. This change is simply a matter of keeping up with upstream. Before this users who'd install git via their package system would get an up-to-date Error.pm, but if it's installed from source they'd get one more than a decade old. This undoes a local hack we'd accumulated in 96bc4de85c ("Eliminate Scalar::Util usage from private-Error.pm", 2006-07-26), it's been redundant since my d48b284183 ("perl: bump the required Perl version to 5.8 from 5.6.[21]", 2010-09-24). This also undoes 3a51467b94 ("Typo fix: replacing it's -> its", 2013-04-13). This is the Nth time I find that some upstream code of ours (in contrib/, in sha1dc/ and now in perl/ ...) has diverged from upstream because of some tree-wide typo fixing. Let's not do those fixes against upstream projects, it's more valuable that we have a 1=1 mapping to upstream than to fix typos in docs we never even generate from this code. If someone wants to fix typos in them fine, but they should do it with a patch to upstream which git.git can then incorporate. The upstream code doesn't cleanly pass a --check, so I'm adding a .gitattributes file for similar reasons as done for sha1dc in 5d184f468e ("sha1dc: ignore indent-with-non-tab whitespace violations", 2017-06-06). The updated source was retrieved from https://fastapi.metacpan.org/source/SHLOMIF/Error-0.17025/lib/Error.pm Signed-off-by: Ævar Arnfjörð Bjarmason <avarab@gmail.com> Signed-off-by: Junio C Hamano <gitster@pobox.com>
Ævar Arnfjörð Bjarmason committed
Mar 3, 2018 at 15:38 UTC
e5741c3627a9b50ba1f87a33d1ee2c3410486cac
2 files changed
+255
-41
perl/Git/FromCPAN/.gitattributes
new
+1
@@ -0,0 +1 @@
1
+/Error.pm whitespace=-blank-at-eof
perl/Git/FromCPAN/Error.pm
+254
-41
@@ -12,10 +12,12 @@
12
package Error;
13
14
use strict;
15
+use warnings;
16
+
17
use vars qw($VERSION);
18
use 5.004;
19
18
-$VERSION = "0.15009";
20
+$VERSION = "0.17025";
21
22
use overload (
23
'""' => 'stringify',
@@ -32,21 +34,35 @@ $Error::THROWN = undef; # last error thrown, a workaround until die $ref works
34
my $LAST; # Last error created
35
my %ERROR; # Last error associated with package
36
35
-sub throw_Error_Simple
37
+sub _throw_Error_Simple
38
{
39
my $args = shift;
40
return Error::Simple->new($args->{'text'});
41
}
42
41
-$Error::ObjectifyCallback = \&throw_Error_Simple;
43
+$Error::ObjectifyCallback = \&_throw_Error_Simple;
44
45
46
# Exported subs are defined in Error::subs
47
48
+use Scalar::Util ();
49
+
50
sub import {
51
shift;
52
+ my @tags = @_;
53
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
49
- Error::subs->import(@_);
54
+
55
+ @tags = grep {
56
+ if( $_ eq ':warndie' ) {
57
+ Error::WarnDie->import();
58
+ 0;
59
+ }
60
+ else {
61
+ 1;
62
+ }
63
+ } @tags;
64
+
65
+ Error::subs->import(@tags);
66
}
67
68
# I really want to use last for the name of this method, but it is a keyword
@@ -107,10 +123,6 @@ sub stacktrace {
123
$text;
124
}
125
110
-# Allow error propagation, ie
111
-#
112
-# $ber->encode(...) or
113
-# return Error->prior($ber)->associate($ldap);
126
127
sub associate {
128
my $err = shift;
@@ -130,6 +142,7 @@ sub associate {
142
return;
143
}
144
145
+
146
sub new {
147
my $self = shift;
148
my($pkg,$file,$line) = caller($Error::Depth);
@@ -246,6 +259,10 @@ sub value {
259
260
package Error::Simple;
261
262
+use vars qw($VERSION);
263
+
264
+$VERSION = "0.17025";
265
+
266
@Error::Simple::ISA = qw(Error);
267
268
sub new {
@@ -288,14 +305,6 @@ use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
305
306
@ISA = qw(Exporter);
307
291
-
292
-sub blessed {
293
- my $item = shift;
294
- local $@; # don't kill an outer $@
295
- ref $item and eval { $item->can('can') };
296
-}
297
-
298
-
308
sub run_clauses ($$$\@) {
309
my($clauses,$err,$wantarray,$result) = @_;
310
my $code = undef;
@@ -314,16 +323,17 @@ sub run_clauses ($$$\@) {
323
my $pkg = $catch->[$i];
324
unless(defined $pkg) {
325
#except
317
- splice(@$catch,$i,2,$catch->[$i+1]->());
326
+ splice(@$catch,$i,2,$catch->[$i+1]->($err));
327
$i -= 2;
328
next CATCHLOOP;
329
}
321
- elsif(blessed($err) && $err->isa($pkg)) {
330
+ elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) {
331
$code = $catch->[$i+1];
332
while(1) {
333
my $more = 0;
325
- local($Error::THROWN);
334
+ local($Error::THROWN, $@);
335
my $ok = eval {
336
+ $@ = $err;
337
if($wantarray) {
338
@{$result} = $code->($err,\$more);
339
}
@@ -341,10 +351,9 @@ sub run_clauses ($$$\@) {
351
undef $err;
352
}
353
else {
344
- $err = defined($Error::THROWN)
345
- ? $Error::THROWN : $@;
346
- $err = $Error::ObjectifyCallback->({'text' =>$err})
347
- unless ref($err);
354
+ $err = $@ || $Error::THROWN;
355
+ $err = $Error::ObjectifyCallback->({'text' =>$err})
356
+ unless ref($err);
357
}
358
last CATCH;
359
};
@@ -357,7 +366,9 @@ sub run_clauses ($$$\@) {
366
if(defined($owise = $clauses->{'otherwise'})) {
367
my $code = $clauses->{'otherwise'};
368
my $more = 0;
369
+ local($Error::THROWN, $@);
370
my $ok = eval {
371
+ $@ = $err;
372
if($wantarray) {
373
@{$result} = $code->($err,\$more);
374
}
@@ -374,11 +385,10 @@ sub run_clauses ($$$\@) {
385
undef $err;
386
}
387
else {
377
- $err = defined($Error::THROWN)
378
- ? $Error::THROWN : $@;
388
+ $err = $@ || $Error::THROWN;
389
380
- $err = $Error::ObjectifyCallback->({'text' =>$err})
381
- unless ref($err);
390
+ $err = $Error::ObjectifyCallback->({'text' =>$err})
391
+ unless ref($err);
392
}
393
}
394
}
@@ -398,7 +408,7 @@ sub try (&;$) {
408
409
do {
410
local $Error::THROWN = undef;
401
- local $@ = undef;
411
+ local $@ = undef;
412
413
$ok = eval {
414
if($wantarray) {
@@ -413,21 +423,21 @@ sub try (&;$) {
423
1;
424
};
425
416
- $err = defined($Error::THROWN) ? $Error::THROWN : $@
426
+ $err = $@ || $Error::THROWN
427
unless $ok;
428
};
429
430
shift @Error::STACK;
431
432
$err = run_clauses($clauses,$err,wantarray,@result)
423
- unless($ok);
433
+ unless($ok);
434
435
$clauses->{'finally'}->()
436
if(defined($clauses->{'finally'}));
437
438
if (defined($err))
439
{
430
- if (blessed($err) && $err->can('throw'))
440
+ if (Scalar::Util::blessed($err) && $err->can('throw'))
441
{
442
throw $err;
443
}
@@ -506,12 +516,116 @@ sub otherwise (&;$) {
516
}
517
518
1;
519
+
520
+package Error::WarnDie;
521
+
522
+sub gen_callstack($)
523
+{
524
+ my ( $start ) = @_;
525
+
526
+ require Carp;
527
+ local $Carp::CarpLevel = $start;
528
+ my $trace = Carp::longmess("");
529
+ # Remove try calls from the trace
530
+ $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
531
+ $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
532
+ my @callstack = split( m/\n/, $trace );
533
+ return @callstack;
534
+}
535
+
536
+my $old_DIE;
537
+my $old_WARN;
538
+
539
+sub DEATH
540
+{
541
+ my ( $e ) = @_;
542
+
543
+ local $SIG{__DIE__} = $old_DIE if( defined $old_DIE );
544
+
545
+ die @_ if $^S;
546
+
547
+ my ( $etype, $message, $location, @callstack );
548
+ if ( ref($e) && $e->isa( "Error" ) ) {
549
+ $etype = "exception of type " . ref( $e );
550
+ $message = $e->text;
551
+ $location = $e->file . ":" . $e->line;
552
+ @callstack = split( m/\n/, $e->stacktrace );
553
+ }
554
+ else {
555
+ # Don't apply subsequent layer of message formatting
556
+ die $e if( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ );
557
+ $etype = "perl error";
558
+ my $stackdepth = 0;
559
+ while( caller( $stackdepth ) =~ m/^Error(?:$|::)/ ) {
560
+ $stackdepth++
561
+ }
562
+
563
+ @callstack = gen_callstack( $stackdepth + 1 );
564
+
565
+ $message = "$e";
566
+ chomp $message;
567
+
568
+ if ( $message =~ s/ at (.*?) line (\d+)\.$// ) {
569
+ $location = $1 . ":" . $2;
570
+ }
571
+ else {
572
+ my @caller = caller( $stackdepth );
573
+ $location = $caller[1] . ":" . $caller[2];
574
+ }
575
+ }
576
+
577
+ shift @callstack;
578
+ # Do it this way in case there are no elements; we don't print a spurious \n
579
+ my $callstack = join( "", map { "$_\n"} @callstack );
580
+
581
+ die "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n";
582
+}
583
+
584
+sub TAXES
585
+{
586
+ my ( $message ) = @_;
587
+
588
+ local $SIG{__WARN__} = $old_WARN if( defined $old_WARN );
589
+
590
+ $message =~ s/ at .*? line \d+\.$//;
591
+ chomp $message;
592
+
593
+ my @callstack = gen_callstack( 1 );
594
+ my $location = shift @callstack;
595
+
596
+ # $location already starts in a leading space
597
+ $message .= $location;
598
+
599
+ # Do it this way in case there are no elements; we don't print a spurious \n
600
+ my $callstack = join( "", map { "$_\n"} @callstack );
601
+
602
+ warn "$message:\n$callstack";
603
+}
604
+
605
+sub import
606
+{
607
+ $old_DIE = $SIG{__DIE__};
608
+ $old_WARN = $SIG{__WARN__};
609
+
610
+ $SIG{__DIE__} = \&DEATH;
611
+ $SIG{__WARN__} = \&TAXES;
612
+}
613
+
614
+1;
615
+
616
__END__
617
618
=head1 NAME
619
620
Error - Error/exception handling in an OO-ish way
621
622
+=head1 WARNING
623
+
624
+Using the "Error" module is B<no longer recommended> due to the black-magical
625
+nature of its syntactic sugar, which often tends to break. Its maintainers
626
+have stopped actively writing code that uses it, and discourage people
627
+from doing so. See the "SEE ALSO" section below for better recommendations.
628
+
629
=head1 SYNOPSIS
630
631
use Error qw(:try);
@@ -529,7 +643,7 @@ Error - Error/exception handling in an OO-ish way
643
try {
644
do_some_stuff();
645
die "error!" if $condition;
532
- throw Error::Simple -text => "Oops!" if $other_condition;
646
+ throw Error::Simple "Oops!" if $other_condition;
647
}
648
catch Error::IO with {
649
my $E = shift;
@@ -587,7 +701,7 @@ C<BLOCK> will be passed two arguments. The first will be the error
701
being thrown. The second is a reference to a scalar variable. If this
702
variable is set by the catch block then, on return from the catch
703
block, try will continue processing as if the catch block was never
590
-found.
704
+found. The error will also be available in C<$@>.
705
706
To propagate the error the catch block may call C<$err-E<gt>throw>
707
@@ -608,7 +722,7 @@ type.
722
Catch any error by executing the code in C<BLOCK>
723
724
When evaluated C<BLOCK> will be passed one argument, which will be the
611
-error being processed.
725
+error being processed. The error will also be available in C<$@>.
726
727
Only one otherwise block may be specified per try block
728
@@ -625,12 +739,25 @@ Only one finally block may be specified per try block
739
740
=back
741
742
+=head1 COMPATIBILITY
743
+
744
+L<Moose> exports a keyword called C<with> which clashes with Error's. This
745
+example returns a prototype mismatch error:
746
+
747
+ package MyTest;
748
+
749
+ use warnings;
750
+ use Moose;
751
+ use Error qw(:try);
752
+
753
+(Thanks to C<maik.hentsche@amd.com> for the report.).
754
+
755
=head1 CLASS INTERFACE
756
757
=head2 CONSTRUCTORS
758
759
The C<Error> object is implemented as a HASH. This HASH is initialized
633
-with the arguments that are passed to its constructor. The elements
760
+with the arguments that are passed to it's constructor. The elements
761
that are used by, or are retrievable by the C<Error> class are listed
762
below, other classes may add to these.
763
@@ -655,6 +782,10 @@ an object blessed into that package as the C<-object> argument.
782
783
=over 4
784
785
+=item Error->new()
786
+
787
+See the Error::Simple documentation.
788
+
789
=item throw ( [ ARGS ] )
790
791
Create a new C<Error> object and throw an error, which will be caught
@@ -730,6 +861,13 @@ The line where the constructor of this error was called from
861
862
The text of the error
863
864
+=item $err->associate($obj)
865
+
866
+Associates an error with an object to allow error propagation. I.e:
867
+
868
+ $ber->encode(...) or
869
+ return Error->prior($ber)->associate($ldap);
870
+
871
=back
872
873
=head2 OVERLOAD METHODS
@@ -759,11 +897,9 @@ to the constructor.
897
898
=head1 PRE-DEFINED ERROR CLASSES
899
762
-=over 4
763
-
764
-=item Error::Simple
900
+=head2 Error::Simple
901
766
-This class can be used to hold simple error strings and values. Its
902
+This class can be used to hold simple error strings and values. It's
903
constructor takes two arguments. The first is a text value, the second
904
is a numeric value. These values are what will be returned by the
905
overload methods.
@@ -775,7 +911,6 @@ of the error object.
911
This class is used internally if an eval'd block die's with an error
912
that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified)
913
778
-=back
914
915
=head1 $Error::ObjectifyCallback
916
@@ -804,6 +939,76 @@ class MyError::Bar by default:
939
# Error handling here.
940
}
941
942
+=cut
943
+
944
+=head1 MESSAGE HANDLERS
945
+
946
+C<Error> also provides handlers to extend the output of the C<warn()> perl
947
+function, and to handle the printing of a thrown C<Error> that is not caught
948
+or otherwise handled. These are not installed by default, but are requested
949
+using the C<:warndie> tag in the C<use> line.
950
+
951
+ use Error qw( :warndie );
952
+
953
+These new error handlers are installed in C<$SIG{__WARN__}> and
954
+C<$SIG{__DIE__}>. If these handlers are already defined when the tag is
955
+imported, the old values are stored, and used during the new code. Thus, to
956
+arrange for custom handling of warnings and errors, you will need to perform
957
+something like the following:
958
+
959
+ BEGIN {
960
+ $SIG{__WARN__} = sub {
961
+ print STDERR "My special warning handler: $_[0]"
962
+ };
963
+ }
964
+
965
+ use Error qw( :warndie );
966
+
967
+Note that setting C<$SIG{__WARN__}> after the C<:warndie> tag has been
968
+imported will overwrite the handler that C<Error> provides. If this cannot be
969
+avoided, then the tag can be explicitly C<import>ed later
970
+
971
+ use Error;
972
+
973
+ $SIG{__WARN__} = ...;
974
+
975
+ import Error qw( :warndie );
976
+
977
+=head2 EXAMPLE
978
+
979
+The C<__DIE__> handler turns messages such as
980
+
981
+ Can't call method "foo" on an undefined value at examples/warndie.pl line 16.
982
+
983
+into
984
+
985
+ Unhandled perl error caught at toplevel:
986
+
987
+ Can't call method "foo" on an undefined value
988
+
989
+ Thrown from: examples/warndie.pl:16
990
+
991
+ Full stack trace:
992
+
993
+ main::inner('undef') called at examples/warndie.pl line 20
994
+ main::outer('undef') called at examples/warndie.pl line 23
995
+
996
+=cut
997
+
998
+=head1 SEE ALSO
999
+
1000
+See L<Exception::Class> for a different module providing Object-Oriented
1001
+exception handling, along with a convenient syntax for declaring hierarchies
1002
+for them. It doesn't provide Error's syntactic sugar of C<try { ... }>,
1003
+C<catch { ... }>, etc. which may be a good thing or a bad thing based
1004
+on what you want. (Because Error's syntactic sugar tends to break.)
1005
+
1006
+L<Error::Exception> aims to combine L<Error> and L<Exception::Class>
1007
+"with correct stringification".
1008
+
1009
+L<TryCatch> and L<Try::Tiny> are similar in concept to Error.pm only providing
1010
+a syntax that hopefully breaks less.
1011
+
1012
=head1 KNOWN BUGS
1013
1014
None, but that does not mean there are not any.
@@ -816,12 +1021,20 @@ The code that inspired me to write this was originally written by
1021
Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
1022
<jglick@sig.bsh.com>.
1023
1024
+C<:warndie> handlers added by Paul Evans <leonerd@leonerd.org.uk>
1025
+
1026
=head1 MAINTAINER
1027
821
-Shlomi Fish <shlomif@iglu.org.il>
1028
+Shlomi Fish, L<http://www.shlomifish.org/> .
1029
1030
=head1 PAST MAINTAINERS
1031
1032
Arun Kumar U <u_arunkumar@yahoo.com>
1033
1034
+=head1 COPYRIGHT
1035
+
1036
+Copyright (c) 1997-8 Graham Barr. All rights reserved.
1037
+This program is free software; you can redistribute it and/or modify it
1038
+under the same terms as Perl itself.
1039
+
1040
=cut