lib/Class/Accessor/Grouped.pm

   1 package Class::Accessor::Grouped;
   2 use strict;
   3 use warnings;
   4 use Carp ();
   5 use Scalar::Util ();
   6
   7 BEGIN {
   8   if ($] < 5.009_005) {
   9     require MRO::Compat;
  10   }
  11   else {
  12     require mro;
  13   }
  14 }
  15
  16 our $VERSION = '0.10006';
  17 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
  18
  19 # when changing minimum version don't forget to adjust Makefile.PL as well
  20 our $__minimum_xsa_version;
  21 BEGIN { $__minimum_xsa_version = '1.13' }
  22
  23 our $USE_XS;
  24 # the unless defined is here so that we can override the value
  25 # before require/use, *regardless* of the state of $ENV{CAG_USE_XS}
  26 $USE_XS = $ENV{CAG_USE_XS}
  27     unless defined $USE_XS;
  28
  29 # Yes this method is undocumented
  30 # Yes it should be a private coderef like all the rest at the end of this file
  31 # No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
  32 # %$*@!?&!&#*$!!!
  33 sub _mk_group_accessors {
  34     my($self, $maker, $group, @fields) = @_;
  35     my $class = Scalar::Util::blessed $self || $self;
  36
  37     no strict 'refs';
  38     no warnings 'redefine';
  39
  40     # So we don't have to do lots of lookups inside the loop.
  41     $maker = $self->can($maker) unless ref $maker;
  42
  43     foreach (@fields) {
  44         if( $_ eq 'DESTROY' ) {
  45             Carp::carp("Having a data accessor named DESTROY in ".
  46                        "'$class' is unwise.");
  47         }
  48
  49         my ($name, $field) = (ref $_)
  50             ? (@$_)
  51             : ($_, $_)
  52         ;
  53
  54         my $alias = "_${name}_accessor";
  55
  56         for my $meth ($name, $alias) {
  57
  58             # the maker may elect to not return anything, meaning it already
  59             # installed the coderef for us (e.g. lack of Sub::Name)
  60             my $cref = $self->$maker($group, $field, $meth)
  61                 or next;
  62
  63             my $fq_meth = "${class}::${meth}";
  64
  65             *$fq_meth = Sub::Name::subname($fq_meth, $cref);
  66                 #unless defined &{$class."\:\:$field"}
  67         }
  68     }
  69 };
  70
  71 # coderef is setup at the end for clarity
  72 my $gen_accessor;
  73
  74 =head1 NAME
  75
  76 Class::Accessor::Grouped - Lets you build groups of accessors
  77
  78 =head1 SYNOPSIS
  79
  80  use base 'Class::Accessor::Grouped';
  81
  82  # make basic accessors for objects
  83  __PACKAGE__->mk_group_accessors(simple => qw(id name email));
  84
  85  # make accessor that works for objects and classes
  86  __PACKAGE__->mk_group_accessors(inherited => 'awesome_level');
  87
  88 =head1 DESCRIPTION
  89
  90 This class lets you build groups of accessors that will call different
  91 getters and setters.
  92
  93 =head1 METHODS
  94
  95 =head2 mk_group_accessors
  96
  97  __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]);
  98
  99 =over 4
 100
 101 =item Arguments: $group, @fieldspec
 102
 103 Returns: none
 104
 105 =back
 106
 107 Creates a set of accessors in a given group.
 108
 109 $group is the name of the accessor group for the generated accessors; they
 110 will call get_$group($field) on get and set_$group($field, $value) on set.
 111
 112 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
 113 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
 114 methods.
 115
 116 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
 117 this is used as both field and accessor name, if a listref it is expected to
 118 be of the form [ $accessor, $field ].
 119
 120 =cut
 121
 122 sub mk_group_accessors {
 123     my ($self, $group, @fields) = @_;
 124
 125     $self->_mk_group_accessors('make_group_accessor', $group, @fields);
 126     return;
 127 }
 128
 129 =head2 mk_group_ro_accessors
 130
 131  __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]);
 132
 133 =over 4
 134
 135 =item Arguments: $group, @fieldspec
 136
 137 Returns: none
 138
 139 =back
 140
 141 Creates a set of read only accessors in a given group. Identical to
 142 L</mk_group_accessors> but accessors will throw an error if passed a value
 143 rather than setting the value.
 144
 145 =cut
 146
 147 sub mk_group_ro_accessors {
 148     my($self, $group, @fields) = @_;
 149
 150     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 151 }
 152
 153 =head2 mk_group_wo_accessors
 154
 155  __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]);
 156
 157 =over 4
 158
 159 =item Arguments: $group, @fieldspec
 160
 161 Returns: none
 162
 163 =back
 164
 165 Creates a set of write only accessors in a given group. Identical to
 166 L</mk_group_accessors> but accessors will throw an error if not passed a
 167 value rather than getting the value.
 168
 169 =cut
 170
 171 sub mk_group_wo_accessors {
 172     my($self, $group, @fields) = @_;
 173
 174     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 175 }
 176
 177 =head2 get_simple
 178
 179 =over 4
 180
 181 =item Arguments: $field
 182
 183 Returns: $value
 184
 185 =back
 186
 187 Simple getter for hash-based objects which returns the value for the field
 188 name passed as an argument.
 189
 190 =cut
 191
 192 sub get_simple {
 193     return $_[0]->{$_[1]};
 194 }
 195
 196 =head2 set_simple
 197
 198 =over 4
 199
 200 =item Arguments: $field, $new_value
 201
 202 Returns: $new_value
 203
 204 =back
 205
 206 Simple setter for hash-based objects which sets and then returns the value
 207 for the field name passed as an argument.
 208
 209 =cut
 210
 211 sub set_simple {
 212     return $_[0]->{$_[1]} = $_[2];
 213 }
 214
 215
 216 =head2 get_inherited
 217
 218 =over 4
 219
 220 =item Arguments: $field
 221
 222 Returns: $value
 223
 224 =back
 225
 226 Simple getter for Classes and hash-based objects which returns the value for
 227 the field name passed as an argument. This behaves much like
 228 L<Class::Data::Accessor> where the field can be set in a base class,
 229 inherited and changed in subclasses, and inherited and changed for object
 230 instances.
 231
 232 =cut
 233
 234 sub get_inherited {
 235     my $class;
 236
 237     if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
 238         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 239           return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
 240         }
 241         else {
 242           Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 243         }
 244     }
 245     else {
 246         $class = $_[0];
 247     }
 248
 249     no strict 'refs';
 250     no warnings 'uninitialized';
 251
 252     my $cag_slot = '::__cag_'. $_[1];
 253     return ${$class.$cag_slot} if defined(${$class.$cag_slot});
 254
 255     # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
 256     my $cur_gen = mro::get_pkg_gen ($class);
 257     if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
 258         @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
 259         ${$class.'::__cag_pkg_gen__'} = $cur_gen;
 260     }
 261
 262     for (@{$class.'::__cag_supers__'}) {
 263         return ${$_.$cag_slot} if defined(${$_.$cag_slot});
 264     };
 265
 266     return undef;
 267 }
 268
 269 =head2 set_inherited
 270
 271 =over 4
 272
 273 =item Arguments: $field, $new_value
 274
 275 Returns: $new_value
 276
 277 =back
 278
 279 Simple setter for Classes and hash-based objects which sets and then returns
 280 the value for the field name passed as an argument. When called on a hash-based
 281 object it will set the appropriate hash key value. When called on a class, it
 282 will set a class level variable.
 283
 284 B<Note:>: This method will die if you try to set an object variable on a non
 285 hash-based object.
 286
 287 =cut
 288
 289 sub set_inherited {
 290     if (defined Scalar::Util::blessed $_[0]) {
 291         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 292             return $_[0]->{$_[1]} = $_[2];
 293         } else {
 294             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 295         };
 296     } else {
 297         no strict 'refs';
 298
 299         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 300     };
 301 }
 302
 303 =head2 get_component_class
 304
 305 =over 4
 306
 307 =item Arguments: $field
 308
 309 Returns: $value
 310
 311 =back
 312
 313 Gets the value of the specified component class.
 314
 315     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 316
 317     $self->result_class->method();
 318
 319     ## same as
 320     $self->get_component_class('result_class')->method();
 321
 322 =cut
 323
 324 sub get_component_class {
 325     return $_[0]->get_inherited($_[1]);
 326 };
 327
 328 =head2 set_component_class
 329
 330 =over 4
 331
 332 =item Arguments: $field, $class
 333
 334 Returns: $new_value
 335
 336 =back
 337
 338 Inherited accessor that automatically loads the specified class before setting
 339 it. This method will die if the specified class could not be loaded.
 340
 341     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 342     __PACKAGE__->result_class('MyClass');
 343
 344     $self->result_class->method();
 345
 346 =cut
 347
 348 sub set_component_class {
 349     if ($_[2]) {
 350         local $^W = 0;
 351         require Class::Inspector;
 352         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 353             eval "require $_[2]";
 354
 355             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 356         };
 357     };
 358
 359     return $_[0]->set_inherited($_[1], $_[2]);
 360 };
 361
 362 =head1 INTERNAL METHODS
 363
 364 These methods are documented for clarity, but are never meant to be called
 365 directly, and are not really meant for overriding either.
 366
 367 =head2 get_super_paths
 368
 369 Returns a list of 'parent' or 'super' class names that the current class
 370 inherited from. This is what drives the traversal done by L</get_inherited>.
 371
 372 =cut
 373
 374 sub get_super_paths {
 375     return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
 376 };
 377
 378 =head2 make_group_accessor
 379
 380  __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length');
 381  __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color');
 382
 383 =over 4
 384
 385 =item Arguments: $group, $field, $accessor
 386
 387 Returns: \&accessor_coderef ?
 388
 389 =back
 390
 391 Called by mk_group_accessors for each entry in @fieldspec. Either returns
 392 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 393 C<undef> if it elects to install the coderef on its own.
 394
 395 =cut
 396
 397 sub make_group_accessor { $gen_accessor->('rw', @_) }
 398
 399 =head2 make_group_ro_accessor
 400
 401  __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate');
 402  __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number');
 403
 404 =over 4
 405
 406 =item Arguments: $group, $field, $accessor
 407
 408 Returns: \&accessor_coderef ?
 409
 410 =back
 411
 412 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
 413 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 414 C<undef> if it elects to install the coderef on its own.
 415
 416 =cut
 417
 418 sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
 419
 420 =head2 make_group_wo_accessor
 421
 422  __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie');
 423  __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject');
 424
 425 =over 4
 426
 427 =item Arguments: $group, $field, $accessor
 428
 429 Returns: \&accessor_coderef ?
 430
 431 =back
 432
 433 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
 434 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 435 C<undef> if it elects to install the coderef on its own.
 436
 437 =cut
 438
 439 sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
 440
 441
 442 =head1 PERFORMANCE
 443
 444 To provide total flexibility L<Class::Accessor::Grouped> calls methods
 445 internally while performing get/set actions, which makes it noticeably
 446 slower than similar modules. To compensate, this module will automatically
 447 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
 448 accessors if this module is available on your system.
 449
 450 =head2 Benchmark
 451
 452 This is the result of a set/get/set loop benchmark on perl 5.12.1 with
 453 thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
 454 L<Moo>, L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>,
 455 L<XSA|Class::XSAccessor>, and L<CAF_XSA|Class::XSAccessor::Compat>:
 456
 457            Rate  CAG moOse  CAF moUse  moo HANDMADE CAF_XS moUse_XS moo_XS CAF_XSA  XSA CAG_XS
 458  CAG      169/s   --  -21% -24%  -32% -32%     -34%   -59%     -63%   -67%    -67% -67%   -67%
 459  moOse    215/s  27%    --  -3%  -13% -13%     -15%   -48%     -53%   -58%    -58% -58%   -58%
 460  CAF      222/s  31%    3%   --  -10% -10%     -13%   -46%     -52%   -57%    -57% -57%   -57%
 461  moUse    248/s  46%   15%  11%    --  -0%      -3%   -40%     -46%   -52%    -52% -52%   -52%
 462  moo      248/s  46%   15%  11%    0%   --      -3%   -40%     -46%   -52%    -52% -52%   -52%
 463  HANDMADE 255/s  50%   18%  14%    3%   3%       --   -38%     -45%   -50%    -51% -51%   -51%
 464  CAF_XS   411/s 143%   91%  85%   66%  66%      61%     --     -11%   -20%    -20% -21%   -21%
 465  moUse_XS 461/s 172%  114% 107%   86%  86%      81%    12%       --   -10%    -11% -11%   -11%
 466  moo_XS   514/s 204%  139% 131%  107% 107%     102%    25%      12%     --     -0%  -1%    -1%
 467  CAF_XSA  516/s 205%  140% 132%  108% 108%     103%    26%      12%     0%      --  -0%    -0%
 468  XSA      519/s 206%  141% 133%  109% 109%     104%    26%      13%     1%      0%   --    -0%
 469  CAG_XS   519/s 206%  141% 133%  109% 109%     104%    26%      13%     1%      0%   0%     --
 470
 471 Benchmark program is available in the root of the
 472 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
 473
 474 =head2 Notes on Class::XSAccessor
 475
 476 You can force (or disable) the use of L<Class::XSAccessor> before creating a
 477 particular C<simple> accessor by either manipulating the global variable
 478 C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
 479 L<localization|perlfunc/local>, or you can do so before runtime via the
 480 C<CAG_USE_XS> environment variable.
 481
 482 Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
 483 L</set_simple> this module does its best to detect if you are overriding
 484 one of these methods and will fall back to using the perl version of the
 485 accessor in order to maintain consistency. However be aware that if you
 486 enable use of C<Class::XSAccessor> (automatically or explicitly), create
 487 an object, invoke a simple accessor on that object, and B<then> manipulate
 488 the symbol table to install a C<get/set_simple> override - you get to keep
 489 all the pieces.
 490
 491 =head1 AUTHORS
 492
 493 Matt S. Trout <mst@shadowcatsystems.co.uk>
 494
 495 Christopher H. Laco <claco@chrislaco.com>
 496
 497 =head1 CONTRIBUTORS
 498
 499 Caelum: Rafael Kitover <rkitover@cpan.org>
 500
 501 frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
 502
 503 groditi: Guillermo Roditi <groditi@cpan.org>
 504
 505 Jason Plum <jason.plum@bmmsi.com>
 506
 507 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 508
 509
 510 =head1 COPYRIGHT & LICENSE
 511
 512 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 513
 514 This program is free software; you can redistribute it and/or modify
 515 it under the same terms as perl itself.
 516
 517 =cut
 518
 519 ########################################################################
 520 ########################################################################
 521 ########################################################################
 522 #
 523 # Here be many angry dragons
 524 # (all code is in private coderefs since everything inherits CAG)
 525 #
 526 ########################################################################
 527 ########################################################################
 528
 529 BEGIN {
 530
 531   die "Huh?! No minimum C::XSA version?!\n"
 532     unless $__minimum_xsa_version;
 533
 534   local $@;
 535   my $err;
 536
 537
 538   $err = eval { require Sub::Name; 1; } ? undef : do {
 539     delete $INC{'Sub/Name.pm'};   # because older perls suck
 540     $@;
 541   };
 542   *__CAG_ENV__::NO_SUBNAME = $err
 543     ? sub () { $err }
 544     : sub () { 0 }
 545   ;
 546
 547
 548   $err = eval {
 549     require Class::XSAccessor;
 550     Class::XSAccessor->VERSION($__minimum_xsa_version);
 551     require Sub::Name;
 552     1;
 553   } ? undef : do {
 554     delete $INC{'Sub/Name.pm'};   # because older perls suck
 555     delete $INC{'Class/XSAccessor.pm'};
 556     $@;
 557   };
 558   *__CAG_ENV__::NO_CXSA = $err
 559     ? sub () { $err }
 560     : sub () { 0 }
 561   ;
 562
 563
 564   *__CAG_ENV__::BROKEN_GOTO = ($] < '5.008009')
 565     ? sub () { 1 }
 566     : sub () { 0 }
 567   ;
 568
 569
 570   *__CAG_ENV__::UNSTABLE_DOLLARAT = ($] < '5.013002')
 571     ? sub () { 1 }
 572     : sub () { 0 }
 573   ;
 574
 575
 576   *__CAG_ENV__::TRACK_UNDEFER_FAIL = (
 577     $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
 578       and
 579     $0 =~ m|^ x?t / .+ \.t $|x
 580   ) ? sub () { 1 }
 581     : sub () { 0 }
 582   ;
 583 }
 584
 585 # Autodetect unless flag supplied
 586 my $xsa_autodetected;
 587 if (! defined $USE_XS) {
 588   $USE_XS = __CAG_ENV__::NO_CXSA ? 0 : 1;
 589   $xsa_autodetected++;
 590 }
 591
 592 my $maker_templates = {
 593   rw => {
 594     xs_call => 'accessors',
 595     pp_code => sub {
 596       my $set = "set_$_[0]";
 597       my $get = "get_$_[0]";
 598       my $field = $_[1];
 599       $field =~ s/'/\\'/g;
 600
 601       "
 602         \@_ != 1
 603           ? shift->$set('$field', \@_)
 604           : shift->$get('$field')
 605       "
 606     },
 607   },
 608   ro => {
 609     xs_call => 'getters',
 610     pp_code => sub {
 611       my $get = "get_$_[0]";
 612       my $field = $_[1];
 613       $field =~ s/'/\\'/g;
 614
 615       "
 616         \@_ == 1
 617           ? shift->$get('$field')
 618           : do {
 619             my \$caller = caller;
 620             my \$class = ref \$_[0] || \$_[0];
 621             Carp::croak(\"'\$caller' cannot alter the value of '$field' \".
 622                         \"(read-only attributes of class '\$class')\");
 623           }
 624       "
 625     },
 626   },
 627   wo => {
 628     xs_call => 'setters',
 629     pp_code => sub {
 630       my $set = "set_$_[0]";
 631       my $field = $_[1];
 632       $field =~ s/'/\\'/g;
 633
 634       "
 635         \@_ != 1
 636           ? shift->$set('$field', \@_)
 637           : do {
 638             my \$caller = caller;
 639             my \$class = ref \$_[0] || \$_[0];
 640             Carp::croak(\"'\$caller' cannot access the value of '$field' \".
 641                         \"(write-only attributes of class '\$class')\");
 642           }
 643       "
 644     },
 645   },
 646 };
 647
 648
 649 my ($accessor_maker_cache, $no_xsa_warned_classes);
 650
 651 # can't use pkg_gen to track this stuff, as it doesn't
 652 # detect superclass mucking
 653 my $original_simple_getter = __PACKAGE__->can ('get_simple');
 654 my $original_simple_setter = __PACKAGE__->can ('set_simple');
 655
 656 # Note!!! Unusual signature
 657 $gen_accessor = sub {
 658   my ($type, $class, $group, $field, $methname) = @_;
 659   if (my $c = Scalar::Util::blessed( $class )) {
 660     $class = $c;
 661   }
 662
 663   # When installing an XSA simple accessor, we need to make sure we are not
 664   # short-circuiting a (compile or runtime) get_simple/set_simple override.
 665   # What we do here is install a lazy first-access check, which will decide
 666   # the ultimate coderef being placed in the accessor slot
 667   #
 668   # Also note that the *original* class will always retain this shim, as
 669   # different branches inheriting from it may have different overrides.
 670   # Thus the final method (properly labeled and all) is installed in the
 671   # calling-package's namespace
 672   if ($USE_XS and $group eq 'simple') {
 673     die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA )
 674       if __CAG_ENV__::NO_CXSA;
 675
 676     my ($expected_cref, $cached_implementation);
 677     my $ret = $expected_cref = sub {
 678       my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];
 679
 680       # $cached_implementation will be set only if the shim got
 681       # 'around'ed, in which case it is handy to avoid re-running
 682       # this block over and over again
 683       my $resolved_implementation = $cached_implementation->{$current_class} || do {
 684         if (
 685           ($current_class->can('get_simple')||0) == $original_simple_getter
 686             &&
 687           ($current_class->can('set_simple')||0) == $original_simple_setter
 688         ) {
 689           # nothing has changed, might as well use the XS crefs
 690           #
 691           # note that by the time this code executes, we already have
 692           # *objects* (since XSA works on 'simple' only by definition).
 693           # If someone is mucking with the symbol table *after* there
 694           # are some objects already - look! many, shiny pieces! :)
 695           #
 696           # The weird breeder thingy is because XSA does not have an
 697           # interface returning *just* a coderef, without installing it
 698           # anywhere :(
 699           Class::XSAccessor->import(
 700             replace => 1,
 701             class => '__CAG__XSA__BREEDER__',
 702             $maker_templates->{$type}{xs_call} => {
 703               $methname => $field,
 704             },
 705           );
 706           __CAG__XSA__BREEDER__->can($methname);
 707         }
 708         else {
 709           if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
 710             # not using Carp since the line where this happens doesn't mean much
 711             warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
 712               . "'$current_class' inheriting from '$class' due to an overriden get_simple and/or "
 713               . "set_simple\n";
 714           }
 715
 716           do {
 717             # that's faster than local
 718             $USE_XS = 0;
 719             my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
 720             $USE_XS = 1;
 721             $c;
 722           };
 723         }
 724       };
 725
 726       # if after this shim was created someone wrapped it with an 'around',
 727       # we can not blindly reinstall the method slot - we will destroy the
 728       # wrapper. Silently chain execution further...
 729       if ( !$expected_cref or $expected_cref != ($current_class->can($methname)||0) ) {
 730
 731         # there is no point in re-determining it on every subsequent call,
 732         # just store for future reference
 733         $cached_implementation->{$current_class} ||= $resolved_implementation;
 734
 735         # older perls segfault if the cref behind the goto throws
 736         # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 737         return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
 738
 739         goto $resolved_implementation;
 740       }
 741
 742       if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
 743         my $deferred_calls_seen = do {
 744           no strict 'refs';
 745           \%{"${current_class}::__cag_deferred_xs_shim_invocations"}
 746         };
 747         my @cframe = caller(0);
 748         if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
 749           Carp::carp (
 750             "Deferred version of method $cframe[3] invoked more than once (originally "
 751           . "invoked at $already_seen). This is a strong indication your code has "
 752           . 'cached the original ->can derived method coderef, and is using it instead '
 753           . 'of the proper method re-lookup, causing performance regressions'
 754           );
 755         }
 756         else {
 757           $deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]";
 758         }
 759       }
 760
 761       # install the resolved implementation into the code slot so we do not
 762       # come here anymore (hopefully)
 763       # since XSAccessor was available - so is Sub::Name
 764       {
 765         no strict 'refs';
 766         no warnings 'redefine';
 767
 768         my $fq_name = "${current_class}::${methname}";
 769         *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
 770
 771         # need to update what the shim expects too *in case* its
 772         # ->can was cached for some moronic reason
 773         $expected_cref = $resolved_implementation;
 774         Scalar::Util::weaken($expected_cref);
 775       }
 776
 777       # older perls segfault if the cref behind the goto throws
 778       # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 779       return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
 780
 781       goto $resolved_implementation;
 782     };
 783
 784     Scalar::Util::weaken($expected_cref); # to break the self-reference
 785     $ret;
 786   }
 787
 788   # no Sub::Name - just install the coderefs directly (compiling every time)
 789   elsif (__CAG_ENV__::NO_SUBNAME) {
 790     my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 791       $maker_templates->{$type}{pp_code}->($group, $field);
 792
 793     no warnings 'redefine';
 794     local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
 795     eval "sub ${class}::${methname} { $src }";
 796
 797     undef;  # so that no further attempt will be made to install anything
 798   }
 799
 800   # a coderef generator with a variable pad (returns a fresh cref on every invocation)
 801   else {
 802     ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
 803       my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 804         $maker_templates->{$type}{pp_code}->($group, $field);
 805
 806       local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
 807       eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
 808     })->()
 809   }
 810 };
 811
 812 1;