File Coverage

blib/lib/BW/Base.pm

Criterion	Covered	Total	%
statement	12	68	17.6
branch	0	28	0.0
condition	0	5	0.0
subroutine	4	11	36.3
pod	4	4	100.0
total	20	116	17.2

# BW::Base.pm
# Base methods for BW::* modules
#
# by Bill Weinman - http://bw.org/
# Copyright (c) 1995-2010 The BearHeart Group, LLC
#
# See HISTORY
#

package BW::Base;
use strict;
use warnings;
use 5.008;

use BW::Constants;

our $VERSION = "1.4";

#
# Most of the methods in this module, including new() and _init(),
# are designed to be inherited.
#

sub new
{
    my $c     = shift;
    my $class = ref($c) || $c;
    my $self  = {};

    bless( $self, $class );
    $self->_init(@_) or return undef;
    return $self;
}

sub _init
{
    my $self = shift;
    my $arg  = $_[0];
    my $sn   = "_init";

    $self->{me} = ref($self);
    $self->{version} = $VERSION;

    # handle different sorts of arguments
    if ( ref($arg) eq 'HASH' ) {    # hash ref?
        foreach my $k ( keys %$arg ) {
            if ( $self->can($k) ) {
                $self->$k( $arg->{$k} );
            } else {
                $self->_error("$sn: no setter for property $k");
            }
        }
    } elsif ( defined $_[1] ) {     # array? (hash but not ref)
        while (@_) {
            my $k = shift;
            my $v = shift;
            if ( $self->can($k) ) {
                $self->$k($v);
            } else {
                $self->_error("$sn: no setter for property $k");
            }
        }
    }

    return SUCCESS;
}

# settergetterers

### generalized setter/getter that is called by all the others
sub _setter_getter
{
    my $self = shift;
    my $arg  = shift;

    # take the name of the caller and use it as the name of the
    # property to be set/get
    my $caller = ( split( /::/, ( caller(1) )[3] ) )[-1];

    if ( defined $arg ) {
        $self->{$caller} = $arg;
        return SUCCESS;
    } else {
        return $self->{$caller};
    }
}

# _setter_getter entry points look like this:
# sub foo { _setter_getter(@_); }

# debug(m) prints a stack trace along with a debug message
sub debug
{
    my ( $self, $message ) = @_;
    my $out = '';

    my @c = caller(1);
    if ( substr( $c[3], 0, 5 ) eq 'main:' ) { @c = caller(2) }
    my ( $package, $filename, $line, $subroutine, $hashargs, $wantarray, $evaltext, $is_require, $hints, $bitmask ) = @c;

    $message = $self unless ref($self);

    $out .= "$$: ";
    $out .= "$subroutine: " if $subroutine;
    $out .= "$message\n" if $message;
    STDERR->print($out);
}

# set the error string and return FAILURE
sub _error
{
    my $self = shift;
    $self->{error} .= "\n" if $self->{error};
    $self->{error} = '' unless $self->{error};
    $self->{error} .= "$self->{me}: " . ( shift || 'unknown error' );
    return FAILURE;
}

# get and clear error string
sub error
{
    my $self   = shift;
    my $errstr = $self->{error};
    $self->{error} = VOID;
    return $errstr;
}

# check error from other BW::* module
sub checkerror
{
    my ( $self, $o ) = @_;
    my $sn = 'check_error';
    if ($o) {
        my $e = $o->error;
        return $e ? $self->_error($e) : SUCCESS;
    } else {
        return $self->_error("$sn: no or unblessed object");
    }
}

1;

__END__