Commit | Line | Data |
---|---|---|
a272bf38 DL |
1 | # For internal Module::CoreList use only. |
2 | package Module::CoreList::TieHashDelta; | |
3 | use strict; | |
4 | use vars qw($VERSION); | |
5 | ||
7792a6f5 | 6 | $VERSION = '5.20151120'; |
a272bf38 DL |
7 | |
8 | sub TIEHASH { | |
9 | my ($class, $changed, $removed, $parent) = @_; | |
10 | ||
11 | return bless { | |
12 | changed => $changed, | |
13 | removed => $removed, | |
14 | parent => $parent, | |
15 | keys_inflated => 0, | |
16 | }, $class; | |
17 | } | |
18 | ||
19 | sub FETCH { | |
20 | my ($self, $key) = @_; | |
21 | ||
22 | if (exists $self->{changed}{$key}) { | |
23 | return $self->{changed}{$key}; | |
24 | } elsif (exists $self->{removed}{$key}) { | |
25 | return undef; | |
26 | } elsif (defined $self->{parent}) { | |
27 | return $self->{parent}{$key}; | |
28 | } | |
29 | return undef; | |
30 | } | |
31 | ||
32 | sub EXISTS { | |
33 | my ($self, $key) = @_; | |
34 | ||
42484eed | 35 | restart: |
a272bf38 DL |
36 | if (exists $self->{changed}{$key}) { |
37 | return 1; | |
38 | } elsif (exists $self->{removed}{$key}) { | |
39 | return ''; | |
40 | } elsif (defined $self->{parent}) { | |
42484eed DD |
41 | $self = tied %{$self->{parent}}; #avoid extreme magic/tie recursion |
42 | goto restart; | |
a272bf38 DL |
43 | } |
44 | return ''; | |
45 | } | |
46 | ||
47 | sub FIRSTKEY { | |
48 | my ($self) = @_; | |
49 | ||
50 | if (not $self->{keys_inflated}) { | |
51 | # This inflates the whole set of hashes... Somewhat expensive, but saves | |
52 | # many tied hash calls later. | |
53 | my @parent_keys; | |
54 | if (defined $self->{parent}) { | |
55 | @parent_keys = keys %{$self->{parent}}; | |
56 | } | |
57 | ||
58 | @parent_keys = grep !exists $self->{removed}{$_}, @parent_keys; | |
59 | for my $key (@parent_keys) { | |
60 | next if exists $self->{changed}->{$key}; | |
61 | $self->{changed}{$key} = $self->{parent}{$key}; | |
62 | } | |
63 | ||
64 | $self->{keys_inflated} = 1; | |
65 | } | |
66 | ||
67 | keys %{$self->{changed}}; # reset each | |
68 | $self->NEXTKEY; | |
69 | } | |
70 | ||
71 | sub NEXTKEY { | |
72 | my ($self) = @_; | |
711703f9 | 73 | each %{$self->{changed}}; |
a272bf38 DL |
74 | } |
75 | ||
76 | 1; |