[Templates-cvs] cvs commit: TT3/lib/Template/TT3/VObject Hash.pm List.pm
cvs@template-toolkit.org
cvs@template-toolkit.org
Sat, 06 Dec 2003 16:00:09 +0000
cvs 03/12/06 16:00:08
Added: lib/Template/TT3/VObject Hash.pm List.pm
Log:
* added VObject base class and Hash and List virtual object modules
Revision Changes Path
1.1 TT3/lib/Template/TT3/VObject/Hash.pm
Index: Hash.pm
===================================================================
#============================================================= -*-perl-*-
#
# Template::TT3::VObject::Hash
#
# DESCRIPTION
# Virtual object implementing virtual methods for examining and
# manipulating hashs.
#
# AUTHOR
# Andy Wardley <abw@wardley.org>
#
# COPYRIGHT
# Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved.
# Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
#
# This module is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# REVISION
# $Id: Hash.pm,v 1.1 2003/12/06 16:00:06 abw Exp $
#
# TODO
# * much of this was written some time ago. I need to go through
# and check that they all still make sense.
#
#========================================================================
package Template::TT3::VObject::Hash;
use strict;
use warnings;
use Template::TT3::VObject;
use vars qw( $VERSION $DEBUG $ERROR $WARNING $VCLASS $VMETHOD );
use base qw( Template::TT3::VObject );
$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
$DEBUG = 0 unless defined $DEBUG;
$ERROR = '';
$VCLASS = 'Hash';
$VMETHOD = {
# informers
ref => \&hash_ref,
type => \&hash_type,
# converters
text => \&hash_text,
item => \&hash_item,
list => \&hash_list,
hash => \&hash_hash,
copy => \&hash_copy,
# accessors
each => \&hash_each,
keys => \&hash_keys,
values => \&hash_values,
keyvalues => \&hash_keyvalues,
exists => \&hash_exists,
defined => \&hash_defined,
sort => \&hash_sort,
nsort => \&hash_nsort,
# mutators
import => \&hash_import,
};
#------------------------------------------------------------------------
# hash_ref() [% hash.ref %]
#
# Returns 'HASH'.
#------------------------------------------------------------------------
sub hash_ref {
return 'HASH';
}
#------------------------------------------------------------------------
# hash_type() [% hash.type %]
#
# Returns 'HASH'.
#------------------------------------------------------------------------
sub hash_type {
return $VCLASS;
}
#------------------------------------------------------------------------
# hash_text() [% hash.text %]
#
# Generate a text representation of the hash.
#------------------------------------------------------------------------
sub hash_text {
my ($hash, $joint1, $joint2) = @_;
$joint1 = ' => ' unless defined $joint1;
$joint2 = ', ' unless defined $joint2;
return join($joint2, map {
my $val = $hash->{ $_ };
$val = '' unless defined $val;
"$_$joint1$val";
} sort keys %$hash);
}
#------------------------------------------------------------------------
# hash_item($key) [% hash.item('foo') %]
#
# Returns the item in the hash corresponding to the key passed as an
# argument.
#------------------------------------------------------------------------
sub hash_item {
my ($hash, $item) = @_;
$item = '' unless defined $item;
$hash->{ $item };
}
#------------------------------------------------------------------------
# hash_list() [% hash.list %]
#
# Returns the hash reference as the single item in a list.
#------------------------------------------------------------------------
sub hash_list {
return [ $_[0] ];
}
#------------------------------------------------------------------------
# hash_hash() [% hash.hash %]
#
# Returns the hash unmodified.
#------------------------------------------------------------------------
sub hash_hash {
return $_[0];
}
#------------------------------------------------------------------------
# hash_copy() [% hash.copy %]
#
# Returns a copy of the hash.
#------------------------------------------------------------------------
sub hash_copy {
my $hash = shift;
return { %$hash };
}
#------------------------------------------------------------------------
# hash_each() [% hash.each %]
#
# Returns the hash keys and values flattened to a list.
#------------------------------------------------------------------------
sub hash_each {
[ %{ $_[0] } ];
}
#------------------------------------------------------------------------
# hash_keys() [% hash.keys %]
#
# Returns a list of the hash keys.
#------------------------------------------------------------------------
sub hash_keys {
[ keys %{ $_[0] } ]
}
#------------------------------------------------------------------------
# hash_values() [% hash.values %]
#
# Returns a list of the hash values.
#------------------------------------------------------------------------
sub hash_values {
[ values %{ $_[0] } ];
}
#------------------------------------------------------------------------
# hash_keyvalues() [% hash.keyvalues %]
#
# Returns a list of hash arrays, each one containing a 'key' and 'value'
# item to represent each item in the original hash.
#------------------------------------------------------------------------
sub hash_keyvalues {
my $hash = shift;
[ map {
{
key => $_ ,
value => $hash->{ $_ }
}
} keys %$hash
];
}
#------------------------------------------------------------------------
# hash_exists($key) [% hash.exists('foo') %]
#
# Returns true if the $key specified exists in the hash.
#------------------------------------------------------------------------
sub hash_exists {
exists $_[0]->{ $_[1] };
}
#------------------------------------------------------------------------
# hash_defined($key) [% hash.defined('foo') %]
#
# Returns true if the $key specified is defined in the hash.
#------------------------------------------------------------------------
sub hash_defined {
defined $_[0]->{ $_[1] };
}
#------------------------------------------------------------------------
# hash_sort() [% hash.sort %]
#
# Returns the keys of the hash alphabetically sorted according to the
# values.
#------------------------------------------------------------------------
sub hash_sort {
my $hash = shift;
[ sort { lc $hash->{$a} cmp lc $hash->{$b} } (keys %$hash) ];
}
#------------------------------------------------------------------------
# hash_nsort() [% hash.nsort %]
#
# Returns the keys of the hash numerically sorted according to the
# values.
#------------------------------------------------------------------------
sub hash_nsort {
my $hash = shift;
no warnings;
[ sort { $hash->{$a} <=> $hash->{$b} } (keys %$hash) ];
}
#------------------------------------------------------------------------
# hash_import($newhash) [% hash.import(newhash) %]
#
# Imports the values in the hash passed by reference as the $newhash
# argument into the current hash.
#------------------------------------------------------------------------
sub hash_import {
my ($hash, $import) = @_;
$import = { } unless ref $import eq 'HASH';
@$hash{ keys %$import } = values %$import;
return $hash;
# return '';
}
1;
__END__
=head1 NAME
Template::TT3::VObject::Hash - hash virtual object
=head1 SYNOPSIS
use Template::TT3::VObject::Hash
my $vtable = Template::TT3::VObject::Hash->vmethod();
my $handler = $vtable->{ keys };
my $hash = { pi => 3.14, e => 2.718 };
my $result = &$handler($hash);
=head1 DESCRIPTION
# TODO
=head1 METHODS
=head2 new()
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt>
=head1 VERSION
$Revision: 1.1 $
=head1 COPYRIGHT
Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved.
Copyright (C) 1998-2002 Canon Research Centre Europe 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:
1.1 TT3/lib/Template/TT3/VObject/List.pm
Index: List.pm
===================================================================
#============================================================= -*-perl-*-
#
# Template::TT3::VObject::List
#
# DESCRIPTION
# Virtual object implementing virtual methods for examining and
# manipulating lists.
#
# AUTHOR
# Andy Wardley <abw@wardley.org>
#
# COPYRIGHT
# Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved.
# Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
#
# This module is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# REVISION
# $Id: List.pm,v 1.1 2003/12/06 16:00:06 abw Exp $
#
# TODO
# * much of this was written some time ago. I need to go through
# and check that they all still make sense.
#
# * list_hash() should probably return { @$list } rather than
# { 0 => $list->[0], 1 => $list->[1], etc }
#
#========================================================================
package Template::TT3::VObject::List;
use strict;
use warnings;
use Template::TT3::VObject;
use vars qw( $VERSION $DEBUG $ERROR $WARNING $VCLASS $VMETHOD );
use base qw( Template::TT3::VObject );
$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
$DEBUG = 0 unless defined $DEBUG;
$ERROR = '';
$VCLASS = 'List';
$VMETHOD = {
# informers
ref => \&list_ref,
type => \&list_type,
# converters
text => \&list_text,
item => \&list_item,
list => \&list_list,
hash => \&list_hash,
copy => \&list_copy,
# mutators
push => \&list_push,
pop => \&list_pop,
shift => \&list_shift,
unshift => \&list_unshift,
splice => \&list_splice,
merge => \&list_merge,
# accessors
max => \&list_max,
size => \&list_size,
first => \&list_first,
last => \&list_last,
grep => \&list_grep,
join => \&list_join,
sort => \&list_sort,
nsort => \&list_nsort,
reverse => \&list_reverse,
slice => \&list_slice,
unique => \&list_unique,
};
#------------------------------------------------------------------------
# list_ref() [% list.ref %]
#
# Returns the Perl reference type, 'ARRAY'.
#------------------------------------------------------------------------
sub list_ref {
return 'ARRAY';
}
#------------------------------------------------------------------------
# list_type() [% list.type %]
#
# Returns the TT type identifier, 'List'.
#
# TODO: should this be list_class() or vclass() from base class?
#------------------------------------------------------------------------
sub list_type {
return $VCLASS;
}
#------------------------------------------------------------------------
# list_text() [% list.text %]
#
# Returns list. Returns list as a text string.
#------------------------------------------------------------------------
sub list_text {
return list_join(shift, ', ');
}
#------------------------------------------------------------------------
# list_item($n) [% list.item(3) %]
#
# Returns item $n in the list. Returns first item if $n is unspecified.
#------------------------------------------------------------------------
sub list_item {
return $_[0]->[ $_[1] || 0 ];
}
#------------------------------------------------------------------------
# list_list() [% list.list %]
#
# No-op. Returns unmodified list.
#------------------------------------------------------------------------
sub list_list {
return $_[0];
}
#------------------------------------------------------------------------
# list_hash() [% list.hash %]
#
# Returns a reference to a hash containing each entry in the list keyed
# by its index number, e.g. { 0 => $list->[0]. 1 => $list->[1], ... }
#
# TODO: perhaps this should return { @$list } instead?
#------------------------------------------------------------------------
sub list_hash {
my $list = shift;
my $n = 0;
return { map { ($n++, $_) } @$list };
}
#------------------------------------------------------------------------
# list_copy() [% list.hash %]
#
# Returns a copy of the list.
#------------------------------------------------------------------------
sub list_copy {
my $list = shift;
return [ @$list ];
}
#------------------------------------------------------------------------
# list_push($a, $b, ...) [% list.push(a, b, ...) %]
#
# Pushes the arguments onto the list. Returns the number of items added.
#------------------------------------------------------------------------
sub list_push {
my $list = shift;
return push(@$list, @_);
}
#------------------------------------------------------------------------
# list_pop() [% list.pop %]
#
# Pops the last item from the list and returns it.
#------------------------------------------------------------------------
sub list_pop {
my $list = shift;
return pop(@$list);
}
#------------------------------------------------------------------------
# list_shift() [% list.shift %]
#
# Shifts the first item from the list and returns it.
#------------------------------------------------------------------------
sub list_shift {
my $list = shift;
return shift(@$list);
}
#------------------------------------------------------------------------
# list_unshift($a, $b, ...) [% list.unshift(a, b, ...) %]
#
# Unshifts the arguments onto the list. Returns number of items added.
#------------------------------------------------------------------------
sub list_unshift {
my $list = shift;
return unshift(@$list, @_);
}
#------------------------------------------------------------------------
# list_splice($offset, $length, $replace) [% list.splice(0, 3, list) %]
# list_splice($offset, $length, $a, $b) [% list.splice(0, 3, a, b) %]
#
# Just like Perl's splice(), splices $replace list (or list of items)
# into list at offset, replacing $length items. $replace, $length and
# $offset are optional. Returns list of items spliced out of list.
#------------------------------------------------------------------------
sub list_splice {
my ($list, $offset, $length, @replace) = @_;
if (@replace) {
# @replace can contain a list of multiple replace items, or
# be a single reference to a list
@replace = @{ $replace[0] }
if @replace == 1 && ref $replace[0] eq 'ARRAY';
return [ splice @$list, $offset, $length, @replace ];
}
elsif (defined $length) {
return [ splice @$list, $offset, $length ];
}
elsif (defined $offset) {
return [ splice @$list, $offset ];
}
else {
return [ splice(@$list) ];
}
}
#------------------------------------------------------------------------
# list_merge($a, $b, $c, ...) [% list.merge(a, b, c) %]
#
# Merges the arguments onto the end of the list. If an item is a list
# then its contents are pushed onto the list, otherwise the item itself.
#------------------------------------------------------------------------
sub list_merge {
my $list = shift;
push(@$list, map { defined && ref eq 'ARRAY' ? @$_ : $_ } @_);
return $list;
}
#------------------------------------------------------------------------
# list_max() [% list.max %]
#
# Returns the index of the last item in the list.
#------------------------------------------------------------------------
sub list_max {
my $list = shift;
no warnings;
return $#$list;
}
#------------------------------------------------------------------------
# list_size() [% list.size %]
#
# Returns the size of the list.
#------------------------------------------------------------------------
sub list_size {
my $list = shift;
no warnings;
return $#$list + 1;
}
#------------------------------------------------------------------------
# list_first() [% list.first %]
#
# Returns the first item in the list.
#------------------------------------------------------------------------
sub list_first {
my $list = shift;
return $list->[0] unless @_;
return [ @$list[0..$_[0]-1] ];
}
#------------------------------------------------------------------------
# list_last() [% list.last %]
#
# Returns the last item in the list.
#------------------------------------------------------------------------
sub list_last {
my $list = shift;
return $list->[-1] unless @_;
return [ @$list[-$_[0]..-1] ];
}
#------------------------------------------------------------------------
# list_grep($pattern) [% list.grep('\.png$') %]
#
# Returns a new list containing items from the list that match $pattern.
#------------------------------------------------------------------------
sub list_grep {
my ($list, $pattern) = @_;
$pattern ||= '';
return [ grep /$pattern/, @$list ];
}
#------------------------------------------------------------------------
# list_join($joint) [% list.join(', ') %]
#
# Returns a string containing the items in the list joined together with
# the joining delimiter passed as an argument or ' ' if undefined.
#------------------------------------------------------------------------
sub list_join {
my ($list, $joint) = @_;
join(defined $joint ? $joint : ' ',
map { defined $_ ? $_ : '' } @$list);
}
#------------------------------------------------------------------------
# list_sort($field) [% list.sort('name') %]
#
# Returns a new list containing the list items in alphabetically
# sorted order. If a search field is passed as an argument and the
# items in the list are hash references containing that key or objects
# supporting that method, then the appropriate value from the hash or
# value returned by calling the object method will be used as the sorting
# key.
#------------------------------------------------------------------------
sub list_sort {
my ($list, $field) = @_;
return $list unless $#$list; # no need to sort 1 item lists
if (defined $field) { # Schwartzian Transform
return [ map { $_->[0] } # for case insensitivity
sort { $a->[1] cmp $b->[1] }
map { [ $_, lc( ref($_) eq 'HASH'
? $_->{ $field }
: UNIVERSAL::can($_, $field)
? $_->$field()
: $_ ) ] }
@$list ];
}
else {
return [ map { $_->[0] }
sort { $a->[1] cmp $b->[1] }
map { [ $_, lc $_ ] }
@$list ];
}
}
#------------------------------------------------------------------------
# list_nsort($field) [% list.sort('age') %]
#
# As per sort() but sorting numerically.
#------------------------------------------------------------------------
sub list_nsort {
my ($list, $field) = @_;
return $list unless $#$list; # no need to sort 1 item lists
if ($field) { # Schwartzian Transform
return [ map { $_->[0] } # for case insensitivity
sort { $a->[1] <=> $b->[1] }
map { [ $_, lc(ref($_) eq 'HASH'
? $_->{ $field }
: UNIVERSAL::can($_, $field)
? $_->$field()
: $_) ] }
@$list ];
}
else {
return [ map { $_->[0] }
sort { $a->[1] <=> $b->[1] }
map { [ $_, lc $_ ] }
@$list ];
}
}
#------------------------------------------------------------------------
# list_reverse() [% list.reverse %]
#
# Returns a new list containing the list items in reverse order.
#------------------------------------------------------------------------
sub list_reverse {
my $list = shift;
return [ reverse @$list ];
}
#------------------------------------------------------------------------
# list_slice($from, $to) [% list.slice %]
#
# Returns a new list containing the item in the range $from .. $to.
#------------------------------------------------------------------------
sub list_slice {
my ($list, $from, $to) = @_;
$from ||= 0;
$to = $#$list unless defined $to;
return [ @$list[$from..$to] ];
}
#------------------------------------------------------------------------
# list_unique() [% list.unique %]
#
# Returns a new list with all duplicate entries removed. Unlike the
# Unix utility 'uniq', the list does not need to be pre-sorted.
#------------------------------------------------------------------------
sub list_unique {
my $list = shift;
my %seen;
return [ grep { ! $seen{$_}++ } @$list ];
}
1;
__END__
=head1 NAME
Template::TT3::VObject::List - list virtual object
=head1 SYNOPSIS
use Template::TT3::VObject::List
# TODO
=head1 DESCRIPTION
# TODO
=head1 METHODS
=head2 new()
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt>
=head1 VERSION
$Revision: 1.1 $
=head1 COPYRIGHT
Copyright (C) 1996-2003 Andy Wardley. All Rights Reserved.
Copyright (C) 1998-2002 Canon Research Centre Europe 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: