File Coverage

blib/lib/Exception/Sink.pm

Criterion	Covered	Total	%
statement	9	72	12.5
branch	0	42	0.0
condition	0	3	0.0
subroutine	3	10	30.0
pod	7	7	100.0
total	19	134	14.1

##############################################################################
#
#  Exception::Sink
#  Copyright (c) 2006-2024 Vladi Belperchinov-Shabanski "Cade"
#
#  http://cade.noxrun.com/
#
#  GPLv2
#
##############################################################################
#
#  compact general purpose exception handling
#
##############################################################################
package Exception::Sink;
use Exporter;
our @ISA         = qw( Exporter );
our @EXPORT      = qw(
                       sink
                       dive
                       surface
                       surface2

                       boom_skip
                       boom
                     );

our @EXPORT_OK   = qw(
                       $DEBUG_SINK
                       get_stack_trace
                     );

our %EXPORT_TAGS = ( 'none' => [ ] );
our $VERSION     = '3.09';
use Exception::Sink::Class;
use strict;

our $DEBUG_SINK = 0;

sub sink($);
sub dive();
sub surface(@);
sub surface2(@);

sub boom_skip($$);
sub boom($);

##############################################################################
#
# sink( "CLASS: ID: message..." )
# sinks the ship of class and id with reason message
#

sub sink($)
{
  my $msg = shift;

  my $org = $msg;

  my $class = 'UNKNOWN';
  my $id    = 'UNKNOWN';

  $class = $1 || $2 if $msg =~ s/^([a-z0-9_]+)\s*:\s*|^([a-z0-9_]+)$//i;
  $id    = $1       if $msg =~ s/^([a-z0-9_]+)\s*:\s*|^([a-z0-9_]+)$//i;

  $msg =~ s/\s+at\s+\/\S+.+$//;
  chomp( $msg );

  my ( $p, $f, $l ) = caller();
  $f =~ s/^(.*\/)([^\/]+)$/$2/;

  $class = uc $class;

  print STDERR "sink: $class ($f:$l)\n" if $DEBUG_SINK;

  die Exception::Sink::Class->new(
      'CLASS'   => $class,
      'ID'      => $id,
      'MSG'     => $msg,
      'PACKAGE' => $p,
      'FILE'    => $f,
      'LINE'    => $l,
      'ORG'     => $org,
      );
}

##############################################################################
#
# dive()
# continue sinking...
#

sub dive()
{
  print STDERR "dive: pre: $@\n" if $DEBUG_SINK;
  return 0 unless $@;
  if( !ref($@) )
    {
    print STDERR "dive: non-ship, resink: $@\n" if $DEBUG_SINK;
    # re-sink, non-ship
    my $AT=$@;
    eval { sink "SINK: $AT"; }
    };

  print STDERR "dive: $@->{CLASS}\n" if $DEBUG_SINK;

  die; # propagate
}

##############################################################################
#
# surface( class list )
# stops sinking of specific classes...
#

sub surface(@)
{
  print STDERR "surface: enter: $@ -> @_\n" if $DEBUG_SINK;
  return 0 unless $@;
  return 1 unless @_; # catch all
  if( !ref($@) )
    {
    print STDERR "surface: non-ship, resink: $@\n" if $DEBUG_SINK;
    # re-sink, non-ship
    my $AT=$@;
    if( $AT =~ /^[A-Z0-9_]+\:/ )
      {
      eval { sink $AT; }
      }
    else
      {
      eval { sink "SINK: $AT"; }
      }
    };

  print STDERR "surface: $@->{CLASS} -> @_?\n" if $DEBUG_SINK;

  for my $class ( @_ )
    {
    return 1 if    $class eq '*';
    return 1 if uc $class eq $@->{ 'CLASS' };
    }
  print STDERR "surface: $@->{CLASS} -> continuing...\n" if $DEBUG_SINK;
  return 0;
}

sub surface2(@)
{
  return 1 if surface(@_);
  dive();
  return 0;
}

##############################################################################
#
# boom()
# sink with stack trace
#

sub boom_skip($$)
{
  my $msg  = shift;
  my $skip = shift;
  chomp( $msg );
  $msg = "BOOM: [$$] $msg\n";
  sink( join '', ( $msg, get_stack_trace( $skip ) ) );
}

sub boom($)
{
  boom_skip($_[0],0);
}

sub get_stack_trace
{
  my $skip = shift;

  my @st;
  my $i;
  my $ml;

  $i = 1 + $skip; # skip get_stack_trace frame and optionally first N frames
  while ( my ( $pack, $file, $line, $subname ) = caller($i++) )
    {
    my $l = length( "$pack::$subname" );
    $ml = $l if $l > $ml;
    }

  $i = 1 + $skip; # skip get_stack_trace frame and optionally first N frames
  my $ii;
  while ( my ( $pack, $file, $line, $subname ) = caller($i++) )
    {
    $ii++;
    my $l = length( "$pack::$subname" );
    my $pad = ' ' x ( $ml - $l );
    push @st, "      [$$] $ii: $pack::$subname $pad $file line $line\n";
    }

  return wantarray ? ( @st ) : join( '', @st );
}

##############################################################################
1;
##############################################################################

__END__