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