[Templates-cvs] cvs commit: TT3/lib/Template Base.pm
cvs@template-toolkit.org
cvs@template-toolkit.org
Tue, 23 Mar 2004 10:32:15 +0000
cvs 04/03/23 10:32:14
Added: lib/Template Base.pm
Log:
* added the new Template::Base module
Revision Changes Path
1.1 TT3/lib/Template/Base.pm
Index: Base.pm
===================================================================
#========================================================================
#
# Template::Base
#
# DESCRIPTION
# Base class module implementing common functionality for various
# other Template Toolkit modules.
#
# AUTHOR
# Andy Wardley <abw@wardley.org>
#
# COPYRIGHT
# Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved.
# Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
# Copyright (C) 2003-2004 Fotango Ltd.
#
# This module is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# REVISION
# $Id: Base.pm,v 1.1 2004/03/23 10:32:13 abw Exp $
#
#========================================================================
package Template::Base;
use strict;
use warnings;
use vars qw( $VERSION $DEBUG $ERROR $WARNINGS $PAD $TEXTLEN $UTILS );
require Template::Utils;
$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
$DEBUG = 0 unless defined $DEBUG;
$ERROR = '';
$PAD = 2;
$TEXTLEN = 32;
$UTILS = 'Template::Utils';
#------------------------------------------------------------------------
# new({ key1 => $value1, key2 => $value2, ... })
# new( key1 => $value1, key2 => $value2, ... )
#
# Constructor method creates blessed hash, folds arguments into a config
# hash and calls init() method. Most subclasses can use this default
# constructor and subclass only the init() method.
#------------------------------------------------------------------------
sub new {
my $class = shift;
$class = ref $class || $class;
# allow hash ref as first argument, otherwise fold args into hash
my $config = defined $_[0] && UNIVERSAL::isa($_[0], 'HASH')
? shift : { @_ };
my ($debug) = $class->pkgconf($config, 'debug');
my $self = bless {
DEBUG => $debug,
ERROR => '',
}, $class;
return $self->init($config)
|| $class->error($self->error());
}
#------------------------------------------------------------------------
# clone({ key1 => $value1, ... })
# clone( key1 => $value1, ... )
#
# Clones the current object to create a new copy and then calls the init()
# method to initialise it, forwarding all arguments.
#------------------------------------------------------------------------
sub clone {
my $self = shift;
my $class = ref $self || $self;
# allow hash ref as first argument, otherwise fold args into hash
my $config = defined $_[0] && UNIVERSAL::isa($_[0], 'HASH')
? shift : { @_ };
my $clone = bless {
%$self,
ERROR => '',
}, $class;
return $clone->init($config);
}
#------------------------------------------------------------------------
# init(\%config)
#
# Initialisation method called by new() constructor. This is generally
# redefined by subclasses.
#------------------------------------------------------------------------
sub init {
return $_[0];
}
#------------------------------------------------------------------------
# pkgvar($name, $default)
#
# Looks for the scalar package variable named by the first argument
# (no leading '$') in the current package, accounting for subclassing,
# returning the $default value if not defined.
#------------------------------------------------------------------------
sub pkgvar {
my ($self, $name, $default) = @_;
my $class = ref $self || $self;
no strict 'refs';
my $value = ${ "${class}::${name}" };
return defined $value ? $value : $default;
}
#------------------------------------------------------------------------
# pkgconf(\%config, @params)
#
# Looks in the $config hash passed as a first argument for each of the
# named parameters passed as the remaining arguments, @params. The
# method first looks each parameter as specified (e.g. 'name'), then
# for the upper case equivalent ('NAME'), and then for a corresponding
# package variable in the $self class, or in that of the caller.
#------------------------------------------------------------------------
sub pkgconf {
my ($self, $config, @keys) = @_;
my $class = ref $self || $self;
my ($pkg, $f, $l) = caller();
my ($key, $uckey, $value, @values);
no strict 'refs';
foreach $key (@keys) {
$uckey = uc $key;
$self->debug("looking for $uckey in class [$class] package [$pkg]\n")
if $self->{ DEBUG };
if (defined ($value = delete $config->{ $key })) {
$self->debug("$key already defined in config: $value\n")
if $self->{ DEBUG };
}
elsif (defined ($value = delete $config->{ $uckey })) {
$self->debug("$uckey defined in config, copied to $key: $value\n")
if $self->{ DEBUG };
}
elsif (defined ($value = ${"${class}::${uckey}"})) {
$self->debug("got subclass value for ${class}::${uckey} : $value\n")
if $self->{ DEBUG };
}
elsif (defined ($value = ${"${pkg}::${uckey}"})) {
$self->debug("got package value for ${pkg}::${uckey} : $value\n")
if $self->{ DEBUG };
}
else {
return $self->error("no value provided for $key");
}
$self->{ $key } = $value;
push(@values, $value);
}
return @values;
}
#------------------------------------------------------------------------
# error()
# error($msg1, $msg2, $msg3, ...)
#
# Returns current error when called without args. When called with
# args they are concatenated to define a new error string which is set
# in the object error item and/or the $ERROR package variable. A
# single reference argument (e.g. an exception object) can be passed
# as an argument. This is used as is without being first stringified.
#------------------------------------------------------------------------
sub error {
my $self = shift;
my $class = ref $self || $self;
no strict 'refs';
if (@_) {
# don't stringify objects passed as argument
my $error = ref $_[0]
? shift
: join('', map { defined($_) ? $_ : '' } @_);
$self->{ ERROR } = $error if ref $self;
${"$class\::ERROR"} = $error;
return undef;
}
elsif (ref $self) {
return $self->{ ERROR };
}
else {
return ${"$class\::ERROR"};
}
}
#------------------------------------------------------------------------
# warning()
# warning($msg1, $msg2, $msg3, ...)
#
# Similar to error(), above, but allows multiple (non-fatal) warnings to
# be raised by pushing them onto an internal list. Returns a reference
# to a list of warnings when called without arguments.
#------------------------------------------------------------------------
sub warning {
my $self = shift;
my $class = ref $self || $self;
my $warnings;
no strict 'refs';
if (@_) {
# don't stringify objects passed as argument
my $message = ref $_[0] ? shift : join('', @_);
if (ref $self) {
# add to object internal list
$warnings = $self->{ WARNINGS } ||= [ ];
push(@$warnings, $message);
}
else {
# add to package list
$warnings = ${"$class\::WARNINGS"} ||= [ ];
push(@$warnings, $message);
}
return 0;
}
elsif (ref $self) {
return $self->{ WARNINGS } ||= [ ];
}
else {
return ${"$class\::WARNINGS"} ||= [ ];
}
}
#------------------------------------------------------------------------
# warnings()
# warnings($warning1, $warning2, ...)
#
# Forwards each of any arguments passed to the warning() method.
# Returns the current list of warnings when called without arguments.
#------------------------------------------------------------------------
sub warnings {
my $self = shift;
if (@_) {
# pass separate arguments on to $self->warning()
foreach my $msg (@_) {
$self->warning($msg);
}
return 0;
}
else {
my $warnings = $self->warning();
return @$warnings;
}
}
#------------------------------------------------------------------------
# decline($reason)
#
# General purpose method used to decline a request of some kind. Calls
# error() to report the reason passed as one or more arguments, and then
# returns 0.
#------------------------------------------------------------------------
sub decline {
my $self = shift;
$self->error(@_);
return 0;
}
#------------------------------------------------------------------------
# throw()
#
# This method is only here temporarily. It might get moved, it might
# get implemented properly. TBA.
#------------------------------------------------------------------------
sub throw {
my $self = shift;
die @_;
}
#------------------------------------------------------------------------
# module($name, $config)
#
# Load a module. The $name passed should correspond to an object item
# indicating the module package name
# (e.g. scanner => Template::Scanner)
#------------------------------------------------------------------------
sub module {
my $self = shift;
my $name = shift;
my $config = @_ && UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ };
$self->debug("module($name)\n") if $DEBUG;
# TODO: may want to implement caching, e.g. have an object
# cache => { scanner => 1, parser => 1, handler => 0 } item
# and then cache objects accordingly
# $config or $self should define a $name item (e.g. 'scanner',
# 'parser', etc, to provide an object or class name
my $package = $config->{ $name } || $self->{ $name }
|| return $self->error("no $name module defined");
# item may already be an object
return $package if ref $package;
# $config or $self can have set a load_$item flag (e.g. 'load_scanner',
# 'load_parser') to enable/disable loading of that module
my $load_key = "load_$name";
if (exists $config->{ $load_key }
? $config->{ $load_key }
: exists $self->{ $load_key }
? $self->{ $load_key }
: 1 ) {
# load module
$UTILS->load_module($package)
|| return $self->error($UTILS->error());
# don't bother loading it again
$self->{ $load_key } = 0;
}
return $package;
}
#------------------------------------------------------------------------
# object($name, $config)
#
# Load a module and instantiate an object.
#------------------------------------------------------------------------
sub object {
my $self = shift;
my $name = shift;
my $module = $self->module( $name ) || return;
# module may already be an object
return $module if ref $module;
# otherwise create one
return $module->new(@_)
|| $self->error("failed to create $name: ", $module->error());
}
#------------------------------------------------------------------------
# debug($msg1, $msg2, ...)
#
# Debugging method which currently outputs all arguments to STDERR.
# This should eventually be refactored to provide more flexible that
# allows DEBUG to be set to a handler (object, subroutine), or something
# like that.
#------------------------------------------------------------------------
sub debug {
my $self = shift;
my $class = ref $self || $self;
print STDERR '[', $class, '] ', join('', @_);
}
#------------------------------------------------------------------------
# dump()
#
# Debugging method to return a text representation of the object
# internals.
#------------------------------------------------------------------------
sub dump {
my $self = shift;
$self->dump_item($self);
}
#------------------------------------------------------------------------
# dump_hash(\%hash)
#
# Debugging method to return a text representation of a hash reference.
#------------------------------------------------------------------------
sub dump_hash {
my ($self, $hash, $indent) = @_;
$indent ||= 0;
my $pad = ' ' x ($indent * $PAD);
return "$pad\{\n"
. join( ",\n",
map { "$pad$_ => " . $self->dump_item($hash->{$_}, $indent + 1) }
keys %$hash )
. "\n$pad}";
}
#------------------------------------------------------------------------
# dump_list(\@list)
#
# Debugging method to return a text representation of an array reference.
#------------------------------------------------------------------------
sub dump_list {
my ($self, $list, $indent) = @_;
$indent ||= 0;
my $pad = ' ' x ($indent * $PAD);
return "$pad\[\n"
. join(",\n", map { $self->dump_item($_, $indent + 1) } @$list)
. "\n$pad]";
}
#------------------------------------------------------------------------
# dump_item($item)
#
# Debugging method to return a text representation of a value, calling
# the appropriate dump_hash() or dump_list() method as appropriate.
#------------------------------------------------------------------------
sub dump_item {
my ($self, $item, $indent) = @_;
$indent ||= 0;
my $pad = ' ' x ($indent * $PAD);
return $pad . $item unless ref $item;
if (UNIVERSAL::isa($item, 'HASH')) {
return $self->dump_hash($item, $indent + 1);
}
elsif (UNIVERSAL::isa($item, 'ARRAY')) {
return $self->dump_list($item, $indent + 1);
}
elsif (UNIVERSAL::isa($item, 'SCALAR')) {
return $pad . $$item;
}
else {
return $item;
}
}
#------------------------------------------------------------------------
# dump_text($text, $length)
#
# Debugging method to return a truncated and sanitised representation of
# a text string.
#------------------------------------------------------------------------
sub dump_text {
my ($self, $text, $length) = @_;
$text = $$text if ref $text;
$length ||= $TEXTLEN;
my $snippet = substr($text, 0, $length);
$snippet .= '...' if length $text > $length;
$snippet =~ s/\n/\\n/g;
return $snippet;
}
1;
__END__
=head1 NAME
Template::Base - base class module
=head1 SYNOPSIS
package My::Template::Module;
use Template::Base;
use base qw( Template::Base );
# define init() method for initialisation
sub init {
my ($self, $config)
# $config is a hash of named parameters
$self->{ name } = $config->{ name }
|| return $self->error('no name specified');
# return $self to indicate success
return $self;
}
# rest of the module follows...
package main;
# using the module
my $object = My::Template::Module->new( name => 'thingy' )
|| die My::Template::Module->error();
=head1 DESCRIPTION
This module implements a base class object from which most of the
other Template Toolkit modules are derived. It implements a number of
methods to aid in object creation and configuration, error reporting,
debugging, and for loading and instantiating objects of other classes.
=head1 METHODS
=head2 new(\%config)
This is a general purpose constructor method. It accepts either a
reference to a hash array of named parameters (or an object derived
from a hash array), or a list of named parameters which are then
folded into a hash reference.
# hash reference of named params
my $object = My::Template::Module->new({
arg1 => 'value1',
arg2 => 'value2',
...etc...
});
# list of named params
my $object = My::Template::Module->new(
arg1 => 'value1',
arg2 => 'value2',
...etc...
);
The constructor creates a new object by blessing a hash reference
and then calls the C<init()> method, passing the reference to the
hash array of named parameters.
The C<new()> method returns whatever the C<init()> method returns
(usually the C<$self> reference, but it can actually be something
else). If C<init()> doesn't return a true value then the C<new()>
method will return C<undef>. The C<error()> method can then be
called to determine the cause of the problem.
my $object = My::Template::Module->new()
|| die My::Template::Module->error();
Constructor errors can also be examined via the C<$ERROR> package
variable. Note that this is in the package of the subclass module
rather than Template::Base.
my $object = My::Template::Module->new()
|| die $My::Template::Module::ERROR;
=head2 clone(\%config)
This method creates a copy of the current object and then calls its
init() method, forwarding to it any arguments passed.
my $copy = $object->clone( answer => '69, dude!' )
|| die $object->error();
=head2 init(\%config)
This initialisation method is called by the C<new()> constructor method.
It is passed a reference to a hash array of named parameters. The
method may perform any configuration or initialisation processes and
should then return the C<$self> reference to inidicate success.
sub init {
my ($self, $config) = @_;
# set the 'answer' parameter or default to 42
$self->{ answer } = $config->{ answer } || 42;
return $self;
}
The C<init()> method can actually return any true value. Whatever
it returns is what gets passed back to the user from the C<new()>
method. That's why you nearly always want to pass C<$self> back.
However, there are certain cases (e.g. plugins) where object
constructors don't return an object at all, just something that is
constructed like one.
If something goes wrong in the C<init()> method then you should
call the C<error()> method and return C<undef>. The C<error()>
method returns C<undef> when you pass it an argument, so you
can use it as follows:
sub init {
my ($self, $config) = @_;
# set the 'answer' parameter or report error
$self->{ answer } = $config->{ answer }
|| return $self->error('no answer supplied');
return $self;
}
=head2 pkgvar($name, $default)
This method provides a convenient way to examine for the value of a
scalar package variable. The first argument, C<$name>, provides the
name of the variable in question (no leading C<$>). The second
argument can be used to provide a default value to be used if the
variable is undefined.
sub init {
my ($self, $config) = @_;
# allow $LIMIT to be specified as a package
# variable or default to a value of 10
$self->{ limit } = $self->pkgvar( LIMIT => 10 );
return $self;
}
=head2 pkgconf(\%config, @params)
This method looks in the hash array referenced by the first argument
for each of the named parameters passed as the remaining arguments.
sub init {
my ($self, $config) = @_;
$self->pkgconf($config, qw( size limit ))
|| return;
return $self;
}
It first looks for the parameter as specified (e.g. 'size'). If not
defined it then looks for the upper case equivalent (e.g. 'SIZE').
Failing that it then looks for a package variable (e.g. '$SIZE') in
the subclass package and then in the caller's package. If any of
these searches return a defined value then it is copied into C<$self>
using the original name (i.e. 'size') as a key. Otherwise the method
returns an error.
=head2 module($name, \%config)
This method looks in the current object for the name of a module defined
by the first argument and loads it.
my $object = My::Template::Module->new({
warp_drive => 'My::Warp::Drive'
});
my $warpmod = $object->module('warp_drive');
The object can also set an internal flag of the form "load_$name" to override
the default behaviour of loading the relevant module.
my $object = My::Template::Module->new({
warp_drive => 'My::Warp::Drive'
load_warp_drive => 0,
});
A list of named arguments, or a reference to a hash array of the same, can
follow the module name, providing custom values for these items.
my $modules = {
warp_drive => 'My::Warp::Drive',
load_warp_drive => 0, # already online
teleporter => 'My::Teleporter',
};
my $warpmod = $object->module( warp_drive => $modules )
|| die $object->error();
=head2 object($name, \%config)
This method calls the C<module()> method to load the module associated
with C<$name> and then instantiates an object by calling the C<new()>
method, forwards all remaining arguments.
my $warp_drive = $object->object( warp_drive => { warp => 2 } )
|| die $object->error();
=head2 error()
The C<error()> method is used for error reporting. When an object method
fails for some reason, it calls the C<error()> method passing an argument
denoting the problem that occurred.
sub engage {
my $self = shift;
return $self->error('warp drive offline');
}
Multiple arguments can be passed to the C<error()> method. They are
concatenated into a single string.
sub engage {
my $self = shift;
return $self->error( 'warp drive number ',
$self->{ engine_no },
' is offline' );
}
When the C<engage()> method is called, the C<undef> value returned
indicates that an error has occurred. The C<error()> method can then
be called again, this time without any arguments, to retrieve the
error message.
$object->engage()
|| die $object->error(); # warp drive number 3 is offline
The C<error()> method can also be called as a class method. In this
case, it updates and retrieves the C<$ERROR> package variable in the
package of the subclass module.
# calling package error() method
my $object = My::Template::Module->new()
|| die My::Template::Module->error();
# accessing $ERROR package variable
my $object = My::Template::Module->new()
|| die $My::Template::Module::ERROR;
=head2 warning()
This method is very similar to C<error()> described above. However,
while an object can only report one error at any time (we assume that
an error is a "fatal" condition which requires the object to return
right away), it can report any number of non-fatal warnings. The
C<warning()> method maintains a list of warnings inside the object
or in the C<$WARNINGS> package variable (a reference to a list) when
called as a class method.
When called with arguments, the C<warning()> method concatentates
them into a single string and adds it to the current warnings list.
sub disengage {
my $self = shift;
$self->warning('warp drive already offline')
unless $self->{ engaged };
# ...etc...
return 1;
}
When called in this way, the C<warning()> method returns C<0> (in contrast
to the C<error()> method which returns C<undef>). So you might choose
to write your method like this:
sub disengage {
my $self = shift;
return $self->warning('warp drive already offline')
unless $self->{ engaged };
# ...etc...
return 1;
}
And call it like this:
defined $object->disengage()
|| die $object->error();
When you call the warning() method without any arguments, it returns
a reference to a list of current warnings.
my $warnings = $object->warning();
if (@$warnings) {
warn "warning while disengaging warp drive: ", @$warnings;
}
=head2 warnings()
When called with arguments, this method calls the C<warning()> method once
for each argument. Thus the following examples are equivalent.
# single call to warnings()
$object->warnings('foo', 'bar', 'baz');
# multiple calls to warning()
$object->warning('foo');
$object->warning('bar');
$object->warning('baz');
When called without arguments, the C<warnings()> method returns a
list of warnings (rather than the reference to a list of warnings
that C<warning()> returns).
if ($object->warnings()) {
die "warning while disengaging warp drive: ",
$object->warnings();
}
=head2 decline($reason)
This method is similar to the C<error()> method described above. In
fact, it is implemented as a wrapper around C<error()>, forwarding all
arguments to allow the object to set its internal error string. However,
instead of returning C<undef>, the C<decline()> method returns 0.
This may be subject to change.
=head2 debug($msg1, $msg2, ...)
At present this method simply prints all arguments to STDERR, prefixed
by an object identifier. This should eventually provide alternatives,
allowing custom debug handlers to be defined, etc.
=head2 dump()
Debugging method which returns a text representation of the object internals.
print STDERR $object->dump();
=head2 dump_hash(\%hash)
Debugging method which returns a text representation of the hash array passed
by reference as the first argument.
print STDERR $object->dump_hash(\%hash);
=head2 dump_list(\@list)
Debugging method which returns a text representation of the array
passed by reference as the first argument.
print STDERR $object->dump_list(\@list);
=head2 dump_text($text)
Debugging method which returns a truncated and sanitised representation of the
text string passed (directly or by references) as the first argument.
print STDERR $object->dump_text($text);
=head2 dump_item($item)
Debugging method which calls the appropriate C<dump_hash()>, C<dump_list()> or
C<dump_text()> method for the item passed as the first argument.
print STDERR $object->dump_item($item);
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt>
=head1 VERSION
$Revision: 1.1 $
=head1 COPYRIGHT
Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved.
Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
Copyright (C) 2003-2004 Fotango Ltd.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: