My::Hash::* reimplementation for separate feature add-on packages (cleanup).

diff --git a/Hash.pm b/Hash.pm
new file mode 100644 (file)
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 <project-www.jankratochvil.net@jankratochvil.net>
+# 
+# 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 (file)
--- a/Hash/Makefile.am
+++ b/Hash/Makefile.am
@@ -18,9 +18,8 @@
 
 include $(top_srcdir)/Makefile-head.am
 
 
 include $(top_srcdir)/Makefile-head.am
 

-SUBDIRS= \
-               Sub
-

 EXTRA_DIST+= \
 EXTRA_DIST+= \

+               Push.pm

                Sub.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 (file)
--- a/Hash/Sub/Makefile.am
+++ b/Hash/Push.pm
@@ -1,5 +1,5 @@
 # $Id$
 # $Id$

-# automake source for the Makefile of My/Hash/Readonly/ subdir
+# Hash tied to optionally dynamically generate its values

 # Copyright (C) 2005 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
 # 
 # This program is free software; you can redistribute it and/or modify
 # Copyright (C) 2005 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
 # 
 # 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
 
 
 # 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 (file)
--- 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
 
 
 # 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;
 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
 use My::Web;   # for &Wrequire

+Wrequire 'My::Hash';
+our @ISA=qw(My::Hash);

 use Carp qw(cluck confess);
 
 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!
 
 
 
 # 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"; }
 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 (file)
--- 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;
 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);
 
 
 use Carp qw(cluck confess);
 
 


@@ -30,22 +31,11 @@ sub FETCH($$)
 {
 my($this,$key)=@_;
 
 {
 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);
 }
 
        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;