view release on metacpan or  search on metacpan

t/autodbUtil.pm  view on Meta::CPAN

  } else {
    my $ref=ref $obj;
    if ($entry_type=~/^obj/i) {
      $ok&&=report_fail
	($ref eq $class,"$label: cache entry has wrong class: got $ref, expected $class",
	 $file,$line);
    } else {			# Oid or OidDeleted
      confess "Ilegal entry_type $entry_type" unless $entry_type=~/oid$|deleted$/i;
      my $correct_ref=$entry_type=~/oid$/i? 'Class::AutoDB::Oid': 'Class::AutoDB::OidDeleted';
      $ok&&=report_fail
	($ref eq $correct_ref,
	 "$label. cache entry has wrong class: got $ref, expected $correct_ref",$file,$line);
      my $oid_class=$obj->{_CLASS};
      my $oid_oid=$obj->{_OID};
      $ok&&=report_fail
	($oid_oid==$oid,
	 "$label. $entry_type contains wrong oid: got $oid_oid, expected $oid",$file,$line);
      # Oid must have class. optional for OidDeleted
      if ($entry_type=~/oid$/i || (defined $class && exists $obj->{_CLASS})) { 
	$ok&&=report_fail
	  ($oid_class eq $class,
	   "$label. $entry_type contains wrong class: got $oid_class, expected $class",
	   $file,$line);
      }
      # check for extraneous keys.
      my @oid_keys=keys %$obj;
      my $bad_keys=join(',',grep !/_CLASS|_OID/,@oid_keys);
      $ok&&=report_fail(!$bad_keys,
			"$label. $entry_type contains extraneous keys: $bad_keys",$file,$line);
    }
  }
  !$no_report_pass? report_pass($ok,$label): $ok;
}
# conjure up Oid entries in object cache. returns entry in case anyone wants it (which they do :)
use Class::AutoDB::Oid;
use Class::AutoDB::OidDeleted;
sub conjure_oid {
  my($oid,$entry_type,$class)=@_;
  confess "Ilegal entry_type $entry_type" unless $entry_type=~/oid$|deleted$/i;
  my $obj={_OID=>$oid};
  $obj->{_CLASS}=$class if defined $class;
  bless $obj,$entry_type=~/oid$/i? 'Class::AutoDB::Oid': 'Class::AutoDB::OidDeleted';
  oid2obj($oid,$obj);
  obj2oid($obj,$oid);
  $obj;
}


# TODO: use is all thawed tests!
# $actual_objects. array of lots of object. 
# $correct_thawed. subset of $actual_objects expected to be thawed
sub cmp_thawed {
  my($actual_objects,$correct_thawed,$label)=@_;
 my($package,$file,$line)=caller; # for fails
  my $ok=_cmp_thawed($actual_objects,$correct_thawed,$label,$file,$line);
  report_pass($ok,$label);
}
sub _cmp_thawed {
  my($actual_objects,$correct_thawed,$label,$file,$line)=@_;
  my @actual_thawed=grep {'Class::AutoDB::Oid' ne ref $_} @$actual_objects;
  # unthawed objects are fragile and esily thawed. do the cmp this way to avoid thawing
  my @actual_refs=
    uniq map {ref($_).'='.Scalar::Util::reftype($_).sprintf('(%0x)',Scalar::Util::refaddr($_))}
      @actual_thawed;
  my @correct_refs=
    uniq map {ref($_).'='.Scalar::Util::reftype($_).sprintf('(%0x)',Scalar::Util::refaddr($_))}
      @$correct_thawed;
  @actual_refs=sort @actual_refs;
  @correct_refs=sort @correct_refs;
  
  my($ok,$details)=cmp_details(\@actual_refs,\@correct_refs);
  report_fail($ok,$label,$file,$line,$details);
}
# remember a list of oids or all oids for later tests
sub remember_oids {
  tie_oid;
  my @objs=@_? @_: all_objects;
  my @oids=grep {$_>1} map {autodb->oid($_)} @objs;
  @oid{@oids}=@oids;
  # get id-able oids and corresponding ids
  my @oids=grep {$_>1} map {autodb->oid($_)} grep {UNIVERSAL::can($_,'id')} @objs;
  my @ids=map {autodb->oid($_)>1? $_->id: ()} grep {UNIVERSAL::can($_,'id')} @objs;
  @oid2id{@oids}=@ids;
  @id2oid{@ids}=@oids;
}
# return those tables (from a given list) that are actually in database
sub actual_tables {
  my @correct=@_;
  my $tables=dbh->selectcol_arrayref(qq(SHOW TABLES));
  my @actual;
  for my $table (@$tables) {
    push(@actual,$table) if grep {$table eq $_} @correct;
  }
  @actual;
}
# return hash of counts for given list of tables
sub actual_counts {
  my @tables=@_;
  my %counts;
  for my $table (@tables) {
    # NG 10-09-09: added _AutoDB special case to handle deleted objects
    my $sql=qq(SELECT COUNT(oid) FROM $table);
    $sql.=' WHERE object IS NOT NULL' if $table eq '_AutoDB';
    # my($count)=dbh->selectrow_array(qq(SELECT COUNT(oid) FROM $table));
    my($count)=dbh->selectrow_array($sql);
    $counts{$table}=$count||0; # convert undef to 0 (usually nonexistent table)
  }
  wantarray? %counts: \%counts;
}
# remove elements with non-true counts
sub norm_counts {
  my %counts=(@_==1 && ref $_[0])? %{$_[0]}: @_;
  map {$counts{$_} or delete $counts{$_}} keys %counts;
  wantarray? %counts: \%counts;
}
# return columns that are actually in a database table
sub actual_columns {
  my($table)=@_;
  my $columns=dbh->selectcol_arrayref(qq(SHOW COLUMNS FROM $table)) || [];
  wantarray? @$columns: $columns;
}