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