lib/Class/Accessor/Grouped.pm

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