view release on metacpan or  search on metacpan

t/autodbTestObject.pm  view on Meta::CPAN

    my $ok=1;
    my $label=$self->label."oid before del";
    $ok&&=($del_objects{refaddr $object}?
	   _ok_deloid($object,$label,$file,$line,@correct_tables): 1);
  }
  if ($del_type=~/multi/) {
    autodb->del(@objects);
  } else {
    map {autodb->del($_)} @objects;
  }
  # now do the per-object after-del tests (and accumulate final diffs)
  my $final_diffs={};
  for my $object (@objects) {
    $self->current_object($object); # all class- and object-specific attrs use this
    my $class=$self->class;
    my %coll2keys=%{$self->coll2keys};
    my @correct_colls=@{$self->correct_colls};
    my @tables=@{$self->tables};
    my @correct_tables=@{$self->correct_tables};
    my $correct_diffs= $del_objects{refaddr $object}? {}: $self->correct_diffs;

    my $ok=1;
    my $label=$self->label."oid after del";
    $ok&&=_ok_deloid($object,$label,$file,$line,@correct_tables);
    # add correct_diffs to final diffs
    while(my($table,$diff)=each %$correct_diffs) {
      $final_diffs->{$table}-=$diff;
    }
  }
  # test final diffs
  $self->current_object(undef);
  my $actual_diffs=$self->diff_counts;
  my($ok,$details)=cmp_details($actual_diffs,$final_diffs);
  # report($ok,$self->label."table counts",$file,$line,$details);
  report_fail($ok,$self->label."table counts",$file,$line,$details);
  report_pass($ok,$self->label);
  # cmp_deeply($actual_diffs,$correct_diffs,$self->label."table counts");
  # report_pass($ok,$label);

  $self->objects(undef);     # clear so won't retest these objects next time
  push(@{$self->del_objects},@objects); # update for next time
  scalar @objects;
}

sub do_get {
  my $self=shift;
  my $get_args=@_? shift: $self->get_args;
  my $get_type=@_? shift: $self->get_type;
  my $correct_count=@_? shift: scalar @{$self->correct_objects};
  confess 'need to query database but get_args not set' unless $get_args;
  my(@actual_objects,$actual_count);
  if ('CODE' eq ref $get_args) {
    my %get_args=&$get_args($self);
    $get_args=\%get_args;
  }
  if ($get_type eq 'get') {
    @actual_objects=autodb->get($get_args);
    $actual_count=autodb->count($get_args);
  } elsif ($get_type=~/^find([_-]{0,1}get){0,1}$/) {
    my $cursor=autodb->find($get_args);
    @actual_objects=$cursor->get;
    $actual_count=$cursor->count;
  } elsif ($get_type=~/^find[_-]{0,1}get[_-]{0,1}next$/) {
    my $cursor=autodb->find($get_args);
    while (my $object=$cursor->get_next) {
      push(@actual_objects,$object);
    } 
    $actual_count=$cursor->count;
  } else {
    confess "invalid get_type $get_type";
  }
  # is($actual_count,scalar @correct_objects,$self->label.'count');
  unless($actual_count==$correct_count) {
    report_fail(0,$self->label.'count');
    diag("   got: $actual_count");
    diag("expect: $correct_count");
  }
  wantarray? @actual_objects: \@actual_objects;
}
# args are objects. last arg can be put_type
sub do_put {
  my $self=shift;
  my $put_type=!ref $_[$#_]? pop: $self->put_type;
  my @objects=@_;
  if ($put_type=~/multi|objects/) {
    if ($put_type=~/objects/) {
      if ($put_type=~/multi/) {
	autodb->put_objects(@objects);
      } else {
	autodb->put_objects;
      }
    } else {
      autodb->put(@objects);
    }
  } else {
    map {autodb->put($_)} @objects;
  }
}
sub make_object {
  my $self=shift;
  my $objects=$self->make_objects(1);
  # caller now responsible for saving in $self
  # $self->object($objects->[0]);
  $objects->[0];
}
sub make_objects {
  my $self=shift;
  my $n=@_? shift: 1;
  my $class=$self->class;
  my $new_args=$self->new_args;	              # sub
  confess 'need to make objects but new_args not set' unless $new_args; 
  confess 'need to make objects but new_args not CODE ref' unless 'CODE' eq ref $new_args; 
  my @objects=map {my %new_args=&$new_args($self); new $class %new_args;} (1..$n);
  # caller now responsible for saving in $self
  # $self->objects(\@objects);
  \@objects;
}
sub label {
  my $self=shift;
  my $label= @_? $self->{label}=$_[0]: ($self->{label});
  my @label=($self->labelprefix);
  if ('CODE' eq ref $label) {
    push(@label,&$label($self));
  } elsif ($label ne '') {	# empty string means 'no label'
    my $object=$self->current_object;
    push(@label,$label,(UNIVERSAL::can($object,'id')? $object->id: ()));
  }
  @label=map {s/^\s+|\s+$//g; $_} grep {length $_} @label; # strip leading and trailing whitespace