# Copyright (c) 2010 Elizabeth Grace Frank-Backman.
# All rights reserved.
#
# Liscenced under the "Artistic Liscence"
# (see http://dev.perl.org/licenses/artistic.html)

use strict;
use warnings;

package Exception::Lite;
our @ISA = qw(Exporter);
our @EXPORT_OK=qw(declareExceptionClass isException isChainable);
my $CLASS='Exception::Lite';

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

our $STRINGIFY=3;
our $TAB=3;
our $FILTER=1;
our $UNDEF='<undef>';

# 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 'TAB')     {   $TAB=$v;
      }
      0;
    } else {
      1;
    }
  } @_);
}

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

use Scalar::Util ();
use threads;

our $MSG_BAD_NEW_PARAMS
  = 'bad parameter list to %s->new(...) 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 -or- you are using a string as a chained '.
  "exception)\n";

our $MSG_BAD_RETHROW_PARAMS
  = '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";


#==================================================================
# EXPORTABLE FUNCTIONS
#==================================================================

#------------------------------------------------------------------
# Generate exception class

sub declareExceptionClass {
  my ($sClass, $sSuperClass, $xFormatRule, $bCustomizeSubclass) = @_;
  my $sRef=ref($sSuperClass);
  if ($sRef) {
    $bCustomizeSubclass = $xFormatRule;
    $xFormatRule = $sSuperClass;
  } else {
    $sRef = ref($xFormatRule);
  }

  # set up things dependent on whether or not the class has a
  # format string or expects a message for each instance

  my ($sOptionalParams, $sAddOrOmit, $sRethrowMsg,$sMakeMsg
      , $sReplaceMsg);

  if ($sRef) {
    #generate format data
    $xFormatRule=$xFormatRule->($sClass) if ($sRef eq 'CODE');

    my $sFormat=$xFormatRule->[0];
    $sOptionalParams='my $e; $e=shift if ref($_[0]);';
    $sAddOrOmit='added an unnecessary message or format';

    my $sSprintf = 'sprintf(\'' . $sFormat
       . '\', map {defined($_)?$_:\''. $UNDEF .'\'} @$h{qw('
       . join(' ', @$xFormatRule[1..$#$xFormatRule]) . ')});';

    $sMakeMsg='my $msg='.$sSprintf;
    $sRethrowMsg='';
    $sReplaceMsg='$_[0]->[0]='.$sSprintf;

  } else {
    $sOptionalParams = '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';
    $sMakeMsg='';
    $sRethrowMsg='my $msg=shift; $_[0]->[0]=$msg if defined($msg);';
    $sReplaceMsg='';
  }

  my $sPath = $sClass; $sPath =~ s/::/\//g;
  my $sDeclare = "package $sClass; \$INC{'$sPath.pm'}=".__FILE__.";" .
    'sub new { my $cl=shift;'.  $sOptionalParams .
    # generate stack trace for this exception and eliminate duplicate
    # frames from chained exception; set other variables
      'my $st=Exception::Lite::_cacheStackTrace;'.
      'if ($e) {my $n=$#{$e->[2]}-$#$st;$e->[2]=[@{$e->[2]}[0..$n]]}'.
      'my ($f,$l) = @{$st->[0]};' .
    # use the caller file/line number to warn of bad parameters
      'if (scalar(@_)%2) { shift @_;'.
        'warn sprintf($Exception::Lite::MSG_BAD_NEW_PARAMS,$cl,$f,$l'.
           ',"'.$sAddOrOmit.'");'.
      '}'.
    # initialize exception object
      'my $h={@_};'.$sMakeMsg.
      'my $self=bless([$msg,$h,$st,$$,threads->tid,$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 ($p,$f,$l)=caller(0);$_[0]->PROPAGATE($f,$l);'.
      'my $self=shift;' . $sRethrowMsg .
      'if (@_%2) { shift @_;' .
        'warn sprintf($Exception::Lite::MSG_BAD_RETHROW_PARAMS'.
            ',$f, $l, "'.$sAddOrOmit.'");' .
      '} $self->replaceProperties({@_}) if (@_);'.
      'return $self'.
    '}';

    unless ($sSuperClass && $sSuperClass->can('_getInterface')
            && ($sSuperClass->_getInterface() eq __PACKAGE__)) {
      $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=~s/(sub |use )/\n$1/g; print STDERR "\n$sDeclare\n";

  eval $sDeclare;

  if ($sSuperClass) {
    # this needs to be in a separate eval, at least in Perl 5.8.8
    # Otherwise, for some reason our @ISA ends up being undefined
    eval "\@${sClass}::ISA=qw($sSuperClass);";
  }
  return $sClass;
}

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

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

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

sub isException {
  my ($e, $sClass) = @_;
  my $sRef=ref($e);
  return !$sRef
    ? 0
    : (defined($sClass)
       ? $sRef->isa($sClass)
       : ($sRef->can('_getInterface')
          && ($e->_getInterface() eq __PACKAGE__))
      )? 1 : 0;
}

#==================================================================
# PRIVATE SUBROUTINES
#==================================================================

# 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 _cacheCall {
  my $iFrame = $_[0];

  my @aCaller;
  my $sArgs;

  # caller populates @DB::args if called within DB package
  eval {
    package DB;

    #get rid of eval and call to _cacheCall
    @aCaller = caller($iFrame+2);

    # mark leading undefined elements as maybe shifted away
    my $iDefined;
    $sArgs = join("\n", map { defined($_)
                                ? do {$iDefined=1; "'$_'"}
                                : 'undef'
                                  . (defined($iDefined)
                                     ?'':'  (maybe shifted away?)'
                                    )
                            } @DB::args);
  };

  return $#aCaller < 0 ? $sArgs : [ @aCaller[0..3], $sArgs ];
}

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

sub _cacheStackTrace {
  my @aStack;

  # set up initial frame
  my $iFrame=1; # call to new
  my $xCall = _cacheCall($iFrame++);
  my ($sPackage, $iFile, $iLine) = @$xCall;

  $xCall =  _cacheCall($iFrame++);  #context of call to new
  while (ref($xCall)) {
    my $sSub  = $xCall->[3];  # subroutine containing file,line
    my $sArgs = $xCall->[4];  # args used to call $sSub

    # 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
        || ((ref($FILTER) eq 'CODE')
            && $FILTER->($iFrame, $iFile, $iLine, $sSub, $sArgs))
        || ($sSub ne '(eval)')) {
      push @aStack, [ $iFile, $iLine, $sSub, $sArgs ];
      ($sPackage, $iFile, $iLine) = @$xCall;
    }

    $xCall = _cacheCall($iFrame++);
  }

  push @aStack, [ $iFile, $iLine, "<package: $sPackage>", $xCall ];
  return \@aStack;
}

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

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);

  $sIndent.=' ' x $TAB;
  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,$sArgs) = @{$st->[$iFrame]};
    if ($iFrame) {
      #2nd and following stack frame
      $sMsg .= "\n${sIndent}${sReach}via file $f, line $l in $s";
    } else {
      # first stack frame
      $sMsg .= "\n${sIndent}${sThrow}at  file $f, line $l in $s, pid="
        . $e->getPid() . ", tid=" . $e->getTid();
      return "$sMsg\n" if $STRINGIFY == 1;
    }

    if ($STRINGIFY > 3) {
      my $sVar= (($iFrame+1) == $iTop ? '@ARGV' : '@_');
      my $sVarIndent = "\n${sIndent}" . (' ' x $TAB);
      my $sArgPrefix = "${sVarIndent}".(' ' x length($sVar)).' ';
      $sArgs =~ s/\n/$sArgPrefix,/g;
      $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;
}

#==================================================================
# MODULE INITIALIZATION
#==================================================================

1;