Projekt

Allgemein

Profil

« Zurück | Weiter » 

Revision c311f0f2

Von Moritz Bunkus vor mehr als 13 Jahren hinzugefügt

  • ID c311f0f2b26213afd814d8ff2e954da54b09fcf0
  • Vorgänger f416a998
  • Nachfolger 27ffa16a

Exception::Lite als neues Standard-Exception-Modul in Fallback-Module aufgenommen

Unterschiede anzeigen:

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;
modules/fallback/Exception/Lite.pod
1
=head1 NAME
2

  
3
Exception::Lite - light weight exception handling class with smart
4
stack tracing, chaining, and localization support.
5

  
6
=head1 SYNOPSIS
7

  
8
   # --------------------------------------------------------
9
   # making this module available to your code
10
   # --------------------------------------------------------
11

  
12
   #Note: there are NO automatic exports
13

  
14
   use Exception::Lite qw(declareExceptionClass
15
                          isException
16
                          isChainable
17
                          onDie
18
                          onWarn);
19

  
20
   # imports only: declareExceptionClass isException isChainable
21
   use Exception::Lite qw(:common);
22

  
23
   # imports all exportable methods listed above
24
   use Exception::Lite qw(:all);
25

  
26

  
27
   # --------------------------------------------------------
28
   # declare an exception class
29
   # --------------------------------------------------------
30

  
31
   # no format rule
32
   declareExceptionClass($sClass);
33
   declareExceptionClass($sClass, $sSuperClass);
34

  
35
   # with format rule
36
   declareExceptionClass($sClass, $aFormatRule);
37
   declareExceptionClass($sClass, $sSuperClass, $aFormatRule);
38

  
39
   # with customized subclass
40
   declareExceptionClass($sClass, $sSuperClass, 1);
41
   declareExceptionClass($sClass, $aFormatRule, 1);
42
   declareExceptionClass($sClass, $sSuperClass, $aFormatRule, 1);
43

  
44
   # --------------------------------------------------------
45
   # throw an exception
46
   # --------------------------------------------------------
47

  
48
   die $sClass->new($sMsg, $prop1 => $val1, ...);  #no format rule
49
   die $sClass->new($prop1 => $val1, ...);         #has format rule
50

  
51
   #-or-
52

  
53
   $e = $sClass->new($sMsg, $prop1 => $val1, ...); #no format rule
54
   $e = $sClass->new($prop1 => $val1, ...);        #has format rule
55

  
56
   die $e;
57

  
58
   # --------------------------------------------------------
59
   # catch and test an exception
60
   # --------------------------------------------------------
61

  
62
   # Note: for an explanation of why we don't use if ($@)... here,
63
   # see Catching and Rethrowing exceptions below
64

  
65
   eval {
66
     .... some code that may die here ...
67
     return 1;
68
   } or do {
69
     my $e=$@;
70

  
71
     if (isException($e, 'Class1')) {
72
       ... do something ...
73
     } elsif (isExcption($e, 'Class2')) {
74
        ... do something else ...
75
     }
76
   };
77

  
78
   isException($e);        # does $e have the above exception methods?
79
   isException($e,$sClass) # does $e belong to $sClass or a subclass?
80

  
81
   # --------------------------------------------------------
82
   # getting information about an exception object
83
   # --------------------------------------------------------
84

  
85
   $e->getMessage();
86
   $e->getProperty($sName);
87
   $e->isProperty($sName);
88
   $e->replaceProperties($hOverride);
89

  
90
   $e->getPid();
91
   $e->getPackage();
92
   $e->getTid();
93

  
94
   $e->getStackTrace();
95
   $e->getFrameCount();
96
   $e->getFile($i);
97
   $e->getLine($i);
98
   $e->getSubroutine($i);
99
   $e->getArgs($i);
100

  
101
   $e->getPropagation();
102
   $e->getChained();
103

  
104

  
105
   # --------------------------------------------------------
106
   # rethrowing exceptions
107
   # --------------------------------------------------------
108

  
109
   # using original properties and message
110

  
111
   $@=$e; die;         # pure Perl way (reset $@ in case wiped out)
112

  
113
   die $e->rethrow();  # same thing, but a little less cryptic
114

  
115

  
116
   # overriding original message/properties
117

  
118
   die $e->rethrow(path=>$altpath, user=>$nameReplacingId);
119

  
120

  
121
   # --------------------------------------------------------
122
   # creation of chained exceptions (one triggered by another)
123
   # (new exception with "memory" of what caused it and stack
124
   # trace from point of cause to point of capture)
125
   # --------------------------------------------------------
126

  
127
   isChainable($e);        # can $e be used as a chained exception?
128

  
129
   die $sClass->new($e, $sMsg, $prop1 => $val1, ...);#no format rule
130
   die $sClass->new($e, $prop1 => $val1, ...);       #has format rule
131

  
132
   # --------------------------------------------------------
133
   # print out full message from an exception
134
   # --------------------------------------------------------
135

  
136
   print $e                         # print works
137
   warn $e                          # warn works
138
   print "$e\n";                    # double quotes work
139
   my $sMsg=$e."\n"; print $sMsg;   # . operator works
140

  
141

  
142
   # --------------------------------------------------------
143
   # global control variables (maybe set on the command line)
144
   # --------------------------------------------------------
145

  
146
   $Exception::Lite::STRINGIFY   #set rule for stringifying messages
147

  
148
      = 1;        # message and file/line where it occured
149
      = 2;        # 1 + what called what (simplified stack trace)
150
      = 3;        # 2 + plus any chained exceptions and where message
151
                  # was caught, if propagated and rethrown
152
      = 4;        # 3 + arguments given to each call in stack trace
153
      = coderef   # custom formatting routine
154

  
155
   $Exception::Lite::TAB   # set indentation for stringified
156
                           # messages, particularly indentation for
157
                           # call parameters and chained exceptions
158

  
159
   $Exception::Lite::FILTER
160
     = 0         # see stack exactly as Perl does
161
     = 1         # remove frames added by eval blocks
162
     = coderef   # custom filter - see getStackTrace for details
163

  
164
   # --------------------------------------------------------
165
   # controlling the stack trace from the command line
166
   # --------------------------------------------------------
167

  
168
   perl -mException::Lite=STRINGIFY=1,FILTER=0,TAB=4
169
   perl -m'Exception::Lite qw(STRINGIFY=1 FILTER=0 TAB=4)'
170

  
171
   # --------------------------------------------------------
172
   # built in exception classes
173
   # --------------------------------------------------------
174

  
175
   # generic wrapper for converting exception strings and other
176
   # non-Exception::Lite exceptions into exception objects
177

  
178
   Exception::Class::Any->new($sMessageText);
179

  
180
To assist in debugging and testing, this package also includes
181
two methods that set handlers for die and warn. These methods
182
should I<only> be used temporarily during active debugging. They
183
should not be used in production software, least they interfere
184
with the way other programmers using your module wish to do their
185
debugging and testing.
186

  
187
   # --------------------------------------------------------
188
   # force all exceptions/warnings to use Exception::Lite to
189
   # print out messages and stack traces
190
   # --------------------------------------------------------
191

  
192
   # $stringify is the value for EXCEPTION::Lite::STRINGIFY
193
   # that you want to use locally to print out messages. It
194
   # will have no effect outside of the die handler
195

  
196
   Exception::Lite::onDie($stringify);
197
   Exception::Lite::onWarn($stringify);
198

  
199
=head1 DESCRIPTION
200

  
201
The C<Exception::Lite> class provides an easy and very light weight
202
way to generate context aware exceptions.  It was developed because
203
the exception modules on CPAN as of December,2010 were heavy on
204
features I didn't care for and did not have the features I most
205
needed to test and debug code efficiently.
206

  
207
=head2 Features
208

  
209
This module provides a light weight but powerful exception class
210
that
211

  
212
=over 
213

  
214
=item *
215

  
216
provides an uncluttered stack trace that clearly shows what
217
called what and what exception triggered what other exception.
218
It significantly improves on the readability of the stack trace
219
dumps provided by C<carp> and other exception modules on
220
CPAN (as of 12/2010).  For further discussion and a sample, see
221
L</More intelligent stack trace>.
222

  
223
=item *
224

  
225
gives the user full control over the amount of debugging
226
information displayed when exceptions are thrown.
227

  
228
=item *
229

  
230
permits global changes to the amount of debugging information
231
displayed via the command line.
232

  
233
=item *
234

  
235
closely integrates exception classes, messages, and properties
236
so that they never get out of sync with one another.  This in
237
turn eliminates redundant coding and helps reduce the cost of
238
writing,validating and maintaining a set of exceptions.
239

  
240
=item *
241

  
242
is easy to retrofit with native language support, even if this
243
need appears late in the development process.This makes it
244
suitable for use with agile development strategies.
245

  
246
=item *
247

  
248
act like strings in string context but are in fact objects with
249
a class hierarchy and properties.They can be thrown and rethrown
250
with standard Perl syntax. Like any object, they can be uniquely
251
identified in numeric context where they equal their reference
252
address (the value returned by C<Scalar::Util::refaddr()>.
253

  
254
=item *
255

  
256
does not interfere with signal handlers or the normal Perl syntax
257
and the assumptions of Perl operators.
258

  
259
=item *
260

  
261
can be easily extended and subclassed
262

  
263
=back
264

  
265
=head2 Lightweight how?
266

  
267
Despite these features C<Exception::Lite> maintains its "lite"
268
status by
269

  
270
=over
271

  
272
=item *
273

  
274
using only core modules
275

  
276
=item *
277

  
278
generating tiny exception classes (30-45LOC per class).
279

  
280
=item *
281

  
282
eliminating excess baggage by customizing generated classes to
283
  reflect the actual needs of exception message generation.  For
284
  instance an exception wrapped around a fixed string message would
285
  omit code for message/property integration and would be little
286
  more than a string tied to a stack trace and property hash.
287

  
288
=item *
289

  
290
storing only the minimum amount of stack trace data needed to
291
  generate exception messages and avoiding holding onto references
292
  from dead stack frames.  (Note: some CPAN modules hold onto
293
  actual variables from each frame, possibly interfering with
294
  garbage collection).
295

  
296
=item *
297

  
298
doing all its work, including class generation and utilities in
299
  a single file that is less than half the size of the next smallest
300
  similarly featured all-core exception class on CPAN (support for
301
  both properties and a class heirarchy).  C<Exception::Lite>
302
  contains about 400 lines when developer comments are excluded). The
303
  next smallest all core module is L<Exception::Base|Exception::Base>
304
  which clocks in at just over 1000 lines after pod and developer
305
  comments are excluded).
306

  
307
=item *
308

  
309
avoiding a heavy-weight base class.  Code shared by
310
  C<Exception::Lite> classes are stored in function calls that total
311
  230 or so lines of code relying on nothing but core modules. This
312
  is significantly less code than is needed by the two CPAN packages
313
  with comparable features.  The all core
314
  L<Exception::Base|Exception::Base> class contains 700+ lines of
315
  code.  The base class of L<Exception::Class|Exception::Class> has
316
  200 lines of its own but drags in two rather large non-core
317
  modules as dependencies:  L<Devel::StackTrace|Devel::StackTrace>
318
  L<Class::Data::Inheritable|Class::Data::Inheritable>.
319

  
320
=back
321

  
322
C<Exception::Lite> has more features (chaining, message/property
323
integration) but less code due to the following factors:
324

  
325
=over
326

  
327
=item *
328

  
329
working with Perl syntax rather than trying to replace it.
330

  
331
=item *
332

  
333
using a light approach to OOP - exception classes have just enough
334
and no more OO features than are needed to be categorized by a
335
class, participate in a class heirarchy and to have properties.
336

  
337
=item *
338

  
339
respecting separation of concerns. C<Exception::Lite> focuses
340
on the core responsibility of an exception and leaves the bulk of
341
syntax creation (e.g. Try/Catch) to specialist modules like
342
L<Try::Tiny|Try::Tiny>.  Other modules try to double as
343
comprehensive providers of exception related syntactic sugar.
344

  
345
=item *
346

  
347
not trying to be the only kind of exception that an application
348
uses.
349

  
350
=back
351

  
352
=head1 USAGE
353

  
354
=head2 Defining Exception Classes
355

  
356
C<Exception::Lite> provides two different ways to define messages.
357
The first way, without a format rule, lets you compose a freeform
358
message for each exception.  The second way, with a format rule,
359
lets you closely integrate messages and properties and facilitates
360
localization of messages for any packages using your software.
361

  
362
=head3 Defining freeform messages
363

  
364
If you want to compose a free form message for each and every
365
exception, the class declaration is very simple:
366

  
367
   declareExceptionClass($sClass);
368
   declareExceptionClass($sClass, $sSuperClass);
369

  
370
   # with customized subclass
371
   declareExceptionClass($sClass, $sSuperClass, 1);
372

  
373
C<$sClass> is the name of the exception class.
374

  
375
C<$sSuperClass> is the name of the superclass, if there is one.
376
The superclass can be any class created by C<Exception::Lite>. It
377
can also be any role class, i.e. a class that has methods but no
378
object data of its own.
379

  
380
The downside of this simple exception class is that there is
381
absolutely no integration of your messages and any properties that
382
you assign to the exception.  If you would like to see your property
383
values included in the message string,consider using a formatted
384
message instead.
385

  
386
=head3 Defining formatted messages
387

  
388
If you wish to include property values in your messages, you need
389
to declare a formatted message class. To do this, you define a
390
format rule and pass it to the constructor:
391

  
392
   $aFormatRule = ['Cannot copy %s to %s', qw(from to) ];
393

  
394
   declareExceptionClass($sClass, $aFormatRule);
395
   declareExceptionClass($sClass, $sSuperClass, $aFormatRule);
396

  
397
   # with customized subclass
398
   declareExceptionClass($sClass, $aFormatRule, 1);
399
   declareExceptionClass($sClass, $sSuperClass, $aFormatRule, 1);
400

  
401
Format rules are nothing more than a sprintf message string
402
followed by a list of properties in the same order as the
403
placeholders in the message string.  Later on when an exception
404
is generated, the values of the properties will replace the
405
property names.  Some more examples of format rules:
406

  
407

  
408
   $aFormatRule = ['Illegal argument <%s>: %s', qw(arg reason)];
409
   declareExceptionClass('BadArg', $aFormatRule);
410

  
411
   $aFormatRule = ['Cannot open file <%s>> %s', qw(file reason)];
412
   declareExceptionClass('OpenFailed', $aFormatRule);
413

  
414
   $sFormatRule = ['Too few %s,  must be at least %s', qw(item min)];
415
   declareExceptionClass('TooFewWidgets', $aFormatRule);
416

  
417

  
418
Later on when you throw an exception you can forget about the message
419
and set the properties, the class will do the rest of the work:
420

  
421
    die BadArg->new(arg=>$sPassword, reason=>'Too few characters');
422

  
423

  
424
    open(my $fh, '>', $sFile)
425
      or die OpenFailed->new(file=>$sFile, reason=>$!);
426

  
427
And still later when you catch the exception, you have two kinds
428
of information for the price of one:
429

  
430
    # if you catch BadArg
431

  
432
    $e->getProperty('arg')      # mine
433
    $e->getProperty('reason')   # too few characters
434
    $e->getMessage()   # Illegal argument <mine>: too few characters
435

  
436

  
437
    # if you catch OpenFailed
438

  
439
    $e->getProperty('file')     # foo.txt
440
    $e->getProperty('reason')   # path not found
441
    $e->getMessage()   # Cannot open <foo.txt>: path not found
442

  
443

  
444
=head2 Creating and throwing exceptions
445

  
446
When it comes times to create an exception, you create and
447
throw it like this (C<$sClass> is a placeholder for the name of
448
your exception class);
449

  
450

  
451
   die $sClass->new($sMsg, prop1 => $val1, ...);  #no format rule
452
   die $sClass->new(prop1 => $val1, ...);         #has format rule
453

  
454
   #-or-
455

  
456
   $e = $sClass->new($sMsg, prop1 => $val1, ...); #no format rule
457
   $e = $sClass->new(prop1 => $val1, ...);        #has format rule
458

  
459
   die $e;
460

  
461

  
462
For example:
463

  
464
   # Freeform exceptions (caller composes message, has message
465
   # parameter ($sMsg) before the list of properties)
466

  
467
   close $fh or die UnexpectedException
468
     ->new("Couldn't close file handle (huh?): $!");
469

  
470
   die PropertySettingError("Couldn't set property"
471
     , prop=>foo, value=>bar);
472

  
473
   # Formatted exceptions (no $sMsg parameter)
474

  
475
   if (length($sPassword) < 8) {
476
      die BadArg->new(arg=>$sPassword, reason=>'Too few characters');
477
   }
478

  
479
   open(my $fh, '>', $sFile)
480
      or die OpenFailed->new(file=>$sFile, reason=>$!);
481

  
482
In the above examples the order of the properties does not matter.
483
C<Exception::Lite> is using the property names, not the order of
484
the properties to find the right value to plug into the message
485
format string.
486

  
487
=head2 Catching and testing exceptions
488

  
489
In Perl there are two basic ways to work with exceptions:
490

  
491
* native Perl syntax
492

  
493
* Java like syntax (requires non-core modules)
494

  
495
=head3 Catching exceptions the Java way
496

  
497
Java uses the following idiom to catch exceptions:
498

  
499
   try {
500
     .... some code here ...
501
  } catch (SomeExceptionClass e) {
502
    ... error handling code here ...
503
  } catch (SomeOtherExceptionClass e) {
504
    ... error handling code here ...
505
  } finally {
506
    ... cleanup code here ...
507
  }
508

  
509
There are several CPAN modules that provide some sort of syntactic
510
sugar so that you can emulate java syntax. The one recommended
511
for C<Exception::Lite> users is L<Try::Tiny|Try::Tiny>.
512
L<Try::Tiny|Try::Tiny> is an elegant class that concerns itself
513
only with making it possible to use java-like syntax.  It can be
514
used with any sort of exception.
515

  
516
Some of the other CPAN modules that provide java syntax also
517
require that you use their exception classes because the java like
518
syntax is part of the class definition rather than a pure
519
manipulation of Perl syntax.
520

  
521

  
522
=head3 Catching exceptions the Perl way
523

  
524
The most reliable and fastest way to catch an exception is to use
525
C< eval/do >:
526

  
527
   eval {
528
     ...
529
     return 1;
530
   } or do {
531
     # save $@ before using it - it can easily be clobbered
532
     my $e=$@;
533

  
534
     ... do something with the exception ...
535

  
536
     warn $e;                 #use $e as a string
537
     warn $e->getMessage();   # use $e as an object
538
   }
539

  
540

  
541
The C<eval> block ends with C<return 1;> to insure that successful
542
completion of the eval block never results in an undefined value.
543
In certain cases C<undef> is a valid return value for a statement,
544
We don't want to enter the C<do> block for any reason other than
545
a thrown exception.
546

  
547
C< eval/do > is both faster and more reliable than the C< eval/if>
548
which is commonly promoted in Perl programming tutorials:
549

  
550
  # eval ... if
551

  
552
  eval {...};
553
  if ($@) {....}
554

  
555
It is faster because the C<do> block is executed if and only
556
if the eval fails. By contrast the C<if> must be evaluated both
557
in cases of succes and failure.
558

  
559
C< eval/do > is more reliable because the C<do> block is guaranteed
560
to be triggered by any die, even one that accidentally throws undef
561
or '' as the "exception". If an exception is thrown within the C<eval>
562
block, it will always evaluate to C<undef> therefore triggering the
563
C<do> block.
564

  
565
On the other hand we can't guarentee that C<$@> will be defined
566
even if an exception is thrown. If C<$@> is C<0>, C<undef>, or an
567
empty string, the C<if> block will never be entered.  This happens
568
more often then many programmers realize.  When eval exits the
569
C< eval > block, it calls destructors of any C<my> variables. If
570
any of those has an C< eval > statement, then the value of C<$@> is
571
wiped clean or reset to the exception generated by the destructor.
572

  
573
Within the C<do> block, it is a good idea to save C<$@> immediately
574
into a variable before doing any additional work.  Any subroutine
575
you call might also clobber it.  Even built-in commands that don't
576
normally set C<$@> can because Perl lets a programmer override
577
built-ins with user defined routines and those user define routines
578
might set C<$@> even if the built-in does not.
579

  
580
=head3 Testing exceptions
581

  
582
Often when we catch an exception we want to ignore some, rethrow
583
others, and in still other cases, fix the problem. Thus we need a
584
way to tell what kind of exception we've caught.  C<Exception::Lite>
585
provides the C<isException> method for this purpose.  It can be
586
passed any exception, including scalar exceptions:
587

  
588
   # true if this exception was generated by Exception::Line
589
   isException($e);
590

  
591

  
592
   # true if this exception belongs to $sClass. It may be a member
593
   # of the class or a subclass.  C<$sClass> may be any class, not
594
   # just an Exception::Lite generated class. You can even use this
595
   # method to test for string (scalar) exceptions:
596

  
597
   isException($e,$sClass);
598

  
599
   isException($e,'Excption::Class');
600
   isException($e, 'BadArg');
601
   isException($e, '');
602

  
603
And here is an example in action. It converts an exception to a
604
warning and determines how to do it by checing the class.
605

  
606

  
607
   eval {
608
     ...
609
     return 1;
610
   } or do {
611
     my $e=$@;
612
     if (Exception::Lite::isException($e)) {
613

  
614
        # get message w/o stack trace, "$e" would produce trace
615
        warn $e->getMessage();
616

  
617
     } elsif (Exception::Lite::isException('Exception::Class') {
618

  
619
        # get message w/o stack trace, "$e" would produce trace
620
        warn $e->message();
621

  
622
     } elsif (Exception::Lite::isException($e,'')) {
623

  
624
        warn $e;
625
     }
626
   }
627

  
628
=head2 Rethrowing exceptions
629

  
630
Perl doesn't have a C<rethrow> statement.  To reliably rethrow an
631
exception, you must set C<$@> to the original exception (in case it
632
has been clobbered during the error handling process) and then call
633
C<die> without any arguments.
634

  
635
   eval {
636
     ...
637
     return 1;
638
   } or do {
639
     my $e=$@;
640

  
641
     # do some stuff
642

  
643
     # rethrow $e
644
     $@=$e; die;
645
   }
646

  
647
The above code will cause the exception's C<PROPAGATE> method to
648
record the file and line number where the exception is rethrown.
649
See C<getLine>, C<getFile>, and C<getPropagation> in the class
650
reference below for more information.
651

  
652
As this Perl syntax is not exactly screaming "I'm a rethrow", 
653
C<Exception::Lite> provides an alternative and hopefully more
654
intuitive way of propagating an exception. There is no magic here,
655
it just does what perl would do had you used the normal syntax,
656
i.e. call the exception's C<PROPAGATE> method.
657

  
658
   eval {
659
     ...
660
     return 1;
661
   } or do {
662
     my $e=$@;
663

  
664
     # rethrow $e
665
     die $e->rethrow();
666
   }
667

  
668
=head2 Chaining Messages
669

  
670
As an exception moves up the stack, its meaning may change. For
671
example, suppose a subroutine throws the message "File not open".
672
The immediate caller might be able to use that to try and open
673
a different file.  On the other hand, if the message gets thrown
674
up the stack, the fact that a file failed to open might not
675
have any meaning at all.  That higher level code only cares that
676
the data it needed wasn't available. When it notifies the user,
677
it isn't going to say "File not found", but "Can't run market
678
report: missing data feed.".
679

  
680
When the meaning of the exception changes, it is normal to throw
681
a new exception with a class and message that captures the new
682
meaning. However, if this is all we do, we lose the original
683
source of the problem.
684

  
685
Enter chaining.  Chaining is the process of making one exception
686
"know" what other exception caused it.  You can create a new
687
exception without losing track of the original source of the
688
problem.
689

  
690
To chain exceptions is simple: just create a new exception and
691
pass the caught exception as the first parameter to C<new>. So
692
long as the exception is a non-scalar, it will be interpreted
693
as a chained exception and not a property name or message text
694
(the normal first parameter of C<new>).
695

  
696
Chaining is efficient, especially if the chained exception is
697
another C<Exception::Lite> exception. It does not replicate
698
the stack trace.  Rather the original stack trace is shorted to
699
include only the those fromes frome the time it was created to
700
the time it was chained.
701

  
702
Any non-scalar exception can be chained.  To test whether or not
703
a caught exception is chainable, you can use the method
704
C<isChainable>.  This method is really nothing more than
705
a check to see if the exception is a non-scalar, but it helps
706
to make your code more self documenting if you use that method
707
rather than C<if (ref($e))>.
708

  
709
If an exception isn't chainable, and you still want to chain
710
it, you can wrap the exception in an exception class. You
711
can use the built-in C<Exception::Class::Any> or any class of
712
your own choosing.
713

  
714
   #-----------------------------------------------------
715
   # define some classes
716
   #-----------------------------------------------------
717

  
718
   # no format rule
719
   declareExceptionClass('HouseholdDisaster');
720

  
721
   # format rule
722
   declareExceptionClass('ProjectDelay'
723
     , ['The project was delayed % days', qw(days)]);
724

  
725
   #-----------------------------------------------------
726
   # chain some exceptins
727
   #-----------------------------------------------------
728

  
729
   eval {
730
     .... some code here ...
731
     return 1;
732
  } or do {
733
    my $e=$@;
734
    if (Exception::Lite::isChainable($e)) {
735
      if (Exception::Lite::isException($e, 'FooErr') {
736
        die 'SomeNoFormatException'->new($e, "Caught a foo");
737
      } else {
738
        die 'SomeFormattedException'->new($e, when => 'today');
739
      }
740
    } elsif ($e =~ /fire/) {
741
       die 'Exception::Lite::Any'->new($e);
742
       die 'SomeFormattedException'->new($e, when => 'today');
743
    } else {
744
      # rethrow it since we can't chain it
745
      $@=$e; die;
746
    }
747
  }
748

  
749
=head2 Reading Stack Traces
750

  
751
At its fullest level of detail, a stack trace looks something
752
like this:
753

  
754
 Exception! Mayhem! and then ...
755

  
756
    thrown  at  file Exception/Lite.t, line 307
757
    in main::weKnowBetterThanYou, pid=24986, tid=1
758
       @_=('ARRAY(0x83a8a90)'
759
          ,'rot, rot, rot'
760
          ,'Wikerson brothers'
761
          ,'triculous tripe'
762
          ,'There will be no more talking to hoos who are not!'
763
          ,'black bottom birdie'
764
          ,'from the three billionth flower'
765
          ,'Mrs Tucanella returns with uncles and cousins'
766
          ,'sound off! sound off! come make yourself known!'
767
          ,'Apartment 12J'
768
          ,'Jo Jo the young lad'
769
          ,'the whole world was saved by the smallest of all'
770
          )
771
    reached via file Exception/Lite.t, line 281
772
    in main::notAWhatButAWho
773
       @_=()
774
    reached via file Exception/Lite.t, line 334 in main::__ANON__
775
       @_=()
776
    reached via file Exception/Lite.t, line 335 in <package: main>
777
       @ARGV=()
778

  
779
    Triggered by...
780
    Exception! Horton hears a hoo!
781
       rethrown at file Exception/Lite.t, line 315
782

  
783
       thrown  at  file Exception/Lite.t, line 316
784
       in main::horton, pid=24986, tid=1
785
          @_=('15th of May'
786
             ,'Jungle of Nool'
787
             ,'a small speck of dust on a small clover'
788
             ,'a person's a person no matter how small'
789
             )
790
       reached via file Exception/Lite.t, line 310 in main::hoo
791
          @_=('Dr Hoovey'
792
             ,'hoo-hoo scope'
793
             ,'Mrs Tucanella'
794
             ,'Uncle Nate'
795
             )
796
       reached via file Exception/Lite.t, line 303
797
       in main::weKnowBetterThanYou
798
          @_=('ARRAY(0x83a8a90)'
799
             ,'rot, rot, rot'
800
             ,'Wikerson brothers'
801
             ,'triculous tripe'
802
             ,'There will be no more talking to hoos who are not!'
803
             ,'black bottom birdie'
804
             ,'from the three billionth flower'
805
             ,'Mrs Tucanella returns with uncles and cousins'
806
             ,'sound off! sound off! come make yourself known!'
807
             ,'Apartment 12J'
808
             ,'Jo Jo the young lad'
809
             ,'the whole world was saved by the smallest of all'
810
             )
811

  
812

  
813
=over
814

  
815
=item *
816

  
817
lines begining with "thrown" indicate a line where a new exception
818
was thrown. If an exception was chained, there might be multiple
819
such lines.
820

  
821
=item *
822

  
823
lines beginning with "reached via" indicate the path travelled
824
I<down> to the point where the exception was thrown. This is the
825
code that was excuted before the exception was triggered.
826

  
827
=item *
828

  
829
lines beginning with "rethrown at" indicate the path travelled
830
I<up> the stack by the exception I<after> it was geenerated. Each
831
line indicates a place where the exception was caught and rethrown.
832

  
833
=item *
834

  
835
lines introduced with "Triggered by" are exceptions that were
836
chained together. The original exception is the last of the
837
triggered exceptions.  The original line is the "thrown" line
838
for the original exception.
839

  
840
=item *
841

  
842
C<@_> and <C@ARGV> below a line indicates what is left of the
843
parameters passed to a method, function or entry point routine.
844
In ideal circumstances they are the parameters passed to the
845
subroutine mentioned in the line immediately above C<@_>. In
846
reality, they can be overwritten or shifted away between the
847
point when the subroutine started and the line was reached.
848

  
849
Note: if you use L<Getopt::Long> to process C<@ARGV>, C<@ARGV>
850
will be empty reduced to an empty array. If this bothers you, you
851
can localize <@ARGV> before calling C<GetOptions>, like this:
852

  
853
  my %hARGV;
854
  {
855
    local @ARGV = @ARGV;
856
    GetOptions(\%hARGV,...);
857
  }
858

  
859
=item *
860

  
861
pid is the process id where the code was running
862

  
863
=item *
864

  
865
tid is the thread id where the code was running
866

  
867
=back
868

  
869
=head1 SPECIAL TOPICS
870

  
871
=head2 Localization of error messages
872

  
873
Rather than treat the error message and properties as entirely
874
separate entities, it gives you the option to define a format string
875
that will take your property values and insert them automatically
876
into your message.  Thus when you generate an exception, you can
877
specify only the properties and have your message automatically
878
generated without any need to repeat the property values in messy
879
C<sprintf>'s that clutter up your program.
880

  
881
One can localize from the very beginning when one declares the
882
class or later on after the fact if you are dealing with legacy
883
software or developing on an agile module and only implementing
884
what you need now.
885

  
886
To localize from the get-go:
887

  
888
   # myLookupSub returns the arguments to declareException
889
   # e.g.  ('CopyError', [ 'On ne peut pas copier de %s a %s'
890
                           , qw(from to)])
891

  
892
   declareExceptionClass( myLookupSub('CopyError', $ENV{LANG}) );
893

  
894

  
895
   # .... later on, exception generation code doesn't need to
896
   # know or care about the language. it just sets the properties
897

  
898

  
899
    # error message depends on locale:
900
    #   en_US:  'Cannot copy A.txt to B.txt'
901
    #   fr_FR:  'On ne peut pas copier de A.txt a B.txt'
902
    #   de_DE:  'Kann nicht kopieren von A.txt nach B.txt'
903

  
904
    die 'CopyError'->new(from => 'A.txt', to => 'B.txt');
905

  
906

  
907
Another alternative if you wish to localize from the get-go is
908
to pass a code reference instead of a format rule array. In this
909
case, C<Exception::Lite> will automatically pass the class name
910
to the subroutine and retrieve the value returned.
911

  
912

  
913
   # anothherLookupSub has parameters ($sClass) and returns
914
   # a format array, for example:
915
   #
916
   # %LOCALE_FORMAT_HASH = (
917
   #    CopyError => {
918
   #        en_US => ['Cannot copy %s to %s', qw(from to)]
919
   #       ,fr_FR => ['On ne peut pas copier de %s a %s', qw(from to)]
920
   #       ,de_DE => ['Kann nicht kopieren von %s nach %s''
921
   #                   , qw(from to)]
922
   #
923
   #    AddError => ...
924
   # );
925
   #
926
   # sub anotherLookupSub {
927
   #    my ($sClass) = @_;
928
   #    my $sLocale = $ENV{LANG}
929
   #    return $LOCALE_FORMAT_HASH{$sClass}{$sLocale};
930
   # }
931
   #
932

  
933
   declareExceptionClass('CopyError', &anotherLookupSub);
934
   declareExceptionClass('AddError', &anotherLookupSub);
935

  
936

  
937
    # error message depends on locale:
938
    #   en_US:  'Cannot copy A.txt to B.txt'
939
    #   fr_FR:  'On ne peut pas copier de A.txt a B.txt'
940
    #   de_DE:  'Kann nicht kopieren von A.txt nach B.txt'
941

  
942
    die CopyError->new(from => 'A.txt', to => 'B.txt');
943
    die AddError->new(path => 'C.txt');
944

  
945

  
946
If you need to put in localization after the fact, perhaps for a
947
new user interface you are developing, the design pattern might
948
look like this:
949

  
950
   # in the code module you are retrofitting would be an exception
951
   # that lived in a single language world. 
952

  
953
   declareExceptionClass('CopyError'
954
     ['Cannot copy %s to %s', [qw(from to)]);
955

  
956

  
... Dieser Diff wurde abgeschnitten, weil er die maximale Anzahl anzuzeigender Zeilen überschreitet.

Auch abrufbar als: Unified diff