xt/extra/internals/describe_class_methods.t

   1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   2
   3 use strict;
   4 use warnings;
   5 no warnings 'once';
   6
   7 use Config;
   8 my $skip_threads;
   9 BEGIN {
  10   if( ! $Config{useithreads} ) {
  11     $skip_threads = 'your perl does not support ithreads';
  12   }
  13   elsif( "$]" < 5.008005 ) {
  14     $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
  15   }
  16   elsif( $INC{'Devel/Cover.pm'} ) {
  17     $skip_threads = 'Devel::Cover does not work with ithreads yet';
  18   }
  19
  20   unless( $skip_threads ) {
  21     require threads;
  22     threads->import;
  23   }
  24 }
  25
  26 use Test::More;
  27 use Test::Exception;
  28 use DBIx::Class::_Util qw(
  29   quote_sub describe_class_methods
  30   serialize refdesc sigwarn_silencer
  31   modver_gt_or_eq_and_lt
  32 );
  33 use List::Util 'shuffle';
  34 use Errno ();
  35
  36 use DBICTest;
  37
  38 my $pkg_gen_history = {};
  39
  40 { package UEBERVERSAL; sub ueber {} }
  41 @UNIVERSAL::ISA = "UEBERVERSAL";
  42 sub UNIVERSAL::uni { "unistuff" }
  43
  44 sub grab_pkg_gen ($) {
  45   push @{ $pkg_gen_history->{$_[0]} }, [
  46     DBIx::Class::_Util::get_real_pkg_gen($_[0]),
  47     'line ' . ( (caller(0))[2] ),
  48   ];
  49 }
  50
  51 @DBICTest::AttrLegacy::ISA  = 'DBIx::Class';
  52 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
  53
  54 grab_pkg_gen("DBICTest::AttrLegacy");
  55
  56 my $var = \42;
  57 my $s = quote_sub(
  58   'DBICTest::AttrLegacy::attr',
  59   '$v',
  60   { '$v' => $var },
  61   {
  62     attributes => [qw( ResultSet DBIC_random_attr )],
  63     package => 'DBICTest::AttrLegacy',
  64   },
  65 );
  66
  67 grab_pkg_gen("DBICTest::AttrLegacy");
  68
  69 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
  70
  71 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
  72
  73 is_deeply
  74   [ sort( attributes::get( $s ) ) ],
  75   [qw( DBIC_random_attr ResultSet )],
  76   'Attribute installed',
  77 ;
  78
  79 {
  80   package DBICTest::SomeGrandParentClass;
  81   use base 'DBIx::Class::MethodAttributes';
  82   sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) };
  83 }
  84 {
  85   package DBICTest::SomeParentClass;
  86   use base qw(DBICTest::SomeGrandParentClass);
  87 }
  88 {
  89   package DBICTest::AnotherParentClass;
  90   use base 'DBIx::Class::MethodAttributes';
  91   sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ };
  92 }
  93
  94 {
  95   package DBICTest::AttrTest;
  96
  97   @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass );
  98   use mro 'c3';
  99
 100   # pathological case - but can (and sadly does) happen
 101   *VALID_DBIC_CODE_ATTRIBUTE = \&DBICTest::SomeGrandParentClass::VALID_DBIC_CODE_ATTRIBUTE;
 102
 103   ::grab_pkg_gen("DBICTest::AttrTest");
 104
 105   eval <<'EOS' or die $@;
 106       sub attr :lvalue :method :DBIC_attr1 { $$var}
 107       1;
 108 EOS
 109
 110   ::grab_pkg_gen("DBICTest::AttrTest");
 111
 112   ::throws_ok {
 113     attributes->import(
 114       'DBICTest::AttrTest',
 115       DBICTest::AttrTest->can('attr'),
 116       'DBIC_unknownattr',
 117     );
 118   } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
 119 }
 120
 121 is_deeply
 122   [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
 123   [qw( DBIC_attr1 lvalue method )],
 124   'Attribute installed',
 125 ;
 126
 127 ok(
 128   ! DBICTest::AttrTest->can('__attr_cache'),
 129   'Inherited classdata never created on core attrs'
 130 );
 131
 132 is_deeply(
 133   DBICTest::AttrTest->_attr_cache,
 134   {},
 135   'Cache never instantiated on core attrs'
 136 );
 137
 138 sub add_more_attrs {
 139
 140   # Test that secondary attribute application works
 141   attributes->import(
 142     'DBICTest::AttrLegacy',
 143     DBICTest::AttrLegacy->can('attr'),
 144     'SomethingNobodyUses',
 145   );
 146
 147   # and that double-application also works
 148   attributes->import(
 149     'DBICTest::AttrLegacy',
 150     DBICTest::AttrLegacy->can('attr'),
 151     'SomethingNobodyUses',
 152   );
 153
 154   grab_pkg_gen("DBICTest::AttrLegacy");
 155
 156   is_deeply
 157     [ sort( attributes::get( $s ) )],
 158     [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
 159     'Secondary attributes installed',
 160   ;
 161
 162   is_deeply (
 163     DBICTest::AttrLegacy->_attr_cache->{$s},
 164     [ qw( ResultSet SomethingNobodyUses ) ],
 165     'Attributes visible in legacy DBIC attribute API',
 166   );
 167
 168   # Test that secondary attribute application works
 169   attributes->import(
 170     'DBICTest::AttrTest',
 171     DBICTest::AttrTest->can('attr'),
 172     'DBIC_attr2',
 173   );
 174
 175   grab_pkg_gen("DBICTest::AttrTest");
 176
 177   # and that double-application also works
 178   attributes->import(
 179     'DBICTest::AttrTest',
 180     DBICTest::AttrTest->can('attr'),
 181     'DBIC_attr2',
 182     'DBIC_attr3',
 183   );
 184
 185   grab_pkg_gen("DBICTest::AttrTest");
 186
 187   is_deeply
 188     [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
 189     [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
 190     'DBIC-specific attribute installed',
 191   ;
 192
 193   ok(
 194     ! DBICTest::AttrTest->can('__attr_cache'),
 195     'Inherited classdata never created on core+DBIC-specific attrs'
 196   );
 197
 198   is_deeply(
 199     DBICTest::AttrTest->_attr_cache,
 200     {},
 201     'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
 202   );
 203
 204   # no point dragging in threads::shared, just do the check here
 205   for my $class ( keys %$pkg_gen_history ) {
 206     my $stack = $pkg_gen_history->{$class};
 207
 208     for my $i ( 1 .. $#$stack ) {
 209       cmp_ok(
 210         $stack->[$i-1][0],
 211           ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ),
 212         $stack->[$i][0],
 213         "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]"
 214       );
 215     }
 216   }
 217
 218   my $cnt;
 219   # check that class description is stable, and changes when needed
 220   #
 221   # FIXME - this list used to contain 'main', but that started failing as
 222   # of the commit introducing this line with bizarre "unstable gen" errors
 223   # Punting for the time being - will fix at some point in the future
 224   #
 225   for my $class (qw(
 226     DBICTest::AttrTest
 227     DBICTest::AttrLegacy
 228     DBIx::Class
 229   )) {
 230     my $desc = describe_class_methods($class);
 231
 232     is_deeply(
 233       describe_class_methods($class),
 234       $desc,
 235       "describe_class_methods result is stable over '$class' (pass $_)"
 236     ) for (1,2,3);
 237
 238     my $desc2 = do {
 239       no strict 'refs';
 240
 241       $cnt++;
 242
 243       eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@;
 244
 245       my $rv = describe_class_methods($class);
 246
 247       delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"};
 248
 249       $rv
 250     };
 251
 252     delete $_->{cumulative_gen} for $desc, $desc2;
 253     ok(
 254       serialize( $desc )
 255         ne
 256       serialize( $desc2 ),
 257       "touching UNIVERSAL changed '$class' method availability"
 258     );
 259   }
 260
 261   my $bottom_most_V_D_C_A = refdesc(
 262     describe_class_methods("DBIx::Class::MethodAttributes")
 263      ->{methods}
 264       ->{VALID_DBIC_CODE_ATTRIBUTE}
 265        ->[0]
 266   );
 267
 268   for my $class ( shuffle( qw(
 269     DBICTest::AttrTest
 270     DBICTest::AttrLegacy
 271     DBICTest::SomeGrandParentClass
 272     DBIx::Class::Schema
 273     DBIx::Class::ResultSet
 274     DBICTest::Schema::Track
 275   ))) {
 276     my $desc = describe_class_methods($class);
 277
 278     is (
 279       refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
 280       $bottom_most_V_D_C_A,
 281       "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class"
 282     );
 283
 284     is (
 285       refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
 286       $bottom_most_V_D_C_A,
 287       "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class"
 288     ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE};
 289   }
 290
 291   # check that describe_class_methods returns the right stuff
 292   # ( on the simpler class )
 293   my $expected_AttrTest_linear_ISA = [qw(
 294     DBICTest::SomeParentClass
 295     DBICTest::SomeGrandParentClass
 296     DBICTest::AnotherParentClass
 297     DBIx::Class::MethodAttributes
 298   )];
 299
 300   my $expected_AttrTest_full_ISA = { map { $_ => 1 } (
 301     qw( UEBERVERSAL UNIVERSAL DBICTest::AttrTest ),
 302     @$expected_AttrTest_linear_ISA,
 303   )};
 304
 305   my $expected_desc = {
 306     class => "DBICTest::AttrTest",
 307
 308     # sum and/or is_deeply are buggy on old List::Util/Test::More
 309     # do the sum by hand ourselves to be sure
 310     cumulative_gen => do {
 311       require Math::BigInt;
 312       my $gen = Math::BigInt->new(0);
 313
 314       $gen += DBIx::Class::_Util::get_real_pkg_gen($_)
 315         for keys %$expected_AttrTest_full_ISA;
 316
 317       $gen;
 318     },
 319     mro => {
 320       type => 'c3',
 321       is_c3 => 1,
 322     },
 323     linear_isa => $expected_AttrTest_linear_ISA,
 324     isa => $expected_AttrTest_full_ISA,
 325     methods => {
 326       FETCH_CODE_ATTRIBUTES => [
 327         {
 328           attributes => {},
 329           name => "FETCH_CODE_ATTRIBUTES",
 330           via_class => "DBIx::Class::MethodAttributes"
 331         },
 332       ],
 333       MODIFY_CODE_ATTRIBUTES => [
 334         {
 335           attributes => {},
 336           name => "MODIFY_CODE_ATTRIBUTES",
 337           via_class => "DBIx::Class::MethodAttributes"
 338         },
 339       ],
 340       VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [
 341         {
 342           attributes => {},
 343           name => 'VALID_DBIC_CODE_ATTRIBUTE',
 344           via_class => 'DBICTest::AttrTest'
 345         },
 346         {
 347           attributes => {},
 348           name => "VALID_DBIC_CODE_ATTRIBUTE",
 349           via_class => "DBICTest::SomeGrandParentClass",
 350         },
 351         {
 352           attributes => {},
 353           name => "VALID_DBIC_CODE_ATTRIBUTE",
 354           via_class => "DBICTest::AnotherParentClass"
 355         },
 356         {
 357           attributes => {},
 358           name => "VALID_DBIC_CODE_ATTRIBUTE",
 359           via_class => "DBIx::Class::MethodAttributes"
 360         },
 361       ]),
 362       _attr_cache => [
 363         {
 364           attributes => {},
 365           name => "_attr_cache",
 366           via_class => "DBIx::Class::MethodAttributes"
 367         },
 368       ],
 369       attr => [
 370         {
 371           attributes => {
 372             DBIC_attr1 => 1,
 373             DBIC_attr2 => 1,
 374             DBIC_attr3 => 1,
 375             lvalue => 1,
 376             method => 1
 377           },
 378           name => "attr",
 379           via_class => "DBICTest::AttrTest"
 380         }
 381       ],
 382       ueber => [
 383         {
 384           attributes => {},
 385           name => "ueber",
 386           via_class => "UEBERVERSAL",
 387         }
 388       ],
 389       uni => [
 390         {
 391           attributes => {},
 392           name => "uni",
 393           via_class => "UNIVERSAL",
 394         }
 395       ],
 396       can => [
 397         {
 398           attributes => {},
 399           name => "can",
 400           via_class => "UNIVERSAL",
 401         },
 402       ],
 403       isa => [
 404         {
 405           attributes => {},
 406           name => "isa",
 407           via_class => "UNIVERSAL",
 408         },
 409       ],
 410       VERSION => [
 411         {
 412           attributes => {},
 413           name => "VERSION",
 414           via_class => "UNIVERSAL",
 415         },
 416       ],
 417       ( DBIx::Class::_ENV_::OLD_MRO ? () : (
 418         DOES => [{
 419           attributes => {},
 420           name => "DOES",
 421           via_class => "UNIVERSAL",
 422         }],
 423       ) ),
 424     },
 425   };
 426
 427   $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}
 428     = $V_D_C_A_stack;
 429
 430   $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE}
 431     = $V_D_C_A_stack->[0];
 432
 433   $expected_desc->{methods_defined_in_class}{attr}
 434     = $expected_desc->{methods}{attr}[0];
 435
 436   is_deeply (
 437     describe_class_methods("DBICTest::AttrTest"),
 438     $expected_desc,
 439     'describe_class_methods returns correct data',
 440   );
 441
 442   # ensure that asking with a different MRO will not perturb the cache
 443   my $cached_desc = serialize(
 444     $DBIx::Class::_Util::__describe_class_query_cache->{"DBICTest::AttrTest|c3"}
 445   );
 446
 447   # now try to ask for DFS explicitly, adjust our expectations
 448   $expected_desc->{mro} = { type => 'dfs', is_c3 => 0 };
 449
 450   # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE
 451   # sourcing-list will change places
 452   splice @$_, -2, 2, @{$_}[-1, -2]
 453     for $V_D_C_A_stack, $expected_AttrTest_linear_ISA;
 454
 455   is_deeply (
 456     # work around taint, see TODO below
 457     {
 458       %{ describe_class_methods({ class => "DBICTest::AttrTest", use_mro => "dfs" }) },
 459       cumulative_gen => $expected_desc->{cumulative_gen},
 460     },
 461     $expected_desc,
 462     'describing with explicit mro returns correct data'
 463   );
 464
 465   if (
 466     DBIx::Class::_ENV_::OLD_MRO
 467       or
 468     ! DBIx::Class::_ENV_::TAINT_MODE
 469       or
 470     ! $INC{"threads.pm"}
 471       or
 472     # $TODO did not work on T::B under threads in this range
 473     # https://github.com/Test-More/test-more/issues/683
 474     ! modver_gt_or_eq_and_lt( 'Test::More', '1.300', '1.302027' )
 475   ) {
 476     local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)"
 477       if
 478         DBIx::Class::_ENV_::TAINT_MODE
 479           and
 480         DBIx::Class::_ENV_::PERL_VERSION > 5.009
 481     ;
 482
 483     ok(
 484       (
 485         serialize( describe_class_methods("DBICTest::AttrTest") )
 486           eq
 487         $cached_desc
 488       ),
 489       "Asking for alternative mro type did not invalidate cache"
 490     );
 491   }
 492
 493   # setting mro explicitly still matches what we expect
 494   mro::set_mro("DBICTest::AttrTest", "dfs");
 495
 496   is_deeply (
 497     # in case set_mro starts increasing pkg_gen...
 498     {
 499       %{describe_class_methods("DBICTest::AttrTest")},
 500       cumulative_gen => $expected_desc->{cumulative_gen},
 501     },
 502     $expected_desc,
 503     'describing with implicit mro returns correct data'
 504   );
 505
 506   # check that a UNIVERSAL-parent interrogation makes sense
 507   # ( it should not list anything from UNIVERSAL itself )
 508   is_deeply (
 509     describe_class_methods("UEBERVERSAL"),
 510     {
 511       # should be cached by now, thus safe to rely on...?
 512       cumulative_gen => DBIx::Class::_Util::get_real_pkg_gen('UEBERVERSAL'),
 513
 514       class => 'UEBERVERSAL',
 515       mro => { is_c3 => 0, type => 'dfs' },
 516       isa => { UEBERVERSAL => 1 },
 517       linear_isa => [],
 518       methods => {
 519         ueber => $expected_desc->{methods}{ueber}
 520       },
 521       methods_defined_in_class => {
 522         ueber => $expected_desc->{methods}{ueber}[0]
 523       },
 524     },
 525     "Expected description of a parent-of-UNIVERSAL class (pathological case)",
 526   );
 527 }
 528
 529 if ($skip_threads) {
 530   SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
 531
 532   add_more_attrs();
 533 }
 534 else { SKIP: {
 535
 536   my $t = threads->create(sub {
 537
 538     my $t = threads->create(sub {
 539
 540       add_more_attrs();
 541       select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 542
 543       42;
 544
 545     }) || do {
 546       die "Unable to start thread: $!"
 547         unless $! == Errno::EAGAIN();
 548
 549       SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 }
 550
 551       return 42 ;
 552     };
 553
 554     my $rv = $t->join;
 555
 556     select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 557
 558     $rv;
 559   }) || do {
 560     die "Unable to start thread: $!"
 561       unless $! == Errno::EAGAIN();
 562
 563     skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1;
 564   };
 565
 566   is (
 567     $t->join,
 568     42,
 569     'Thread stack exitted succesfully'
 570   );
 571 }}
 572
 573 # check "crosed-over" mro
 574 {
 575   {
 576     package DBICTest::WackyDFS;
 577     use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass );
 578   }
 579
 580   is_deeply
 581     describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE},
 582     [
 583       {
 584         attributes => {},
 585         name => "VALID_DBIC_CODE_ATTRIBUTE",
 586         via_class => "DBICTest::SomeGrandParentClass",
 587       },
 588       {
 589         attributes => {},
 590         name => "VALID_DBIC_CODE_ATTRIBUTE",
 591         via_class => "DBIx::Class::MethodAttributes"
 592       },
 593     ],
 594     'Expected description on unusable inheritance hierarchy'
 595   ;
 596 }
 597
 598 # check pathological cases ( combinations of cases from
 599 # Package::Stash and Devel::Isa::Explainer )
 600 {
 601   {
 602     package DBICTest::Exotic;
 603
 604     use constant CSCALAR    => 1;
 605     use constant CSCALARREF => \1;
 606     use constant CARRAYREF  => [];
 607     use constant CHASHREF   => {};
 608     use constant CSUB       => sub { };
 609
 610     sub subnormal { }
 611     sub substub;
 612     sub subnormalproto () { }
 613     sub substubproto ();
 614
 615     sub Bsubnormal { }
 616     sub Bsubstub;
 617     sub Bsubnormalproto () { }
 618     sub Bsubstubproto ();
 619
 620     our @OURARRAY;
 621     our %OURHASH;
 622     our $OURSCALAR;
 623
 624     *someXSUB = \&DBIx::Class::_Util::deep_clone;
 625
 626     *EMPTYGLOB = *EMPTYGLOB;
 627
 628     our @GLOBCOLLISION;
 629     our %GLOBCOLLISION;
 630     sub GLOBCOLLISION { }
 631
 632     no strict 'refs';
 633     ${'DBICTest::'}{stubUNDEF} = undef;
 634     ${'DBICTest::'}{stubSCALAR} = 1;
 635
 636     bless $_, "0"
 637       for map
 638         { \&{"DBICTest::Exotic::Bsub$_"} }
 639         qw( normal stub )
 640     ;
 641
 642     bless $_, __PACKAGE__
 643       for map
 644         { \&{"DBICTest::Exotic::Bsub$_"} }
 645         qw( normalproto stubproto )
 646     ;
 647
 648     package DBICTest::Exotic::SubPackage;
 649     *CHILDGLOB = *CHILDGLOB;
 650   }
 651
 652   my $expected = [ sort
 653     qw(
 654       CSCALAR CSCALARREF CARRAYREF CHASHREF CSUB
 655       GLOBCOLLISION someXSUB
 656     ),
 657     (map
 658       {( "Bsub$_", "sub$_" )}
 659       qw( normal stub normalproto stubproto )
 660     ),
 661   ];
 662
 663   # FIXME because attributes::get() has an error in its signature parser
 664   local $SIG{__WARN__} = sigwarn_silencer qr/Unable to determine attributes of/;
 665
 666   is_deeply
 667     [ sort keys %{
 668       describe_class_methods('DBICTest::Exotic')->{methods_defined_in_class}
 669     } ],
 670     $expected,
 671     'All expected methods recognized in pathological cases'
 672   ;
 673
 674   # blow the cache
 675   *DBICTest::Exotic::zzz_extra_method = sub {};
 676
 677   is_deeply
 678     [ sort keys %{
 679       describe_class_methods('DBICTest::Exotic')->{methods_defined_in_class}
 680     } ],
 681     [ @$expected, 'zzz_extra_method' ],
 682     'All expected methods yet again recognized in pathological cases'
 683   ;
 684 }
 685
 686 done_testing;