1 package Class::Accessor::Grouped;
9 our $VERSION = '0.09007';
10 $VERSION = eval $VERSION;
12 # when changing minimum version don't forget to adjust L</PERFROMANCE> as well
13 our $__minimum_xsa_version = '1.06';
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;
21 my ($xsa_loaded, $xsa_autodetected);
24 return if $xsa_loaded++;
25 require Class::XSAccessor;
26 Class::XSAccessor->VERSION($__minimum_xsa_version);
30 if (defined $USE_XS) {
31 $load_xsa->() if ($USE_XS && ! $xsa_loaded);
35 $xsa_autodetected = 1;
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') {
43 eval { $load_xsa->(); $USE_XS = 1 };
49 my $maker_type_map = {
52 cag => 'make_group_accessor',
56 cag => 'make_group_ro_accessor',
60 cag => 'make_group_wo_accessor',
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
69 my $no_xsa_classes_warned;
70 my $add_xs_accessor = sub {
71 my ($class, $group, $field, $name, $type) = @_;
73 Class::XSAccessor->import({
76 $maker_type_map->{$type}{xsa} => {
81 my $xs_cref = $class->can($name);
84 my $cag_method = $maker_type_map->{$type}{cag};
86 $class->$cag_method ($group, $field, $name, $type);
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");
96 my $current_class = Scalar::Util::blessed( $self ) || $self;
100 $current_class->can("get_$group") == $original_getter
102 $current_class->can("set_$group") == $original_setter
104 # nothing has changed, might as well use the XS crefs
106 # note that by the time this code executes, we already have
107 # *objects* (since XSA works on 'simple' only by definition).
108 # If someone is mucking with the symbol table *after* there
109 # are some objects already - look! many, shiny pieces! :)
110 $final_cref = $xs_cref;
113 $final_cref = $pp_cref;
114 if ($USE_XS and ! $xsa_autodetected and ! $no_xsa_classes_warned->{$current_class}++) {
116 # not using Carp since the line where this happens doesn't mean much
117 warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
118 . "'$current_class' due to an overriden get_$group and/or set_$group\n";
122 # installing an XSA cref that was originally created on a class
123 # different than $current_class is perfectly safe as per
125 my $fq_meth = "${current_class}::${name}";
128 no warnings qw/redefine/;
130 *$fq_meth = Sub::Name::subname($fq_meth, $final_cref);
136 my $install_group_accessors = sub {
137 my($self, $maker, $group, @fields) = @_;
138 my $class = Scalar::Util::blessed $self || $self;
141 no warnings 'redefine';
143 # So we don't have to do lots of lookups inside the loop.
144 $maker = $self->can($maker) unless ref $maker eq 'CODE';
147 if( $_ eq 'DESTROY' ) {
148 Carp::carp("Having a data accessor named DESTROY in ".
149 "'$class' is unwise.");
152 my ($name, $field) = (ref $_)
157 my $alias = "_${name}_accessor";
159 for my $meth ($name, $alias) {
161 # the maker may elect to not return anything, meaning it already
162 # installed the coderef for us
163 my $cref = $self->$maker($group, $field, $meth)
166 my $fq_meth = join('::', $class, $meth);
168 *$fq_meth = Sub::Name::subname($fq_meth, $cref);
169 #unless defined &{$class."\:\:$field"}
177 Class::Accessor::Grouped - Lets you build groups of accessors
183 This class lets you build groups of accessors that will call different
188 =head2 mk_group_accessors
192 =item Arguments: $group, @fieldspec
198 Creates a set of accessors in a given group.
200 $group is the name of the accessor group for the generated accessors; they
201 will call get_$group($field) on get and set_$group($field, $value) on set.
203 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
204 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
207 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
208 this is used as both field and accessor name, if a listref it is expected to
209 be of the form [ $accessor, $field ].
213 sub mk_group_accessors {
214 my ($self, $group, @fields) = @_;
216 $self->$install_group_accessors('make_group_accessor', $group, @fields);
220 =head2 mk_group_ro_accessors
224 =item Arguments: $group, @fieldspec
230 Creates a set of read only accessors in a given group. Identical to
231 L</mk_group_accessors> but accessors will throw an error if passed a value
232 rather than setting the value.
236 sub mk_group_ro_accessors {
237 my($self, $group, @fields) = @_;
239 $self->$install_group_accessors('make_group_ro_accessor', $group, @fields);
242 =head2 mk_group_wo_accessors
246 =item Arguments: $group, @fieldspec
252 Creates a set of write only accessors in a given group. Identical to
253 L</mk_group_accessors> but accessors will throw an error if not passed a
254 value rather than getting the value.
258 sub mk_group_wo_accessors {
259 my($self, $group, @fields) = @_;
261 $self->$install_group_accessors('make_group_wo_accessor', $group, @fields);
264 =head2 make_group_accessor
268 =item Arguments: $group, $field, $method
270 Returns: \&accessor_coderef ?
274 Called by mk_group_accessors for each entry in @fieldspec. Either returns
275 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
276 C<undef> if it elects to install the coderef on its own.
280 sub make_group_accessor {
281 my ($class, $group, $field, $name) = @_;
283 if ( $group eq 'simple' && $use_xs->() ) {
284 return $add_xs_accessor->(@_, 'rw');
287 my $set = "set_$group";
288 my $get = "get_$group";
292 # eval for faster fastiness
293 my $code = eval "sub {
295 return shift->$set('$field', \@_);
298 return shift->$get('$field');
301 Carp::croak $@ if $@;
306 =head2 make_group_ro_accessor
310 =item Arguments: $group, $field, $method
312 Returns: \&accessor_coderef ?
316 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
317 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
318 C<undef> if it elects to install the coderef on its own.
322 sub make_group_ro_accessor {
323 my($class, $group, $field, $name) = @_;
325 if ( $group eq 'simple' && $use_xs->() ) {
326 return $add_xs_accessor->(@_, 'ro');
329 my $get = "get_$group";
333 my $code = eval "sub {
335 my \$caller = caller;
336 Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
337 \"objects of class '$class'\");
340 return shift->$get('$field');
343 Carp::croak $@ if $@;
348 =head2 make_group_wo_accessor
352 =item Arguments: $group, $field, $method
354 Returns: \&accessor_coderef ?
358 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
359 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
360 C<undef> if it elects to install the coderef on its own.
364 sub make_group_wo_accessor {
365 my($class, $group, $field, $name) = @_;
367 if ( $group eq 'simple' && $use_xs->() ) {
368 return $add_xs_accessor->(@_, 'wo')
371 my $set = "set_$group";
375 my $code = eval "sub {
377 my \$caller = caller;
378 Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
379 \"objects of class '$class'\");
382 return shift->$set('$field', \@_);
385 Carp::croak $@ if $@;
394 =item Arguments: $field
400 Simple getter for hash-based objects which returns the value for the field
401 name passed as an argument.
406 return $_[0]->{$_[1]};
413 =item Arguments: $field, $new_value
419 Simple setter for hash-based objects which sets and then returns the value
420 for the field name passed as an argument.
425 return $_[0]->{$_[1]} = $_[2];
433 =item Arguments: $field
439 Simple getter for Classes and hash-based objects which returns the value for
440 the field name passed as an argument. This behaves much like
441 L<Class::Data::Accessor> where the field can be set in a base class,
442 inherited and changed in subclasses, and inherited and changed for object
450 if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
451 if (Scalar::Util::reftype $_[0] eq 'HASH') {
452 return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
455 Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
463 no warnings 'uninitialized';
465 my $cag_slot = '::__cag_'. $_[1];
466 return ${$class.$cag_slot} if defined(${$class.$cag_slot});
468 # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
469 my $cur_gen = mro::get_pkg_gen ($class);
470 if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
471 @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
472 ${$class.'::__cag_pkg_gen__'} = $cur_gen;
475 for (@{$class.'::__cag_supers__'}) {
476 return ${$_.$cag_slot} if defined(${$_.$cag_slot});
486 =item Arguments: $field, $new_value
492 Simple setter for Classes and hash-based objects which sets and then returns
493 the value for the field name passed as an argument. When called on a hash-based
494 object it will set the appropriate hash key value. When called on a class, it
495 will set a class level variable.
497 B<Note:>: This method will die if you try to set an object variable on a non
503 if (defined Scalar::Util::blessed $_[0]) {
504 if (Scalar::Util::reftype $_[0] eq 'HASH') {
505 return $_[0]->{$_[1]} = $_[2];
507 Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
512 return ${$_[0].'::__cag_'.$_[1]} = $_[2];
516 =head2 get_component_class
520 =item Arguments: $field
526 Gets the value of the specified component class.
528 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
530 $self->result_class->method();
533 $self->get_component_class('result_class')->method();
537 sub get_component_class {
538 return $_[0]->get_inherited($_[1]);
541 =head2 set_component_class
545 =item Arguments: $field, $class
551 Inherited accessor that automatically loads the specified class before setting
552 it. This method will die if the specified class could not be loaded.
554 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
555 __PACKAGE__->result_class('MyClass');
557 $self->result_class->method();
561 sub set_component_class {
564 require Class::Inspector;
565 if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
568 Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
572 return $_[0]->set_inherited($_[1], $_[2]);
575 =head2 get_super_paths
577 Returns a list of 'parent' or 'super' class names that the current class inherited from.
581 sub get_super_paths {
582 return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
589 To provide total flexibility L<Class::Accessor::Grouped> calls methods
590 internally while performing get/set actions, which makes it noticeably
591 slower than similar modules. To compensate, this module will automatically
592 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
593 accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is
594 available on your system.
598 This is the result of a set/get/set loop benchmark on perl 5.12.1 with
599 thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
600 L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>
601 and L<XSA|Class::XSAccessor>:
603 Rate CAG moOse CAF HANDMADE CAF_XS moUse_XS CAG_XS XSA
604 CAG 1777/s -- -27% -29% -36% -62% -67% -72% -73%
605 moOse 2421/s 36% -- -4% -13% -48% -55% -61% -63%
606 CAF 2511/s 41% 4% -- -10% -47% -53% -60% -61%
607 HANDMADE 2791/s 57% 15% 11% -- -41% -48% -56% -57%
608 CAF_XS 4699/s 164% 94% 87% 68% -- -13% -25% -28%
609 moUse_XS 5375/s 203% 122% 114% 93% 14% -- -14% -18%
610 CAG_XS 6279/s 253% 159% 150% 125% 34% 17% -- -4%
611 XSA 6515/s 267% 169% 159% 133% 39% 21% 4% --
613 Benchmark program is available in the root of the
614 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
616 =head2 Notes on Class::XSAccessor
618 You can force (or disable) the use of L<Class::XSAccessor> before creating a
619 particular C<simple> accessor by either manipulating the global variable
620 C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
621 L<localization|perlfunc/local>, or you can do so before runtime via the
622 C<CAG_USE_XS> environment variable.
624 Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
625 L</set_simple> this module does its best to detect if you are overriding
626 one of these methods and will fall back to using the perl version of the
627 accessor in order to maintain consistency. However be aware that if you
628 enable use of C<Class::XSAccessor> (automatically or explicitly), create
629 an object, invoke a simple accessor on that object, and B<then> manipulate
630 the symbol table to install a C<get/set_simple> override - you get to keep
633 While L<Class::XSAccessor> works surprisingly well for the amount of black
634 magic it tries to pull off, it's still black magic. At present (Sep 2010)
635 the module is known to have problems on Windows under heavy thread-stress
636 (e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
637 will not be used automatically if you are running under C<MSWin32>.
641 Matt S. Trout <mst@shadowcatsystems.co.uk>
643 Christopher H. Laco <claco@chrislaco.com>
647 Caelum: Rafael Kitover <rkitover@cpan.org>
649 groditi: Guillermo Roditi <groditi@cpan.org>
651 Jason Plum <jason.plum@bmmsi.com>
653 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
656 =head1 COPYRIGHT & LICENSE
658 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
660 This program is free software; you can redistribute it and/or modify
661 it under the same terms as perl itself.