File Coverage

blib/lib/Tie/Hash/Vivify.pm
Criterion Covered Total %
statement 39 39 100.0
branch 4 4 100.0
condition 6 6 100.0
subroutine 13 13 100.0
pod 1 1 100.0
total 63 63 100.0


line stmt bran cond sub pod time code
1             package Tie::Hash::Vivify;
2              
3 2     2   36013 use 5.006001;
  2         8  
4 2     2   11 use strict;
  2         4  
  2         66  
5 2     2   15 use warnings;
  2         11  
  2         777  
6              
7             our $VERSION = "1.04";
8              
9             sub new {
10 11     11 1 75 my ($class, $defsub, %params) = @_;
11 11         46 tie my %hash => $class, $defsub, %params;
12 11         36 \%hash;
13             }
14              
15             sub TIEHASH {
16 12     12   34 my ($class, $defsub, %params) = @_;
17 12         45 bless [{}, $defsub, \%params], $class;
18             }
19              
20             sub FETCH {
21 45     45   3214 my ($self, $key) = @_;
22 45         90 my ($hash, $defsub) = @$self;
23 45 100       100 if (exists $hash->{$key}) {
24 32         130 $hash->{$key};
25             }
26             else {
27 13         36 $hash->{$key} = $defsub->();
28             }
29             }
30              
31             sub STORE {
32 12     12   1666 my($self, $key, $value) = @_;
33            
34             # print STDERR "ref(\$value): ".ref($value)."\n";
35             # print STDERR "infect_children: ".($self->[2]->{infect_children} ? 1 : 0)."\n";
36             # if(ref($value) eq 'HASH') { print STDERR "tied: ".!!tied(%{$value})."\n" }
37             # print STDERR "\n";
38 12 100 100     75 if(
      100        
39             ref($value) eq 'HASH' &&
40             $self->[2]->{infect_children} &&
41 8         33 !tied(%{$value})
42             # this would re-tie anything except a THV
43             # !(tied(%{$value}) && tied(%{$value})->isa(__PACKAGE__))
44             ) {
45 5         10 $self->[0]->{$key} = __PACKAGE__->new($self->[1], %{$self->[2]});
  5         16  
46 5         9 $self->[0]->{$key}->{$_} = $value->{$_} foreach(keys(%{$value}));
  5         20  
47 5         16 $self->[0]->{$key};
48             } else {
49 7         28 $self->[0]->{$key} = $value;
50             }
51             }
52              
53             # copied from Tie::ExtraHash in perl-5.10.1/lib/Tie/Hash.pm
54 12     12   2297 sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
  12         31  
  12         21  
  12         44  
55 17     17   27 sub NEXTKEY { each %{$_[0][0]} }
  17         42  
56 19     19   1049 sub EXISTS { exists $_[0][0]->{$_[1]} }
57 1     1   5 sub DELETE { delete $_[0][0]->{$_[1]} }
58 1     1   457 sub CLEAR { %{$_[0][0]} = () }
  1         5  
59 1     1   2 sub SCALAR { scalar %{$_[0][0]} }
  1         7  
60              
61             1;
62              
63              
64             =head1 NAME
65              
66             Tie::Hash::Vivify - Create hashes that autovivify in interesting ways.
67              
68             =head1 DESCRIPTION
69              
70             This module implements a hash where if you read a key that doesn't exist, it
71             will call a code reference to fill that slot with a value.
72              
73             =head1 SYNOPSIS
74              
75             use Tie::Hash::Vivify;
76              
77             my $default = 0;
78             tie my %hash => 'Tie::Hash::Vivify', sub { "default" . $default++ };
79             print $hash{foo}; # default0
80             print $hash{bar}; # default1
81             print $hash{foo}; # default0
82             $hash{baz} = "hello";
83             print $hash{baz}; # hello
84              
85             my $hashref = Tie::Hash::Vivify->new(sub { "default" });
86             $hashref->{foo}; # default
87             # ...
88              
89             =head1 OBJECT-ORIENTED INTERFACE
90              
91             You can also create your magic hash in an objecty way:
92              
93             =head2 new
94              
95             my $hashref = Tie::Hash::Vivify->new(sub { "my default" });
96              
97             =head1 "INFECTING" CHILD HASHES
98              
99             By default, hashes contained within your hash do *not* inherit magical
100             vivification behaviour. If you want them to, then pass some extra
101             params thus:
102              
103             tie my %hash => 'Tie::Hash::Vivify', sub { "default" . $default++ }, infect_children => 1;
104              
105             my $hashref = Tie::Hash::Vivify->new(sub { "my default" }, infect_children => 1);
106              
107             This will not, however, work if the child you insert is already tied - that
108             would require re-tieing it, which would lose whatever magic behaviour the
109             original had.
110              
111             =head1 BUGS
112              
113             C appears to not work properly on perl 5.8.2 and
114             earlier. I don't really care, and frankly nor should you. In the
115             unlikely event that you do care, please submit a patch.
116              
117             =head1 AUTHORS
118              
119             Luke Palmer, lrpalmer gmail com (original author)
120              
121             David Cantrell Edavid@cantrell.org.ukE (current maintainer)
122              
123             =head1 COPYRIGHT AND LICENSE
124              
125             Copyright (C) 2005 by Luke Palmer
126              
127             Some parts Copyright 2010 David Cantrell Edavid@cantrell.org.ukE.
128              
129             This software is free-as-in-speech software, and may be used,
130             distributed, and modified under the terms of either the GNU
131             General Public Licence version 2 or the Artistic Licence. It's
132             up to you which one you use. The full text of the licences can
133             be found in the files GPL2.txt and ARTISTIC.txt, respectively.
134              
135             =cut