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