The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Class::AutoDB::RegistryVersion;
use vars qw(@ISA @AUTO_ATTRIBUTES @OTHER_ATTRIBUTES %SYNONYMS %DEFAULTS);
use strict;
# use Data::Dumper;
use Storable qw(dclone);
use Class::AutoClass;
# use Hash::AutoHash::Args;
use Class::AutoDB::Registration;
use Class::AutoDB::Collection;
@ISA = qw(Class::AutoClass);

# The guts of the Registry implementation.  Each Registry has two of these.
# RegistryVersion does not inherit from Serialize!!
# Instead, the versions are serialized as part of the overall registry.

@AUTO_ATTRIBUTES=qw(registry name2coll class2collnames _class2transients);
@OTHER_ATTRIBUTES=qw();
%SYNONYMS=();
%DEFAULTS=(name2coll=>{},class2collnames=>{},_class2transients=>{});
Class::AutoClass::declare(__PACKAGE__);

# NG 09-03-19: commented out _init_self -- stub not needed
# sub _init_self {
#   my($self,$class,$args)=@_;
#   return unless $class eq __PACKAGE__; # to prevent subclasses from re-running this
# }

# NG 11-01-07: added copy. needed to enable runtime schema changes
#              deep copies state, except for 'registry'
sub copy {
  my $self=shift;
  my $copy=new Class::AutoDB::RegistryVersion registry=>$self->registry;
  while(my($key,$value)=each %$self) {
    next if $key eq 'registry';
    $value=dclone($value);
    $copy->{$key}=$value;
  }
  $copy;
}

sub register {
  my $self=shift;
  my $registration=new Class::AutoDB::Registration(@_);
  my $name2coll=$self->name2coll || $self->name2coll({});
  # NG 09-11-12: AutoClass no longer defines class
  # NG 09-11-17: However, Registration does define class !!
  my $class=$registration->class;
  # my $class=ref $registration;
  my $collnames=$registration->collnames;
  my $transients=$registration->transients;
  if ($class) {
    my $class2collnames=$self->class2collnames || $self->class2collnames({});
    my $class2transients=$self->_class2transients || $self->_class2transients({});
    my $class_collnames=$class2collnames->{$class} || ($class2collnames->{$class}=[]);
    my $class_transients=$class2transients->{$class} || ($class2transients->{$class}=[]);
    push(@$class_collnames,@$collnames);
    push(@$class_transients,@$transients);
    for my $super ($class->ISA) {	# add in collections from superclasses. 
                                        # recursively, this includes all ancestors
      next unless UNIVERSAL::isa($super,'Class::AutoDB::Object');
      my $super_collnames=$class2collnames->{$super} || [];
      push(@$class_collnames,@$super_collnames);
      my $super_transients=$class2transients->{$super} || [];
      push(@$class_transients,@$super_transients);
    }
    # uniqify the names
    my %h; @h{@$class_collnames}=@$class_collnames; @$class_collnames=values %h;
           @h{@$class_transients}=@$class_transients; @$class_transients=values %h; # DM removed my %h
  }
  my %collname2keys=%{$registration->collections};
  while(my($collname,$keys)=each %collname2keys) {
    my $collection=$name2coll->{$collname} || 
      ($name2coll->{$collname}=new Class::AutoDB::Collection(-name=>$collname));
    $collection->register($keys);
  }
  $registration;
}
sub collections {
  my $self=shift;
  my $name2coll=$self->name2coll || $self->name2coll({});
  wantarray? values %$name2coll: [values %$name2coll];
}
sub collection {
  my $self=shift;
  my $name=!ref $_[0]? $_[0]: $_[0]->name;
  my $name2coll=$self->name2coll || $self->name2coll({});
  $name2coll->{$name};
}
sub class2collections {
  my($self,$class)=@_;
  # NG 11-01-05: make sure class already used, else class2collections not set
  #              code adapted from Oid::AUTOLOAD
  {no strict 'refs';
   unless (${$class.'::'}{AUTODB}) {
     eval "require $class" or die $@;
   }}
  my $collnames=$self->class2collnames->{$class} || [];
  my @collections=map {$self->collection($_)} @$collnames;
  wantarray? @collections: \@collections;
}
sub class2transients {
  my($self,$class)=@_;
  my $transients=$self->_class2transients->{$class} || [];
  wantarray? @$transients: $transients;
}
sub merge {
  my($self,$diff)=@_;
  my $name2coll=$self->name2coll || $self->name2coll({});
  my $new_collections=$diff->new_collections;
  for my $collection (@$new_collections) {
    my $name=$collection->name;
    $name2coll->{$name}=$collection; # easy case -- just add to registry
  }
  my $expanded_diffs=$diff->expanded_diffs;
  for my $diff (@$expanded_diffs) {
    my $collection=$diff->baseline;
    $collection->merge($diff);
  }
  # class2colls -- assume all changes are expansions of one sort or another
  my $class2collnames={};
  my $baseline_class2collnames=$self->class2collnames;
  # init to baseline
  @$class2collnames{keys %$baseline_class2collnames}=values %$baseline_class2collnames;
  my $other_class2collnames=$diff->other->class2collnames;
  while(my($class,$other_collnames)=each %$other_class2collnames) {
    my $baseline_collnames=$baseline_class2collnames->{$class} || [];
    my $collnames=uniq($baseline_collnames,$other_collnames); # combine and uniqify the names
    $class2collnames->{$class}=$collnames;
  }
  $self->class2collnames($class2collnames);
}
sub _flatten {map {'ARRAY' eq ref $_? @$_: $_} @_;}

# combine and uniquify two lists
sub uniq {
  my($list1,$list2)=@_;
  my %hash;
  @hash{@$list1}=@$list1 if $list1;
  @hash{@$list2}=@$list2 if $list2;
  [values %hash];
}

1;