#!/usr/bin/perl
#
# Copyright 2003-5 Bernard Quatermass
#
# This program may be copied only under the terms of either
# the Artistic License or the GNU General Public License,
# which may be found in the Perl 5.0 source kit.
#
# Author: bernard@quatermass.co.uk
#
# StdModule.pm
# 
# The following is a standard framework for a module.
# It provides a few base methods and is expected to
# be used as the core for other modules.
#
# Typically it would be used by a module as follows,
#
#
#   use StdModule;
#   use vars qw( @ISA %myparams );
#   @ISA= qw(StdModule);
#   %myparams = { 'name' => 'fred', 'thing' => 'thong' };
#   sub new {
#     $self = __PACKAGE__->SUPER::new( \%myparams, @_ );
#     # And post initialisation.
#
# etc
#
#

package StdModule;

use strict;

use vars qw( $AUTOLOAD );

# This hash describes the parameters that can be passed
# in the constructor call, together with the default values for same.

sub
new
{
    my $protoverse = shift;
    my $class      = ref($protoverse) || $protoverse;

    my $params = shift || return undef;	# gimme summat

    my $self = { '__params' => { }, };
    # Ensure the base attributes exist with their default values.
    foreach( keys %$params )
    {
	$self->{'__params'}->{$_} = $params->{$_};
    }

    $self = bless($self, $class);

    # Also need to drop the next param as it appears to be the class name.
    # This allow us to exploit the set_params function.
    shift;
    $self->set_params( @_ )
	if @_;

    return $self;
}


##
## This AUTLOAD routine ensures we can get/set any base or derived
## element via an object method, rather than the caller having to
## assume any knowledge of the internal data structure.
## The derived data classes take priority.
## Values can only be set if the field already exists.
## To create a new field the ## add_derived method should
## be called.
##

sub
AUTOLOAD
{
    my $self = shift;
    my $type = ref($self)
	or warn "$self is not an object";
    my $pname = $AUTOLOAD;
    $pname =~ s/.*://;   # strip fully-qualified portion
    my $x = exists $self->{'__params'}->{$pname};
    $self->{'__params'}->{$pname} = $_[0]
	if @_ && $x;
    return ($x) ? $self->{'__params'}->{$pname} : undef;
}

sub
add_params
{
    my $self = shift;
    if ( ref($_[0]) eq 'HASH' || ! (scalar(@_) % 2) )
    {
	my $attr = (ref($_[0]) eq 'HASH') ? shift : { @_ };
	foreach my $k( keys %$attr )
	{
	    $self->{'__params'}->{$k} = $attr->{$k}
		if ! exists $self->{'__params'}->{$k};
	}
    }else
    {
	my $pname = shift;
	$self->{'__params'}->{$pname} = undef
	    if ! exists $self->{'__params'}->{$pname};
    }
}

sub
set_params
{
    my $self = shift;
    if ( ref($_[0]) eq 'HASH' || ! (scalar(@_) % 2) )
    {
	my $attr = (ref($_[0]) eq 'HASH') ? shift : { @_ };
	# Now transfer any supplied attributes into place
	# We call via method in case any parent has overridden us.
	foreach my $k( keys %$attr )
	{
	    $self->$k( $attr->{$k} );
	}
    }
    return;
}

1;
## End of File