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