dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm

   1 # For internal Module::CoreList use only.
   2 package Module::CoreList::TieHashDelta;
   3 use strict;
   4 use vars qw($VERSION);
   5
   6 $VERSION = '5.20160520';
   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
  35     restart:
  36     if (exists $self->{changed}{$key}) {
  37         return 1;
  38     } elsif (exists $self->{removed}{$key}) {
  39         return '';
  40     } elsif (defined $self->{parent}) {
  41         $self = tied %{$self->{parent}}; #avoid extreme magic/tie recursion
  42         goto restart;
  43     }
  44     return '';
  45 }
  46
  47 sub FIRSTKEY {
  48     my ($self) = @_;
  49
  50     if (not $self->{keys_inflated}) {
  51         # exceeds the warning limit of 100 calls since 5.23.2
  52         no warnings 'recursion';
  53
  54         # This inflates the whole set of hashes... Somewhat expensive, but saves
  55         # many tied hash calls later.
  56         my @parent_keys;
  57         if (defined $self->{parent}) {
  58             @parent_keys = keys %{$self->{parent}};
  59         }
  60
  61         @parent_keys = grep !exists $self->{removed}{$_}, @parent_keys;
  62         for my $key (@parent_keys) {
  63             next if exists $self->{changed}->{$key};
  64             $self->{changed}{$key} = $self->{parent}{$key};
  65         }
  66
  67         $self->{keys_inflated} = 1;
  68     }
  69
  70     keys %{$self->{changed}}; # reset each
  71     $self->NEXTKEY;
  72 }
  73
  74 sub NEXTKEY {
  75     my ($self) = @_;
  76     each %{$self->{changed}};
  77 }
  78
  79 1;