File Coverage

lib/Badger/Base.pm

Criterion	Covered	Total	%
statement	204	217	94.0
branch	76	96	79.1
condition	69	116	59.4
subroutine	32	36	88.8
pod	20	20	100.0
total	401	485	82.6

#========================================================================
#
# Badger::Base
#
# DESCRIPTION
#   Base class module implementing common functionality for various
#   other Badger modules.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Base;

use Badger::Class
    version   => 0.01,
    debug     => 0,
    constants => 'CODE HASH ARRAY BLANK SPACE PKG REFS ONCE WARN NONE',
    import    => 'class classes',
    utils     => 'blessed reftype xprintf',
    words     => 'ID EXCEPTION THROWS ERROR DECLINED before after',
    constant  => {
        base_id => 'Badger',      # stripped from class name to make id
        TRIAL   => 'Badger::Base::Trial',
    };

use Badger::Exception;              # TODO: autoload
use Badger::Debug 'debug debug_up dump_data_inline dump_data dump_list dump_hash';

our $EXCEPTION = 'Badger::Exception' unless defined $EXCEPTION;
our $ON_WARN   = WARN;
our $MESSAGES  = {
    not_found       => '%s not found: %s',
    not_found_in    => '%s not found in %s',
    not_implemented => '%s is not implemented %s',
    no_component    => 'No %s component defined',
    bad_method      => "Invalid method '%s' called on %s at %s line %s",
    invalid         => 'Invalid %s specified: %s',
    unexpected      => 'Invalid %s specified: %s (expected a %s)',
    missing_to      => 'No %s specified to %s',
    missing         => 'No %s specified',
    todo            => '%s is TODO %s',
    at_line         => '%s at line %s',
    at_file_line    => '%s in %s at line %s',
};


sub new {
    my $class = shift;

    # install warning handling for odd number of parameters when DEBUG enabled
    local $SIG{__WARN__} = sub {
        Badger::Utils::odd_params(@_);
    } if DEBUG;

    my $args  = @_ && ref $_[0] eq HASH ? shift : { @_ };
    my $self  = bless { }, ref $class || $class;
       $self  = $self->init($args);

    # be careful to account for object that overload the boolean comparison
    # operator and may return false to a simple truth test.
    return defined $self
        ? $self
        : $self->error("init() method failed\n");
}

sub init {
    my $self = shift;
    # default action is to store reference to entire configuration so
    # that methods can examine it later if they need to
    $self->{ config } = shift;
    return $self;
}

sub warn {
    my $self  = shift;
    return unless @_;

    my $message  = join(BLANK, @_);
    my $handlers = $self->on_warn;

    $self->debug("dispatching handlers for warn: ", $self->dump_data_inline($handlers), "\n") if DEBUG;
    $self->_dispatch_handlers( warn => $handlers => $message )
        if $handlers && @$handlers;

    # Warning is usually raised by the last handler in the chain which
    # defaults to 'warn', so it's OK to just drop out here.
}

sub error {
    my $self  = shift;
    my $class = ref     $self || $self;
    my $type  = reftype $self || BLANK;
    no strict   REFS;
    no warnings ONCE;

    if (@_) {
        # don't stringify objects passed as argument
        my $message = ref $_[0] ? shift : join(BLANK, map { defined($_) ? $_ : BLANK } @_);
        my $handlers = $self->on_error;

        # set package variable
        ${ $class.PKG.ERROR    } = $message;
        ${ $class.PKG.DECLINED } = 0;

        if ($type eq HASH) {
            # set ERROR and DECLINED items in object
            $self->{ ERROR    } = $message;
            $self->{ DECLINED } = 0;
        }

        ($message) = $self->_dispatch_handlers( error => $handlers => $message )
            if $handlers && @$handlers;

        $self->throw($message);
    }
    elsif ($type eq HASH) {
        return $self->{ ERROR };
    }
    else {
        return ${ $class.PKG.ERROR };
    }
    # not reached
}

sub decline {
    my $self   = shift;
    my $class  = ref     $self || $self;
    my $type   = reftype $self || BLANK;
    my $reason = @_ == 1 ? shift : join(BLANK, @_);
    no strict   REFS;
    no warnings ONCE;

    ${ $class.PKG.ERROR    } = $reason;
    ${ $class.PKG.DECLINED } = 1;

    if ($type eq HASH) {
        $self->{ ERROR    } = $reason;
        $self->{ DECLINED } = 1;
    }

    return undef;
}

sub declined {
    my $self  = shift;
    my $class = ref     $self || $self;
    my $type  = reftype $self || BLANK;
    no strict REFS;
    return ($type eq HASH)
        ? $self->{ DECLINED }
        : ${ $class.PKG.DECLINED };
}

sub reason {
    my $self  = shift;
    my $class = ref     $self || $self;
    my $type  = reftype $self || BLANK;
    no strict REFS;
    return $type eq HASH
         ? $self->{ ERROR }
         : ${ $class.PKG.ERROR };
}

sub throw {
    my $self = shift;
    my $type = shift;
    my $emod = $self->exception;
    my $e;

    # TODO: grok file/line/sub from caller and add to exceptions

    if (! @_) {
        # single argument can be an exception object or an error message
        # which is given whatever type is returned by throws()
        #
        #   throw($exception)
        #   throw($info)

        if (blessed $type && $type->isa($emod)) {
            $self->debug("returning exception object: ", ref $type, " => [$type]\n") if DEBUG;
            $e = $type;
        }
        else {
            $self->debug("creating new exception object chain: info => $type\n") if DEBUG;
            $e = $emod->new( type => $self->throws, info => $type );
        }
    }
    else {
        # Next argument can also be an exception object (e.g. when chaining
        # exceptions) or a regular info message.  In the first case, we don't
        # re-throw the exception if it's already of the correct $type (but we
        # do if any extra arguments are provided)
        #
        #   throw($type, $exception)
        #   throw($type, $info)

        my $info = shift;

        if (! @_ && blessed $info && $info->isa($emod) && $info->type eq $type) {
            # second argument is already an exception of type $type
            $e = $info;
        }
        else {
            my $config = @_ && ref $_[0] eq HASH ? shift : { @_ };
            # construct a new exception from $type and $info fields
            $config->{ type } = $type;
            $config->{ info } = $info;
            $self->debug("creating new exception object: ", $self->dump_hash($config), "\n") if DEBUG;
            $e = $emod->new($config);
        }
    }
    $e->throw;
}

sub try {
    my $self = shift;
    if (@_) {
        my $method = shift;
        if (wantarray) {
            my @result = eval { $self->$method(@_) };
            $self->decline($@) if $@;
            return @result;
        }
        else {
            my $result = eval { $self->$method(@_) };
            $self->decline($@) if $@;
            return $result;
        }
    }
    else {
        return TRIAL->_bind_($self);
    }
}

sub catch {
    # this depends on some code in Badger::Exception which I haven't
    # written yet...
    shift->todo;
}

sub throws {
    my $self  = shift;
    my $type  = reftype $self || BLANK;
    my $class = class($self);
    my $throws;

    if (@_) {
        # hash objects store exception type in $self->{ THROWS }, anything
        # else (classes and non-hash objects) use the $THROWS package var
        $throws = $type eq HASH
            ? ($self->{ THROWS } = shift)
            :  $class->var(THROWS, shift);
    }
    elsif ($type eq HASH) {
        # we also look in $self->{ config } to see if a 'throws' was
        # specified as a constructor argument.
        $throws = $self->{ THROWS }
              ||= $self->{ config }
              &&  $self->{ config }->{ throws };
    }

    # fall back on looking for any package variable in class / base classes
    return $throws
        || $class->any_var(THROWS)
        || $class->id;
}

sub exception {
    my $self  = shift;
    my $type  = reftype $self || BLANK;
    my $emod;

    # TODO: Move this into Template::Class.  It's so rare that you want to
    # set an exception type this way.  Then we can have throw() pass the $type
    # to exception() and allow subclasses to make a decision about what kind
    # of exception to return based on the $type.
    if (@_) {
        # as per throws() above, we have to be careful to only treat $self
        # like a hash when it is a hash-based object
        $emod = $type eq HASH
            ? ($self->{ EXCEPTION } = shift)
            : class($self)->var(EXCEPTION, shift);
    }
    elsif ($type eq HASH) {
        $emod = $self->{ EXCEPTION }
            ||= $self->{ config }
            &&  $self->{ config }->{ exception };
    }
    return $emod
        || class($self)->any_var(EXCEPTION);
}

sub fatal {
    my $self  = shift;
    my $class = ref $self || $self;
    my $error = join(BLANK, @_);
    no strict REFS;

    # set package variable
    ${ $class.PKG.ERROR } = $error;

    if (ref $self && reftype $self eq HASH) {
        $self->{ ERROR    } = $error;
        $self->{ DECLINED } = 0;
    }

    require Carp;
    Carp::confess("Fatal badger error: ", @_);
}


#-----------------------------------------------------------------------
# messages
#-----------------------------------------------------------------------

sub message {
    my $self   = shift;
    my $name   = shift
        || $self->fatal("message() called without format name");
    my $ref    = $self && reftype $self;
    my $format;

    # allow $self object to have an internal messages hash
    if ($self && $ref && $ref eq HASH && $self->{ messages }) {
        $format = $self->{ messages }->{ $name }
            if reftype $self->{ messages } eq HASH;
    }

    $format = class($self)->hash_value( MESSAGES => $name )
        || $self->fatal("message() called with invalid message type: $name")
            unless defined $format;

    xprintf($format, @_);
}

sub warn_msg {
    # explicitly quantify local message() method in case a subclass decides
    # to re-implement the message() method to do something else
    $_[0]->warn( message(@_) );
}

sub error_msg {
    $_[0]->error( message(@_) );
}

sub fatal_msg {
    $_[0]->fatal( message(@_) );
}

sub decline_msg {
    $_[0]->decline( message(@_) );
}

sub debug_msg {
    $_[0]->debug( message(@_) );
}

sub throw_msg {
    my $self = shift;
    $self->throw( shift, message($self, @_) );
}


#-----------------------------------------------------------------------
# generate not_implemented() and todo() methods
#-----------------------------------------------------------------------

class->methods(
    map {
        my $name = $_;
        $name => sub {
            my $self = shift;
            my $ref  = ref $self || $self;
            my ($pkg, $file, $line, $sub) = caller(0);
            $sub = (caller(1))[3];   # subroutine the caller was called from
            $sub =~ s/(.*):://;
            my $msg  = @_ ? join(BLANK, SPACE, @_) : BLANK;
            return $self->error_msg( $name => "$sub()$msg", "for $ref in $file at line $line" );
        };
    }
    qw( not_implemented todo )
);


#-----------------------------------------------------------------------
# generate on_warn() and on_error() methods
#-----------------------------------------------------------------------

class->methods(
    map {
        my $on_event = $_;
        my $ON_EVENT = uc $on_event;

        $on_event => sub {
            my $self  = shift;
            my $class = class($self);
            my $list;

            if (ref $self && reftype $self eq HASH) {
                # look in $self->{ config }->{ on_xxx } or in $ON_XXX pkg
                # var for one or more event handlers
                $list = $self->{ $ON_EVENT }
                    ||= $self->{ config }->{ $on_event }
                    ||  $class->list_vars($ON_EVENT);
                # careful!  the config value might be a single handler
                $list = $self->{ $ON_EVENT } = [$list]
                    unless ref $list eq ARRAY;
                $self->debug("got $on_event handlers: ", $self->dump_data_inline($list), "\n") if DEBUG;
            }
            else {
                # class method or non-hash objects use pkg vars only
                $list = $class->var_default($ON_EVENT, []);
                $list = $class->var($ON_EVENT, [$list])
                    unless ref $list eq ARRAY;
            }

            # Add to the list any extra handlers passed as args.  First
            # argument can be 'before' or 'after' to add remaining args
            # to start or end of list, otherwise the entire list is replaced.
            if (@_) {
                if ($_[0] eq before) {
                    shift;
                    unshift(@$list, @_);
                }
                elsif ($_[0] eq after) {
                    shift;
                    push(@$list, @_);
                }
                else {
                    @$list = @_;
                }
            }
            # push(@$list, @_);

            return $list;
        }
    }
    qw( on_warn on_error )
);


#-----------------------------------------------------------------------
# internal method to dispatch on_error/on_warning handlers
#-----------------------------------------------------------------------

sub _dispatch_handlers {
    my ($self, $type, $handlers, @args) = @_;

    $self->debug("_dispatch handlers: ", $self->dump_data_inline($handlers), "\n") if DEBUG;

    foreach (@$handlers) {
        my $handler = $_;        # don't alias list items
        $self->debug("dispatch handler: $handler\n") if DEBUG;
        if (! ref $handler) {
            if ($handler eq WARN) {         # 'warn' - we make sure that the
                my $msg = join('', @args);  # message is newline terminated
                chomp($msg);                # to stop Perl from adding a line
                CORE::warn $msg, "\n";      # number that'll be wrong.
            }
            elsif ($handler eq NONE) {      # NONE/0 - bail out
                last;
            }
            else {
                $handler = $self->can($handler)
                    || return $self->fatal("Invalid on_$type method: $handler");
                @args = $handler->($self, @args);
            }
        }
        elsif (ref $handler eq CODE) {
            @args = $handler->(@args);
        }
        else {
            $self->fatal("Invalid on_$type handler: $handler");
        }
        $self->debug("mid-dispatch args: [", join(', ', @args), "]\n") if DEBUG;
        # bail out if we got an empty list of return values or a single
        # false value
        last if ! @args || @args == 1 && ! $args[0];
    }
    $self->debug("returning ", join(', ', @args), "\n") if DEBUG;
    return @args;
}



#-----------------------------------------------------------------------
# Badger::Base::Trial - nomadic object for $object->try operation
#-----------------------------------------------------------------------

package Badger::Base::Trial;
our $AUTOLOAD;

sub _bind_ {
    my ($class, $object) = @_;
    bless \$object, ref $class || $class;
}

sub AUTOLOAD {
    my $self = shift;
    my ($method) = ($AUTOLOAD =~ /([^:]+)$/ );
    return if $method eq 'DESTROY';

    # call method on target object in eval block, and downgrade
    if (wantarray) {
        my @result = eval { $$self->$method(@_) };
        $$self->decline($@) if $@;
        return @result;
    }
    else {
        my $result = eval { $$self->$method(@_) };
        $$self->decline($@) if $@;
        return $result;
    }

    # TODO: catch missing error methods
}


1;
__END__