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