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