projekt kivitendo

# Copyright (c) 2010 Elizabeth Grace Frank-Backman.

# All rights reserved.

# Liscenced under the "Artistic Liscence"

# (see http://dev.perl.org/licenses/artistic.html)

use 5.8.8;

use strict;

use warnings;

use overload;

package Exception::Lite;

our @ISA = qw(Exporter);

our @EXPORT_OK=qw(declareExceptionClass isException isChainable

                  onDie onWarn);

our %EXPORT_TAGS

  =( common => [qw(declareExceptionClass isException isChainable)]

     , all => [@EXPORT_OK]

   );

my $CLASS='Exception::Lite';

#------------------------------------------------------------------

our $STRINGIFY=3;

our $FILTER=1;

our $UNDEF='<undef>';

our $TAB=3;

our $LINE_LENGTH=120;

# provide command line control over amount and layout of debugging

# information, e.g. perl -mException::Lite=STRINGIFY=4

sub import {

  Exception::Lite->export_to_level(1, grep {

    if (/^(\w+)=(.*)$/) {

      my $k = $1;

      my $v = $2;

      if ($k eq 'STRINGIFY')        { $STRINGIFY=$v;

      } elsif ($k eq 'FILTER')      { $FILTER=$v;

      } elsif ($k eq 'LINE_LENGTH') { $LINE_LENGTH=$v;

      } elsif ($k eq 'TAB')         { $TAB=$v;

      }

      0;

    } else {

      1;

    }

  } @_);

}

#------------------------------------------------------------------

# Note to source code divers: DO NOT USE THIS. This is intended for

# internal use but must be declared with "our" because we need to

# localize it.  This is an implementation detail and cannot be relied

# on for future releases.

our $STACK_OFFSET=0;

#------------------------------------------------------------------

use Scalar::Util ();

use constant EVAL => '(eval)';

#==================================================================

# EXPORTABLE FUNCTIONS

#==================================================================

sub declareExceptionClass {

  my ($sClass, $sSuperClass, $xFormatRule, $bCustomizeSubclass) = @_;

  my $sPath = $sClass; $sPath =~ s/::/\//g; $sPath .= '.pm';

  if ($INC{$sPath}) {

    # we want to start with the caller's frame, not ours

    local $STACK_OFFSET = $STACK_OFFSET + 1;

    die 'Exception::Lite::Any'->new("declareExceptionClass failed: "

                                    . "$sClass is already defined!");

    return undef;

  }

  my $sRef=ref($sSuperClass);

  if ($sRef) {

    $bCustomizeSubclass = $xFormatRule;

    $xFormatRule = $sSuperClass;

    $sSuperClass=undef;

  } else {

    $sRef = ref($xFormatRule);

    if (!$sRef && defined($xFormatRule)) {

      $bCustomizeSubclass = $xFormatRule;

      $xFormatRule = undef;

    }

  }

  # set up things dependent on whether or not the class has a

  # format string or expects a message for each instance

  my ($sLeadingParams, $sAddOrOmit, $sRethrowMsg, $sMakeMsg);

  my $sReplaceMsg='';

  if ($sRef) {

    $sLeadingParams='my $e; $e=shift if ref($_[0]);';

    $sAddOrOmit='added an unnecessary message or format';

    $sRethrowMsg='';

    #generate format rule

    $xFormatRule=$xFormatRule->($sClass) if ($sRef eq 'CODE');

    my $sFormat= 'q{' . $xFormatRule->[0] . '}';

    if (scalar($xFormatRule) == 1) {

      $sMakeMsg='my $msg='.$sFormat;

    } else {

      my $sSprintf = 'Exception::Lite::_sprintf(' . $sFormat

        . ', map {defined($_)?$_:\''. $UNDEF .'\'} @$h{qw('

        . join(' ', @$xFormatRule[1..$#$xFormatRule]) . ')});';

      $sMakeMsg='my $msg='.$sSprintf;

      $sReplaceMsg='$_[0]->[0]='.$sSprintf;

    }

  } else {

    $sLeadingParams = 'my $e=shift; my $msg;'.

      'if(ref($e)) { $msg=shift; $msg=$e->[0] if !defined($msg);}'.

      'else { $msg=$e;$e=undef; }';

    $sAddOrOmit='omitted a required message';

    $sRethrowMsg='my $msg=shift; $_[0]->[0]=$msg if defined($msg);';

    $sMakeMsg='';

  }

  # put this in an eval so that it doesn't cause parse errors at

  # compile time in no-threads versions of Perl

  my $sTid = eval q{defined(&threads::tid)?'threads->tid':'undef'};

  my $sDeclare = "package $sClass;".

    'sub new { my $cl=shift;'.  $sLeadingParams .

      'my $st=Exception::Lite::_cacheStackTrace($e);'.

      'my $h= Exception::Lite::_shiftProperties($cl' .

         ',$st,"'.$sAddOrOmit.'",@_);' . $sMakeMsg .

      'my $self=bless([$msg,$h,$st,$$,'.$sTid.',$e,[]],$cl);';

  # the remainder depends on the type of subclassing

  if ($bCustomizeSubclass) {

    $sDeclare .= '$self->[7]={}; $self->_new(); return $self; }'

      . 'sub _p_getSubclassData { $_[0]->[7]; }';

  } else {

    $sDeclare .= 'return $self;}'.

    'sub replaceProperties {'.

       'my $h={%{$_[0]->[1]},%{$_[1]}}; $_[0]->[1]=$h;'.$sReplaceMsg.

    '}'.

    'sub rethrow {' .

      'my $self=shift;' . $sRethrowMsg .

      'Exception::Lite::_rethrow($self,"'.$sAddOrOmit.'",@_)' .

    '}';

    unless (isExceptionClass($sSuperClass)) {

      $sDeclare .=

        'sub _getInterface { \'Exception::Lite\' }' .

        'sub getMessage { $_[0]->[0] };' .

        'sub getProperty { $_[0]->[1]->{$_[1]} }' .

        'sub isProperty { exists($_[0]->[1]->{$_[1]})?1:0 }' .

        'sub getStackTrace { $_[0]->[2] }' .

        'sub getFrameCount { scalar(@{$_[0]->[2]}); }' .

        'sub getFile { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[0] };' .

        'sub getLine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[1] };' .

        'sub getSubroutine { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[2] };' .

        'sub getArgs { $_[0]->[2]->[ $_[1]?$_[1]:0 ]->[3] };' .

        'sub getPackage {$_[0]->[2]->[-1]->[2] =~ /(\w+)>$/;$1}'.

        'sub getPid { $_[0]->[3] }' .

        'sub getTid { $_[0]->[4] }' .

        'sub getChained { $_[0]->[5] }' .

        'sub getPropagation { $_[0]->[6]; }' .

        'use overload '.

           'q{""} => \&Exception::Lite::_dumpMessage ' .

           ', q{0+} => \&Exception::Lite::_refaddr, fallback=>1;' .

        'sub PROPAGATE { push @{$_[0]->[6]},[$_[1],$_[2]]; $_[0]}';

    }

  }

  $sDeclare .= 'return 1;';

  local $SIG{__WARN__} = sub {

    my ($p,$f,$l) = caller(2);

    my $s=$_[0]; $s =~ s/at \(eval \d+\)\s+line\s+\d+\.//m;

    print STDERR "$s in declareExceptionClass($sClass,...) "

      ."in file $f, line $l\n";

  };

  eval $sDeclare or do {

    my ($p,$f,$l) = caller(1);

    print STDERR "Can't create class $sClass at file $f, line $l\n";

    if ($sClass =~ /\w:\w/) {

      print STDERR "Bad class name: "

        ."At least one ':' is not doubled\n";

    } elsif ($sClass !~ /^\w+(?:::\w+)*$/) {

      print STDERR "Bad class name: $sClass\n";

    } else {

      $sDeclare=~s/(sub |use )/\n$1/g; print STDERR "$sDeclare\n";

    }

  };

  # this needs to be separate from the eval, otherwise it never

  # ends up in @INC or @ISA, at least in Perl 5.8.8

  $INC{$sPath} = __FILE__;

  eval "\@${sClass}::ISA=qw($sSuperClass);" if $sSuperClass;

  return $sClass;

}

#------------------------------------------------------------------

sub isChainable { return ref($_[0])?1:0; }

#------------------------------------------------------------------

sub isException {

  my ($e, $sClass) = @_;

  my $sRef=ref($e);

  return !defined($sClass)

    ? ($sRef ? isExceptionClass($sRef) : 0)

    : $sClass eq ''

       ? ($sRef eq '' ? 1 : 0)

       : ($sRef eq '')

            ? 0

            : $sRef->isa($sClass)

               ?1:0;

}

#------------------------------------------------------------------

sub isExceptionClass {

  return defined($_[0]) && $_[0]->can('_getInterface')

    && ($_[0]->_getInterface() eq __PACKAGE__) ? 1 : 0;

}

#------------------------------------------------------------------

sub onDie {

  my $iStringify = $_[0];

  $SIG{__DIE__} = sub {

    $Exception::Lite::STRINGIFY=$iStringify;

    warn 'Exception::Lite::Any'->new('Unexpected death:'.$_[0])

      unless $^S || isException($_[0]);

  };

}

#------------------------------------------------------------------

sub onWarn {

  my $iStringify = $_[0];

  $SIG{__WARN__} = sub {

    $Exception::Lite::STRINGIFY=$iStringify;

    print STDERR 'Exception::Lite::Any'->new("Warning: $_[0]");

  };

}

#==================================================================

# PRIVATE SUBROUTINES

#==================================================================

#------------------------------------------------------------------

sub _cacheCall {

  my $iFrame = $_[0];

  my @aCaller;

  my $aArgs;

  # caller populates @DB::args if called within DB package

  eval {

    # this 2 line wierdness is needed to prevent Module::Build from finding

    # this and adding it to the provides list.

    package

      DB;

    #get rid of eval and call to _cacheCall

    @aCaller = caller($iFrame+2);

    # mark leading undefined elements as maybe shifted away

    my $iDefined;

    if ($#aCaller < 0) {

      @DB::args=@ARGV;

    }

    $aArgs = [  map {

      defined($_)

        ? do {$iDefined=1;

              "'$_'" . (overload::Method($_,'""')

                        ? ' ('.overload::StrVal($_).')':'')}

          : 'undef' . (defined($iDefined)

                       ? '':'  (maybe shifted away?)')

        } @DB::args];

  };

  return $#aCaller < 0 ? \$aArgs : [ @aCaller[0..3], $aArgs ];

}

#------------------------------------------------------------------

sub _cacheStackTrace {

  my $e=$_[0]; my $st=[];

  # set up initial frame

  my $iFrame= $STACK_OFFSET + 1; # call to new

  my $aCall = _cacheCall($iFrame++);

  my ($sPackage, $iFile, $iLine, $sSub, $sArgs) = @$aCall;

  my $iLineFrame=$iFrame;

  $aCall =  _cacheCall($iFrame++);  #context of call to new

  while (ref($aCall) ne 'REF') {

    $sSub  = $aCall->[3];  # subroutine containing file,line

    $sArgs = $aCall->[4];  # args used to call $sSub

    #print STDERR "debug-2: package=$sPackage file=$iFile line=$iLine"

    #  ." sub=$sSub, args=@$sArgs\n";

    # in evals we want the line number within the eval, but the

    # name of the sub in which the eval was located. To get this

    # we wait to push on the stack until we get an actual sub name

    # and we avoid overwriting the location information, hence 'ne'

    if (!$FILTER || ($sSub ne EVAL)) {

      my $aFrame=[ $iFile, $iLine, $sSub, $sArgs ];

      ($sPackage, $iFile, $iLine) = @$aCall;

      $iLineFrame=$iFrame;

      my $sRef=ref($FILTER);

      if ($sRef eq 'CODE') {

        my $x = $FILTER->(@$aFrame, $iFrame, $iLineFrame);

        if (ref($x) eq 'ARRAY') {

          $aFrame=$x;

        } elsif (!$x) {

          $aFrame=undef;

        }

      } elsif (($sRef eq 'ARRAY') && ! _isIgnored($sSub, $FILTER)) {

        $aFrame=undef;

      } elsif (($sRef eq 'Regexp') && !_isIgnored($sSub, [$FILTER])) {

        $aFrame=undef;

      }

      push(@$st, $aFrame) if $aFrame;

    }

    $aCall = _cacheCall($iFrame++);

  }

  push @$st, [ $iFile, $iLine, "<package: $sPackage>", $$aCall ];

  if ($e) { my $n=$#{$e->[2]}-$#$st;$e->[2]=[@{$e->[2]}[0..$n]]};

  return $st;

}

#-----------------------------

sub _isIgnored {

  my ($sSub, $aIgnore) = @_;

  foreach my $re (@$aIgnore) { return 1 if $sSub =~ $re; }

  return 0;

}

#------------------------------------------------------------------

sub _dumpMessage {

  my ($e, $iDepth) = @_;

  my $sMsg = $e->getMessage();

  return $sMsg unless $STRINGIFY;

  if (ref($STRINGIFY) eq 'CODE') {

    return $STRINGIFY->($sMsg);

  }

  $iDepth = 0 unless defined($iDepth);

  my $sIndent = ' ' x ($TAB*$iDepth);

  $sMsg = "\n${sIndent}Exception! $sMsg";

  return $sMsg if $STRINGIFY == 0;

  my ($sThrow, $sReach);

  my $sTab = ' ' x $TAB;

  $sIndent.= $sTab;

  if ($STRINGIFY > 2) {

    my $aPropagation = $e->getPropagation();

    for (my $i=$#$aPropagation; $i >= 0; $i--) {

      my ($f,$l) = @{$aPropagation->[$i]};

      $sMsg .= "\n${sIndent}rethrown at file $f, line $l";

    }

    $sMsg .= "\n";

    $sThrow='thrown  ';

    $sReach='reached ';

  } else {

    $sThrow='';

    $sReach='';

  }

  my $st=$e->getStackTrace();

  my $iTop = scalar @$st;

  for (my $iFrame=0; $iFrame<$iTop; $iFrame++) {

    my ($f,$l,$s,$aArgs) = @{$st->[$iFrame]};

    if ($iFrame) {

      #2nd and following stack frame

      my $sVia="${sIndent}${sReach}via file $f, line $l";

      my $sLine="$sVia in $s";

      $sMsg .= (length($sLine)>$LINE_LENGTH

                ? "\n$sVia\n$sIndent${sTab}in $s" : "\n$sLine");

    } else {

      # first stack frame

      my $tid=$e->getTid();

      my $sAt="${sIndent}${sThrow}at  file $f, line $l";

      my $sLine="$sAt in $s";

      $sMsg .= (length($sLine)>$LINE_LENGTH

                ? "\n$sAt\n$sIndent${sTab}in $s" : "\n$sLine")

        . ", pid=" . $e->getPid() . (defined($tid)?", tid=$tid":'');

      return "$sMsg\n" if $STRINGIFY == 1;

    }

    if ($STRINGIFY > 3) {

      my $bTop = ($iFrame+1) == $iTop;

      my $sVar= ($bTop && !$iDepth) ? '@ARGV' : '@_';

      my $bMaybeEatenByGetOpt = $bTop && !scalar(@$aArgs)

        && exists($INC{'Getopt/Long.pm'});

      my $sVarIndent = "\n${sIndent}" . (' ' x $TAB);

      my $sArgPrefix = "${sVarIndent}".(' ' x length($sVar)).' ';

      if ($bMaybeEatenByGetOpt) {

        $sMsg .= $sArgPrefix . $sVar

          . '()    # maybe eaten by Getopt::Long?';

      } else {

        my $sArgs = join($sArgPrefix.',', @$aArgs);

        $sMsg .= "${sVarIndent}$sVar=($sArgs";

        $sMsg .= $sArgs ? "$sArgPrefix)" : ')';

      }

    }

  }

  $sMsg.="\n";

  return $sMsg if $STRINGIFY == 2;

  my $eChained = $e->getChained();

  if (defined($eChained)) {

    my $sTrigger = isException($eChained)

      ? _dumpMessage($eChained, $iDepth+1)

      : "\n${sIndent}$eChained\n";

    $sMsg .= "\n${sIndent}Triggered by...$sTrigger";

  }

  return $sMsg;

}

#------------------------------------------------------------------

# refaddr has a prototype($) so we can't use it directly as an

# overload operator: it complains about being passed 3 parameters

# instead of 1.

sub _refaddr { Scalar::Util::refaddr($_[0]) };

#------------------------------------------------------------------

sub _rethrow {

  my $self = shift; my $sAddOrOmit = shift;

  my ($p,$f,$l)=caller(1);

  $self->PROPAGATE($f,$l);

  if (@_%2) {

    warn sprintf('bad parameter list to %s->rethrow(...)'

      .'at file %d, line %d: odd number of elements in property-value '

      .'list, property value has no property name and will be '

      ."discarded (common causes: you have %s string)\n"

      ,$f, $l, $sAddOrOmit);

    shift @_;

  }

  $self->replaceProperties({@_}) if (@_);

  return $self;

}

#------------------------------------------------------------------

# Traps warnings and reworks them so that they tell the user how

# to fix the problem rather than obscurely complain about an

# invisible sprintf with uninitialized values that seem to come from

# no where (and make Exception::Lite look like it is broken)

sub _sprintf {

  my $sMsg;

  my $sWarn;

  {

    local $SIG{__WARN__} = sub { $sWarn=$_[0] if !defined($sWarn) };

    # sprintf has prototype ($@)

    my $sFormat = shift;

    $sMsg = sprintf($sFormat, @_);

  }

  if (defined($sWarn)) {

    my $sReason='';

    my ($f, $l, $s) = (caller(1))[1,2,3];

    $s =~ s/::(\w+)\z/->$1/;

    $sWarn =~ s/sprintf/$s/;

    $sWarn =~ s/\s+at\s+[\w\/\.]+\s+line\s+\d+\.\s+\z//;

    if ($sWarn

        =~ m{^Use of uninitialized value in|^Missing argument}) {

      my $p=$s; $p =~ s/->\w+\z//;

      $sReason ="\n     Most likely cause: "

        . "Either you are missing property-value pairs needed to"

        . "build the message or your exception class's format"

        . "definition mistakenly has too many placeholders "

        . "(e.g. %s,%d,etc)\n";

    }

    warn "$sWarn called at file $f, line $l$sReason\n";

  }

  return $sMsg;

}

#------------------------------------------------------------------

sub _shiftProperties {

  my $cl= shift;  my $st=shift;  my $sAddOrOmit = shift;

  if (@_%2) {

    $"='|';

    warn sprintf('bad parameter list to %s->new(...) at '

      .'file %s, line %d: odd number of elements in property-value '

      .'list, property value has no property name and will be '

      .'discarded (common causes: you have %s string -or- you are '

      ."using a string as a chained exception)\n"

      ,$cl,$st->[0]->[0],$st->[0]->[1], $sAddOrOmit);

    shift @_;

  }

  return {@_};

}

#==================================================================

# MODULE INITIALIZATION

#==================================================================

declareExceptionClass(__PACKAGE__ .'::Any');

1;

=head1 NAME

Exception::Lite - light weight exception handling class with smart

stack tracing, chaining, and localization support.

=head1 SYNOPSIS

   # --------------------------------------------------------

   # making this module available to your code

   # --------------------------------------------------------

   #Note: there are NO automatic exports

   use Exception::Lite qw(declareExceptionClass

                          isException

                          isChainable

                          onDie

                          onWarn);

   # imports only: declareExceptionClass isException isChainable

   use Exception::Lite qw(:common);

   # imports all exportable methods listed above

   use Exception::Lite qw(:all);

   # --------------------------------------------------------

   # declare an exception class

   # --------------------------------------------------------

   # no format rule

   declareExceptionClass($sClass);

   declareExceptionClass($sClass, $sSuperClass);

   # with format rule

   declareExceptionClass($sClass, $aFormatRule);

   declareExceptionClass($sClass, $sSuperClass, $aFormatRule);

   # with customized subclass

   declareExceptionClass($sClass, $sSuperClass, 1);

   declareExceptionClass($sClass, $aFormatRule, 1);

   declareExceptionClass($sClass, $sSuperClass, $aFormatRule, 1);

   # --------------------------------------------------------

   # throw an exception

   # --------------------------------------------------------

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

   die $sClass->new($prop1 => $val1, ...);         #has format rule

   #-or-

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

   $e = $sClass->new($prop1 => $val1, ...);        #has format rule

   die $e;

   # --------------------------------------------------------

   # catch and test an exception

   # --------------------------------------------------------

   # Note: for an explanation of why we don't use if ($@)... here,

   # see Catching and Rethrowing exceptions below

   eval {

     .... some code that may die here ...

     return 1;

   } or do {

     my $e=$@;

     if (isException($e, 'Class1')) {

       ... do something ...

     } elsif (isExcption($e, 'Class2')) {

        ... do something else ...

     }

   };

   isException($e);        # does $e have the above exception methods?

   isException($e,$sClass) # does $e belong to $sClass or a subclass?

   # --------------------------------------------------------

   # getting information about an exception object

   # --------------------------------------------------------

   $e->getMessage();

   $e->getProperty($sName);

   $e->isProperty($sName);

   $e->replaceProperties($hOverride);

   $e->getPid();

   $e->getPackage();

   $e->getTid();

   $e->getStackTrace();

   $e->getFrameCount();

   $e->getFile($i);

   $e->getLine($i);

   $e->getSubroutine($i);

   $e->getArgs($i);

   $e->getPropagation();

   $e->getChained();

   # --------------------------------------------------------

   # rethrowing exceptions

   # --------------------------------------------------------

   # using original properties and message

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

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

   # overriding original message/properties

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

   # --------------------------------------------------------

   # creation of chained exceptions (one triggered by another)

   # (new exception with "memory" of what caused it and stack

   # trace from point of cause to point of capture)

   # --------------------------------------------------------

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

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

   die $sClass->new($e, $prop1 => $val1, ...);       #has format rule

   # --------------------------------------------------------

   # print out full message from an exception

   # --------------------------------------------------------

   print $e                         # print works

   warn $e                          # warn works

   print "$e\n";                    # double quotes work

   my $sMsg=$e."\n"; print $sMsg;   # . operator works

   # --------------------------------------------------------

   # global control variables (maybe set on the command line)

   # --------------------------------------------------------

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

      = 1;        # message and file/line where it occured

      = 2;        # 1 + what called what (simplified stack trace)

      = 3;        # 2 + plus any chained exceptions and where message

                  # was caught, if propagated and rethrown

      = 4;        # 3 + arguments given to each call in stack trace

      = coderef   # custom formatting routine

   $Exception::Lite::TAB   # set indentation for stringified

                           # messages, particularly indentation for

                           # call parameters and chained exceptions

   $Exception::Lite::FILTER

     = 0         # see stack exactly as Perl does

     = 1         # remove frames added by eval blocks

     = coderef   # custom filter - see getStackTrace for details

   # --------------------------------------------------------

   # controlling the stack trace from the command line

   # --------------------------------------------------------

   perl -mException::Lite=STRINGIFY=1,FILTER=0,TAB=4

   perl -m'Exception::Lite qw(STRINGIFY=1 FILTER=0 TAB=4)'

   # --------------------------------------------------------

   # built in exception classes

   # --------------------------------------------------------

   # generic wrapper for converting exception strings and other

   # non-Exception::Lite exceptions into exception objects

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

To assist in debugging and testing, this package also includes

two methods that set handlers for die and warn. These methods

should I<only> be used temporarily during active debugging. They

should not be used in production software, least they interfere

with the way other programmers using your module wish to do their

debugging and testing.

   # --------------------------------------------------------

   # force all exceptions/warnings to use Exception::Lite to

   # print out messages and stack traces

   # --------------------------------------------------------

   # $stringify is the value for EXCEPTION::Lite::STRINGIFY

   # that you want to use locally to print out messages. It

   # will have no effect outside of the die handler

   Exception::Lite::onDie($stringify);

   Exception::Lite::onWarn($stringify);

=head1 DESCRIPTION

The C<Exception::Lite> class provides an easy and very light weight

way to generate context aware exceptions.  It was developed because

the exception modules on CPAN as of December,2010 were heavy on

features I didn't care for and did not have the features I most

needed to test and debug code efficiently.

=head2 Features

This module provides a light weight but powerful exception class

that

=over 

=item *

provides an uncluttered stack trace that clearly shows what

called what and what exception triggered what other exception.

It significantly improves on the readability of the stack trace

dumps provided by C<carp> and other exception modules on

CPAN (as of 12/2010).  For further discussion and a sample, see

L</More intelligent stack trace>.

=item *

gives the user full control over the amount of debugging

information displayed when exceptions are thrown.

=item *

permits global changes to the amount of debugging information

displayed via the command line.

=item *

closely integrates exception classes, messages, and properties

so that they never get out of sync with one another.  This in

turn eliminates redundant coding and helps reduce the cost of

writing,validating and maintaining a set of exceptions.

=item *

is easy to retrofit with native language support, even if this

need appears late in the development process.This makes it

suitable for use with agile development strategies.

=item *

act like strings in string context but are in fact objects with

a class hierarchy and properties.They can be thrown and rethrown

with standard Perl syntax. Like any object, they can be uniquely

identified in numeric context where they equal their reference

address (the value returned by C<Scalar::Util::refaddr()>.

=item *

does not interfere with signal handlers or the normal Perl syntax

and the assumptions of Perl operators.

=item *

can be easily extended and subclassed

=back

=head2 Lightweight how?

Despite these features C<Exception::Lite> maintains its "lite"

status by

=over

=item *

using only core modules

=item *

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

=item *

eliminating excess baggage by customizing generated classes to

  reflect the actual needs of exception message generation.  For

  instance an exception wrapped around a fixed string message would

  omit code for message/property integration and would be little

  more than a string tied to a stack trace and property hash.

=item *

storing only the minimum amount of stack trace data needed to

  generate exception messages and avoiding holding onto references

  from dead stack frames.  (Note: some CPAN modules hold onto

  actual variables from each frame, possibly interfering with

  garbage collection).

=item *

doing all its work, including class generation and utilities in

  a single file that is less than half the size of the next smallest

  similarly featured all-core exception class on CPAN (support for

  both properties and a class heirarchy).  C<Exception::Lite>

  contains about 400 lines when developer comments are excluded). The

  next smallest all core module is L<Exception::Base|Exception::Base>

  which clocks in at just over 1000 lines after pod and developer

  comments are excluded).

=item *

avoiding a heavy-weight base class.  Code shared by

  C<Exception::Lite> classes are stored in function calls that total

  230 or so lines of code relying on nothing but core modules. This

  is significantly less code than is needed by the two CPAN packages

  with comparable features.  The all core

  L<Exception::Base|Exception::Base> class contains 700+ lines of

  code.  The base class of L<Exception::Class|Exception::Class> has

  200 lines of its own but drags in two rather large non-core

  modules as dependencies:  L<Devel::StackTrace|Devel::StackTrace>

  L<Class::Data::Inheritable|Class::Data::Inheritable>.

=back

C<Exception::Lite> has more features (chaining, message/property

integration) but less code due to the following factors:

=over

=item *

working with Perl syntax rather than trying to replace it.

=item *

using a light approach to OOP - exception classes have just enough

and no more OO features than are needed to be categorized by a

class, participate in a class heirarchy and to have properties.

=item *

respecting separation of concerns. C<Exception::Lite> focuses

on the core responsibility of an exception and leaves the bulk of

syntax creation (e.g. Try/Catch) to specialist modules like

L<Try::Tiny|Try::Tiny>.  Other modules try to double as

comprehensive providers of exception related syntactic sugar.

=item *

not trying to be the only kind of exception that an application

uses.

=back

=head1 USAGE

=head2 Defining Exception Classes

C<Exception::Lite> provides two different ways to define messages.

The first way, without a format rule, lets you compose a freeform

message for each exception.  The second way, with a format rule,

lets you closely integrate messages and properties and facilitates

localization of messages for any packages using your software.

=head3 Defining freeform messages

If you want to compose a free form message for each and every

exception, the class declaration is very simple:

   declareExceptionClass($sClass);

   declareExceptionClass($sClass, $sSuperClass);

   # with customized subclass

   declareExceptionClass($sClass, $sSuperClass, 1);

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

C<$sSuperClass> is the name of the superclass, if there is one.

The superclass can be any class created by C<Exception::Lite>. It

can also be any role class, i.e. a class that has methods but no

object data of its own.

The downside of this simple exception class is that there is

absolutely no integration of your messages and any properties that

you assign to the exception.  If you would like to see your property

values included in the message string,consider using a formatted

message instead.

=head3 Defining formatted messages

If you wish to include property values in your messages, you need

to declare a formatted message class. To do this, you define a

format rule and pass it to the constructor:

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

   declareExceptionClass($sClass, $aFormatRule);

   declareExceptionClass($sClass, $sSuperClass, $aFormatRule);

   # with customized subclass

   declareExceptionClass($sClass, $aFormatRule, 1);

   declareExceptionClass($sClass, $sSuperClass, $aFormatRule, 1);

Format rules are nothing more than a sprintf message string

followed by a list of properties in the same order as the

placeholders in the message string.  Later on when an exception

is generated, the values of the properties will replace the

property names.  Some more examples of format rules:

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

   declareExceptionClass('BadArg', $aFormatRule);

   $aFormatRule = ['Cannot open file <%s>> %s', qw(file reason)];

   declareExceptionClass('OpenFailed', $aFormatRule);

   $sFormatRule = ['Too few %s,  must be at least %s', qw(item min)];

   declareExceptionClass('TooFewWidgets', $aFormatRule);

Later on when you throw an exception you can forget about the message

and set the properties, the class will do the rest of the work:

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

    open(my $fh, '>', $sFile)

      or die OpenFailed->new(file=>$sFile, reason=>$!);

And still later when you catch the exception, you have two kinds

of information for the price of one:

    # if you catch BadArg

    $e->getProperty('arg')      # mine

    $e->getProperty('reason')   # too few characters

    $e->getMessage()   # Illegal argument <mine>: too few characters

    # if you catch OpenFailed

    $e->getProperty('file')     # foo.txt

    $e->getProperty('reason')   # path not found

    $e->getMessage()   # Cannot open <foo.txt>: path not found

=head2 Creating and throwing exceptions

When it comes times to create an exception, you create and

throw it like this (C<$sClass> is a placeholder for the name of

your exception class);

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

   die $sClass->new(prop1 => $val1, ...);         #has format rule

   #-or-

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

   $e = $sClass->new(prop1 => $val1, ...);        #has format rule

   die $e;

For example:

   # Freeform exceptions (caller composes message, has message

   # parameter ($sMsg) before the list of properties)

   close $fh or die UnexpectedException

     ->new("Couldn't close file handle (huh?): $!");

   die PropertySettingError("Couldn't set property"

     , prop=>foo, value=>bar);

   # Formatted exceptions (no $sMsg parameter)

   if (length($sPassword) < 8) {

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

   }

   open(my $fh, '>', $sFile)

      or die OpenFailed->new(file=>$sFile, reason=>$!);

In the above examples the order of the properties does not matter.

C<Exception::Lite> is using the property names, not the order of

the properties to find the right value to plug into the message

format string.

=head2 Catching and testing exceptions

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

* native Perl syntax

* Java like syntax (requires non-core modules)

=head3 Catching exceptions the Java way

Java uses the following idiom to catch exceptions:

   try {

     .... some code here ...

  } catch (SomeExceptionClass e) {

    ... error handling code here ...

  } catch (SomeOtherExceptionClass e) {

    ... error handling code here ...

  } finally {

    ... cleanup code here ...

  }

There are several CPAN modules that provide some sort of syntactic

sugar so that you can emulate java syntax. The one recommended

for C<Exception::Lite> users is L<Try::Tiny|Try::Tiny>.

L<Try::Tiny|Try::Tiny> is an elegant class that concerns itself

only with making it possible to use java-like syntax.  It can be

used with any sort of exception.

Some of the other CPAN modules that provide java syntax also

require that you use their exception classes because the java like

syntax is part of the class definition rather than a pure

manipulation of Perl syntax.

=head3 Catching exceptions the Perl way

The most reliable and fastest way to catch an exception is to use

C< eval/do >:

   eval {

     ...

     return 1;

   } or do {

     # save $@ before using it - it can easily be clobbered

     my $e=$@;

     ... do something with the exception ...

     warn $e;                 #use $e as a string

     warn $e->getMessage();   # use $e as an object

   }

The C<eval> block ends with C<return 1;> to insure that successful

completion of the eval block never results in an undefined value.

In certain cases C<undef> is a valid return value for a statement,

We don't want to enter the C<do> block for any reason other than

a thrown exception.

C< eval/do > is both faster and more reliable than the C< eval/if>

which is commonly promoted in Perl programming tutorials:

  # eval ... if

  eval {...};

  if ($@) {....}

It is faster because the C<do> block is executed if and only

if the eval fails. By contrast the C<if> must be evaluated both

in cases of succes and failure.

C< eval/do > is more reliable because the C<do> block is guaranteed

to be triggered by any die, even one that accidentally throws undef

or '' as the "exception". If an exception is thrown within the C<eval>

block, it will always evaluate to C<undef> therefore triggering the

C<do> block.

On the other hand we can't guarentee that C<$@> will be defined

even if an exception is thrown. If C<$@> is C<0>, C<undef>, or an

empty string, the C<if> block will never be entered.  This happens

more often then many programmers realize.  When eval exits the

C< eval > block, it calls destructors of any C<my> variables. If

any of those has an C< eval > statement, then the value of C<$@> is

wiped clean or reset to the exception generated by the destructor.

Within the C<do> block, it is a good idea to save C<$@> immediately

into a variable before doing any additional work.  Any subroutine

you call might also clobber it.  Even built-in commands that don't

normally set C<$@> can because Perl lets a programmer override

built-ins with user defined routines and those user define routines

might set C<$@> even if the built-in does not.

=head3 Testing exceptions

Often when we catch an exception we want to ignore some, rethrow

others, and in still other cases, fix the problem. Thus we need a

way to tell what kind of exception we've caught.  C<Exception::Lite>

provides the C<isException> method for this purpose.  It can be

passed any exception, including scalar exceptions:

   # true if this exception was generated by Exception::Line

   isException($e);

   # true if this exception belongs to $sClass. It may be a member

   # of the class or a subclass.  C<$sClass> may be any class, not

   # just an Exception::Lite generated class. You can even use this

   # method to test for string (scalar) exceptions:

   isException($e,$sClass);

   isException($e,'Excption::Class');

   isException($e, 'BadArg');

   isException($e, '');

And here is an example in action. It converts an exception to a

warning and determines how to do it by checing the class.

   eval {

     ...

     return 1;

   } or do {

     my $e=$@;

     if (Exception::Lite::isException($e)) {

        # get message w/o stack trace, "$e" would produce trace

        warn $e->getMessage();

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

        # get message w/o stack trace, "$e" would produce trace

        warn $e->message();

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

        warn $e;

     }

   }

=head2 Rethrowing exceptions

Perl doesn't have a C<rethrow> statement.  To reliably rethrow an

exception, you must set C<$@> to the original exception (in case it

has been clobbered during the error handling process) and then call

C<die> without any arguments.

   eval {

     ...

     return 1;

   } or do {

     my $e=$@;

     # do some stuff

     # rethrow $e

     $@=$e; die;

   }

The above code will cause the exception's C<PROPAGATE> method to

record the file and line number where the exception is rethrown.

See C<getLine>, C<getFile>, and C<getPropagation> in the class

reference below for more information.

As this Perl syntax is not exactly screaming "I'm a rethrow", 

C<Exception::Lite> provides an alternative and hopefully more

intuitive way of propagating an exception. There is no magic here,

it just does what perl would do had you used the normal syntax,

i.e. call the exception's C<PROPAGATE> method.

   eval {

     ...

     return 1;

   } or do {

     my $e=$@;

     # rethrow $e

     die $e->rethrow();

   }

=head2 Chaining Messages

As an exception moves up the stack, its meaning may change. For

example, suppose a subroutine throws the message "File not open".

The immediate caller might be able to use that to try and open

a different file.  On the other hand, if the message gets thrown

up the stack, the fact that a file failed to open might not

have any meaning at all.  That higher level code only cares that

the data it needed wasn't available. When it notifies the user,

it isn't going to say "File not found", but "Can't run market

report: missing data feed.".

When the meaning of the exception changes, it is normal to throw

a new exception with a class and message that captures the new

meaning. However, if this is all we do, we lose the original

source of the problem.

Enter chaining.  Chaining is the process of making one exception

"know" what other exception caused it.  You can create a new

exception without losing track of the original source of the

problem.

To chain exceptions is simple: just create a new exception and

pass the caught exception as the first parameter to C<new>. So

long as the exception is a non-scalar, it will be interpreted

as a chained exception and not a property name or message text

(the normal first parameter of C<new>).

Chaining is efficient, especially if the chained exception is

another C<Exception::Lite> exception. It does not replicate

the stack trace.  Rather the original stack trace is shorted to

include only the those fromes frome the time it was created to

the time it was chained.

Any non-scalar exception can be chained.  To test whether or not

a caught exception is chainable, you can use the method

C<isChainable>.  This method is really nothing more than

a check to see if the exception is a non-scalar, but it helps

to make your code more self documenting if you use that method

rather than C<if (ref($e))>.

If an exception isn't chainable, and you still want to chain

it, you can wrap the exception in an exception class. You

can use the built-in C<Exception::Class::Any> or any class of

your own choosing.

   #-----------------------------------------------------

   # define some classes

   #-----------------------------------------------------

   # no format rule

   declareExceptionClass('HouseholdDisaster');

   # format rule

   declareExceptionClass('ProjectDelay'

     , ['The project was delayed % days', qw(days)]);

   #-----------------------------------------------------

   # chain some exceptins

   #-----------------------------------------------------

   eval {

     .... some code here ...

     return 1;

  } or do {

    my $e=$@;

    if (Exception::Lite::isChainable($e)) {

      if (Exception::Lite::isException($e, 'FooErr') {

        die 'SomeNoFormatException'->new($e, "Caught a foo");

      } else {

        die 'SomeFormattedException'->new($e, when => 'today');

      }

    } elsif ($e =~ /fire/) {

       die 'Exception::Lite::Any'->new($e);

       die 'SomeFormattedException'->new($e, when => 'today');

    } else {

      # rethrow it since we can't chain it

      $@=$e; die;

    }

  }

=head2 Reading Stack Traces

At its fullest level of detail, a stack trace looks something

like this:

 Exception! Mayhem! and then ...

    thrown  at  file Exception/Lite.t, line 307

    in main::weKnowBetterThanYou, pid=24986, tid=1

       @_=('ARRAY(0x83a8a90)'

          ,'rot, rot, rot'

          ,'Wikerson brothers'

          ,'triculous tripe'

          ,'There will be no more talking to hoos who are not!'

          ,'black bottom birdie'

          ,'from the three billionth flower'

          ,'Mrs Tucanella returns with uncles and cousins'

          ,'sound off! sound off! come make yourself known!'

          ,'Apartment 12J'

          ,'Jo Jo the young lad'

          ,'the whole world was saved by the smallest of all'

          )

    reached via file Exception/Lite.t, line 281

    in main::notAWhatButAWho

       @_=()

    reached via file Exception/Lite.t, line 334 in main::__ANON__

       @_=()

    reached via file Exception/Lite.t, line 335 in <package: main>

       @ARGV=()

    Triggered by...

    Exception! Horton hears a hoo!

       rethrown at file Exception/Lite.t, line 315

       thrown  at  file Exception/Lite.t, line 316

       in main::horton, pid=24986, tid=1

          @_=('15th of May'

             ,'Jungle of Nool'

             ,'a small speck of dust on a small clover'

             ,'a person's a person no matter how small'

             )

       reached via file Exception/Lite.t, line 310 in main::hoo

          @_=('Dr Hoovey'

             ,'hoo-hoo scope'

             ,'Mrs Tucanella'

             ,'Uncle Nate'

             )

       reached via file Exception/Lite.t, line 303

       in main::weKnowBetterThanYou

          @_=('ARRAY(0x83a8a90)'

             ,'rot, rot, rot'

             ,'Wikerson brothers'

             ,'triculous tripe'

             ,'There will be no more talking to hoos who are not!'

             ,'black bottom birdie'

             ,'from the three billionth flower'

             ,'Mrs Tucanella returns with uncles and cousins'

             ,'sound off! sound off! come make yourself known!'

             ,'Apartment 12J'

             ,'Jo Jo the young lad'

             ,'the whole world was saved by the smallest of all'

             )

=over

=item *

lines begining with "thrown" indicate a line where a new exception

was thrown. If an exception was chained, there might be multiple

such lines.

=item *

lines beginning with "reached via" indicate the path travelled

I<down> to the point where the exception was thrown. This is the

code that was excuted before the exception was triggered.

=item *

lines beginning with "rethrown at" indicate the path travelled

I<up> the stack by the exception I<after> it was geenerated. Each

line indicates a place where the exception was caught and rethrown.

=item *

lines introduced with "Triggered by" are exceptions that were

chained together. The original exception is the last of the

triggered exceptions.  The original line is the "thrown" line

for the original exception.

=item *

C<@_> and <C@ARGV> below a line indicates what is left of the

parameters passed to a method, function or entry point routine.

In ideal circumstances they are the parameters passed to the

subroutine mentioned in the line immediately above C<@_>. In

reality, they can be overwritten or shifted away between the

point when the subroutine started and the line was reached.

Note: if you use L<Getopt::Long> to process C<@ARGV>, C<@ARGV>

will be empty reduced to an empty array. If this bothers you, you

can localize <@ARGV> before calling C<GetOptions>, like this:

  my %hARGV;

  {

    local @ARGV = @ARGV;

    GetOptions(\%hARGV,...);

  }

=item *

pid is the process id where the code was running

=item *

tid is the thread id where the code was running

=back

=head1 SPECIAL TOPICS

=head2 Localization of error messages

Rather than treat the error message and properties as entirely

separate entities, it gives you the option to define a format string

that will take your property values and insert them automatically

into your message.  Thus when you generate an exception, you can

specify only the properties and have your message automatically

generated without any need to repeat the property values in messy

C<sprintf>'s that clutter up your program.

One can localize from the very beginning when one declares the

class or later on after the fact if you are dealing with legacy

software or developing on an agile module and only implementing

what you need now.

To localize from the get-go:

   # myLookupSub returns the arguments to declareException

   # e.g.  ('CopyError', [ 'On ne peut pas copier de %s a %s'

                           , qw(from to)])

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

   # .... later on, exception generation code doesn't need to

   # know or care about the language. it just sets the properties

    # error message depends on locale:

    #   en_US:  'Cannot copy A.txt to B.txt'

    #   fr_FR:  'On ne peut pas copier de A.txt a B.txt'

    #   de_DE:  'Kann nicht kopieren von A.txt nach B.txt'

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

Another alternative if you wish to localize from the get-go is

to pass a code reference instead of a format rule array. In this

case, C<Exception::Lite> will automatically pass the class name

to the subroutine and retrieve the value returned.

   # anothherLookupSub has parameters ($sClass) and returns

   # a format array, for example:

   #

   # %LOCALE_FORMAT_HASH = (

   #    CopyError => {

   #        en_US => ['Cannot copy %s to %s', qw(from to)]

   #       ,fr_FR => ['On ne peut pas copier de %s a %s', qw(from to)]

   #       ,de_DE => ['Kann nicht kopieren von %s nach %s''

   #                   , qw(from to)]

   #

   #    AddError => ...

   # );

   #

   # sub anotherLookupSub {

   #    my ($sClass) = @_;

   #    my $sLocale = $ENV{LANG}

   #    return $LOCALE_FORMAT_HASH{$sClass}{$sLocale};

   # }

   #

   declareExceptionClass('CopyError', &anotherLookupSub);

   declareExceptionClass('AddError', &anotherLookupSub);

    # error message depends on locale:

    #   en_US:  'Cannot copy A.txt to B.txt'

    #   fr_FR:  'On ne peut pas copier de A.txt a B.txt'

    #   de_DE:  'Kann nicht kopieren von A.txt nach B.txt'

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

    die AddError->new(path => 'C.txt');

If you need to put in localization after the fact, perhaps for a

new user interface you are developing, the design pattern might

look like this:

   # in the code module you are retrofitting would be an exception

   # that lived in a single language world. 

   declareExceptionClass('CopyError'

     ['Cannot copy %s to %s', [qw(from to)]);