xt/extra/diagnostics/divergent_metadata.t

   1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   2
   3 # things will die if this is set
   4 BEGIN { $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE} = 0 }
   5
   6 use strict;
   7 use warnings;
   8
   9 use Test::More;
  10
  11 use DBICTest::Util 'capture_stderr';
  12 use DBICTest;
  13
  14 my ($fn) = __FILE__ =~ /( [^\/\\]+ ) $/x;
  15 my @divergence_lines;
  16
  17 my $art = DBICTest->init_schema->resultset("Artist")->find(1);
  18
  19 push @divergence_lines, __LINE__ + 1;
  20 DBICTest::Schema::Artist->add_columns("Something_New");
  21
  22 push @divergence_lines, __LINE__ + 1;
  23 $_->add_column("Something_New_2") for grep
  24   { $_ != $art->result_source }
  25   DBICTest::Schema::Artist->result_source_instance->__derived_instances
  26 ;
  27
  28 push @divergence_lines, __LINE__ + 1;
  29 DBICTest::Schema::Artist->result_source_instance->name("foo");
  30
  31 my $orig_class_rsrc_before_table_triggered_reinit = DBICTest::Schema::Artist->result_source_instance;
  32
  33 push @divergence_lines, __LINE__ + 1;
  34 DBICTest::Schema::Artist->table("bar");
  35
  36 is(
  37   capture_stderr {
  38     ok(
  39       DBICTest::Schema::Artist->has_column( "Something_New" ),
  40       'Added column visible'
  41     );
  42
  43     ok(
  44       (! DBICTest::Schema::Artist->has_column( "Something_New_2" ) ),
  45       'Column added on children not visible'
  46     );
  47   },
  48   '',
  49   'No StdErr output during rsrc augmentation'
  50 );
  51
  52 my $err = capture_stderr {
  53   ok(
  54     ! $art->has_column($_),
  55     "Column '$_' not visible on @{[ $art->table ]}"
  56   ) for qw(Something_New Something_New_2);
  57 };
  58
  59 # Tricky text - check it painstakingly as things may go off
  60 # in very subtle ways
  61 my $expected_warning_1 = join '.+?', map { quotemeta $_ }
  62   "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*",
  63
  64   "${orig_class_rsrc_before_table_triggered_reinit}->add_columns(...) at",
  65     "$fn line $divergence_lines[0]",
  66
  67   "@{[ DBICTest::Schema->source('Artist') ]}->add_column(...) at",
  68     "$fn line $divergence_lines[1]",
  69
  70   "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->has_column(...)",
  71 ;
  72
  73 like
  74   $err,
  75   qr/$expected_warning_1/s,
  76   'Correct warning on diverged metadata'
  77 ;
  78
  79 my $expected_warning_2 = join '.+?', map { quotemeta $_ }
  80   "@{[ $art->result_source ]} (the metadata instance of source 'Artist') is *OUTDATED*",
  81
  82   "${orig_class_rsrc_before_table_triggered_reinit}->name(...) at",
  83     "$fn line $divergence_lines[2]",
  84
  85   "${orig_class_rsrc_before_table_triggered_reinit}->table(...) at",
  86     "$fn line $divergence_lines[3]",
  87
  88   "Stale metadata accessed by 'getter' @{[ $art->result_source ]}->table(...)",
  89 ;
  90
  91 like
  92   $err,
  93   qr/$expected_warning_2/s,
  94   'Correct warning on diverged metadata'
  95 ;
  96
  97 done_testing;