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