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