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