# ==================================================================
# Gossamer Threads Module Library
#
#	GT_Base
#	Author  : Alex Krohn (alex@gossamer-threads.com)
# 
# Copyright (c) 1999 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#	Base module that handles common functions like initilization, 
#   debugging, etc. Should not be used except as a base class.
#
# Revision: ($REVISION $)
#

package GT_Base;
# ===============================================================

	require 5.004;	# We need perl 5.004 for a lot of the OO features.

	use strict;
	use Carp     qw/carp croak confess/;
	use vars     qw/$AUTOLOAD $DEBUG $VERSION/;

	$DEBUG   = 0;
	$VERSION = '1.0';

sub new {
# -------------------------------------------------------
# Create a base object and use set or init to initilize anything.
#
	my $this   = shift;
	my $class  = ref $this || $this;
	no strict 'refs';
	my $attrib = defined ${"$class\:\:ATTRIBS"} ? ${"$class\:\:ATTRIBS"} : {};
	my $debug  = defined ${"$class\:\:DEBUG"} ? ${"$class\:\:DEBUG"} : $DEBUG;
	use strict 'refs';
	my $self   = {
					'_attrib' => $attrib,
					'_debug'  => $debug,
					map  { $_ => $attrib->{$_} } keys %$attrib
				};
	bless $self, $class;
	$self->debug ("New object instantiated.") if ($self->{_debug});
	if ($self->can('init')) {
		$self->init(@_);
	}
	else {
		$self->set(@_) if (@_);	
	}
	return $self;
}

sub DESTROY {
# -------------------------------------------------------
# Object is nuked.
#
	$_[0]->debug ("Object destroyed.") if ($_[0]->{_debug});
}

sub AUTOLOAD {
# -------------------------------------------------------
# Accessor for all the fields.
#
	my ($self, $param) = @_;
	my ($attrib)   = $AUTOLOAD =~ /::([^:]+)$/;

	if (exists $self->{$attrib}) {
		if (defined $param) {
			$self->debug ("Setting '$attrib' => '$param'.") if ($self->{_debug});
			$self->{$attrib} = $param;
		}
		return $self->{$attrib};
	}
	else {
		$self->error ("Unknown method '$attrib' called.", 'FATAL');
	}
}

sub debug {
# -------------------------------------------------------
# Displays a debugging message.
#
	my ($self, $msg, $level) = @_;
	my $pkg  = ref $self;
	$level ||= 1;
	carp "$pkg ($$): $msg" if ($level <= $self->{_debug});
}

sub debug_level {
# -------------------------------------------------------
# Set the debug level for either the class or object.
#
	if (ref $_[0]) {
		if (@_ > 1) { $_[0]->{_debug} = $_[1]; };
		return $_[0]->{_debug};
	}
	else {
		my $pkg   = shift;
		no strict 'refs';
		if (@_) {
			my $level = shift;
			${"$pkg\:\:DEBUG"} = $level; 
		}
		my $dbg = ${"$pkg\:\:DEBUG"};
		use strict 'refs';
		return $dbg;
	}
}

sub error {
# -------------------------------------------------------
# Error handler.
#
	my ($self, $msg, $level, @args) = @_;
	my $pkg = ref $self;
	my $err = $pkg . "\:\:ERRORS";
	no strict 'refs';
	my $cls_err = ${$err};
	use strict 'refs';
	if (defined $cls_err) {
		(exists $cls_err->{$msg}) and ($msg = $cls_err->{$msg});
		$msg =~ s/%1%/defined $args[0] ? $args[0] : ''/eg;
		$msg =~ s/%2%/defined $args[1] ? $args[1] : ''/eg;
	}
	if (defined $pkg::error) {
		$pkg::error = $msg;
	}
	if (uc $level eq 'FATAL') {
		$self->{_debug} ? confess "$pkg ($$): $msg" : croak "$pkg ($$): $msg";
	}
	elsif (uc $level eq 'WARN') {
		carp "$pkg ($$): $msg";
	}
	return undef;
}

sub set {
# -------------------------------------------------------
# Set one or more attributes.
#
	if (@_ and !ref $_[0]) { &class_set(@_); }
	else {
		my ($self, $p) = &_common_param(@_);
		if (ref $p) {
			my $f = 0;
			foreach my $attrib (@{$self->{_attrib}}) {
				next unless (exists $p->{$attrib});
				$self->debug ("Setting '$attrib' to '${$p}{$attrib}'.") if ($self->{_debug});
				$self->{$attrib} = $p->{$attrib};
				$f++;
			}
			return $f;
		}
		else {
			$self->error ("Argument to set must be either hash, hash ref, array, array ref or CGI object.", 'FATAL');
		}
	}
}

sub class_set {
# -------------------------------------------------------
# Set the class init attributes.
#
	my $pkg = shift;
	my $atrib_s = $pkg . "\:\:ATTRIBS";
	no strict 'refs'; my $attribs = ${$atrib_s}; use strict 'refs';
	return unless (ref $attribs eq 'HASH');

# Figure out what we were passed in.
	my $out  = {};
	CASE: {
		(ref $_[0] eq 'HASH') and do { $out = shift; last CASE; };
		(ref $_[0] eq 'CGI' or (ref $_[0] and &UNIVERSAL::isa($_[0], 'CGI')) or (ref $_[0] eq 'GT_CGI')) 
							  and do { foreach ($_->param) { $out->{$_} = $_->param($_); }	last CASE; };
		(@_ > 1)			  and do { %{$out} = @_; last CASE; };
	};

# Set the attribs.
	foreach (keys %$out) {
		exists $attribs->{$_} and do {
			$attribs->{$_} = $out->{$_};
		};
	}	
}
sub attrib {
# -------------------------------------------------------
# Returns a list of attributes.
#
	return wantarray ? @{$_[0]->{_attrib}} : $_[0]->{_attrib};
}

sub _common_param {
# -------------------------------------------------------
# Expects to find $self, followed by one or more arguments of
# unknown types. Converts them to hash refs.
#
	my $self = shift;
	my $out  = {};
	(ref $_[0] eq 'HASH') and return ($self, shift);		# Hash ref.
	(ref $_[0] eq 'CGI' or (ref $_[0] and &UNIVERSAL::isa($_[0], 'CGI')) or (ref $_[0] eq 'GT_CGI')) 
								and do {					# CGI ref.
									foreach ($_->param) { $out->{$_} = $_->param($_); }
									return ($self, $out); 
								};
	@_ > 1 and do { my %out = @_; return ($self, \%out); };	# Hash/Array.
	return ($self, shift);									# Scalar.
}

1;