t/39load_namespaces_rt41083.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5 use Test::More skip_all => 'Postponed until after 0.08100';
   6
   7 use lib 't/lib';
   8
   9 =begin
  10
  11 How did this get back here? The test is borked, there is a branch with
  12 the correct test and a tentative fix - branches/subclassed_rsset
  13
  14 Make sure to nuke this file when merging, it is only left here to make
  15 merging of the above branch easier.
  16
  17
  18 ribasushi
  19
  20
  21 =cut
  22
  23
  24 __END__
  25
  26
  27
  28 plan tests => 15;
  29
  30 sub _chk_warning {
  31   defined $_[0]?
  32     $_[0] !~ qr/We found ResultSet class '([^']+)' for '([^']+)', but it seems that you had already set '([^']+)' to use '([^']+)' instead/ :
  33     1
  34 }
  35
  36 sub _chk_extra_sources_warning {
  37   my $p = qr/already has a source, use register_extra_source for additional sources/;
  38   defined $_[0]? $_[0] !~ /$p/ : 1;
  39 }
  40
  41 sub _verify_sources {
  42   my @monikers = @_;
  43   is_deeply (
  44     [ sort DBICNSTest::RtBug41083->sources ],
  45     \@monikers,
  46     'List of resultsource registrations',
  47   );
  48
  49   my %seen_rc;
  50   for my $m (@monikers) {
  51     my $src = DBICNSTest::RtBug41083->source ($m);
  52     my $rc = $src->result_class;
  53
  54     ok ( (++$seen_rc{$rc} == 1), "result_class of $m is unique")
  55       || diag "Source: $m, result_class: $rc";
  56     like ($rc, qr/:: $m $/x, 'result_class matches moniker');
  57   }
  58 }
  59
  60 {
  61   my $warnings;
  62   eval {
  63     local $SIG{__WARN__} = sub { $warnings .= shift };
  64     package DBICNSTest::RtBug41083;
  65     use base 'DBIx::Class::Schema';
  66     __PACKAGE__->load_namespaces(
  67       result_namespace => 'Schema_A',
  68       resultset_namespace => 'ResultSet_A',
  69       default_resultset_class => 'ResultSet'
  70     );
  71   };
  72
  73   ok(!$@) or diag $@;
  74   ok(_chk_warning($warnings), 'expected no resultset complaint');
  75   ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
  76
  77   _verify_sources (qw/A A::Sub/);
  78 }
  79
  80 {
  81   my $warnings;
  82   eval {
  83     local $SIG{__WARN__} = sub { $warnings .= shift };
  84     package DBICNSTest::RtBug41083;
  85     use base 'DBIx::Class::Schema';
  86     __PACKAGE__->load_namespaces(
  87       result_namespace => 'Schema',
  88       resultset_namespace => 'ResultSet',
  89       default_resultset_class => 'ResultSet'
  90     );
  91   };
  92   ok(!$@) or diag $@;
  93   ok(_chk_warning($warnings), 'expected no resultset complaint') or diag $warnings;
  94   ok(_chk_extra_sources_warning($warnings), 'expected no extra sources complaint') or diag($warnings);
  95
  96   _verify_sources (qw/A A::Sub Foo Foo::Sub/);
  97 }