lib/Class/Accessor/Grouped.pm

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