File Coverage

blib/lib/Error/Base.pm

Criterion	Covered	Total	%
statement	81	250	32.4
branch	10	74	13.5
condition	0	2	0.0
subroutine	18	41	43.9
pod	22	22	100.0
total	131	389	33.6

package Error::Base;
#=========# MODULE USAGE
#~ use Error::Base;                # Simple structured errors with full backtrace
#~

#=========# PACKAGE BLOCK
{   #=====# Entire package inside bare block, not indented....

use 5.008008;
use strict;
use warnings;
use version; our $VERSION = qv('v1.0.2');

# Core modules
use overload                    # Overload Perl operations
    '""'    => \&_stringify,
    ;
use Scalar::Util;               # General-utility scalar subroutines

# CPAN modules

# Alternate uses
#~ use Devel::Comments '###', ({ -file => 'debug.log' });                   #~

## use
#============================================================================#

# Pseudo-globals

# Compiled regexes
our $QRFALSE            = qr/\A0?\z/            ;
our $QRTRUE             = qr/\A(?!$QRFALSE)/    ;

our $BASETOP            = 2;    # number of stack frames generated internally
# see also global defaults set in accessors

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

#=========# OPERATOR OVERLOADING
#
#   _stringify();     # short
#
# Purpose   : Overloads stringification.
# Parms     : ____
# Reads     : ____
# Returns   : ____
# Writes    : ____
# Throws    : ____
# See also  : ____
#
# ____
#
sub _stringify {
#   my ($self, $other, $swap) = @_;
    my ($self, undef,  undef) = @_;

    no warnings 'uninitialized';
    if ( defined $self->{-lines} ) {
        return join qq{\n}, @{ $self->{-lines} }, q{};
    }
    else {
        return 'Error::Base internal error: stringifying unthrown object';
    };

}; ## _stringify

#=========# INTERNAL ROUTINE
#
#    @lines      = $self->_trace(               # dump full backtrace
#                    -top      => 2,            # starting stack frame
#                );
#
# Purpose   : Full backtrace dump.
# Parms     : -top  : integer   : usually set at init-time
# Returns   : ____
# Writes    : $self->{-frames}  : unformatted backtrace
# Throws    : 'excessive backtrace'
# See also  : _fuss(), _paired()
#
# ____
#
sub _trace {
    my $self        = shift;
    my %args        = _paired(@_);
    my $i           = defined $args{-top} ? $args{-top} : 1;

    my $bottomed    ;
    my @maxlen      = ( 1, 1, 1 );  # starting length of each field
    my @f           = (             # order in which keys will be dumped
        '-sub',
        '-line',
        '-file',
    );
    my $pad         = q{ };         # padding for better formatting
    my $in          ;               # usually 'in '

    my @frames      ;               # unformatted AoH
    my @lines       ;               # formatted array of strings

    # Get each stack frame.
    while ( not $bottomed ) {
        my $frame           ;

        # Get info for current frame.
        (
            $frame->{-package},
            $frame->{-file},
            $frame->{-line},
            undef,
            undef,
            undef,
            $frame->{-eval}
        )                   = caller( $i );

        # caller returns this from the "wrong" viewpoint
        (
            undef,
            undef,
            undef,
            $frame->{-sub},
            undef,
            undef,
            undef,
        )                   = caller( $i + 1 );

        # Normal exit from while loop.
        if ( not $frame->{-package} ) {
            $bottomed++;
            last;
        };

        # Clean up bottom frame.
        if ( not $frame->{-sub} ) {
            $frame->{-sub}      = q{};
            $frame->{-bottom}   = 1;
        };

        # Get maximum length of each field.
        for my $fc ( 0..$#f ) {
            $maxlen[$fc]    = $maxlen[$fc] > length $frame->{$f[$fc]}
                            ? $maxlen[$fc]
                            : length $frame->{$f[$fc]}
                            ;
        };

        # Clean up any eval text.
        if ($frame->{-eval}) {
            # fake newlines for hard newlines
            $frame->{-eval}     =~ s/\n/\\n/g;
        };
        push @frames, $frame;

        # Safety exit from while loop.
        $i++;
        die 'Error::Base internal error: excessive backtrace'
            if $i > 99;
#~ last if $i > 9;                                             # DEBUG ONLY #~

    }; ## while not bottomed

    # Stash unformatted stack frames.
    $self->{-frames}    = \@frames;

    # Format each stack frame.
    for my $frame (@frames) {

        # Pad each field to maximum length (found in while)
        for my $fc ( 0..$#f ) {
            my $diff            = $maxlen[$fc] - length $frame->{$f[$fc]};
            $frame->{$f[$fc]}   = $frame->{$f[$fc]} . ($pad x $diff);
        };

        # Fix up bottom.
        if ( $frame->{-bottom} ) {
            $frame->{-sub} =~ s/ /_/g;      # all underbars
            $in         = q{___};           # *THREE* underbars
        }
        else {
            $in         = q{in };           # a three-char string
        };

        # Format printable line.
        my $line    = qq*$in$frame->{-sub} at line $frame->{-line}*
                    . qq*    [$frame->{-file}]*
                    ;

        # Append any eval text.
        if ($frame->{-eval}) {
            # hard newlines so number of frames doesn't change
            $line           = $line
                            . qq{\n}
                            . qq*    string eval: "$frame->{-eval}"*
                            . qq{\n}
                            ;
        };

        push @lines, $line;
    }; ## for each frame

    return @lines;
}; ## _trace

#=========# CLASS OR OBJECT METHOD
#
#    Error::Base->crash( $text );    # class method; error text required
#    $err->crash;                    # object method
#    $err->crash( $text );           # object method; error text optional
#    $err->crash( -base => $base );  # named argument okay
#    $err->crash( -foo  => 'bar' );  # set Error::Base options now
#    $err->crash( mybit => 'baz' );  # set your private stuff now
#
# Purpose   : Fatal out of your program's errors
# Parms     : $text     : string    : final   part of error message [odd arg]
#           : -type     : string    : middle  part of error message
#           : -base     : string    : initial part of error message
#           : -top      : integer   : starting backtrace frame
#           : -quiet    : boolean   : TRUE for no backtrace at all
# Returns   : never
# Throws    : $self     : die will stringify
# See also  : _fuss(), crank(), cuss(), init()
#
# The first arg is tested to see if it's a class or object reference.
# Then the next test is to see if an odd number of args remain.
#   If so, then the next arg is shifted off and considered -base.
# All remaining args are considered key/value pairs and passed to new().
#
sub crash{
    my $self    = _fuss(@_);

    die $self;
}; ## crash

#=========# INTERNAL FUNCTION
#
# This does all the work for crash(), crank(), and cuss().
# See crash() for more info.
#
sub _fuss {
    my $self        = shift;
    if ( Scalar::Util::blessed $self ) {        # called on existing object
        $self->init(@_);                        # initialize or overwrite
    }
    else {                                      # called as class method
        $self       = $self->new(@_);
    };

    my $max         = 78;                       # maximum line length
    my $message     ;                           # user-defined error message
    my @lines       ;                           # to stringify $self

    # Deal with array values.
    $self->{-mesg}  = _expand_ref( $self->{-mesg} );

    # Collect all the texts into one message.
    $message        = _join_local(
                        $self->{-base},
                        $self->{-type},
                        $self->{-mesg},
                    );
#~     ### $self

    # Late interpolate.
    $message        = $self->_late( $message );

    # If still no text in there, finally default.
    if    ( not $message ) {
        $message        = 'Undefined error.';
    };
    $self->{-all}   = $message;                 # keep for possible inspection

    # Accumulate.
    @lines          = ( $message );

    # Stack backtrace by default.
    if ( not $self->{-quiet} ) {
        my @trace       = $self->_trace( -top => $self->{-top} );
        push @lines, @trace;
    };

    # Optionally prepend some stuff.
    if ( defined $self->{-prepend} ) {          # prepended to first line
        @{ $self->{-lines} }
            = _join_local( $self->{-prepend}, shift @lines );
    }
    else {
        @{ $self->{-lines} }                = shift @lines;
    };
    if ( defined $self->{-indent} ) {           # prepended to all others
        push @{ $self->{-lines} },
            map { _join_local( $self->{-indent}, $_ ) } @lines;
    }
    else {
        push @{ $self->{-lines} },                      @lines;
    };

    ### @lines
    return $self;

#~     # Do something to control line length and deal with multi-line $all.
#~     my @temp        = split /\n/, $all;         # in case it's multi-line
#~     my $limit       = $max - length $prepend;
#~        @temp        = map { s//\n/ if length > $limit }
#~                         @temp; # avoid excessive line length
#~     my $infix       = qq{\n} . $indent;
#~        $all         = join $infix, @temp;

}; ## _fuss

#=========# CLASS OR OBJECT METHOD
#
# Just like crash() except it warn()-s and does not die().
# See crash() for more info.
sub crank{
    my $self    = _fuss(@_);

    warn $self;
}; ## crank

#=========# CLASS OR OBJECT METHOD
#
# Just like crash() except it just returns $self (after expansion).
# See crash() for more info.
sub cuss{
    my $self    = _fuss(@_);

    return $self;
}; ## crank

#=========# INTERNAL FUNCTION
#
#   $string =_expand_ref( $var );     # expand reference if any
#
# Purpose   : ____
# Parms     : ____
# Reads     : ____
# Returns   : ____
# Invokes   : ____
# Writes    : ____
# Throws    : ____
# See also  : ____
#
# ____
#
sub _expand_ref {
    my $in          = shift;
    my $rt          = Scalar::Util::reftype $in;    # returns no class

    if    ( not $rt ) {                             # simple scalar...
        # ... don't deref
        return $in                                  # unchanged
    }
    elsif ( $rt eq 'SCALAR' ) {                     # scalar ref
        return $$in                                 # dereference
    }
    elsif ( $rt eq 'ARRAY'  ) {                     # array ref
        return _join_local(@$in);                   # deref and join
    }
#~     elsif ( $rt eq 'HASH'   ) {                     # hash ref
#~     my @sorted  = map { $_, $in->{$_} } sort keys %$in;
#~         return _join_local(@sorted);                # deref, sort, and join
#~     }
    else {
        die 'Error::Base internal error: bad reftype in _expand_ref';
    };

}; ## _expand_ref

#=========# INTERNAL FUNCTION
#
#   $string = _join_local(@_);     # short
#
# Purpose   : Like builtin join() but with local list separator.
# Parms     : @_        : strings to join
# Returns   : $string   : joined strings
# Throws    : ____
# See also  : init()
#
# Buitin join() does not take $" (or anything else) by default.
# We splice out empty strings to avoid useless runs of spaces.
#
sub _join_local {
    my @parts       = @_;

    # Splice out empty strings.
   @parts       = grep { $_ ne q** } @parts;

    return join $", @parts;
}; ## _join_local

#=========# INTERNAL FUNCTION
#
#   my %args    = _paired(@_);     # check for unpaired arguments
#
# Purpose   : ____
# Parms     : ____
# Reads     : ____
# Returns   : ____
# Writes    : ____
# Throws    : ____
# See also  : ____
#
# ____
#
sub _paired {
    if ( scalar @_ % 2 ) {  # an odd number modulo 2 is one: true
        die 'Error::Base internal error: unpaired args';
    };
    return @_;
}; ## _paired

#=========# CLASS METHOD
#
#   my $obj     = $class->new();
#   my $obj     = $class->new({ -a  => 'x' });
#
# Purpose   : Object constructor
# Parms     : $class    : Any subclass of this class
#             anything else will be passed to init()
# Returns   : $self
# Invokes   : init()
#
# Good old-fashioned hashref-based object constructor.
#
sub new {
    my $class   = shift;
    my $self    = {};           # always hashref

    bless ($self => $class);
    $self->init(@_);            # init remaining args

    return $self;
}; ## new

#=========# OBJECT METHOD
#
#   $err->init(        k => 'v', f => $b );
#   $err->init( $text, k => 'v', f => $b );
#
# An object can be init()-ed more than once; all new values overwrite the old.
# This non-standard init() allows an unnamed initial arg.
#
# See: crash()
#
sub init {
    my $self        = shift;
    if ( scalar @_ % 2 ) {              # an odd number modulo 2 is one: true
        $self->{-mesg}  = shift;        # and now it's even
    };

    # Merge all values. Newer values always overwrite.
    %{$self}        = ( %{$self}, @_ );

    # Set some default values, mostly to avoid 'uninitialized' warnings.
    $self->put_base(  $self->{-base}  );
    $self->put_type(  $self->{-type}  );
    $self->put_mesg(  $self->{-mesg}  );
    $self->put_quiet( $self->{-quiet} );
    $self->put_nest(  $self->{-nest}  );
    $self->_fix_pre_ind();

    return $self;
}; ## init

#----------------------------------------------------------------------------#
# ACCSESSORS

my $Default = {
    -base           =>  q{},
    -type           =>  q{},
    -mesg           =>  q{},
    -quiet          =>  0,
    -nest           =>  0,
    -prepend        =>  undef,
    -indent         =>  undef,
};



# put
sub put_base {
    my $self            = shift;
    $self->{-base}      = shift;
    if    ( not defined $self->{-base}  ) {
        $self->{-base}  = $Default->{-base};
    };
    return $self;
};
sub put_type {
    my $self            = shift;
    $self->{-type}      = shift;
    if    ( not defined $self->{-type}  ) {
        $self->{-type}  = $Default->{-type};
    };
    return $self;
};
sub put_mesg {
    my $self            = shift;
    $self->{-mesg}      = shift;
    if    ( not defined $self->{-mesg}  ) {
        $self->{-mesg}  = $Default->{-mesg};
    };
    return $self;
};
sub put_quiet {
    my $self            = shift;
    $self->{-quiet}     = shift;
    if    ( not defined $self->{-quiet}  ) {
        $self->{-quiet} = $Default->{-quiet};
    };
    return $self;
};
sub put_nest {
    my $self            = shift;
    $self->{-nest}      = shift;
    if    ( not defined $self->{-nest}  ) {
        $self->{-nest}  = $Default->{-nest};
    };
    # -top is now deprecated from the API
    $self->{-top}       = $self->{-nest} + $BASETOP;
    return $self;
};
sub put_prepend {
    my $self            = shift;
    $self->{-prepend}   = shift;
    $self->_fix_pre_ind();
    return $self;
};
sub put_indent {
    my $self            = shift;
    $self->{-indent}    = shift;
    $self->_fix_pre_ind();
    return $self;
};
# For internal use only
sub _fix_pre_ind {
    my $self            = shift;
    my $indent          ;
    my $case            ;

    $case   = $case . ( defined $self->{-prepend} ? 'P' : '-' );
    $case   = $case . ( defined $self->{-indent}  ? 'I' : '-' );

    # four cases cover all needs
    if    ( $case eq '--' ) {
        $self->{-prepend}   =   $Default->{-prepend};
        $self->{-indent}    =   $Default->{-indent};
    }
    elsif ( $case eq '-I' ) {
        $self->{-prepend}   =   $self->{-indent};
    }
    elsif ( $case eq 'P-' ) {
        my $prepend         = $self->{-prepend};
        $self->{-indent}    = ( substr $prepend, 0, 1           )
                            . ( q{ } x ((length $prepend) - 1)  )
                            ;
    }
    else {
        # ( $case eq 'PI' )     # do nothing
    };

    return $self;
};

# get
sub get_base {
    my $self    = shift;
    return $self->{-base};
};
sub get_type {
    my $self    = shift;
    return $self->{-type};
};
sub get_mesg {
    my $self    = shift;
    return $self->{-mesg};
};
sub get_quiet {
    my $self    = shift;
    return $self->{-quiet};
};
sub get_nest {
    my $self    = shift;
    return $self->{-nest};
};
sub get_prepend {
    my $self    = shift;
    return $self->{-prepend};
};
sub get_indent {
    my $self    = shift;
    return $self->{-indent};
};
sub get_all {
    my $self    = shift;
    return $self->{-all};
};
sub get_lines {
    my $self    = shift;
    return $self->{-lines};
};
sub get_frames {
    my $self    = shift;
    return $self->{-frames};
};

## accessors
#----------------------------------------------------------------------------#

#=========# INTERNAL OBJECT METHOD
#
#   $out    = $self->_late( $in );     # late interpolate
#
# Wrapper method; see Error::Base::Late::_late().
sub _late { return Error::Base::Late::_late(@_) };
##

}   #=====# ... Entire package inside bare block, not indented.
#=========# END PACKAGE BLOCK

package Error::Base::Late;   # switch package to avoid pseudo-global lexicals
{

#=========# INTERNAL FUNCTION IN FOREIGN PACKAGE
#
#   $out    = _late( $self, $in );     # late interpolate
#
# Purpose   : ____
# Parms     : $in       : scalar string
# Reads     : every key in $self starting with a $, @, or % sigil
#           : $self     : available as '$self'
# Returns   : $out      : scalar string
# Writes    : ____
# Throws    : ____
# See also  : ____
#
# I hope this is the worst possible implementation of late().
# Late interpolation is accomplished by multiple immediate interpolations,
#   inside and outside of a string eval.
# Non-core PadWalker is not used to derive interpolation context;
#   caller is required to pass context inside the $self object.
# To avoid collision and unintended interpolation, I make housekeeping
#   variables internal to this routine, package variables.
#   These are fully qualified to a "foreign" package; caller cannot
#   accidentally access them (although I cannot stop you from doing stupid).
# Some work is done in a bare "setup" block with lexical variables.
#   But package variables are used to pass values within the routine,
#   from block to block, inside to outside, within and without the eval.
# Quoting is a major concern. Heredocs are used in three places for
#   double-quoted interpolation; they may not conflict with each other
#   or with any string that may exist within any of:
#       - the string to be interpolated, $in
#       - values passed in $self against @keys (keys with leading sigils)
#   Rather than attempt to exclude all of these from a generic q//,
#       I chose heredocs and three long, arbitrary strings.
#
sub _late {
    use strict;
    use warnings;
    no warnings 'uninitialized';          # too many to count
#~ ##### CASE:
#~ ##### @_
    # No lexical variables loose in the outer block of the subroutine.
    $Error::Base::Late::self    = shift;
    if ( not ref $Error::Base::Late::self ) {
        die 'Error::Base internal error: no $self';
    };
    $Error::Base::Late::in      = shift || undef;
    return $Error::Base::Late::in
        unless $Error::Base::Late::in =~ /[\$\@%]/; # no sigil, don't bother

    # Y0uMaYFiReWHeNReaDYGRiDLeY          # quite unlikely to collide

    @Error::Base::Late::code    = undef;  # to be eval-ed
    $Error::Base::Late::out     = undef;  # interpolated

    #--------------------------------------------------------------------#
    { # setup block

        # Some preamble.
        push @Error::Base::Late::code,
            q**,
            q*#--------------------------------------------------------#*,
            q*# START EVAL                                              *,
            q**,
            q*my $self  = $Error::Base::Late::self;*,
            q**,
        ;

        # Unpack all appropriate k/v pairs into their own lexical variables...

        # Each key includes leading sigil.
        my @keys    = grep { /^[\$\@%]/ } keys %$Error::Base::Late::self;
        return $Error::Base::Late::in   # abort if not interpolating today
#~             unless ( @keys or $Error::Base::Late::in =~ /\$self/ );
            unless ( @keys );
        my $key     ;  # placeholder includes sigil!
        my $val     ;  # value to be interpolated
        my $rt      ;  # builtin 'ref' returns (unwanted) class of blessed ref

        #            my $key = $sigil?$Error::Base::Late::self->{'$key'}?;
        my $ch1  = q*my *                                                   ;
        my $ch2  =        q* = *                                            ;
        my $ch3  =                  q*Error::Base::Late::self->{'*          ;
        my $ch4  =                                                q*'}*     ;
        my $ch5  =                                                  q*;*    ;

        for my $key (@keys) {
            $val            = $Error::Base::Late::self->{$key};
            $rt             = Scalar::Util::reftype $val;   # returns no class

            my $sigil   ;           # sigil (if any) to deref
            my $lbc     = q*{$*;    # left  brace if sigil . '$' for $self
            my $rbc     = q*}*;     # right brace if sigil

            if    ( not $rt ) {                             # simple scalar...
                # ... don't deref
                $lbc    = q{$};     # only '$' for $self
                $rbc    = q{};
            }
            elsif ( $rt eq 'SCALAR' ) {                     # scalar ref
                $sigil      = q{$};
            }
            elsif ( $rt eq 'ARRAY'  ) {                     # array ref
                $sigil      = q{@};
            }
            elsif ( $rt eq 'HASH'   ) {                     # hash ref
                $sigil      = q{%};
            }
            else {
                die 'Error::Base internal error: bad reftype in _late';
            };

            #        my $key = $sigil?$Error::Base::Late::self->{'$key'}?;
            push @Error::Base::Late::code,
                ( join q{},
                    $ch1, $key, $ch2,
                    $sigil, $lbc, $ch3, $key, $ch4, $rbc, $ch5,
                );

        }; ## for keys
    # ... done unpacking.

    # Do the late interpolation phase.
    push @Error::Base::Late::code,
        q**,
        q*<
<
$Error::Base::Late::in
Heredoc02_Y0uMaYFiReWHeNReaDYGRiDLeY
        q*Heredoc01_Y0uMaYFiReWHeNReaDYGRiDLeY*,
        q*#--------------------------------------------------------#*,
        q**,
    ;

    # Code is now fully assembled.
    $Error::Base::Late::eval_code   =
        join qq{\n}, @Error::Base::Late::code;

    } ## setup
    #--------------------------------------------------------------------#
    { # eval string

$Error::Base::Late::out     = eval
<
$Error::Base::Late::eval_code
Heredoc03_Y0uMaYFiReWHeNReaDYGRiDLeY

        if ($@) {
            warn "Error::Base internal warning: in _late eval: $@";
            return $Error::Base::Late::in;           # best we can do
        };

#~         ##### CASE
#~         ##### $Error::Base::Late::self
#~         ##### $Error::Base::Late::in
#~         ##### @Error::Base::Late::code
#~         ##### $Error::Base::Late::eval_code
#~         ##### $@

    } ## eval string
    #--------------------------------------------------------------------#

    # Heredocs add spurious newlines.
    chomp  $Error::Base::Late::out;
    chomp  $Error::Base::Late::out;
#~ my $out =  $Error::Base::Late::out;
#~ ##### $out;
    return $Error::Base::Late::out;
}; ## _late

} ## package Error::Base::Late

## END MODULE
1;
#============================================================================#
__END__