Hash/Merge.pm

   1 # $Id$
   2 # Hash tied to provide additional keys/values than the original.
   3 # Copyright (C) 2005 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; exactly version 2 of June 1991 is required
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the Free Software
  16 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18
  19 package My::Hash::Merge;
  20 our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
  21 our $CVS_ID=q$Id$;
  22 use strict;
  23 use warnings;
  24 use My::Web;    # for &Wrequire
  25 Wrequire 'My::Hash';
  26 our @ISA=qw(My::Hash);
  27 use Carp qw(cluck confess);
  28
  29
  30 sub TIEHASH($@)
  31 {
  32 my($class,@parents)=@_;
  33
  34         my $self=bless {},$class;
  35         for my $parent (@parents) {
  36                 # Possibly upgrade unref("HASH")es:
  37                 $parent=$class->SUPER::TIEHASH($parent)->{"parent"};
  38                 push @{$self->{"parents"}},$parent;
  39                 }
  40         return $self;
  41 }
  42
  43 sub key_find($$)
  44 {
  45 my($self,$key)=@_;
  46
  47         my $count=0;
  48         my $first;
  49         for my $parent (@{$self->{"parents"}}) {
  50                 next if !exists $parent->{$key};
  51                 $count++;
  52                 $first||=$parent;
  53                 }
  54         # 0 IS allowed here.
  55         cluck "Duplicity ($count-icity) for key: $key" if $count>=2;
  56         $first||=$self->{"parents"}[0];
  57         return $first;
  58 }
  59
  60 sub STORE($$$)
  61 {
  62 my($this,$key,$value)=@_;
  63
  64         my $first=$this->key_find($key);
  65         $first->{$key}=$value;
  66 }
  67
  68 sub FETCH($$)
  69 {
  70 my($this,$key)=@_;
  71
  72         my $first=$this->key_find($key);
  73         return if !$first;
  74         return $first->{$key};
  75 }
  76
  77 sub FIRSTKEY($)
  78 {
  79 my($this)=@_;
  80
  81 confess "TODO: Not yet implemented.";
  82 }
  83
  84 sub NEXTKEY($$)
  85 {
  86 my($this,$lastkey)=@_;
  87
  88 confess "TODO: Not yet implemented.";
  89 }
  90
  91 sub EXISTS($$)
  92 {
  93 my($this,$key)=@_;
  94
  95         my $first=$this->key_find($key);
  96         $first||={};
  97         return exists $first->{$key};
  98 }
  99
 100 sub DELETE($$)
 101 {
 102 my($this,$key)=@_;
 103
 104         my $first=$this->key_find($key);
 105         delete $first->{$key};
 106 }
 107
 108 sub CLEAR($)
 109 {
 110 my($this)=@_;
 111
 112 confess "TODO: Not yet implemented.";
 113 }
 114
 115 sub SCALAR
 116 {
 117 my($this)=@_;
 118
 119 confess "TODO: Not yet implemented.";
 120 }
 121
 122 1;