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 my $cag_eval = sub {
 658   #my ($src, $no_warnings, $err_msg) = @_;
 659
 660   my $src = sprintf "{ %s warnings; use strict; no strict 'refs'; %s }",
 661     $_[1] ? 'no' : 'use',
 662     $_[0],
 663   ;
 664
 665   my (@rv, $err);
 666   {
 667     local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
 668     wantarray
 669       ? @rv = eval $src
 670       : $rv[0] = eval $src
 671     ;
 672     $err = $@ if $@ ne '';
 673   }
 674
 675   Carp::croak(join ': ', ($_[2] || 'String-eval failed'), "$err\n$src\n" )
 676     if defined $err;
 677
 678   wantarray ? @rv : $rv[0];
 679 };
 680
 681 my ($accessor_maker_cache, $no_xsa_warned_classes);
 682
 683 # can't use pkg_gen to track this stuff, as it doesn't
 684 # detect superclass mucking
 685 my $original_simple_getter = __PACKAGE__->can ('get_simple');
 686 my $original_simple_setter = __PACKAGE__->can ('set_simple');
 687
 688 # Note!!! Unusual signature
 689 $gen_accessor = sub {
 690   my ($type, $class, $group, $field, $methname) = @_;
 691   $class = ref $class if length ref $class;
 692
 693   # When installing an XSA simple accessor, we need to make sure we are not
 694   # short-circuiting a (compile or runtime) get_simple/set_simple override.
 695   # What we do here is install a lazy first-access check, which will decide
 696   # the ultimate coderef being placed in the accessor slot
 697   #
 698   # Also note that the *original* class will always retain this shim, as
 699   # different branches inheriting from it may have different overrides.
 700   # Thus the final method (properly labeled and all) is installed in the
 701   # calling-package's namespace
 702   if ($USE_XS and $group eq 'simple') {
 703     die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA )
 704       if __CAG_ENV__::NO_CXSA;
 705
 706     my ($expected_cref, $cached_implementation);
 707     my $ret = $expected_cref = sub {
 708       my $current_class = length (ref ($_[0] ) ) ? ref ($_[0]) : $_[0];
 709
 710       # $cached_implementation will be set only if the shim got
 711       # 'around'ed, in which case it is handy to avoid re-running
 712       # this block over and over again
 713       my $resolved_implementation = $cached_implementation->{$current_class} || do {
 714         if (
 715           ($current_class->can('get_simple')||0) == $original_simple_getter
 716             &&
 717           ($current_class->can('set_simple')||0) == $original_simple_setter
 718         ) {
 719           # nothing has changed, might as well use the XS crefs
 720           #
 721           # note that by the time this code executes, we already have
 722           # *objects* (since XSA works on 'simple' only by definition).
 723           # If someone is mucking with the symbol table *after* there
 724           # are some objects already - look! many, shiny pieces! :)
 725           #
 726           # The weird breeder thingy is because XSA does not have an
 727           # interface returning *just* a coderef, without installing it
 728           # anywhere :(
 729           Class::XSAccessor->import(
 730             replace => 1,
 731             class => '__CAG__XSA__BREEDER__',
 732             $maker_templates->{$type}{cxsa_call} => {
 733               $methname => $field,
 734             },
 735           );
 736           __CAG__XSA__BREEDER__->can($methname);
 737         }
 738         else {
 739           if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
 740             # not using Carp since the line where this happens doesn't mean much
 741             warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
 742               . "'$current_class' inheriting from '$class' due to an overriden get_simple and/or "
 743               . "set_simple\n";
 744           }
 745
 746           do {
 747             # that's faster than local
 748             $USE_XS = 0;
 749             my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
 750             $USE_XS = 1;
 751             $c;
 752           };
 753         }
 754       };
 755
 756       # if after this shim was created someone wrapped it with an 'around',
 757       # we can not blindly reinstall the method slot - we will destroy the
 758       # wrapper. Silently chain execution further...
 759       if ( !$expected_cref or $expected_cref != ($current_class->can($methname)||0) ) {
 760
 761         # there is no point in re-determining it on every subsequent call,
 762         # just store for future reference
 763         $cached_implementation->{$current_class} ||= $resolved_implementation;
 764
 765         # older perls segfault if the cref behind the goto throws
 766         # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 767         return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
 768
 769         goto $resolved_implementation;
 770       }
 771
 772       if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
 773         my $deferred_calls_seen = do {
 774           no strict 'refs';
 775           \%{"${current_class}::__cag_deferred_xs_shim_invocations"}
 776         };
 777         my @cframe = caller(0);
 778         if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
 779           Carp::carp (
 780             "Deferred version of method $cframe[3] invoked more than once (originally "
 781           . "invoked at $already_seen). This is a strong indication your code has "
 782           . 'cached the original ->can derived method coderef, and is using it instead '
 783           . 'of the proper method re-lookup, causing minor performance regressions'
 784           );
 785         }
 786         else {
 787           $deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]";
 788         }
 789       }
 790
 791       # install the resolved implementation into the code slot so we do not
 792       # come here anymore (hopefully)
 793       # since XSAccessor was available - so is Sub::Name
 794       {
 795         no strict 'refs';
 796         no warnings 'redefine';
 797
 798         my $fq_name = "${current_class}::${methname}";
 799         *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
 800
 801         # need to update what the shim expects too *in case* its
 802         # ->can was cached for some moronic reason
 803         $expected_cref = $resolved_implementation;
 804         Scalar::Util::weaken($expected_cref);
 805       }
 806
 807       # older perls segfault if the cref behind the goto throws
 808       # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 809       return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
 810
 811       goto $resolved_implementation;
 812     };
 813
 814     Scalar::Util::weaken($expected_cref); # to break the self-reference
 815     $ret;
 816   }
 817
 818   # no Sub::Name - just install the coderefs directly (compiling every time)
 819   elsif (__CAG_ENV__::NO_SUBNAME) {
 820     my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 821       $maker_templates->{$type}{pp_generator}->($group, $field);
 822
 823     $cag_eval->(
 824       "no warnings 'redefine'; sub ${class}::${methname} { $src }; 1",
 825     );
 826
 827     undef;  # so that no further attempt will be made to install anything
 828   }
 829
 830   # a coderef generator with a variable pad (returns a fresh cref on every invocation)
 831   else {
 832     ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
 833       my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 834         $maker_templates->{$type}{pp_generator}->($group, $field);
 835
 836       $cag_eval->( "sub { my \$dummy; sub { \$dummy if 0; $src } }" );
 837     })->()
 838   }
 839 };
 840
 841 1;