File Coverage

blib/lib/Tie/Hash/MultiValueOrdered.pm
Criterion Covered Total %
statement 60 105 57.1
branch 6 14 42.8
condition 1 2 50.0
subroutine 18 29 62.0
pod 13 13 100.0
total 98 163 60.1


line stmt bran cond sub pod time code
1 5     5   22171 use 5.008;
  5         15  
  5         185  
2 5     5   27 use strict;
  5         9  
  5         149  
3 5     5   24 use warnings;
  5         10  
  5         450  
4              
5             {
6             package Tie::Hash::MultiValueOrdered;
7            
8             our $AUTHORITY = 'cpan:TOBYINK';
9             our $VERSION = '0.005';
10            
11             use constant {
12 5         588 IDX_DATA => 0,
13             IDX_ORDER => 1,
14             IDX_LAST => 2,
15             IDX_SEEN => 3,
16             IDX_MODE => 4,
17             NEXT_IDX => 5,
18 5     5   26 };
  5         8  
19             use constant {
20 5         1088 MODE_LAST => -1,
21             MODE_FIRST => 0,
22             MODE_REF => 'ref',
23             MODE_ITER => 'iter',
24 5     5   24 };
  5         8  
25            
26 1     1 1 22 sub fetch_first { $_[0][IDX_MODE] = MODE_FIRST }
27 1     1 1 3 sub fetch_last { $_[0][IDX_MODE] = MODE_LAST }
28 3     3 1 1080 sub fetch_list { $_[0][IDX_MODE] = MODE_REF }
29 0     0 1 0 sub fetch_iterator { $_[0][IDX_MODE] = MODE_ITER }
30            
31 5     5   8981 use Storable qw( dclone );
  5         17954  
  5         2787  
32             sub TIEHASH {
33 7     7   24 my $class = shift;
34 7         43 bless [{}, [], 0, {}, -1], $class;
35             }
36             sub STORE {
37 22     22   58 my ($tied, $key, $value) = @_;
38 22         29 $key = "$key";
39 22         33 push @{$tied->[IDX_ORDER]}, $key;
  22         64  
40 22         29 push @{$tied->[IDX_DATA]{$key}}, $value;
  22         97  
41             }
42             sub FETCH {
43 10     10   34 my ($tied, $key) = @_;
44 10         17 my $mode = $tied->[IDX_MODE];
45 10 100       73 if ($mode eq 'ref')
    50          
46             {
47 4   50     72 return $tied->[IDX_DATA]{$key} || [];
48             }
49             elsif ($mode eq 'iter')
50             {
51 0 0       0 my @values = @{ $tied->[IDX_DATA]{$key} || [] };
  0         0  
52 0     0   0 return sub { shift @values };
  0         0  
53             }
54             else
55             {
56 6 50       86 return unless exists $tied->[IDX_DATA]{"$key"};
57 6         33 return $tied->[IDX_DATA]{$key}[$mode];
58             }
59             }
60             sub EXISTS {
61 4     4   56 my ($tied, $key) = @_;
62 4         16 return exists $tied->[IDX_DATA]{"$key"};
63             }
64             sub DELETE {
65 0     0   0 my ($tied, $key) = @_;
66 0         0 my $r = delete $tied->[IDX_DATA]{"$key"};
67 0 0       0 return $r->[-1] if $r;
68 0         0 return;
69             }
70             sub CLEAR {
71 0     0   0 my $tied = shift;
72 0         0 $tied->[IDX_DATA] = {};
73 0         0 $tied->[IDX_ORDER] = [];
74 0         0 $tied->[IDX_LAST] = 0;
75 0         0 $tied->[IDX_SEEN] = {};
76 0         0 return;
77             }
78             sub FIRSTKEY {
79 7     7   1005 my $tied = shift;
80 7         16 $tied->[IDX_LAST] = -1;
81 7         12 $tied->[IDX_SEEN] = {};
82 7         35 return $tied->NEXTKEY;
83             }
84             sub NEXTKEY {
85 5     5   40 no warnings qw(uninitialized);
  5         6  
  5         3372  
86 19     19   26 my $tied = shift;
87 19         25 my $i = ++$tied->[IDX_LAST];
88 19         79 $i++ while $tied->[IDX_SEEN]{ $tied->[IDX_ORDER][$i] };
89 19         42 $tied->[IDX_SEEN]{ $tied->[IDX_ORDER][$i] }++;
90 19         29 my $key = $tied->[IDX_ORDER][$i];
91 19 50       41 if (wantarray) {
92             return (
93 0         0 $tied->[IDX_ORDER][$i],
94             $tied->FETCH( $tied->[IDX_ORDER][$i] ),
95             );
96             }
97 19         98 return $tied->[IDX_ORDER][$i];
98             }
99             sub get {
100 1     1 1 1075 my ($tied, $key) = @_;
101 1 50       3 return my @list = @{ $tied->[IDX_DATA]{"$key"} || [] };
  1         11  
102             }
103             sub pairs {
104 5     5 1 8 my $tied = shift;
105 5         672 my $clone = dclone( $tied->[IDX_DATA] );
106 18         71 return map {
107 18         19 $_, shift @{$clone->{$_}}
  5         14  
108 5         10 } @{$tied->[IDX_ORDER]}
109             }
110             sub pair_refs {
111 0     0 1   my $tied = shift;
112 0           my $clone = dclone( $tied->[IDX_DATA] );
113 0           return map {
114 0           [ $_, shift @{$clone->{$_}} ]
  0            
115 0           } @{$tied->[IDX_ORDER]}
116             }
117             sub all_keys {
118 0     0 1   my $tied = shift;
119 0           return @{$tied->[IDX_ORDER]};
  0            
120             }
121             sub keys {
122 0     0 1   my $tied = shift;
123 0           my %seen;
124 0           return grep { not $seen{$_}++ } @{$tied->[IDX_ORDER]};
  0            
  0            
125             }
126             sub rr_keys {
127 0     0 1   my $tied = shift;
128 0           my %seen;
129 0           return reverse grep { not $seen{$_}++ } reverse @{$tied->[IDX_ORDER]};
  0            
  0            
130             }
131             sub all_values {
132 0     0 1   my $tied = shift;
133 0           my $alt = 1;
134 0           return grep { $alt=!$alt } $tied->pairs;
  0            
135             }
136             sub values {
137 0     0 1   my $tied = shift;
138 0           return map { $tied->[IDX_DATA]{$_}[-1] } $tied->keys;
  0            
139             }
140             sub rr_values {
141 0     0 1   my $tied = shift;
142 0           return map { $tied->[IDX_DATA]{$_}[0] } $tied->keys;
  0            
143             }
144             }
145              
146             1;
147              
148              
149             __END__