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 # hide from PAUSE
  33     __CAG_ENV__;
  34
  35   die "Huh?! No minimum C::XSA version?!\n"
  36     unless $__minimum_xsa_version;
  37
  38   local $@;
  39   require constant;
  40
  41   # individual (one const at a time) imports so we are 5.6.2 compatible
  42   # if we can - why not ;)
  43   constant->import( NO_SUBNAME => eval {
  44     Module::Runtime::require_module('Sub::Name')
  45   } ? 0 : "$@" );
  46
  47   constant->import( NO_CXSA => ( !NO_SUBNAME() and eval {
  48     Module::Runtime::use_module('Class::XSAccessor' => $__minimum_xsa_version)
  49   } ) ? 0 : "$@" );
  50
  51   constant->import( BROKEN_GOTO => ($] < '5.008009') ? 1 : 0 );
  52
  53   constant->import( UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0 );
  54
  55   constant->import( TRACK_UNDEFER_FAIL => (
  56     $INC{'Test/Builder.pm'} || $INC{'Test/Builder2.pm'}
  57       and
  58     $0 =~ m|^ x?t / .+ \.t $|x
  59   ) ? 1 : 0 );
  60 }
  61
  62 # Yes this method is undocumented
  63 # Yes it should be a private coderef like all the rest at the end of this file
  64 # No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
  65 # %$*@!?&!&#*$!!!
  66 sub _mk_group_accessors {
  67   my($self, $maker, $group, @fields) = @_;
  68   my $class = length (ref ($self) ) ? ref ($self) : $self;
  69
  70   no strict 'refs';
  71   no warnings 'redefine';
  72
  73   # So we don't have to do lots of lookups inside the loop.
  74   $maker = $self->can($maker) unless ref $maker;
  75
  76   for (@fields) {
  77
  78     my ($name, $field) = (ref $_) ? (@$_) : ($_, $_);
  79
  80     for (qw/DESTROY AUTOLOAD CLONE/) {
  81       Carp::carp("Having a data accessor named '$name' in '$class' is unwise.")
  82         if $name eq $_;
  83     }
  84
  85     my $alias = "_${name}_accessor";
  86
  87     for ($name, $alias) {
  88
  89       # the maker may elect to not return anything, meaning it already
  90       # installed the coderef for us (e.g. lack of Sub::Name)
  91       my $cref = $self->$maker($group, $field, $_)
  92         or next;
  93
  94       my $fq_meth = "${class}::$_";
  95
  96       *$fq_meth = Sub::Name::subname($fq_meth, $cref);
  97         #unless defined &{$class."\:\:$field"}
  98     }
  99   }
 100 };
 101
 102 # coderef is setup at the end for clarity
 103 my $gen_accessor;
 104
 105 =head1 NAME
 106
 107 Class::Accessor::Grouped - Lets you build groups of accessors
 108
 109 =head1 SYNOPSIS
 110
 111  use base 'Class::Accessor::Grouped';
 112
 113  # make basic accessors for objects
 114  __PACKAGE__->mk_group_accessors(simple => qw(id name email));
 115
 116  # make accessor that works for objects and classes
 117  __PACKAGE__->mk_group_accessors(inherited => 'awesome_level');
 118
 119 =head1 DESCRIPTION
 120
 121 This class lets you build groups of accessors that will call different
 122 getters and setters.
 123
 124 =head1 METHODS
 125
 126 =head2 mk_group_accessors
 127
 128  __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]);
 129
 130 =over 4
 131
 132 =item Arguments: $group, @fieldspec
 133
 134 Returns: none
 135
 136 =back
 137
 138 Creates a set of accessors in a given group.
 139
 140 $group is the name of the accessor group for the generated accessors; they
 141 will call get_$group($field) on get and set_$group($field, $value) on set.
 142
 143 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
 144 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
 145 methods.
 146
 147 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
 148 this is used as both field and accessor name, if a listref it is expected to
 149 be of the form [ $accessor, $field ].
 150
 151 =cut
 152
 153 sub mk_group_accessors {
 154   my ($self, $group, @fields) = @_;
 155
 156   $self->_mk_group_accessors('make_group_accessor', $group, @fields);
 157   return;
 158 }
 159
 160 =head2 mk_group_ro_accessors
 161
 162  __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]);
 163
 164 =over 4
 165
 166 =item Arguments: $group, @fieldspec
 167
 168 Returns: none
 169
 170 =back
 171
 172 Creates a set of read only accessors in a given group. Identical to
 173 L</mk_group_accessors> but accessors will throw an error if passed a value
 174 rather than setting the value.
 175
 176 =cut
 177
 178 sub mk_group_ro_accessors {
 179   my($self, $group, @fields) = @_;
 180
 181   $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 182   return;
 183 }
 184
 185 =head2 mk_group_wo_accessors
 186
 187  __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]);
 188
 189 =over 4
 190
 191 =item Arguments: $group, @fieldspec
 192
 193 Returns: none
 194
 195 =back
 196
 197 Creates a set of write only accessors in a given group. Identical to
 198 L</mk_group_accessors> but accessors will throw an error if not passed a
 199 value rather than getting the value.
 200
 201 =cut
 202
 203 sub mk_group_wo_accessors {
 204   my($self, $group, @fields) = @_;
 205
 206   $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 207   return;
 208 }
 209
 210 =head2 get_simple
 211
 212 =over 4
 213
 214 =item Arguments: $field
 215
 216 Returns: $value
 217
 218 =back
 219
 220 Simple getter for hash-based objects which returns the value for the field
 221 name passed as an argument.
 222
 223 =cut
 224
 225 sub get_simple {
 226   $_[0]->{$_[1]};
 227 }
 228
 229 =head2 set_simple
 230
 231 =over 4
 232
 233 =item Arguments: $field, $new_value
 234
 235 Returns: $new_value
 236
 237 =back
 238
 239 Simple setter for hash-based objects which sets and then returns the value
 240 for the field name passed as an argument.
 241
 242 =cut
 243
 244 sub set_simple {
 245   $_[0]->{$_[1]} = $_[2];
 246 }
 247
 248
 249 =head2 get_inherited
 250
 251 =over 4
 252
 253 =item Arguments: $field
 254
 255 Returns: $value
 256
 257 =back
 258
 259 Simple getter for Classes and hash-based objects which returns the value for
 260 the field name passed as an argument. This behaves much like
 261 L<Class::Data::Accessor> where the field can be set in a base class,
 262 inherited and changed in subclasses, and inherited and changed for object
 263 instances.
 264
 265 =cut
 266
 267 sub get_inherited {
 268   if ( length (ref ($_[0]) ) ) {
 269     if (Scalar::Util::reftype $_[0] eq 'HASH') {
 270       return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
 271       # everything in @_ is aliased, an assignment won't work
 272       splice @_, 0, 1, ref($_[0]);
 273     }
 274     else {
 275       Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 276     }
 277   }
 278
 279   # if we got this far there is nothing in the instance
 280   # OR this is a class call
 281   # in any case $_[0] contains the class name (see splice above)
 282   no strict 'refs';
 283   no warnings 'uninitialized';
 284
 285   my $cag_slot = '::__cag_'. $_[1];
 286   return ${$_[0].$cag_slot} if defined(${$_[0].$cag_slot});
 287
 288   do { return ${$_.$cag_slot} if defined(${$_.$cag_slot}) }
 289     for $_[0]->get_super_paths;
 290
 291   return undef;
 292 }
 293
 294 =head2 set_inherited
 295
 296 =over 4
 297
 298 =item Arguments: $field, $new_value
 299
 300 Returns: $new_value
 301
 302 =back
 303
 304 Simple setter for Classes and hash-based objects which sets and then returns
 305 the value for the field name passed as an argument. When called on a hash-based
 306 object it will set the appropriate hash key value. When called on a class, it
 307 will set a class level variable.
 308
 309 B<Note:>: This method will die if you try to set an object variable on a non
 310 hash-based object.
 311
 312 =cut
 313
 314 sub set_inherited {
 315   if (length (ref ($_[0]) ) ) {
 316     if (Scalar::Util::reftype $_[0] eq 'HASH') {
 317       return $_[0]->{$_[1]} = $_[2];
 318     } else {
 319       Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 320     };
 321   }
 322
 323   no strict 'refs';
 324   ${$_[0].'::__cag_'.$_[1]} = $_[2];
 325 }
 326
 327 =head2 get_component_class
 328
 329 =over 4
 330
 331 =item Arguments: $field
 332
 333 Returns: $value
 334
 335 =back
 336
 337 Gets the value of the specified component class.
 338
 339  __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 340
 341  $self->result_class->method();
 342
 343  ## same as
 344  $self->get_component_class('result_class')->method();
 345
 346 =cut
 347
 348 sub get_component_class {
 349   $_[0]->get_inherited($_[1]);
 350 };
 351
 352 =head2 set_component_class
 353
 354 =over 4
 355
 356 =item Arguments: $field, $class
 357
 358 Returns: $new_value
 359
 360 =back
 361
 362 Inherited accessor that automatically loads the specified class before setting
 363 it. This method will die if the specified class could not be loaded.
 364
 365  __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 366  __PACKAGE__->result_class('MyClass');
 367
 368  $self->result_class->method();
 369
 370 =cut
 371
 372 sub set_component_class {
 373   if (defined $_[2] and length $_[2]) {
 374     # disable warnings, and prevent $_ being eaten away by a behind-the-scenes
 375     # module loading
 376     local ($^W, $_);
 377
 378     if (__CAG_ENV__::UNSTABLE_DOLLARAT) {
 379       my $err;
 380       {
 381         local $@;
 382         eval { Module::Runtime::use_package_optimistically($_[2]) }
 383           or $err = $@;
 384       }
 385       Carp::croak("Could not load $_[1] '$_[2]': $err") if defined $err;
 386
 387     }
 388     else {
 389       eval { Module::Runtime::use_package_optimistically($_[2]) }
 390         or Carp::croak("Could not load $_[1] '$_[2]': $@");
 391     }
 392   };
 393
 394   $_[0]->set_inherited($_[1], $_[2]);
 395 };
 396
 397 =head1 INTERNAL METHODS
 398
 399 These methods are documented for clarity, but are never meant to be called
 400 directly, and are not really meant for overriding either.
 401
 402 =head2 get_super_paths
 403
 404 Returns a list of 'parent' or 'super' class names that the current class
 405 inherited from. This is what drives the traversal done by L</get_inherited>.
 406
 407 =cut
 408
 409 sub get_super_paths {
 410   # get_linear_isa returns the class itself as the 1st element
 411   # use @_ as a pre-allocated scratch array
 412   (undef, @_) = @{mro::get_linear_isa( length( ref($_[0]) ) ? ref($_[0]) : $_[0] )};
 413   @_;
 414 };
 415
 416 =head2 make_group_accessor
 417
 418  __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length');
 419  __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color');
 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_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_accessor { $gen_accessor->('rw', @_) }
 436
 437 =head2 make_group_ro_accessor
 438
 439  __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate');
 440  __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number');
 441
 442 =over 4
 443
 444 =item Arguments: $group, $field, $accessor
 445
 446 Returns: \&accessor_coderef ?
 447
 448 =back
 449
 450 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
 451 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 452 C<undef> if it elects to install the coderef on its own.
 453
 454 =cut
 455
 456 sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
 457
 458 =head2 make_group_wo_accessor
 459
 460  __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie');
 461  __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject');
 462
 463 =over 4
 464
 465 =item Arguments: $group, $field, $accessor
 466
 467 Returns: \&accessor_coderef ?
 468
 469 =back
 470
 471 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
 472 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 473 C<undef> if it elects to install the coderef on its own.
 474
 475 =cut
 476
 477 sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
 478
 479
 480 =head1 PERFORMANCE
 481
 482 To provide total flexibility L<Class::Accessor::Grouped> calls methods
 483 internally while performing get/set actions, which makes it noticeably
 484 slower than similar modules. To compensate, this module will automatically
 485 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
 486 accessors if this module is available on your system.
 487
 488 =head2 Benchmark
 489
 490 This is the result of a set/get/set loop benchmark on perl 5.12.1 with
 491 thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
 492 L<Moo>, L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>,
 493 L<XSA|Class::XSAccessor>, and L<CAF_XSA|Class::XSAccessor::Compat>:
 494
 495            Rate  CAG moOse  CAF moUse  moo HANDMADE CAF_XS moUse_XS moo_XS CAF_XSA  XSA CAG_XS
 496  CAG      169/s   --  -21% -24%  -32% -32%     -34%   -59%     -63%   -67%    -67% -67%   -67%
 497  moOse    215/s  27%    --  -3%  -13% -13%     -15%   -48%     -53%   -58%    -58% -58%   -58%
 498  CAF      222/s  31%    3%   --  -10% -10%     -13%   -46%     -52%   -57%    -57% -57%   -57%
 499  moUse    248/s  46%   15%  11%    --  -0%      -3%   -40%     -46%   -52%    -52% -52%   -52%
 500  moo      248/s  46%   15%  11%    0%   --      -3%   -40%     -46%   -52%    -52% -52%   -52%
 501  HANDMADE 255/s  50%   18%  14%    3%   3%       --   -38%     -45%   -50%    -51% -51%   -51%
 502  CAF_XS   411/s 143%   91%  85%   66%  66%      61%     --     -11%   -20%    -20% -21%   -21%
 503  moUse_XS 461/s 172%  114% 107%   86%  86%      81%    12%       --   -10%    -11% -11%   -11%
 504  moo_XS   514/s 204%  139% 131%  107% 107%     102%    25%      12%     --     -0%  -1%    -1%
 505  CAF_XSA  516/s 205%  140% 132%  108% 108%     103%    26%      12%     0%      --  -0%    -0%
 506  XSA      519/s 206%  141% 133%  109% 109%     104%    26%      13%     1%      0%   --    -0%
 507  CAG_XS   519/s 206%  141% 133%  109% 109%     104%    26%      13%     1%      0%   0%     --
 508
 509 Benchmark program is available in the root of the
 510 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
 511
 512 =head2 Notes on Class::XSAccessor
 513
 514 You can force (or disable) the use of L<Class::XSAccessor> before creating a
 515 particular C<simple> accessor by either manipulating the global variable
 516 C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
 517 L<localization|perlfunc/local>, or you can do so before runtime via the
 518 C<CAG_USE_XS> environment variable.
 519
 520 Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
 521 L</set_simple> this module does its best to detect if you are overriding
 522 one of these methods and will fall back to using the perl version of the
 523 accessor in order to maintain consistency. However be aware that if you
 524 enable use of C<Class::XSAccessor> (automatically or explicitly), create
 525 an object, invoke a simple accessor on that object, and B<then> manipulate
 526 the symbol table to install a C<get/set_simple> override - you get to keep
 527 all the pieces.
 528
 529 =head1 AUTHORS
 530
 531 Matt S. Trout <mst@shadowcatsystems.co.uk>
 532
 533 Christopher H. Laco <claco@chrislaco.com>
 534
 535 =head1 CONTRIBUTORS
 536
 537 Caelum: Rafael Kitover <rkitover@cpan.org>
 538
 539 frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
 540
 541 groditi: Guillermo Roditi <groditi@cpan.org>
 542
 543 Jason Plum <jason.plum@bmmsi.com>
 544
 545 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 546
 547
 548 =head1 COPYRIGHT & LICENSE
 549
 550 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 551
 552 This program is free software; you can redistribute it and/or modify
 553 it under the same terms as perl itself.
 554
 555 =cut
 556
 557 ########################################################################
 558 ########################################################################
 559 ########################################################################
 560 #
 561 # Here be many angry dragons
 562 # (all code is in private coderefs since everything inherits CAG)
 563 #
 564 ########################################################################
 565 ########################################################################
 566
 567 # Autodetect unless flag supplied
 568 my $xsa_autodetected;
 569 if (! defined $USE_XS) {
 570   $USE_XS = __CAG_ENV__::NO_CXSA ? 0 : 1;
 571   $xsa_autodetected++;
 572 }
 573
 574 my $maker_templates = {
 575   rw => {
 576     xs_call => 'accessors',
 577     pp_code => sub {
 578       my $set = "set_$_[0]";
 579       my $get = "get_$_[0]";
 580       my $field = $_[1];
 581       $field =~ s/'/\\'/g;
 582
 583       "
 584         \@_ != 1
 585           ? shift->$set('$field', \@_)
 586           : shift->$get('$field')
 587       "
 588     },
 589   },
 590   ro => {
 591     xs_call => 'getters',
 592     pp_code => sub {
 593       my $get = "get_$_[0]";
 594       my $field = $_[1];
 595       $field =~ s/'/\\'/g;
 596
 597       "
 598         \@_ == 1
 599           ? shift->$get('$field')
 600           : do {
 601             my \$caller = caller;
 602             my \$class = length( ref(\$_[0]) ) ? ref(\$_[0]) : \$_[0];
 603             Carp::croak(\"'\$caller' cannot alter the value of '$field' \".
 604                         \"(read-only attributes of class '\$class')\");
 605           }
 606       "
 607     },
 608   },
 609   wo => {
 610     xs_call => 'setters',
 611     pp_code => sub {
 612       my $set = "set_$_[0]";
 613       my $field = $_[1];
 614       $field =~ s/'/\\'/g;
 615
 616       "
 617         \@_ != 1
 618           ? shift->$set('$field', \@_)
 619           : do {
 620             my \$caller = caller;
 621             my \$class = length ( ref(\$_[0]) ) ? ref(\$_[0]) : \$_[0];
 622             Carp::croak(\"'\$caller' cannot access the value of '$field' \".
 623                         \"(write-only attributes of class '\$class')\");
 624           }
 625       "
 626     },
 627   },
 628 };
 629
 630
 631 my ($accessor_maker_cache, $no_xsa_warned_classes);
 632
 633 # can't use pkg_gen to track this stuff, as it doesn't
 634 # detect superclass mucking
 635 my $original_simple_getter = __PACKAGE__->can ('get_simple');
 636 my $original_simple_setter = __PACKAGE__->can ('set_simple');
 637
 638 # Note!!! Unusual signature
 639 $gen_accessor = sub {
 640   my ($type, $class, $group, $field, $methname) = @_;
 641   $class = ref $class if length ref $class;
 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 = length (ref ($_[0] ) ) ? ref ($_[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;