lib/Class/Accessor/Grouped.pm

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