t/CXGN/DB/object.t

   1
   2 =head1 NAME
   3
   4 object.t - a test script for the CXGN::DB::Object class.
   5
   6 =head1 AUTHOR
   7
   8 Lukas Mueller
   9
  10 =cut
  11
  12 use strict;
  13
  14 use Test::More tests => 9;
  15 use Test::Warn;
  16
  17 BEGIN {
  18
  19     use_ok("CXGN::DB::Connection");
  20     use_ok("CXGN::DB::Object");
  21
  22 }
  23
  24 my $dbh = CXGN::DB::Connection->new();
  25
  26 my $dbo = CXGN::DB::Object->new($dbh);
  27 isnt( $dbo,          undef, "object not undef check" );
  28 isnt( $dbo->get_dbh, undef, "dbh in object not undef check" );
  29 can_ok( $dbo->get_dbh, 'selectall_arrayref', 'prepare' );
  30
  31 warning_is {
  32     CXGN::DB::Object->new( $dbh->get_actual_dbh )
  33 } undef, 'does not warn for an actual dbh';
  34
  35 my $tdbo = TestDBObject->new($dbh);
  36 isa_ok( $tdbo->get_dbh, "CXGN::DB::Connection" );
  37
  38 my $so = DBIxSchemaObject->connect(
  39     sub { return CXGN::DB::Connection->new()->get_actual_dbh(); } );
  40
  41 my $tso = TestSchemaObject->new($so);
  42
  43 ok( $tso->get_schema()->isa("DBIx::Class"),
  44     "Test schema object accessor test" );
  45
  46 is( $tso->get_dbh()->isa("DBI::db"), 1,
  47     "Test schema object dbh accessor test" );
  48
  49 package TestDBObject;
  50
  51 use base qw | CXGN::DB::Object |;
  52
  53 sub new {
  54     my $class = shift;
  55     my $dbh   = shift;
  56
  57     my $self = $class->SUPER::new($dbh);
  58
  59     return $self;
  60 }
  61
  62 package TestSchemaObject;
  63
  64 use base qw | CXGN::DB::Object |;
  65
  66 sub new {
  67     my $class  = shift;
  68     my $schema = shift;
  69
  70     my $self = $class->SUPER::new($schema);
  71
  72     return $self;
  73 }
  74
  75 package DBIxSchemaObject;
  76
  77 use base qw | DBIx::Class::Schema |;
  78
  79 __PACKAGE__->load_components( "PK::Auto", "Core" );
  80