Mandanten-WebDAV-Upgrade: nicht an Konfigurationseinstellung sondern Existenz von...
[kivitendo-erp.git] / modules / fallback / Exception / Lite.pm
1 # Copyright (c) 2010 Elizabeth Grace Frank-Backman.
2 # All rights reserved.
3 # Liscenced under the "Artistic Liscence"
4 # (see http://dev.perl.org/licenses/artistic.html)
5
6 use 5.8.8;
7 use strict;
8 use warnings;
9 use overload;
10
11 package Exception::Lite;
12 our @ISA = qw(Exporter);
13 our @EXPORT_OK=qw(declareExceptionClass isException isChainable
14                   onDie onWarn);
15 our %EXPORT_TAGS
16   =( common => [qw(declareExceptionClass isException isChainable)]
17      , all => [@EXPORT_OK]
18    );
19 my $CLASS='Exception::Lite';
20
21 #------------------------------------------------------------------
22
23 our $STRINGIFY=3;
24 our $FILTER=1;
25 our $UNDEF='<undef>';
26 our $TAB=3;
27 our $LINE_LENGTH=120;
28
29 # provide command line control over amount and layout of debugging
30 # information, e.g. perl -mException::Lite=STRINGIFY=4
31
32 sub import {
33   Exception::Lite->export_to_level(1, grep {
34     if (/^(\w+)=(.*)$/) {
35       my $k = $1;
36       my $v = $2;
37       if ($k eq 'STRINGIFY')        { $STRINGIFY=$v;
38       } elsif ($k eq 'FILTER')      { $FILTER=$v;
39       } elsif ($k eq 'LINE_LENGTH') { $LINE_LENGTH=$v;
40       } elsif ($k eq 'TAB')         { $TAB=$v;
41       }
42       0;
43     } else {
44       1;
45     }
46   } @_);
47 }
48
49 #------------------------------------------------------------------
50 # Note to source code divers: DO NOT USE THIS. This is intended for
51 # internal use but must be declared with "our" because we need to
52 # localize it.  This is an implementation detail and cannot be relied
53 # on for future releases.
54
55 our $STACK_OFFSET=0;
56
57 #------------------------------------------------------------------
58
59 use Scalar::Util ();
60 use constant EVAL => '(eval)';
61
62 #==================================================================
63 # EXPORTABLE FUNCTIONS
64 #==================================================================
65
66 sub declareExceptionClass {
67   my ($sClass, $sSuperClass, $xFormatRule, $bCustomizeSubclass) = @_;
68   my $sPath = $sClass; $sPath =~ s/::/\//g; $sPath .= '.pm';
69   if ($INC{$sPath}) {
70     # we want to start with the caller's frame, not ours
71     local $STACK_OFFSET = $STACK_OFFSET + 1;
72     die 'Exception::Lite::Any'->new("declareExceptionClass failed: "
73                                     . "$sClass is already defined!");
74     return undef;
75   }
76
77   my $sRef=ref($sSuperClass);
78   if ($sRef) {
79     $bCustomizeSubclass = $xFormatRule;
80     $xFormatRule = $sSuperClass;
81     $sSuperClass=undef;
82   } else {
83     $sRef = ref($xFormatRule);
84     if (!$sRef && defined($xFormatRule)) {
85       $bCustomizeSubclass = $xFormatRule;
86       $xFormatRule = undef;
87     }
88   }
89
90   # set up things dependent on whether or not the class has a
91   # format string or expects a message for each instance
92
93   my ($sLeadingParams, $sAddOrOmit, $sRethrowMsg, $sMakeMsg);
94   my $sReplaceMsg='';
95
96   if ($sRef) {
97     $sLeadingParams='my $e; $e=shift if ref($_[0]);';
98     $sAddOrOmit='added an unnecessary message or format';
99     $sRethrowMsg='';
100
101     #generate format rule
102     $xFormatRule=$xFormatRule->($sClass) if ($sRef eq 'CODE');
103
104     my $sFormat= 'q{' . $xFormatRule->[0] . '}';
105     if (scalar($xFormatRule) == 1) {
106       $sMakeMsg='my $msg='.$sFormat;
107     } else {
108       my $sSprintf = 'Exception::Lite::_sprintf(' . $sFormat
109         . ', map {defined($_)?$_:\''. $UNDEF .'\'} @$h{qw('
110         . join(' ', @$xFormatRule[1..$#$xFormatRule]) . ')});';
111       $sMakeMsg='my $msg='.$sSprintf;
112       $sReplaceMsg='$_[0]->[0]='.$sSprintf;
113     }
114
115   } else {
116     $sLeadingParams = 'my $e=shift; my $msg;'.
117       'if(ref($e)) { $msg=shift; $msg=$e->[0] if !defined($msg);}'.
118       'else { $msg=$e;$e=undef; }';
119     $sAddOrOmit='omitted a required message';
120     $sRethrowMsg='my $msg=shift; $_[0]->[0]=$msg if defined($msg);';
121     $sMakeMsg='';
122   }
123
124   # put this in an eval so that it doesn't cause parse errors at
125   # compile time in no-threads versions of Perl
126
127   my $sTid = eval q{defined(&threads::tid)?'threads->tid':'undef'};
128
129   my $sDeclare = "package $sClass;".
130     'sub new { my $cl=shift;'.  $sLeadingParams .
131       'my $st=Exception::Lite::_cacheStackTrace($e);'.
132       'my $h= Exception::Lite::_shiftProperties($cl' .
133          ',$st,"'.$sAddOrOmit.'",@_);' . $sMakeMsg .
134       'my $self=bless([$msg,$h,$st,$$,'.$sTid.',$e,[]],$cl);';
135
136   # the remainder depends on the type of subclassing
137
138   if ($bCustomizeSubclass) {
139     $sDeclare .= '$self->[7]={}; $self->_new(); return $self; }'
140       . 'sub _p_getSubclassData { $_[0]->[7]; }';
141   } else {
142     $sDeclare .= 'return $self;}'.
143     'sub replaceProperties {'.
144        'my $h={%{$_[0]->[1]},%{$_[1]}}; $_[0]->[1]=$h;'.$sReplaceMsg.
145     '}'.
146     'sub rethrow {' .
147       'my $self=shift;' . $sRethrowMsg .
148       'Exception::Lite::_rethrow($self,"'.$sAddOrOmit.'",@_)' .
149     '}';
150
151     unless (isExceptionClass($sSuperClass)) {
152       $sDeclare .=
153         'sub _getInterface { \'Exception::Lite\' }' .
154         'sub getMessage { $_[0]->[0] };' .
155         'sub getProperty { $_[0]->[1]->{$_[1]} }' .
156         'sub isProperty { exists($_[0]->[1]->{$_[1]})?1:0 }' .
157         'sub getStackTrace { $_[0]->[2] }' .
158         'sub getFrameCount { scalar(@{$_[0]->[2]}); }' .
159         'sub getFile { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[0] };' .
160         'sub getLine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[1] };' .
161         'sub getSubroutine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[2] };' .
162         'sub getArgs { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[3] };' .
163         'sub getPackage {$_[0]->[2]->[-1]->[2] =~ /(\w+)>$/;$1}'.
164         'sub getPid { $_[0]->[3] }' .
165         'sub getTid { $_[0]->[4] }' .
166         'sub getChained { $_[0]->[5] }' .
167         'sub getPropagation { $_[0]->[6]; }' .
168         'use overload '.
169            'q{""} => \&Exception::Lite::_dumpMessage ' .
170            ', q{0+} => \&Exception::Lite::_refaddr, fallback=>1;' .
171         'sub PROPAGATE { push @{$_[0]->[6]},[$_[1],$_[2]]; $_[0]}';
172     }
173   }
174   $sDeclare .= 'return 1;';
175
176   local $SIG{__WARN__} = sub {
177     my ($p,$f,$l) = caller(2);
178     my $s=$_[0]; $s =~ s/at \(eval \d+\)\s+line\s+\d+\.//m;
179     print STDERR "$s in declareExceptionClass($sClass,...) "
180       ."in file $f, line $l\n";
181   };
182
183   eval $sDeclare or do {
184     my ($p,$f,$l) = caller(1);
185     print STDERR "Can't create class $sClass at file $f, line $l\n";
186     if ($sClass =~ /\w:\w/) {
187       print STDERR "Bad class name: "
188         ."At least one ':' is not doubled\n";
189     } elsif ($sClass !~ /^\w+(?:::\w+)*$/) {
190       print STDERR "Bad class name: $sClass\n";
191     } else {
192       $sDeclare=~s/(sub |use )/\n$1/g; print STDERR "$sDeclare\n";
193     }
194   };
195
196   # this needs to be separate from the eval, otherwise it never
197   # ends up in @INC or @ISA, at least in Perl 5.8.8
198   $INC{$sPath} = __FILE__;
199   eval "\@${sClass}::ISA=qw($sSuperClass);" if $sSuperClass;
200
201   return $sClass;
202 }
203
204 #------------------------------------------------------------------
205
206 sub isChainable { return ref($_[0])?1:0; }
207
208 #------------------------------------------------------------------
209
210 sub isException {
211   my ($e, $sClass) = @_;
212   my $sRef=ref($e);
213   return !defined($sClass)
214     ? ($sRef ? isExceptionClass($sRef) : 0)
215     : $sClass eq ''
216        ? ($sRef eq '' ? 1 : 0)
217        : ($sRef eq '')
218             ? 0
219             : $sRef->isa($sClass)
220                ?1:0;
221 }
222
223 #------------------------------------------------------------------
224
225 sub isExceptionClass {
226   return defined($_[0]) && $_[0]->can('_getInterface')
227     && ($_[0]->_getInterface() eq __PACKAGE__) ? 1 : 0;
228 }
229
230 #------------------------------------------------------------------
231
232 sub onDie {
233   my $iStringify = $_[0];
234   $SIG{__DIE__} = sub {
235     $Exception::Lite::STRINGIFY=$iStringify;
236     warn 'Exception::Lite::Any'->new('Unexpected death:'.$_[0])
237       unless $^S || isException($_[0]);
238   };
239 }
240
241 #------------------------------------------------------------------
242
243 sub onWarn {
244   my $iStringify = $_[0];
245   $SIG{__WARN__} = sub {
246     $Exception::Lite::STRINGIFY=$iStringify;
247     print STDERR 'Exception::Lite::Any'->new("Warning: $_[0]");
248   };
249 }
250
251 #==================================================================
252 # PRIVATE SUBROUTINES
253 #==================================================================
254
255 #------------------------------------------------------------------
256
257 sub _cacheCall {
258   my $iFrame = $_[0];
259
260   my @aCaller;
261   my $aArgs;
262
263   # caller populates @DB::args if called within DB package
264   eval {
265     # this 2 line wierdness is needed to prevent Module::Build from finding
266     # this and adding it to the provides list.
267     package
268       DB;
269
270     #get rid of eval and call to _cacheCall
271     @aCaller = caller($iFrame+2);
272
273     # mark leading undefined elements as maybe shifted away
274     my $iDefined;
275     if ($#aCaller < 0) {
276       @DB::args=@ARGV;
277     }
278     $aArgs = [  map {
279       defined($_)
280         ? do {$iDefined=1;
281               "'$_'" . (overload::Method($_,'""')
282                         ? ' ('.overload::StrVal($_).')':'')}
283           : 'undef' . (defined($iDefined)
284                        ? '':'  (maybe shifted away?)')
285         } @DB::args];
286   };
287
288   return $#aCaller < 0 ? \$aArgs : [ @aCaller[0..3], $aArgs ];
289 }
290
291 #------------------------------------------------------------------
292
293 sub _cacheStackTrace {
294   my $e=$_[0]; my $st=[];
295
296   # set up initial frame
297   my $iFrame= $STACK_OFFSET + 1; # call to new
298   my $aCall = _cacheCall($iFrame++);
299   my ($sPackage, $iFile, $iLine, $sSub, $sArgs) = @$aCall;
300   my $iLineFrame=$iFrame;
301
302   $aCall =  _cacheCall($iFrame++);  #context of call to new
303   while (ref($aCall) ne 'REF') {
304     $sSub  = $aCall->[3];  # subroutine containing file,line
305     $sArgs = $aCall->[4];  # args used to call $sSub
306
307     #print STDERR "debug-2: package=$sPackage file=$iFile line=$iLine"
308     #  ." sub=$sSub, args=@$sArgs\n";
309
310     # in evals we want the line number within the eval, but the
311     # name of the sub in which the eval was located. To get this
312     # we wait to push on the stack until we get an actual sub name
313     # and we avoid overwriting the location information, hence 'ne'
314
315     if (!$FILTER || ($sSub ne EVAL)) {
316       my $aFrame=[ $iFile, $iLine, $sSub, $sArgs ];
317       ($sPackage, $iFile, $iLine) = @$aCall;
318       $iLineFrame=$iFrame;
319
320       my $sRef=ref($FILTER);
321       if ($sRef eq 'CODE') {
322         my $x = $FILTER->(@$aFrame, $iFrame, $iLineFrame);
323         if (ref($x) eq 'ARRAY') {
324           $aFrame=$x;
325         } elsif (!$x) {
326           $aFrame=undef;
327         }
328       } elsif (($sRef eq 'ARRAY') && ! _isIgnored($sSub, $FILTER)) {
329         $aFrame=undef;
330       } elsif (($sRef eq 'Regexp') && !_isIgnored($sSub, [$FILTER])) {
331         $aFrame=undef;
332       }
333       push(@$st, $aFrame) if $aFrame;
334     }
335
336     $aCall = _cacheCall($iFrame++);
337   }
338
339   push @$st, [ $iFile, $iLine, "<package: $sPackage>", $$aCall ];
340   if ($e) { my $n=$#{$e->[2]}-$#$st;$e->[2]=[@{$e->[2]}[0..$n]]};
341   return $st;
342 }
343
344 #-----------------------------
345
346 sub _isIgnored {
347   my ($sSub, $aIgnore) = @_;
348   foreach my $re (@$aIgnore) { return 1 if $sSub =~ $re; }
349   return 0;
350 }
351
352 #------------------------------------------------------------------
353
354 sub _dumpMessage {
355   my ($e, $iDepth) = @_;
356
357   my $sMsg = $e->getMessage();
358   return $sMsg unless $STRINGIFY;
359   if (ref($STRINGIFY) eq 'CODE') {
360     return $STRINGIFY->($sMsg);
361   }
362
363   $iDepth = 0 unless defined($iDepth);
364   my $sIndent = ' ' x ($TAB*$iDepth);
365   $sMsg = "\n${sIndent}Exception! $sMsg";
366   return $sMsg if $STRINGIFY == 0;
367
368   my ($sThrow, $sReach);
369   my $sTab = ' ' x $TAB;
370
371   $sIndent.= $sTab;
372   if ($STRINGIFY > 2) {
373     my $aPropagation = $e->getPropagation();
374     for (my $i=$#$aPropagation; $i >= 0; $i--) {
375       my ($f,$l) = @{$aPropagation->[$i]};
376       $sMsg .= "\n${sIndent}rethrown at file $f, line $l";
377     }
378     $sMsg .= "\n";
379     $sThrow='thrown  ';
380     $sReach='reached ';
381   } else {
382     $sThrow='';
383     $sReach='';
384   }
385
386   my $st=$e->getStackTrace();
387   my $iTop = scalar @$st;
388
389   for (my $iFrame=0; $iFrame<$iTop; $iFrame++) {
390     my ($f,$l,$s,$aArgs) = @{$st->[$iFrame]};
391
392     if ($iFrame) {
393       #2nd and following stack frame
394       my $sVia="${sIndent}${sReach}via file $f, line $l";
395       my $sLine="$sVia in $s";
396       $sMsg .= (length($sLine)>$LINE_LENGTH
397                 ? "\n$sVia\n$sIndent${sTab}in $s" : "\n$sLine");
398     } else {
399       # first stack frame
400       my $tid=$e->getTid();
401       my $sAt="${sIndent}${sThrow}at  file $f, line $l";
402       my $sLine="$sAt in $s";
403       $sMsg .= (length($sLine)>$LINE_LENGTH
404                 ? "\n$sAt\n$sIndent${sTab}in $s" : "\n$sLine")
405         . ", pid=" . $e->getPid() . (defined($tid)?", tid=$tid":'');
406
407       return "$sMsg\n" if $STRINGIFY == 1;
408     }
409
410     if ($STRINGIFY > 3) {
411       my $bTop = ($iFrame+1) == $iTop;
412       my $sVar= ($bTop && !$iDepth) ? '@ARGV' : '@_';
413       my $bMaybeEatenByGetOpt = $bTop && !scalar(@$aArgs)
414         && exists($INC{'Getopt/Long.pm'});
415
416       my $sVarIndent = "\n${sIndent}" . (' ' x $TAB);
417       my $sArgPrefix = "${sVarIndent}".(' ' x length($sVar)).' ';
418       if ($bMaybeEatenByGetOpt) {
419         $sMsg .= $sArgPrefix . $sVar
420           . '()    # maybe eaten by Getopt::Long?';
421       } else {
422         my $sArgs = join($sArgPrefix.',', @$aArgs);
423         $sMsg .= "${sVarIndent}$sVar=($sArgs";
424         $sMsg .= $sArgs ? "$sArgPrefix)" : ')';
425       }
426     }
427   }
428   $sMsg.="\n";
429   return $sMsg if $STRINGIFY == 2;
430
431   my $eChained = $e->getChained();
432   if (defined($eChained)) {
433     my $sTrigger = isException($eChained)
434       ? _dumpMessage($eChained, $iDepth+1)
435       : "\n${sIndent}$eChained\n";
436     $sMsg .= "\n${sIndent}Triggered by...$sTrigger";
437   }
438   return $sMsg;
439 }
440
441 #------------------------------------------------------------------
442
443 # refaddr has a prototype($) so we can't use it directly as an
444 # overload operator: it complains about being passed 3 parameters
445 # instead of 1.
446 sub _refaddr { Scalar::Util::refaddr($_[0]) };
447
448 #------------------------------------------------------------------
449
450 sub _rethrow {
451   my $self = shift; my $sAddOrOmit = shift;
452   my ($p,$f,$l)=caller(1);
453   $self->PROPAGATE($f,$l);
454
455   if (@_%2) {
456     warn sprintf('bad parameter list to %s->rethrow(...)'
457       .'at file %d, line %d: odd number of elements in property-value '
458       .'list, property value has no property name and will be '
459       ."discarded (common causes: you have %s string)\n"
460       ,$f, $l, $sAddOrOmit);
461     shift @_;
462   }
463   $self->replaceProperties({@_}) if (@_);
464   return $self;
465 }
466
467 #------------------------------------------------------------------
468 # Traps warnings and reworks them so that they tell the user how
469 # to fix the problem rather than obscurely complain about an
470 # invisible sprintf with uninitialized values that seem to come from
471 # no where (and make Exception::Lite look like it is broken)
472
473 sub _sprintf {
474   my $sMsg;
475   my $sWarn;
476
477   {
478     local $SIG{__WARN__} = sub { $sWarn=$_[0] if !defined($sWarn) };
479
480     # sprintf has prototype ($@)
481     my $sFormat = shift;
482     $sMsg = sprintf($sFormat, @_);
483   }
484
485   if (defined($sWarn)) {
486     my $sReason='';
487     my ($f, $l, $s) = (caller(1))[1,2,3];
488     $s =~ s/::(\w+)\z/->$1/;
489     $sWarn =~ s/sprintf/$s/;
490     $sWarn =~ s/\s+at\s+[\w\/\.]+\s+line\s+\d+\.\s+\z//;
491     if ($sWarn
492         =~ m{^Use of uninitialized value in|^Missing argument}) {
493       my $p=$s; $p =~ s/->\w+\z//;
494       $sReason ="\n     Most likely cause: "
495         . "Either you are missing property-value pairs needed to"
496         . "build the message or your exception class's format"
497         . "definition mistakenly has too many placeholders "
498         . "(e.g. %s,%d,etc)\n";
499     }
500     warn "$sWarn called at file $f, line $l$sReason\n";
501   }
502   return $sMsg;
503 }
504
505 #------------------------------------------------------------------
506
507 sub _shiftProperties {
508   my $cl= shift;  my $st=shift;  my $sAddOrOmit = shift;
509   if (@_%2) {
510     $"='|';
511     warn sprintf('bad parameter list to %s->new(...) at '
512       .'file %s, line %d: odd number of elements in property-value '
513       .'list, property value has no property name and will be '
514       .'discarded (common causes: you have %s string -or- you are '
515       ."using a string as a chained exception)\n"
516       ,$cl,$st->[0]->[0],$st->[0]->[1], $sAddOrOmit);
517     shift @_;
518   }
519   return {@_};
520 }
521
522 #==================================================================
523 # MODULE INITIALIZATION
524 #==================================================================
525
526 declareExceptionClass(__PACKAGE__ .'::Any');
527 1;