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.10009';
  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   require B;
  75   # a perl 5.6 kludge
  76   unless (B->can('perlstring')) {
  77     require Data::Dumper;
  78     my $d = Data::Dumper->new([])->Indent(0)->Purity(0)->Pad('')->Useqq(1)->Terse(1)->Freezer('')->Toaster('');
  79     *B::perlstring = sub { $d->Values([shift])->Dump };
  80   }
  81 }
  82
  83 # Yes this method is undocumented
  84 # Yes it should be a private coderef like all the rest at the end of this file
  85 # No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
  86 # %$*@!?&!&#*$!!!
  87
  88 my $illegal_accessors_warned;
  89 sub _mk_group_accessors {
  90   my($self, $maker, $group, @fields) = @_;
  91   my $class = length (ref ($self) ) ? ref ($self) : $self;
  92
  93   no strict 'refs';
  94   no warnings 'redefine';
  95
  96   # So we don't have to do lots of lookups inside the loop.
  97   $maker = $self->can($maker) unless ref $maker;
  98
  99   for (@fields) {
 100
 101     my ($name, $field) = (ref $_) ? (@$_) : ($_, $_);
 102
 103     if ($name !~ /\A[A-Z_a-z][0-9A-Z_a-z]*\z/) {
 104
 105       if ($name =~ /\0/) {
 106         Carp::croak(sprintf
 107           "Illegal accessor name %s - nulls should never appear in stash keys",
 108           B::perlstring($name),
 109         );
 110       }
 111       elsif (! $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ) {
 112         Carp::croak(
 113           "Illegal accessor name '$name'. If you want CAG to attempt creating "
 114         . 'it anyway (possible if Sub::Name is available) set '
 115         . '$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}'
 116         );
 117       }
 118       elsif (__CAG_ENV__::NO_SUBNAME) {
 119         Carp::croak(
 120           "Unable to install accessor with illegal name '$name': "
 121         . 'Sub::Name not available'
 122         );
 123       }
 124       elsif (
 125         # Because one of the former maintainers of DBIC::SL is a raging
 126         # idiot, there is now a ton of DBIC code out there that attempts
 127         # to create column accessors with illegal names. In the interest
 128         # of not cluttering the logs of unsuspecting victims (unsuspecting
 129         # because these accessors are unusuable anyway) we provide an
 130         # explicit "do not warn at all" escape, until all such code is
 131         # fixed (this will be a loooooong time >:(
 132         $ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK} ne 'DO_NOT_WARN'
 133           and
 134         ! $illegal_accessors_warned->{$class}++
 135       ) {
 136         Carp::carp(
 137           "Installing illegal accessor '$name' into $class, see "
 138         . 'documentation for more details'
 139         );
 140       }
 141     }
 142
 143     Carp::carp("Having a data accessor named '$name' in '$class' is unwise.")
 144       if $name =~ /\A(?: DESTROY | AUTOLOAD | CLONE )\z/x;
 145
 146     my $alias = "_${name}_accessor";
 147
 148     for ($name, $alias) {
 149
 150       # the maker may elect to not return anything, meaning it already
 151       # installed the coderef for us (e.g. lack of Sub::Name)
 152       my $cref = $self->$maker($group, $field, $_)
 153         or next;
 154
 155       my $fq_meth = "${class}::$_";
 156
 157       *$fq_meth = Sub::Name::subname($fq_meth, $cref);
 158         #unless defined &{$class."\:\:$field"}
 159     }
 160   }
 161 };
 162
 163 # $gen_accessor coderef is setup at the end for clarity
 164 my $gen_accessor;
 165
 166 =head1 NAME
 167
 168 Class::Accessor::Grouped - Lets you build groups of accessors
 169
 170 =head1 SYNOPSIS
 171
 172  use base 'Class::Accessor::Grouped';
 173
 174  # make basic accessors for objects
 175  __PACKAGE__->mk_group_accessors(simple => qw(id name email));
 176
 177  # make accessor that works for objects and classes
 178  __PACKAGE__->mk_group_accessors(inherited => 'awesome_level');
 179
 180  # make an accessor which calls a custom pair of getters/setters
 181  sub get_column { ... this will be called when you do $obj->name() ... }
 182  sub set_column { ... this will be called when you do $obj->name('foo') ... }
 183  __PACKAGE__->mk_group_accessors(column => 'name');
 184
 185 =head1 DESCRIPTION
 186
 187 This class lets you build groups of accessors that will call different
 188 getters and setters. The documentation of this module still requires a lot
 189 of work (B<< volunteers welcome >.> >>), but in the meantime you can refer to
 190 L<this post|http://lo-f.at/glahn/2009/08/WritingPowerfulAccessorsForPerlClasses.html>
 191 for more information.
 192
 193 =head2 Notes on accessor names
 194
 195 In general method names in Perl are considered identifiers, and as such need to
 196 conform to the identifier specification of C<qr/\A[A-Z_a-z][0-9A-Z_a-z]*\z/>.
 197 While it is rather easy to invoke methods with non-standard names
 198 (C<< $obj->${\"anything goes"} >>), it is not possible to properly declare such
 199 methods without the use of L<Sub::Name>. Since this module must be able to
 200 function identically with and without its optional dependencies, starting with
 201 version C<0.10008> attempting to declare an accessor with a non-standard name
 202 is a fatal error (such operations would silently succeed since version
 203 C<0.08004>, as long as L<Sub::Name> is present, or otherwise would result in a
 204 syntax error during a string eval).
 205
 206 Unfortunately in the years since C<0.08004> a rather large body of code
 207 accumulated in the wild that does attempt to declare accessors with funny
 208 names. One notable perpetrator is L<DBIx::Class::Schema::Loader>, which under
 209 certain conditions could create accessors of the C<column> group which start
 210 with numbers and/or some other punctuation (the proper way would be to declare
 211 columns with the C<accessor> attribute set to C<undef>).
 212
 213 Therefore an escape mechanism is provided via the environment variable
 214 C<CAG_ILLEGAL_ACCESSOR_NAME_OK>. When set to a true value, one warning is
 215 issued B<per class> on attempts to declare an accessor with a non-conforming
 216 name, and as long as L<Sub::Name> is available all accessors will be properly
 217 created. Regardless of this setting, accessor names containing nulls C<"\0">
 218 are disallowed, due to various deficiencies in perl itself.
 219
 220 If your code base has too many instances of illegal accessor declarations, and
 221 a fix is not feasible due to time constraints, it is possible to disable the
 222 warnings altogether by setting C<$ENV{CAG_ILLEGAL_ACCESSOR_NAME_OK}> to
 223 C<DO_NOT_WARN> (observe capitalization).
 224
 225 =head1 METHODS
 226
 227 =head2 mk_group_accessors
 228
 229  __PACKAGE__->mk_group_accessors(simple => 'hair_length', [ hair_color => 'hc' ]);
 230
 231 =over 4
 232
 233 =item Arguments: $group, @fieldspec
 234
 235 Returns: none
 236
 237 =back
 238
 239 Creates a set of accessors in a given group.
 240
 241 $group is the name of the accessor group for the generated accessors; they
 242 will call get_$group($field) on get and set_$group($field, $value) on set.
 243
 244 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
 245 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
 246 methods.
 247
 248 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
 249 this is used as both field and accessor name, if a listref it is expected to
 250 be of the form [ $accessor, $field ].
 251
 252 =cut
 253
 254 sub mk_group_accessors {
 255   my ($self, $group, @fields) = @_;
 256
 257   $self->_mk_group_accessors('make_group_accessor', $group, @fields);
 258   return;
 259 }
 260
 261 =head2 mk_group_ro_accessors
 262
 263  __PACKAGE__->mk_group_ro_accessors(simple => 'birthdate', [ social_security_number => 'ssn' ]);
 264
 265 =over 4
 266
 267 =item Arguments: $group, @fieldspec
 268
 269 Returns: none
 270
 271 =back
 272
 273 Creates a set of read only accessors in a given group. Identical to
 274 L</mk_group_accessors> but accessors will throw an error if passed a value
 275 rather than setting the value.
 276
 277 =cut
 278
 279 sub mk_group_ro_accessors {
 280   my($self, $group, @fields) = @_;
 281
 282   $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 283   return;
 284 }
 285
 286 =head2 mk_group_wo_accessors
 287
 288  __PACKAGE__->mk_group_wo_accessors(simple => 'lie', [ subject => 'subj' ]);
 289
 290 =over 4
 291
 292 =item Arguments: $group, @fieldspec
 293
 294 Returns: none
 295
 296 =back
 297
 298 Creates a set of write only accessors in a given group. Identical to
 299 L</mk_group_accessors> but accessors will throw an error if not passed a
 300 value rather than getting the value.
 301
 302 =cut
 303
 304 sub mk_group_wo_accessors {
 305   my($self, $group, @fields) = @_;
 306
 307   $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 308   return;
 309 }
 310
 311 =head2 get_simple
 312
 313 =over 4
 314
 315 =item Arguments: $field
 316
 317 Returns: $value
 318
 319 =back
 320
 321 Simple getter for hash-based objects which returns the value for the field
 322 name passed as an argument.
 323
 324 =cut
 325
 326 sub get_simple {
 327   $_[0]->{$_[1]};
 328 }
 329
 330 =head2 set_simple
 331
 332 =over 4
 333
 334 =item Arguments: $field, $new_value
 335
 336 Returns: $new_value
 337
 338 =back
 339
 340 Simple setter for hash-based objects which sets and then returns the value
 341 for the field name passed as an argument.
 342
 343 =cut
 344
 345 sub set_simple {
 346   $_[0]->{$_[1]} = $_[2];
 347 }
 348
 349
 350 =head2 get_inherited
 351
 352 =over 4
 353
 354 =item Arguments: $field
 355
 356 Returns: $value
 357
 358 =back
 359
 360 Simple getter for Classes and hash-based objects which returns the value for
 361 the field name passed as an argument. This behaves much like
 362 L<Class::Data::Accessor> where the field can be set in a base class,
 363 inherited and changed in subclasses, and inherited and changed for object
 364 instances.
 365
 366 =cut
 367
 368 sub get_inherited {
 369   if ( length (ref ($_[0]) ) ) {
 370     if (Scalar::Util::reftype $_[0] eq 'HASH') {
 371       return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
 372       # everything in @_ is aliased, an assignment won't work
 373       splice @_, 0, 1, ref($_[0]);
 374     }
 375     else {
 376       Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 377     }
 378   }
 379
 380   # if we got this far there is nothing in the instance
 381   # OR this is a class call
 382   # in any case $_[0] contains the class name (see splice above)
 383   no strict 'refs';
 384   no warnings 'uninitialized';
 385
 386   my $cag_slot = '::__cag_'. $_[1];
 387   return ${$_[0].$cag_slot} if defined(${$_[0].$cag_slot});
 388
 389   do { return ${$_.$cag_slot} if defined(${$_.$cag_slot}) }
 390     for $_[0]->get_super_paths;
 391
 392   return undef;
 393 }
 394
 395 =head2 set_inherited
 396
 397 =over 4
 398
 399 =item Arguments: $field, $new_value
 400
 401 Returns: $new_value
 402
 403 =back
 404
 405 Simple setter for Classes and hash-based objects which sets and then returns
 406 the value for the field name passed as an argument. When called on a hash-based
 407 object it will set the appropriate hash key value. When called on a class, it
 408 will set a class level variable.
 409
 410 B<Note:>: This method will die if you try to set an object variable on a non
 411 hash-based object.
 412
 413 =cut
 414
 415 sub set_inherited {
 416   if (length (ref ($_[0]) ) ) {
 417     if (Scalar::Util::reftype $_[0] eq 'HASH') {
 418       return $_[0]->{$_[1]} = $_[2];
 419     } else {
 420       Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 421     };
 422   }
 423
 424   no strict 'refs';
 425   ${$_[0].'::__cag_'.$_[1]} = $_[2];
 426 }
 427
 428 =head2 get_component_class
 429
 430 =over 4
 431
 432 =item Arguments: $field
 433
 434 Returns: $value
 435
 436 =back
 437
 438 Gets the value of the specified component class.
 439
 440  __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 441
 442  $self->result_class->method();
 443
 444  ## same as
 445  $self->get_component_class('result_class')->method();
 446
 447 =cut
 448
 449 sub get_component_class {
 450   $_[0]->get_inherited($_[1]);
 451 };
 452
 453 =head2 set_component_class
 454
 455 =over 4
 456
 457 =item Arguments: $field, $class
 458
 459 Returns: $new_value
 460
 461 =back
 462
 463 Inherited accessor that automatically loads the specified class before setting
 464 it. This method will die if the specified class could not be loaded.
 465
 466  __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 467  __PACKAGE__->result_class('MyClass');
 468
 469  $self->result_class->method();
 470
 471 =cut
 472
 473 sub set_component_class {
 474   if (defined $_[2] and length $_[2]) {
 475     # disable warnings, and prevent $_ being eaten away by a behind-the-scenes
 476     # module loading
 477     local ($^W, $_);
 478
 479     if (__CAG_ENV__::UNSTABLE_DOLLARAT) {
 480       my $err;
 481       {
 482         local $@;
 483         eval { Module::Runtime::use_package_optimistically($_[2]) }
 484           or $err = $@;
 485       }
 486       Carp::croak("Could not load $_[1] '$_[2]': $err") if defined $err;
 487
 488     }
 489     else {
 490       eval { Module::Runtime::use_package_optimistically($_[2]) }
 491         or Carp::croak("Could not load $_[1] '$_[2]': $@");
 492     }
 493   };
 494
 495   $_[0]->set_inherited($_[1], $_[2]);
 496 };
 497
 498 =head1 INTERNAL METHODS
 499
 500 These methods are documented for clarity, but are never meant to be called
 501 directly, and are not really meant for overriding either.
 502
 503 =head2 get_super_paths
 504
 505 Returns a list of 'parent' or 'super' class names that the current class
 506 inherited from. This is what drives the traversal done by L</get_inherited>.
 507
 508 =cut
 509
 510 sub get_super_paths {
 511   # get_linear_isa returns the class itself as the 1st element
 512   # use @_ as a pre-allocated scratch array
 513   (undef, @_) = @{mro::get_linear_isa( length( ref($_[0]) ) ? ref($_[0]) : $_[0] )};
 514   @_;
 515 };
 516
 517 =head2 make_group_accessor
 518
 519  __PACKAGE__->make_group_accessor('simple', 'hair_length', 'hair_length');
 520  __PACKAGE__->make_group_accessor('simple', 'hc', 'hair_color');
 521
 522 =over 4
 523
 524 =item Arguments: $group, $field, $accessor
 525
 526 Returns: \&accessor_coderef ?
 527
 528 =back
 529
 530 Called by mk_group_accessors for each entry in @fieldspec. Either returns
 531 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 532 C<undef> if it elects to install the coderef on its own.
 533
 534 =cut
 535
 536 sub make_group_accessor { $gen_accessor->('rw', @_) }
 537
 538 =head2 make_group_ro_accessor
 539
 540  __PACKAGE__->make_group_ro_accessor('simple', 'birthdate', 'birthdate');
 541  __PACKAGE__->make_group_ro_accessor('simple', 'ssn', 'social_security_number');
 542
 543 =over 4
 544
 545 =item Arguments: $group, $field, $accessor
 546
 547 Returns: \&accessor_coderef ?
 548
 549 =back
 550
 551 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
 552 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 553 C<undef> if it elects to install the coderef on its own.
 554
 555 =cut
 556
 557 sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
 558
 559 =head2 make_group_wo_accessor
 560
 561  __PACKAGE__->make_group_wo_accessor('simple', 'lie', 'lie');
 562  __PACKAGE__->make_group_wo_accessor('simple', 'subj', 'subject');
 563
 564 =over 4
 565
 566 =item Arguments: $group, $field, $accessor
 567
 568 Returns: \&accessor_coderef ?
 569
 570 =back
 571
 572 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
 573 a coderef which will be installed at C<&__PACKAGE__::$accessor>, or returns
 574 C<undef> if it elects to install the coderef on its own.
 575
 576 =cut
 577
 578 sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
 579
 580
 581 =head1 PERFORMANCE
 582
 583 To provide total flexibility L<Class::Accessor::Grouped> calls methods
 584 internally while performing get/set actions, which makes it noticeably
 585 slower than similar modules. To compensate, this module will automatically
 586 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
 587 accessors if this module is available on your system.
 588
 589 =head2 Benchmark
 590
 591 This is the benchmark of 200 get/get/set/get/set cycles on perl 5.16.2 with
 592 thread support, showcasing how this modules L<simple (CAG_S)|/get_simple>,
 593 L<inherited (CAG_INH)|/get_inherited> and L<inherited with parent-class data
 594 (CAG_INHP)|/get_inherited> accessors stack up against most popular accessor
 595 builders:  L<Moose>, L<Moo>, L<Mo>, L<Mouse> (both pure-perl and XS variant),
 596 L<Object::Tiny::RW (OTRW)|Object::Tiny::RW>,
 597 L<Class::Accessor (CA)|Class::Accessor>,
 598 L<Class::Accessor::Lite (CAL)|Class::Accessor::Lite>,
 599 L<Class::Accessor::Fast (CAF)|Class::Accessor::Fast>,
 600 L<Class::Accessor::Fast::XS (CAF_XS)|Class::Accessor::Fast::XS>
 601 and L<Class::XSAccessor (XSA)|Class::XSAccessor>
 602
 603                       Rate CAG_INHP CAG_INH     CA  CAG_S    CAF  moOse   OTRW    CAL     mo  moUse HANDMADE    moo CAF_XS moUse_XS    XSA
 604
 605  CAG_INHP  287.021+-0.02/s       --   -0.3% -10.0% -37.1% -53.1% -53.6% -53.7% -54.1% -56.9% -59.0%   -59.6% -59.8% -78.7%   -81.9% -83.5%
 606
 607  CAG_INH  288.025+-0.031/s     0.3%      --  -9.7% -36.9% -52.9% -53.5% -53.5% -53.9% -56.7% -58.8%   -59.5% -59.7% -78.6%   -81.9% -83.5%
 608
 609  CA       318.967+-0.047/s    11.1%   10.7%     -- -30.1% -47.9% -48.5% -48.5% -49.0% -52.1% -54.4%   -55.1% -55.3% -76.3%   -79.9% -81.7%
 610
 611  CAG_S    456.107+-0.054/s    58.9%   58.4%  43.0%     -- -25.4% -26.3% -26.4% -27.0% -31.5% -34.8%   -35.8% -36.1% -66.1%   -71.3% -73.9%
 612
 613  CAF      611.745+-0.099/s   113.1%  112.4%  91.8%  34.1%     --  -1.2%  -1.2%  -2.1%  -8.1% -12.6%   -14.0% -14.3% -54.5%   -61.5% -64.9%
 614
 615  moOse    619.051+-0.059/s   115.7%  114.9%  94.1%  35.7%   1.2%     --  -0.1%  -1.0%  -7.0% -11.6%   -12.9% -13.3% -54.0%   -61.0% -64.5%
 616
 617  OTRW       619.475+-0.1/s   115.8%  115.1%  94.2%  35.8%   1.3%   0.1%     --  -0.9%  -6.9% -11.5%   -12.9% -13.2% -54.0%   -61.0% -64.5%
 618
 619  CAL      625.106+-0.085/s   117.8%  117.0%  96.0%  37.1%   2.2%   1.0%   0.9%     --  -6.1% -10.7%   -12.1% -12.5% -53.5%   -60.6% -64.2%
 620
 621  mo         665.44+-0.12/s   131.8%  131.0% 108.6%  45.9%   8.8%   7.5%   7.4%   6.5%     --  -4.9%    -6.4%  -6.8% -50.5%   -58.1% -61.9%
 622
 623  moUse       699.9+-0.15/s   143.9%  143.0% 119.4%  53.5%  14.4%  13.1%  13.0%  12.0%   5.2%     --    -1.6%  -2.0% -48.0%   -55.9% -59.9%
 624
 625  HANDMADE   710.98+-0.16/s   147.7%  146.8% 122.9%  55.9%  16.2%  14.9%  14.8%  13.7%   6.8%   1.6%       --  -0.4% -47.2%   -55.2% -59.2%
 626
 627  moo        714.04+-0.13/s   148.8%  147.9% 123.9%  56.6%  16.7%  15.3%  15.3%  14.2%   7.3%   2.0%     0.4%     -- -46.9%   -55.0% -59.1%
 628
 629  CAF_XS   1345.55+-0.051/s   368.8%  367.2% 321.8% 195.0% 120.0% 117.4% 117.2% 115.3% 102.2%  92.2%    89.3%  88.4%     --   -15.3% -22.9%
 630
 631  moUse_XS    1588+-0.036/s   453.3%  451.3% 397.9% 248.2% 159.6% 156.5% 156.3% 154.0% 138.6% 126.9%   123.4% 122.4%  18.0%       --  -9.0%
 632
 633  XSA      1744.67+-0.052/s   507.9%  505.7% 447.0% 282.5% 185.2% 181.8% 181.6% 179.1% 162.2% 149.3%   145.4% 144.3%  29.7%     9.9%     --
 634
 635 Benchmarking program is available in the root of the
 636 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
 637
 638 =head2 Notes on Class::XSAccessor
 639
 640 You can force (or disable) the use of L<Class::XSAccessor> before creating a
 641 particular C<simple> accessor by either manipulating the global variable
 642 C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
 643 L<localization|perlfunc/local>, or you can do so before runtime via the
 644 C<CAG_USE_XS> environment variable.
 645
 646 Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
 647 L</set_simple> this module does its best to detect if you are overriding
 648 one of these methods and will fall back to using the perl version of the
 649 accessor in order to maintain consistency. However be aware that if you
 650 enable use of C<Class::XSAccessor> (automatically or explicitly), create
 651 an object, invoke a simple accessor on that object, and B<then> manipulate
 652 the symbol table to install a C<get/set_simple> override - you get to keep
 653 all the pieces.
 654
 655 =head1 AUTHORS
 656
 657 Matt S. Trout <mst@shadowcatsystems.co.uk>
 658
 659 Christopher H. Laco <claco@chrislaco.com>
 660
 661 =head1 CONTRIBUTORS
 662
 663 Caelum: Rafael Kitover <rkitover@cpan.org>
 664
 665 frew: Arthur Axel "fREW" Schmidt <frioux@gmail.com>
 666
 667 groditi: Guillermo Roditi <groditi@cpan.org>
 668
 669 Jason Plum <jason.plum@bmmsi.com>
 670
 671 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 672
 673
 674 =head1 COPYRIGHT & LICENSE
 675
 676 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 677
 678 This program is free software; you can redistribute it and/or modify
 679 it under the same terms as perl itself.
 680
 681 =cut
 682
 683 ########################################################################
 684 ########################################################################
 685 ########################################################################
 686 #
 687 # Here be many angry dragons
 688 # (all code is in private coderefs since everything inherits CAG)
 689 #
 690 ########################################################################
 691 ########################################################################
 692
 693 # Autodetect unless flag supplied
 694 my $xsa_autodetected;
 695 if (! defined $USE_XS) {
 696   $USE_XS = __CAG_ENV__::NO_CXSA ? 0 : 1;
 697   $xsa_autodetected++;
 698 }
 699
 700
 701 my $maker_templates = {
 702   rw => {
 703     cxsa_call => 'accessors',
 704     pp_generator => sub {
 705       # my ($group, $fieldname) = @_;
 706       my $quoted_fieldname = B::perlstring($_[1]);
 707       sprintf <<'EOS', ($_[0], $quoted_fieldname) x 2;
 708
 709 @_ > 1
 710   ? shift->set_%s(%s, @_)
 711   : shift->get_%s(%s)
 712 EOS
 713
 714     },
 715   },
 716   ro => {
 717     cxsa_call => 'getters',
 718     pp_generator => sub {
 719       # my ($group, $fieldname) = @_;
 720       my $quoted_fieldname = B::perlstring($_[1]);
 721       sprintf  <<'EOS', $_[0], $quoted_fieldname;
 722
 723 @_ > 1
 724   ? do {
 725     my ($meth) = (caller(0))[3] =~ /([^\:]+)$/;
 726     my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0];
 727     Carp::croak(
 728       "'$meth' cannot alter its value (read-only attribute of class $class)"
 729     );
 730   }
 731   : shift->get_%s(%s)
 732 EOS
 733
 734     },
 735   },
 736   wo => {
 737     cxsa_call => 'setters',
 738     pp_generator => sub {
 739       # my ($group, $fieldname) = @_;
 740       my $quoted_fieldname = B::perlstring($_[1]);
 741       sprintf  <<'EOS', $_[0], $quoted_fieldname;
 742
 743 @_ > 1
 744   ? shift->set_%s(%s, @_)
 745   : do {
 746     my ($meth) = (caller(0))[3] =~ /([^\:]+)$/;
 747     my $class = length( ref($_[0]) ) ? ref($_[0]) : $_[0];
 748     Carp::croak(
 749       "'$meth' cannot access its value (write-only attribute of class $class)"
 750     );
 751   }
 752 EOS
 753
 754     },
 755   },
 756 };
 757
 758 my $cag_eval = sub {
 759   #my ($src, $no_warnings, $err_msg) = @_;
 760
 761   my $src = sprintf "{ %s warnings; use strict; no strict 'refs'; %s }",
 762     $_[1] ? 'no' : 'use',
 763     $_[0],
 764   ;
 765
 766   my (@rv, $err);
 767   {
 768     local $@ if __CAG_ENV__::UNSTABLE_DOLLARAT;
 769     wantarray
 770       ? @rv = eval $src
 771       : $rv[0] = eval $src
 772     ;
 773     $err = $@ if $@ ne '';
 774   }
 775
 776   Carp::croak(join ': ', ($_[2] || 'String-eval failed'), "$err\n$src\n" )
 777     if defined $err;
 778
 779   wantarray ? @rv : $rv[0];
 780 };
 781
 782 my ($accessor_maker_cache, $no_xsa_warned_classes);
 783
 784 # can't use pkg_gen to track this stuff, as it doesn't
 785 # detect superclass mucking
 786 my $original_simple_getter = __PACKAGE__->can ('get_simple');
 787 my $original_simple_setter = __PACKAGE__->can ('set_simple');
 788
 789 my ($resolved_methods, $cag_produced_crefs);
 790
 791 # Note!!! Unusual signature
 792 $gen_accessor = sub {
 793   my ($type, $class, $group, $field, $methname) = @_;
 794   $class = ref $class if length ref $class;
 795
 796   # When installing an XSA simple accessor, we need to make sure we are not
 797   # short-circuiting a (compile or runtime) get_simple/set_simple override.
 798   # What we do here is install a lazy first-access check, which will decide
 799   # the ultimate coderef being placed in the accessor slot
 800   #
 801   # Also note that the *original* class will always retain this shim, as
 802   # different branches inheriting from it may have different overrides.
 803   # Thus the final method (properly labeled and all) is installed in the
 804   # calling-package's namespace
 805   if ($USE_XS and $group eq 'simple') {
 806     die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_ENV__::NO_CXSA )
 807       if __CAG_ENV__::NO_CXSA;
 808
 809     my $ret = sub {
 810       my $current_class = length (ref ($_[0] ) ) ? ref ($_[0]) : $_[0];
 811
 812       my $resolved_implementation = $resolved_methods->{$current_class}{$methname} ||= do {
 813         if (
 814           ($current_class->can('get_simple')||0) == $original_simple_getter
 815             &&
 816           ($current_class->can('set_simple')||0) == $original_simple_setter
 817         ) {
 818           # nothing has changed, might as well use the XS crefs
 819           #
 820           # note that by the time this code executes, we already have
 821           # *objects* (since XSA works on 'simple' only by definition).
 822           # If someone is mucking with the symbol table *after* there
 823           # are some objects already - look! many, shiny pieces! :)
 824           #
 825           # The weird breeder thingy is because XSA does not have an
 826           # interface returning *just* a coderef, without installing it
 827           # anywhere :(
 828           Class::XSAccessor->import(
 829             replace => 1,
 830             class => '__CAG__XSA__BREEDER__',
 831             $maker_templates->{$type}{cxsa_call} => {
 832               $methname => $field,
 833             },
 834           );
 835           __CAG__XSA__BREEDER__->can($methname);
 836         }
 837         else {
 838           if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
 839             # not using Carp since the line where this happens doesn't mean much
 840             warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
 841               . "'$current_class' inheriting from '$class' due to an overriden get_simple and/or "
 842               . "set_simple\n";
 843           }
 844
 845           do {
 846             # that's faster than local
 847             $USE_XS = 0;
 848             my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
 849             $USE_XS = 1;
 850             $c;
 851           };
 852         }
 853       };
 854
 855       # if after this shim was created someone wrapped it with an 'around',
 856       # we can not blindly reinstall the method slot - we will destroy the
 857       # wrapper. Silently chain execution further...
 858       if ( ! $cag_produced_crefs->{ $current_class->can($methname) || 0 } ) {
 859
 860         # older perls segfault if the cref behind the goto throws
 861         # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 862         return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
 863
 864         goto $resolved_implementation;
 865       }
 866
 867
 868       if (__CAG_ENV__::TRACK_UNDEFER_FAIL) {
 869         my $deferred_calls_seen = do {
 870           no strict 'refs';
 871           \%{"${current_class}::__cag_deferred_xs_shim_invocations"}
 872         };
 873         my @cframe = caller(0);
 874
 875         if (my $already_seen = $deferred_calls_seen->{$cframe[3]}) {
 876           Carp::carp (
 877             "Deferred version of method $cframe[3] invoked more than once (originally "
 878           . "invoked at $already_seen). This is a strong indication your code has "
 879           . 'cached the original ->can derived method coderef, and is using it instead '
 880           . 'of the proper method re-lookup, causing minor performance regressions'
 881           );
 882         }
 883         else {
 884           $deferred_calls_seen->{$cframe[3]} = "$cframe[1] line $cframe[2]";
 885         }
 886       }
 887
 888       # install the resolved implementation into the code slot so we do not
 889       # come here anymore (hopefully)
 890       # since XSAccessor was available - so is Sub::Name
 891       {
 892         no strict 'refs';
 893         no warnings 'redefine';
 894
 895         my $fq_name = "${current_class}::${methname}";
 896         *$fq_name = Sub::Name::subname($fq_name, $resolved_implementation);
 897       }
 898
 899       # now things are installed - one ref less to carry
 900       delete $resolved_methods->{$current_class}{$methname};
 901
 902       # but need to record it in the expectation registry *in case* it
 903       # was cached via ->can for some moronic reason
 904       Scalar::Util::weaken( $cag_produced_crefs->{$resolved_implementation} = $resolved_implementation );
 905
 906
 907       # older perls segfault if the cref behind the goto throws
 908       # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
 909       return $resolved_implementation->(@_) if __CAG_ENV__::BROKEN_GOTO;
 910
 911       goto $resolved_implementation;
 912     };
 913
 914     Scalar::Util::weaken($cag_produced_crefs->{$ret} = $ret);
 915
 916     $ret; # returning shim
 917   }
 918
 919   # no Sub::Name - just install the coderefs directly (compiling every time)
 920   elsif (__CAG_ENV__::NO_SUBNAME) {
 921     my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 922       $maker_templates->{$type}{pp_generator}->($group, $field);
 923
 924     $cag_eval->(
 925       "no warnings 'redefine'; sub ${class}::${methname} { $src }; 1",
 926     );
 927
 928     undef;  # so that no further attempt will be made to install anything
 929   }
 930
 931   # a coderef generator with a variable pad (returns a fresh cref on every invocation)
 932   else {
 933     ($accessor_maker_cache->{pp}{$type}{$group}{$field} ||= do {
 934       my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
 935         $maker_templates->{$type}{pp_generator}->($group, $field);
 936
 937       $cag_eval->( "sub { my \$dummy; sub { \$dummy if 0; $src } }" );
 938     })->()
 939   }
 940 };
 941
 942 1;