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