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