xt/extra/internals/rsrc_ancestry.t

   1 use warnings;
   2 use strict;
   3
   4 use Config;
   5 BEGIN {
   6   my $skipall;
   7
   8   if( ! $Config{useithreads} ) {
   9     $skipall = 'your perl does not support ithreads';
  10   }
  11   elsif( "$]" < 5.008005 ) {
  12     $skipall = 'DBIC does not actively support threads before perl 5.8.5';
  13   }
  14   elsif( $INC{'Devel/Cover.pm'} ) {
  15     $skipall = 'Devel::Cover does not work with ithreads yet';
  16   }
  17
  18   if( $skipall ) {
  19     print "1..0 # SKIP $skipall\n";
  20     exit 0;
  21   }
  22 }
  23
  24 use threads;
  25 use Test::More;
  26 use DBIx::Class::_Util 'hrefaddr';
  27 use Scalar::Util 'weaken';
  28
  29 {
  30   package DBICTest::Ancestry::Result;
  31
  32   use base 'DBIx::Class::Core';
  33
  34   __PACKAGE__->table("foo");
  35 }
  36
  37 {
  38   package DBICTest::Ancestry::Schema;
  39
  40   use base 'DBIx::Class::Schema';
  41
  42   __PACKAGE__->register_class( r => "DBICTest::Ancestry::Result" );
  43 }
  44
  45 my $schema = DBICTest::Ancestry::Schema->clone;
  46 my $rsrc = $schema->resultset("r")->result_source->clone;
  47
  48 threads->new( sub {
  49
  50   my $another_rsrc = $rsrc->clone;
  51
  52   is_deeply
  53     refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ),
  54     refaddrify(
  55       DBICTest::Ancestry::Schema->source("r"),
  56       $schema->source("r"),
  57       $rsrc,
  58       $another_rsrc,
  59     )
  60   ;
  61
  62   undef $schema;
  63   undef $rsrc;
  64   $another_rsrc->schema(undef);
  65
  66   is_deeply
  67     refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ),
  68     refaddrify(
  69       DBICTest::Ancestry::Schema->source("r"),
  70       $another_rsrc,
  71     )
  72   ;
  73
  74   # tasty crashes without this
  75   select( undef, undef, undef, 0.2 );
  76 })->join;
  77
  78 sub refaddrify {
  79   [ sort map { hrefaddr $_ } @_ ];
  80 }
  81
  82 done_testing;