File Coverage

lib/Kite/Base.pm

Criterion	Covered	Total	%
statement	50	56	89.2
branch	18	22	81.8
condition	3	3	100.0
subroutine	8	9	88.8
pod	3	3	100.0
total	82	93	88.1

#============================================================= -*-perl-*-
#
# Kite::Base
#
# DESCRIPTION
#   Base class module implementing common functionality.
#
# AUTHOR
#   Andy Wardley
#
# COPYRIGHT
#   Copyright (C) 2000 Andy Wardley.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
# VERSION
#   $Id: Base.pm,v 1.3 2000/10/17 11:58:16 abw Exp $
#
#========================================================================

package Kite::Base;

require 5.004;

use strict;
use vars qw( $VERSION $AUTOLOAD );

$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);


#------------------------------------------------------------------------
# new(\%params)
#
# General purpose constructor method which expects a hash reference of
# configuration parameters, or a list of name => value pairs which are
# folded into a hash.  Blesses a hash into an object and calls its
# _init() method, passing the parameter hash reference.  Returns a new
# object derived from Kite::Base, or undef on error.
#------------------------------------------------------------------------

sub new {
    my $class = shift;
    my $params = (@_ && UNIVERSAL::isa($_[0], 'HASH')) ? shift : { @_ };
    my $self = bless {
	_ERROR => '',
    }, $class;
    return $self->init($params) ? $self : $class->error($self->error);
}


#------------------------------------------------------------------------
# init()
#
# Initialisation method called by the new() constructor, passing a
# reference to a hash array containing any configuration items specified
# as constructor arguments.  Should return $self on success or undef on
# error, via a call to the error() method to set the error message.
#------------------------------------------------------------------------

sub init {
    my ($self, $config) = @_;
    my $class = ref $self;
    my $params;

    # get a reference to the $PARAMS hash in the derived class package
    {
	no strict qw( refs );
	$params = ${"$class\::PARAMS"};
    }

    if (defined $params) {
	# initialise the $self object from the $config hash passed, using
	# the $params hash to define acceptable parameters and defaults

	# map all config parameters to upper case
	@$config{ map { uc $_ } keys %$config } = values %$config;

	# read parameters into $self from $config, using defaults if undefined
	foreach my $key (keys %$params) {
	    if ($key =~ /^_/) {
		# just set default for private keys with leading _UNDERSCORE
		$self->{ $key } = $params->{ $key };
	    }
	    else {
		# otherwise use config value, if defined, or default
		$self->{ $key } = defined $config->{ $key }
				  ? $config->{ $key } : $params->{ $key };
	    }
	}
    }

    return $self;
}


#------------------------------------------------------------------------
# error()
# error($msg, ...)
#
# May be called as a class or object method to set or retrieve the
# package variable $ERROR (class method) or internal member
# $self->{ ERROR } (object method).  The presence of parameters indicates
# that the error value should be set.  Undef is then returned.  In the
# abscence of parameters, the current error value is returned.
#------------------------------------------------------------------------

sub error {
    my $self = shift;
    my $errvar;

    {
	no strict qw( refs );
	$errvar = ref $self ? \$self->{ _ERROR } : \${"$self\::ERROR"};
    }
    if (@_) {
	$$errvar = join('', @_);
	return undef;
    }
    else {
	return $$errvar;
    }
}


#------------------------------------------------------------------------
# AUTOLOAD
#
# Autoload method.
#------------------------------------------------------------------------

sub AUTOLOAD {
    my $self = shift;
    my $method = $AUTOLOAD;

    $method =~ s/.*:://;
    return if $method eq 'DESTROY';

    if ($method =~ /^_/) {
	my ($pkg, $file, $line) = caller();
	die "attempt to access private member $method at $file line $line\n";
    }

    $method = uc $method;
    if (@_) {
	return ($self->{ $method } = shift);
    }
    else {
	return $self->{ $method };
    }
}


#------------------------------------------------------------------------
# _dump()
#
# Debug method to return a formatted string containing the object data.
#------------------------------------------------------------------------

sub _dump {
    my $self = shift;
    my $text = "$self:\n";
    while (my ($key, $value) = each %$self) {
	$value = '' unless defined $value;
	$text .= sprintf("    %-12s => $value\n", $key);
    }
    return $text;
}


1;

__END__