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);
132 # older perls segfault if the cref behind the goto throws
133 # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
134 return $final_cref->(@_) if ($] < 5.008009);
140 my $install_group_accessors = sub {
141 my($self, $maker, $group, @fields) = @_;
142 my $class = Scalar::Util::blessed $self || $self;
145 no warnings 'redefine';
147 # So we don't have to do lots of lookups inside the loop.
148 $maker = $self->can($maker) unless ref $maker eq 'CODE';
151 if( $_ eq 'DESTROY' ) {
152 Carp::carp("Having a data accessor named DESTROY in ".
153 "'$class' is unwise.");
156 my ($name, $field) = (ref $_)
161 my $alias = "_${name}_accessor";
163 for my $meth ($name, $alias) {
165 # the maker may elect to not return anything, meaning it already
166 # installed the coderef for us
167 my $cref = $self->$maker($group, $field, $meth)
170 my $fq_meth = join('::', $class, $meth);
172 *$fq_meth = Sub::Name::subname($fq_meth, $cref);
173 #unless defined &{$class."\:\:$field"}
181 Class::Accessor::Grouped - Lets you build groups of accessors
187 This class lets you build groups of accessors that will call different
192 =head2 mk_group_accessors
196 =item Arguments: $group, @fieldspec
202 Creates a set of accessors in a given group.
204 $group is the name of the accessor group for the generated accessors; they
205 will call get_$group($field) on get and set_$group($field, $value) on set.
207 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
208 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
211 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
212 this is used as both field and accessor name, if a listref it is expected to
213 be of the form [ $accessor, $field ].
217 sub mk_group_accessors {
218 my ($self, $group, @fields) = @_;
220 $self->$install_group_accessors('make_group_accessor', $group, @fields);
224 =head2 mk_group_ro_accessors
228 =item Arguments: $group, @fieldspec
234 Creates a set of read only accessors in a given group. Identical to
235 L</mk_group_accessors> but accessors will throw an error if passed a value
236 rather than setting the value.
240 sub mk_group_ro_accessors {
241 my($self, $group, @fields) = @_;
243 $self->$install_group_accessors('make_group_ro_accessor', $group, @fields);
246 =head2 mk_group_wo_accessors
250 =item Arguments: $group, @fieldspec
256 Creates a set of write only accessors in a given group. Identical to
257 L</mk_group_accessors> but accessors will throw an error if not passed a
258 value rather than getting the value.
262 sub mk_group_wo_accessors {
263 my($self, $group, @fields) = @_;
265 $self->$install_group_accessors('make_group_wo_accessor', $group, @fields);
268 =head2 make_group_accessor
272 =item Arguments: $group, $field, $method
274 Returns: \&accessor_coderef ?
278 Called by mk_group_accessors for each entry in @fieldspec. Either returns
279 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
280 C<undef> if it elects to install the coderef on its own.
284 sub make_group_accessor {
285 my ($class, $group, $field, $name) = @_;
287 if ( $group eq 'simple' && $use_xs->() ) {
288 return $add_xs_accessor->(@_, 'rw');
291 my $set = "set_$group";
292 my $get = "get_$group";
296 # eval for faster fastiness
297 my $code = eval "sub {
299 return shift->$set('$field', \@_);
302 return shift->$get('$field');
305 Carp::croak $@ if $@;
310 =head2 make_group_ro_accessor
314 =item Arguments: $group, $field, $method
316 Returns: \&accessor_coderef ?
320 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
321 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
322 C<undef> if it elects to install the coderef on its own.
326 sub make_group_ro_accessor {
327 my($class, $group, $field, $name) = @_;
329 if ( $group eq 'simple' && $use_xs->() ) {
330 return $add_xs_accessor->(@_, 'ro');
333 my $get = "get_$group";
337 my $code = eval "sub {
339 my \$caller = caller;
340 Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
341 \"objects of class '$class'\");
344 return shift->$get('$field');
347 Carp::croak $@ if $@;
352 =head2 make_group_wo_accessor
356 =item Arguments: $group, $field, $method
358 Returns: \&accessor_coderef ?
362 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
363 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
364 C<undef> if it elects to install the coderef on its own.
368 sub make_group_wo_accessor {
369 my($class, $group, $field, $name) = @_;
371 if ( $group eq 'simple' && $use_xs->() ) {
372 return $add_xs_accessor->(@_, 'wo')
375 my $set = "set_$group";
379 my $code = eval "sub {
381 my \$caller = caller;
382 Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
383 \"objects of class '$class'\");
386 return shift->$set('$field', \@_);
389 Carp::croak $@ if $@;
398 =item Arguments: $field
404 Simple getter for hash-based objects which returns the value for the field
405 name passed as an argument.
410 return $_[0]->{$_[1]};
417 =item Arguments: $field, $new_value
423 Simple setter for hash-based objects which sets and then returns the value
424 for the field name passed as an argument.
429 return $_[0]->{$_[1]} = $_[2];
437 =item Arguments: $field
443 Simple getter for Classes and hash-based objects which returns the value for
444 the field name passed as an argument. This behaves much like
445 L<Class::Data::Accessor> where the field can be set in a base class,
446 inherited and changed in subclasses, and inherited and changed for object
454 if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
455 if (Scalar::Util::reftype $_[0] eq 'HASH') {
456 return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
459 Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
467 no warnings 'uninitialized';
469 my $cag_slot = '::__cag_'. $_[1];
470 return ${$class.$cag_slot} if defined(${$class.$cag_slot});
472 # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
473 my $cur_gen = mro::get_pkg_gen ($class);
474 if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
475 @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
476 ${$class.'::__cag_pkg_gen__'} = $cur_gen;
479 for (@{$class.'::__cag_supers__'}) {
480 return ${$_.$cag_slot} if defined(${$_.$cag_slot});
490 =item Arguments: $field, $new_value
496 Simple setter for Classes and hash-based objects which sets and then returns
497 the value for the field name passed as an argument. When called on a hash-based
498 object it will set the appropriate hash key value. When called on a class, it
499 will set a class level variable.
501 B<Note:>: This method will die if you try to set an object variable on a non
507 if (defined Scalar::Util::blessed $_[0]) {
508 if (Scalar::Util::reftype $_[0] eq 'HASH') {
509 return $_[0]->{$_[1]} = $_[2];
511 Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
516 return ${$_[0].'::__cag_'.$_[1]} = $_[2];
520 =head2 get_component_class
524 =item Arguments: $field
530 Gets the value of the specified component class.
532 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
534 $self->result_class->method();
537 $self->get_component_class('result_class')->method();
541 sub get_component_class {
542 return $_[0]->get_inherited($_[1]);
545 =head2 set_component_class
549 =item Arguments: $field, $class
555 Inherited accessor that automatically loads the specified class before setting
556 it. This method will die if the specified class could not be loaded.
558 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
559 __PACKAGE__->result_class('MyClass');
561 $self->result_class->method();
565 sub set_component_class {
568 require Class::Inspector;
569 if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
572 Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
576 return $_[0]->set_inherited($_[1], $_[2]);
579 =head2 get_super_paths
581 Returns a list of 'parent' or 'super' class names that the current class inherited from.
585 sub get_super_paths {
586 return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
593 To provide total flexibility L<Class::Accessor::Grouped> calls methods
594 internally while performing get/set actions, which makes it noticeably
595 slower than similar modules. To compensate, this module will automatically
596 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
597 accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is
598 available on your system.
602 This is the result of a set/get/set loop benchmark on perl 5.12.1 with
603 thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
604 L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>
605 and L<XSA|Class::XSAccessor>:
607 Rate CAG moOse CAF HANDMADE CAF_XS moUse_XS CAG_XS XSA
608 CAG 1777/s -- -27% -29% -36% -62% -67% -72% -73%
609 moOse 2421/s 36% -- -4% -13% -48% -55% -61% -63%
610 CAF 2511/s 41% 4% -- -10% -47% -53% -60% -61%
611 HANDMADE 2791/s 57% 15% 11% -- -41% -48% -56% -57%
612 CAF_XS 4699/s 164% 94% 87% 68% -- -13% -25% -28%
613 moUse_XS 5375/s 203% 122% 114% 93% 14% -- -14% -18%
614 CAG_XS 6279/s 253% 159% 150% 125% 34% 17% -- -4%
615 XSA 6515/s 267% 169% 159% 133% 39% 21% 4% --
617 Benchmark program is available in the root of the
618 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
620 =head2 Notes on Class::XSAccessor
622 You can force (or disable) the use of L<Class::XSAccessor> before creating a
623 particular C<simple> accessor by either manipulating the global variable
624 C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
625 L<localization|perlfunc/local>, or you can do so before runtime via the
626 C<CAG_USE_XS> environment variable.
628 Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
629 L</set_simple> this module does its best to detect if you are overriding
630 one of these methods and will fall back to using the perl version of the
631 accessor in order to maintain consistency. However be aware that if you
632 enable use of C<Class::XSAccessor> (automatically or explicitly), create
633 an object, invoke a simple accessor on that object, and B<then> manipulate
634 the symbol table to install a C<get/set_simple> override - you get to keep
637 While L<Class::XSAccessor> works surprisingly well for the amount of black
638 magic it tries to pull off, it's still black magic. At present (Sep 2010)
639 the module is known to have problems on Windows under heavy thread-stress
640 (e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
641 will not be used automatically if you are running under C<MSWin32>.
645 Matt S. Trout <mst@shadowcatsystems.co.uk>
647 Christopher H. Laco <claco@chrislaco.com>
651 Caelum: Rafael Kitover <rkitover@cpan.org>
653 groditi: Guillermo Roditi <groditi@cpan.org>
655 Jason Plum <jason.plum@bmmsi.com>
657 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
660 =head1 COPYRIGHT & LICENSE
662 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
664 This program is free software; you can redistribute it and/or modify
665 it under the same terms as perl itself.