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