From aaa499f21bc074a0f4508963412ea387a811e3e7 Mon Sep 17 00:00:00 2001 From: short <> Date: Sat, 17 Sep 2005 01:15:22 +0000 Subject: [PATCH] My::Hash::* reimplementation for separate feature add-on packages (cleanup). --- Hash.pm | 90 +++++++++++++++++++++++++++++++++++++++ Hash/Makefile.am | 5 +-- Hash/{Sub/Makefile.am => Push.pm} | 26 +++++++++-- Hash/{Sub => }/Readonly.pm | 15 ++----- Hash/Sub.pm | 18 ++------ 5 files changed, 121 insertions(+), 33 deletions(-) create mode 100644 Hash.pm rename Hash/{Sub/Makefile.am => Push.pm} (56%) rename Hash/{Sub => }/Readonly.pm (88%) diff --git a/Hash.pm b/Hash.pm new file mode 100644 index 0000000..69204e4 --- /dev/null +++ b/Hash.pm @@ -0,0 +1,90 @@ +# $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::... instead of: pass(...) + + +sub new($$;@) +{ +my($class,$parent,@classes)=@_; + + unshift @classes,$class if $class ne __PACKAGE__; + for my $pkg (reverse @classes) { + local $_=$pkg.".pm"; + s{::}{/}g; + require $_; + my %hash; + tie %hash,$pkg,$parent; + $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 $_=ref(tied(%{$self->{"parent"}}))."::".$funcname; + return if /^(?:Tie::StdHash)?::(?:DESTROY|UNTIE)$/; + tied(%{$self->{"parent"}})->$_(@funcargs); +} + +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; diff --git a/Hash/Makefile.am b/Hash/Makefile.am index 7e550dd..0c70402 100644 --- a/Hash/Makefile.am +++ b/Hash/Makefile.am @@ -18,9 +18,8 @@ include $(top_srcdir)/Makefile-head.am -SUBDIRS= \ - Sub - EXTRA_DIST+= \ + Push.pm Sub.pm + Readonly.pm diff --git a/Hash/Sub/Makefile.am b/Hash/Push.pm similarity index 56% rename from Hash/Sub/Makefile.am rename to Hash/Push.pm index 3ea0c64..4e01cba 100644 --- a/Hash/Sub/Makefile.am +++ b/Hash/Push.pm @@ -1,5 +1,5 @@ # $Id$ -# automake source for the Makefile of My/Hash/Readonly/ subdir +# Hash tied to optionally dynamically generate its values # Copyright (C) 2005 Jan Kratochvil # # This program is free software; you can redistribute it and/or modify @@ -16,8 +16,26 @@ # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -include $(top_srcdir)/Makefile-head.am +package My::Hash::Push; +our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; +our $CVS_ID=q$Id$; +use strict; +use warnings; +use My::Web; # for &Wrequire +Wrequire 'My::Hash'; +our @ISA=qw(My::Hash); +use Carp qw(cluck confess); -EXTRA_DIST+= \ - Readonly.pm +sub STORE +{ +my($this,$key,$value)=@_; + + return $this->pass("STORE",$key,$value) if $key!~/_push$/; + my $val_orig=$this->pass("FETCH",$key); + $val_orig=[] if !defined $val_orig; + $val_orig=[$val_orig] if "ARRAY" ne ref $val_orig; + return $this->pass("STORE",$key,[@$val_orig,$value]); +} + +1; diff --git a/Hash/Sub/Readonly.pm b/Hash/Readonly.pm similarity index 88% rename from Hash/Sub/Readonly.pm rename to Hash/Readonly.pm index ad829a9..b84b3ba 100644 --- a/Hash/Sub/Readonly.pm +++ b/Hash/Readonly.pm @@ -16,29 +16,20 @@ # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -package My::Hash::Sub::Readonly; +package My::Hash::Readonly; our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; our $CVS_ID=q$Id$; use strict; use warnings; - use My::Web; # for &Wrequire +Wrequire 'My::Hash'; +our @ISA=qw(My::Hash); use Carp qw(cluck confess); -Wrequire 'My::Hash::Sub'; -our @ISA=qw(My::Hash::Sub); - # Implementation reason: &Hash::Util::lock_hash does not work for tied hashes! -sub TIEHASH($@) -{ -my($class,@list)=@_; - - return bless {@list},$class; -} - sub STORE { confess "READ-ONLY requirement violation"; } sub DELETE { confess "READ-ONLY requirement violation"; } sub CLEAR { confess "READ-ONLY requirement violation"; } diff --git a/Hash/Sub.pm b/Hash/Sub.pm index cde07be..daadf2a 100644 --- a/Hash/Sub.pm +++ b/Hash/Sub.pm @@ -21,8 +21,9 @@ 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; # for Tie::StdHash -our @ISA=qw(Tie::StdHash); +use My::Web; # for &Wrequire +Wrequire 'My::Hash'; +our @ISA=qw(My::Hash); use Carp qw(cluck confess); @@ -30,22 +31,11 @@ sub FETCH($$) { my($this,$key)=@_; - my $val=$this->SUPER::FETCH($key); + my $val=$this->pass("FETCH",$key); return $val if $key=~/_sub$/; # force return $val if !defined $val; # 1-item array is intentional. return $val if "CODE" ne ref $val; return &{$val}($this,$key); } -sub STORE -{ -my($this,$key,$value)=@_; - - return $this->SUPER::STORE($key,$value) if $key!~/_push$/; - my $val_orig=$this->SUPER::FETCH($key); - $val_orig=[] if !defined $val_orig; - $val_orig=[$val_orig] if "ARRAY" ne ref $val_orig; - return $this->SUPER::STORE($key,[@$val_orig,$value]); -} - 1; -- 1.8.3.1