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