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 MRO::Compat;
   7 use Sub::Name ();
   8
   9 our $VERSION = '0.09006';
  10 $VERSION = eval $VERSION;
  11
  12 # when changing minimum version don't forget to adjust L</PERFROMANCE> as well
  13 our $__minimum_xsa_version = '1.06';
  14
  15 our $USE_XS;
  16 # the unless defined is here so that we can override the value
  17 # before require/use, *regardless* of the state of $ENV{CAG_USE_XS}
  18 $USE_XS = $ENV{CAG_USE_XS}
  19     unless defined $USE_XS;
  20
  21 my ($xsa_loaded, $xsa_autodetected);
  22
  23 my $load_xsa = sub {
  24     return if $xsa_loaded++;
  25     require Class::XSAccessor;
  26     Class::XSAccessor->VERSION($__minimum_xsa_version);
  27 };
  28
  29 my $use_xs = sub {
  30     if (defined $USE_XS) {
  31         $load_xsa->() if ($USE_XS && ! $xsa_loaded);
  32         return $USE_XS;
  33     }
  34
  35     $xsa_autodetected = 1;
  36     $USE_XS = 0;
  37
  38     # Class::XSAccessor is segfaulting on win32, in some
  39     # esoteric heavily-threaded scenarios
  40     # Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
  41     if ($^O ne 'MSWin32') {
  42         local $@;
  43         eval { $load_xsa->(); $USE_XS = 1 };
  44     }
  45
  46     return $USE_XS;
  47 };
  48
  49 my $maker_type_map = {
  50   rw => {
  51     xsa => 'accessors',
  52     cag => 'make_group_accessor',
  53   },
  54   ro => {
  55     xsa => 'getters',
  56     cag => 'make_group_ro_accessor',
  57   },
  58   wo => {
  59     xsa => 'setters',
  60     cag => 'make_group_wo_accessor',
  61   },
  62 };
  63
  64 # When installing an XSA simple accessor, we need to make sure we are not
  65 # short-circuiting a (compile or runtime) get_simple/set_simple override.
  66 # What we do here is install a lazy first-access check, which will decide
  67 # the ultimate coderef being placed in the accessor slot
  68
  69 my $no_xsa_classes_warned;
  70 my $add_xs_accessor = sub {
  71     my ($class, $group, $field, $name, $type) = @_;
  72
  73     Class::XSAccessor->import({
  74         replace => 1,
  75         class => $class,
  76         $maker_type_map->{$type}{xsa} => {
  77             $name => $field,
  78         },
  79     });
  80
  81     my $xs_cref = $class->can($name);
  82
  83     my $pp_cref = do {
  84         my $cag_method = $maker_type_map->{$type}{cag};
  85         local $USE_XS = 0;
  86         $class->$cag_method ($group, $field, $name, $type);
  87     };
  88
  89     # can't use pkg_gen to track this stuff, as it doesn't
  90     # detect superclass mucking
  91     my $original_getter = __PACKAGE__->can ("get_$group");
  92     my $original_setter = __PACKAGE__->can ("set_$group");
  93
  94     return sub {
  95         my $self = $_[0];
  96         my $current_class = (ref $self) || $self;
  97
  98         my $final_cref;
  99         if (
 100             $current_class->can("get_$group") == $original_getter
 101                 &&
 102             $current_class->can("set_$group") == $original_setter
 103         ) {
 104             # nothing has changed, might as well use the XS crefs
 105             # (if one changes methods that far into runtime - look pieces!)
 106             $final_cref = $xs_cref;
 107         }
 108         else {
 109             $final_cref = $pp_cref;
 110             if ($USE_XS and ! $xsa_autodetected and ! $no_xsa_classes_warned->{$current_class}++) {
 111                 warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class'
 112                   . " '$current_class' due to an overriden get_$group and/or set_$group\n";
 113             }
 114         }
 115
 116         my $fq_meth = "${current_class}::${name}";
 117
 118         no strict qw/refs/;
 119         no warnings qw/redefine/;
 120         *$fq_meth = Sub::Name::subname($fq_meth, $final_cref);
 121
 122         goto $final_cref;
 123     };
 124 };
 125
 126 =head1 NAME
 127
 128 Class::Accessor::Grouped - Lets you build groups of accessors
 129
 130 =head1 SYNOPSIS
 131
 132 =head1 DESCRIPTION
 133
 134 This class lets you build groups of accessors that will call different
 135 getters and setters.
 136
 137 =head1 METHODS
 138
 139 =head2 mk_group_accessors
 140
 141 =over 4
 142
 143 =item Arguments: $group, @fieldspec
 144
 145 Returns: none
 146
 147 =back
 148
 149 Creates a set of accessors in a given group.
 150
 151 $group is the name of the accessor group for the generated accessors; they
 152 will call get_$group($field) on get and set_$group($field, $value) on set.
 153
 154 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
 155 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
 156 methods.
 157
 158 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
 159 this is used as both field and accessor name, if a listref it is expected to
 160 be of the form [ $accessor, $field ].
 161
 162 =cut
 163
 164 sub mk_group_accessors {
 165   my ($self, $group, @fields) = @_;
 166
 167   $self->_mk_group_accessors('make_group_accessor', $group, @fields);
 168   return;
 169 }
 170
 171
 172 {
 173     no strict 'refs';
 174     no warnings 'redefine';
 175
 176     sub _mk_group_accessors {
 177         my($self, $maker, $group, @fields) = @_;
 178         my $class = Scalar::Util::blessed $self || $self;
 179
 180         # So we don't have to do lots of lookups inside the loop.
 181         $maker = $self->can($maker) unless ref $maker;
 182
 183         foreach (@fields) {
 184             if( $_ eq 'DESTROY' ) {
 185                 Carp::carp("Having a data accessor named DESTROY  in ".
 186                              "'$class' is unwise.");
 187             }
 188
 189             my ($name, $field) = (ref $_)
 190                 ? (@$_)
 191                 : ($_, $_)
 192             ;
 193
 194             my $alias = "_${name}_accessor";
 195
 196             for my $meth ($name, $alias) {
 197
 198                 # the maker may elect to not return anything, meaning it already
 199                 # installed the coderef for us
 200                 my $cref = $self->$maker($group, $field, $meth)
 201                     or next;
 202
 203                 my $fq_meth = join('::', $class, $meth);
 204
 205                 *$fq_meth = Sub::Name::subname($fq_meth, $cref);
 206                     #unless defined &{$class."\:\:$field"}
 207             }
 208         }
 209     }
 210 }
 211
 212 =head2 mk_group_ro_accessors
 213
 214 =over 4
 215
 216 =item Arguments: $group, @fieldspec
 217
 218 Returns: none
 219
 220 =back
 221
 222 Creates a set of read only accessors in a given group. Identical to
 223 L</mk_group_accessors> but accessors will throw an error if passed a value
 224 rather than setting the value.
 225
 226 =cut
 227
 228 sub mk_group_ro_accessors {
 229     my($self, $group, @fields) = @_;
 230
 231     $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
 232 }
 233
 234 =head2 mk_group_wo_accessors
 235
 236 =over 4
 237
 238 =item Arguments: $group, @fieldspec
 239
 240 Returns: none
 241
 242 =back
 243
 244 Creates a set of write only accessors in a given group. Identical to
 245 L</mk_group_accessors> but accessors will throw an error if not passed a
 246 value rather than getting the value.
 247
 248 =cut
 249
 250 sub mk_group_wo_accessors {
 251     my($self, $group, @fields) = @_;
 252
 253     $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
 254 }
 255
 256 =head2 make_group_accessor
 257
 258 =over 4
 259
 260 =item Arguments: $group, $field, $method
 261
 262 Returns: \&accessor_coderef ?
 263
 264 =back
 265
 266 Called by mk_group_accessors for each entry in @fieldspec. Either returns
 267 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
 268 C<undef> if it elects to install the coderef on its own.
 269
 270 =cut
 271
 272 sub make_group_accessor {
 273     my ($class, $group, $field, $name) = @_;
 274
 275     if ( $group eq 'simple' && $use_xs->() ) {
 276         return $add_xs_accessor->(@_, 'rw');
 277     }
 278
 279     my $set = "set_$group";
 280     my $get = "get_$group";
 281
 282     $field =~ s/'/\\'/g;
 283
 284     # eval for faster fastiness
 285     my $code = eval "sub {
 286         if(\@_ > 1) {
 287             return shift->$set('$field', \@_);
 288         }
 289         else {
 290             return shift->$get('$field');
 291         }
 292     };";
 293     Carp::croak $@ if $@;
 294
 295     return $code;
 296 }
 297
 298 =head2 make_group_ro_accessor
 299
 300 =over 4
 301
 302 =item Arguments: $group, $field, $method
 303
 304 Returns: \&accessor_coderef ?
 305
 306 =back
 307
 308 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
 309 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
 310 C<undef> if it elects to install the coderef on its own.
 311
 312 =cut
 313
 314 sub make_group_ro_accessor {
 315     my($class, $group, $field, $name) = @_;
 316
 317     if ( $group eq 'simple' && $use_xs->() ) {
 318         return $add_xs_accessor->(@_, 'ro');
 319     }
 320
 321     my $get = "get_$group";
 322
 323     $field =~ s/'/\\'/g;
 324
 325     my $code = eval "sub {
 326         if(\@_ > 1) {
 327             my \$caller = caller;
 328             Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
 329                         \"objects of class '$class'\");
 330         }
 331         else {
 332             return shift->$get('$field');
 333         }
 334     };";
 335     Carp::croak $@ if $@;
 336
 337     return $code;
 338 }
 339
 340 =head2 make_group_wo_accessor
 341
 342 =over 4
 343
 344 =item Arguments: $group, $field, $method
 345
 346 Returns: \&accessor_coderef ?
 347
 348 =back
 349
 350 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
 351 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
 352 C<undef> if it elects to install the coderef on its own.
 353
 354 =cut
 355
 356 sub make_group_wo_accessor {
 357     my($class, $group, $field, $name) = @_;
 358
 359     if ( $group eq 'simple' && $use_xs->() ) {
 360         return $add_xs_accessor->(@_, 'wo')
 361     }
 362
 363     my $set = "set_$group";
 364
 365     $field =~ s/'/\\'/g;
 366
 367     my $code = eval "sub {
 368         unless (\@_ > 1) {
 369             my \$caller = caller;
 370             Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
 371                         \"objects of class '$class'\");
 372         }
 373         else {
 374             return shift->$set('$field', \@_);
 375         }
 376     };";
 377     Carp::croak $@ if $@;
 378
 379     return $code;
 380 }
 381
 382 =head2 get_simple
 383
 384 =over 4
 385
 386 =item Arguments: $field
 387
 388 Returns: $value
 389
 390 =back
 391
 392 Simple getter for hash-based objects which returns the value for the field
 393 name passed as an argument.
 394
 395 =cut
 396
 397 sub get_simple {
 398   return $_[0]->{$_[1]};
 399 }
 400
 401 =head2 set_simple
 402
 403 =over 4
 404
 405 =item Arguments: $field, $new_value
 406
 407 Returns: $new_value
 408
 409 =back
 410
 411 Simple setter for hash-based objects which sets and then returns the value
 412 for the field name passed as an argument.
 413
 414 =cut
 415
 416 sub set_simple {
 417   return $_[0]->{$_[1]} = $_[2];
 418 }
 419
 420
 421 =head2 get_inherited
 422
 423 =over 4
 424
 425 =item Arguments: $field
 426
 427 Returns: $value
 428
 429 =back
 430
 431 Simple getter for Classes and hash-based objects which returns the value for
 432 the field name passed as an argument. This behaves much like
 433 L<Class::Data::Accessor> where the field can be set in a base class,
 434 inherited and changed in subclasses, and inherited and changed for object
 435 instances.
 436
 437 =cut
 438
 439 sub get_inherited {
 440     my $class;
 441
 442     if ( ($class = ref $_[0]) && Scalar::Util::blessed $_[0]) {
 443         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 444           return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
 445         }
 446         else {
 447           Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
 448         }
 449     }
 450     else {
 451         $class = $_[0];
 452     }
 453
 454     no strict 'refs';
 455     no warnings qw/uninitialized/;
 456
 457     my $cag_slot = '::__cag_'. $_[1];
 458     return ${$class.$cag_slot} if defined(${$class.$cag_slot});
 459
 460     # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
 461     my $cur_gen = mro::get_pkg_gen ($class);
 462     if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
 463         @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
 464         ${$class.'::__cag_pkg_gen__'} = $cur_gen;
 465     }
 466
 467     for (@{$class.'::__cag_supers__'}) {
 468         return ${$_.$cag_slot} if defined(${$_.$cag_slot});
 469     };
 470
 471     return undef;
 472 }
 473
 474 =head2 set_inherited
 475
 476 =over 4
 477
 478 =item Arguments: $field, $new_value
 479
 480 Returns: $new_value
 481
 482 =back
 483
 484 Simple setter for Classes and hash-based objects which sets and then returns
 485 the value for the field name passed as an argument. When called on a hash-based
 486 object it will set the appropriate hash key value. When called on a class, it
 487 will set a class level variable.
 488
 489 B<Note:>: This method will die if you try to set an object variable on a non
 490 hash-based object.
 491
 492 =cut
 493
 494 sub set_inherited {
 495     if (Scalar::Util::blessed $_[0]) {
 496         if (Scalar::Util::reftype $_[0] eq 'HASH') {
 497             return $_[0]->{$_[1]} = $_[2];
 498         } else {
 499             Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
 500         };
 501     } else {
 502         no strict 'refs';
 503
 504         return ${$_[0].'::__cag_'.$_[1]} = $_[2];
 505     };
 506 }
 507
 508 =head2 get_component_class
 509
 510 =over 4
 511
 512 =item Arguments: $field
 513
 514 Returns: $value
 515
 516 =back
 517
 518 Gets the value of the specified component class.
 519
 520     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 521
 522     $self->result_class->method();
 523
 524     ## same as
 525     $self->get_component_class('result_class')->method();
 526
 527 =cut
 528
 529 sub get_component_class {
 530     return $_[0]->get_inherited($_[1]);
 531 };
 532
 533 =head2 set_component_class
 534
 535 =over 4
 536
 537 =item Arguments: $field, $class
 538
 539 Returns: $new_value
 540
 541 =back
 542
 543 Inherited accessor that automatically loads the specified class before setting
 544 it. This method will die if the specified class could not be loaded.
 545
 546     __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
 547     __PACKAGE__->result_class('MyClass');
 548
 549     $self->result_class->method();
 550
 551 =cut
 552
 553 sub set_component_class {
 554     if ($_[2]) {
 555         local $^W = 0;
 556         require Class::Inspector;
 557         if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
 558             eval "use $_[2]";
 559
 560             Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
 561         };
 562     };
 563
 564     return $_[0]->set_inherited($_[1], $_[2]);
 565 };
 566
 567 =head2 get_super_paths
 568
 569 Returns a list of 'parent' or 'super' class names that the current class inherited from.
 570
 571 =cut
 572
 573 sub get_super_paths {
 574     return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
 575 };
 576
 577 1;
 578
 579 =head1 PERFORMANCE
 580
 581 To provide total flexibility L<Class::Accessor::Grouped> calls methods
 582 internally while performing get/set actions, which makes it noticeably
 583 slower than similar modules. To compensate, this module will automatically
 584 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
 585 accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is
 586 available on your system.
 587
 588 =head2 Benchmark
 589
 590 This is the result of a set/get/set loop benchmark on perl 5.12.1 with
 591 thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
 592 L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>
 593 and L<XSA|Class::XSAccessor>:
 594
 595             Rate     CAG   moOse     CAF HANDMADE  CAF_XS moUse_XS CAG_XS     XSA
 596  CAG      1777/s      --    -27%    -29%     -36%    -62%     -67%   -72%    -73%
 597  moOse    2421/s     36%      --     -4%     -13%    -48%     -55%   -61%    -63%
 598  CAF      2511/s     41%      4%      --     -10%    -47%     -53%   -60%    -61%
 599  HANDMADE 2791/s     57%     15%     11%       --    -41%     -48%   -56%    -57%
 600  CAF_XS   4699/s    164%     94%     87%      68%      --     -13%   -25%    -28%
 601  moUse_XS 5375/s    203%    122%    114%      93%     14%       --   -14%    -18%
 602  CAG_XS   6279/s    253%    159%    150%     125%     34%      17%     --     -4%
 603  XSA      6515/s    267%    169%    159%     133%     39%      21%     4%      --
 604
 605 Benchmark program is available in the root of the
 606 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
 607
 608 =head2 Notes on Class::XSAccessor
 609
 610 While L<Class::XSAccessor> works surprisingly well for the amount of black
 611 magic it tries to pull off, it's still black magic. At present (Sep 2010)
 612 the module is known to have problems on Windows under heavy thread-stress
 613 (e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
 614 will not be used automatically if you are running under C<MSWin32>.
 615
 616 You can force the use of L<Class::XSAccessor> before creating a particular
 617 C<simple> accessor by either manipulating the global variable
 618 C<$Class::Accessor::Grouped::USE_XS>, or you can do so before runtime via the
 619 C<CAG_USE_XS> environment variable.
 620
 621 =head1 AUTHORS
 622
 623 Matt S. Trout <mst@shadowcatsystems.co.uk>
 624
 625 Christopher H. Laco <claco@chrislaco.com>
 626
 627 =head1 CONTRIBUTORS
 628
 629 Caelum: Rafael Kitover <rkitover@cpan.org>
 630
 631 groditi: Guillermo Roditi <groditi@cpan.org>
 632
 633 Jason Plum <jason.plum@bmmsi.com>
 634
 635 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
 636
 637
 638 =head1 COPYRIGHT & LICENSE
 639
 640 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
 641
 642 This program is free software; you can redistribute it and/or modify
 643 it under the same terms as perl itself.
 644
 645 =cut