# $Id$ # Hash tied to easily provide add-on features # Copyright (C) 2005 Jan Kratochvil # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; exactly version 2 of June 1991 is required # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA package My::Hash; our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; our $CVS_ID=q$Id$; use strict; use warnings; require Tie::Hash; # Also for: Tie::StdHash our @ISA=qw(Tie::Hash); use Carp qw(cluck confess); # OK, this is just @ISA 'runtime' reimplementation using: ->{"parent"} # Creating classes each time is too complicated in Perl. # Maybe the best would be run-time generation of the classes using: @ISA # This way the feature implementations could use SUPER.pm calls instead of: pass(...) # My::Hash::KIND->new($parent,@optional_KIND_arguments); # My::Hash->new($parent,"My::Hash::KIND_OUTER",["My::Hash::KIND_INNER",@optional_KIND_INNER_arguments]); sub new($$;@) { my($class,$parent,@classes)=@_; @classes=[$class,@classes] if $class ne __PACKAGE__ || !@classes; for my $item (reverse @classes) { my $pkg=(!ref($item) ? $item : $item->[0]); my @args=@{$item}[1..$#$item] if ref $item; local $_=$pkg.".pm"; s{::}{/}g; require $_; my %hash; tie %hash,$pkg,$parent,@args; $parent=\%hash; } return $parent; } sub TIEHASH($$) { my($class,$parent)=@_; my $self=bless {},$class; if (!ref(tied(%$parent))) { my %parent; tie %parent,"Tie::StdHash"; %parent=%$parent; $parent=\%parent; } $self->{"parent"}=$parent; return $self; } sub pass($$@) { my($self,$funcname,@funcargs)=@_; local $@=undef(); my $parent_tied=tied(%{$self->{"parent"}}); my $destroy=1 if $funcname eq "DESTROY" || $funcname eq "UNTIE"; return if !defined($parent_tied) && $destroy; my $r=eval { $parent_tied->$funcname(@funcargs); }; return $r if !$@ || ($destroy && $@=~/^Can't locate object method "$funcname" via package ".*" at /); confess $@; } our $AUTOLOAD; sub AUTOLOAD { my($self,@rest)=@_; my $ref_self=ref($self); cluck "Invalid AUTOLOAD prefix (ref_self=\"$ref_self\"): $AUTOLOAD" if $AUTOLOAD!~s{^\Q$ref_self\E::}{}; return $self->pass($AUTOLOAD,@rest); } # Skip over existing &Tie::Hash::EXISTS and &Tie::Hash::CLEAR to: &AUTOLOAD sub EXISTS { return pass $_[0],"EXISTS",@_[1..$#_]; } sub CLEAR { return pass $_[0],"CLEAR" ,@_[1..$#_]; } 1;