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;