view release on metacpan or  search on metacpan

t/autodbTestObject.pm  view on Meta::CPAN

  # my $correct_diffs=@_? $self->{correct_diffs}=$_[0]: ($self->{correct_diffs});
  my $correct_diffs=$self->{correct_diffs};
  if (ref $correct_diffs) { 	# make sure _AutoDB is there
    $correct_diffs->{_AutoDB}=1 unless defined $correct_diffs->{_AutoDB}
  } elsif (my $correct_tables=$self->correct_tables) { # need correct_tables for this form
    my $diff=defined $correct_diffs? $correct_diffs: 1;	# hang onto old value
    $correct_diffs={};
    my @correct_tables=@{$self->correct_tables};
    my $default_diffs=$self->default_diffs;
    # NG 10-09-09: use defaults for any tables mentioned in default_diffs
    @$correct_diffs{@correct_tables}=
      map {defined $default_diffs->{$_}? $default_diffs->{$_}: $diff} @correct_tables;
    # $self->correct_diffs($correct_diffs);
  } else { 			# minimal default
    $correct_diffs={_AutoDB=>1};
  }
  $correct_diffs;
}
sub object {
  my $self=shift;
  $self->objects([@_]) if @_;
  $self->objects->[0];
}
sub objects {
  my $self=shift;
  if (@_) {
    (@_==1 && 'ARRAY' eq ref $_[0])? $self->{objects}=$_[0]:
      (!defined $_[0]? $self->{objects}=undef: ($self->{objects}=[@_]));
    # (@_==1 && looks_like_number($_[0])? $self->make_objects($_[0]):
    # ($self->{objects}=[@_]));
  }
  $self->{objects};
}
sub correct_object {
  my $self=shift;
  $self->correct_objects([@_]) if @_;
  $self->correct_objects->[0];
}
sub correct_objects {
  my $self=shift;
  if (@_) {
    (@_==1 && 'ARRAY' eq ref $_[0])? $self->{correct_objects}=$_[0]:
      (!defined $_[0]? $self->{correct_objects}=undef: ($self->{correct_objects}=[@_]));
    # (@_==1 && looks_like_number($_[0])? $self->make_correct_objects($_[0]):
    # ($self->{correct_objects}=[@_]));
  }
  $self->{correct_objects};
}
# sub clear_objects {
#   my $self=shift;
#   $self->objects([]);
##  $self->object(undef);
# }
sub old_counts {
  my $self=shift;
  my @tables=@_? @_: @{$self->tables};
  my $old_counts=$self->{old_counts} || ($self->_old_counts(@tables));
  # $old_counts=norm_counts(map {$_=>$old_counts->{$_}} @tables);
  $old_counts;
}
sub update_counts {
  my($self,$new_counts)=@_;
  my $old_counts=$self->old_counts;
  my @tables=keys %$new_counts;
  @$old_counts{@tables}=@$new_counts{@tables};
}
sub diff_counts {
  my $self=shift;
  my @tables=@_? @_: @{$self->tables};
  my $old_counts=$self->old_counts(@tables);
  my $new_counts=actual_counts(@tables);
  my $diff_counts={};
  map {$diff_counts->{$_}=$new_counts->{$_}-$old_counts->{$_}} @tables;
  # update old_counts for next time
  $self->update_counts($new_counts);
  $diff_counts=norm_counts($diff_counts);
  # $diff_counts;
}
# sub _coll2keys {
#   my $self=shift;
#   my $coll2keys=$self->coll2keys;
#   if (my $coll2basekeys=$self->coll2basekeys) {
#     while(my($coll,$basekeys)=each %$coll2basekeys) {
#       my $pair=$coll2keys->{$coll} || ($coll2keys->{$coll}=[[],[]]);
#       $pair->[0]=$basekeys;
#     }
#     $self->coll2basekeys(undef); # so won't compute again
#   }
#   if (my $coll2listkeys=$self->coll2listkeys) {
#     while(my($coll,$listkeys)=each %$coll2listkeys) {
#       my $pair=$coll2keys->{$coll} || ($coll2keys->{$coll}=[[],[]]);
#       $pair->[1]=$listkeys;
#     }
#     $self->coll2listkeys(undef); # so won't compute again
#   }
#   # wantarray? %$coll2keys: $coll2keys;
# }
# sub _coll2tables {
#   my $self=shift;
#   delete $self->{coll2tables};	# delete the key so
#   $self->coll2tables;		# this call will recompute
#   my $coll2keys=$self->coll2keys;
#   my $coll2tables=$self->coll2tables;
#   my $tables=$self->tables([qw(_AutoDB)]);
#   my @tables;
#   while(my($coll,$pair)=each %$coll2keys) {
#     my @tables=($coll,map {$coll.'_'.$_} @{$pair->[1]});
#     $coll2tables->{$coll}=\@tables;
#     push(@$tables,@tables);
#   }
#   # wantarray? %$coll2tables: $coll2tables;
# }
# sub _correct_tables {
#   my $self=shift;
#   my @correct_colls=@{$self->correct_colls};
#   my $coll2keys=$self->coll2keys;
#   my $correct_tables=$self->correct_tables([qw(_AutoDB)]);
#   for my $coll (@correct_colls) {
#     my $pair=$coll2keys->{$coll};
#     my @tables=($coll,map {$coll.'_'.$_} @{$pair->[1]});
#     push(@$correct_tables,@tables);