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 # Yes this method is undocumented
141 # Yes it should be a private coderef like the one above it
142 # No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
144 sub _mk_group_accessors {
145 my($self, $maker, $group, @fields) = @_;
146 my $class = Scalar::Util::blessed $self || $self;
149 no warnings 'redefine';
151 # So we don't have to do lots of lookups inside the loop.
152 $maker = $self->can($maker) unless ref $maker eq 'CODE';
155 if( $_ eq 'DESTROY' ) {
156 Carp::carp("Having a data accessor named DESTROY in ".
157 "'$class' is unwise.");
160 my ($name, $field) = (ref $_)
165 my $alias = "_${name}_accessor";
167 for my $meth ($name, $alias) {
169 # the maker may elect to not return anything, meaning it already
170 # installed the coderef for us
171 my $cref = $self->$maker($group, $field, $meth)
174 my $fq_meth = join('::', $class, $meth);
176 *$fq_meth = Sub::Name::subname($fq_meth, $cref);
177 #unless defined &{$class."\:\:$field"}
185 Class::Accessor::Grouped - Lets you build groups of accessors
191 This class lets you build groups of accessors that will call different
196 =head2 mk_group_accessors
200 =item Arguments: $group, @fieldspec
206 Creates a set of accessors in a given group.
208 $group is the name of the accessor group for the generated accessors; they
209 will call get_$group($field) on get and set_$group($field, $value) on set.
211 If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
212 to tell Class::Accessor::Grouped to use its own get_simple and set_simple
215 @fieldspec is a list of field/accessor names; if a fieldspec is a scalar
216 this is used as both field and accessor name, if a listref it is expected to
217 be of the form [ $accessor, $field ].
221 sub mk_group_accessors {
222 my ($self, $group, @fields) = @_;
224 $self->_mk_group_accessors('make_group_accessor', $group, @fields);
228 =head2 mk_group_ro_accessors
232 =item Arguments: $group, @fieldspec
238 Creates a set of read only accessors in a given group. Identical to
239 L</mk_group_accessors> but accessors will throw an error if passed a value
240 rather than setting the value.
244 sub mk_group_ro_accessors {
245 my($self, $group, @fields) = @_;
247 $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
250 =head2 mk_group_wo_accessors
254 =item Arguments: $group, @fieldspec
260 Creates a set of write only accessors in a given group. Identical to
261 L</mk_group_accessors> but accessors will throw an error if not passed a
262 value rather than getting the value.
266 sub mk_group_wo_accessors {
267 my($self, $group, @fields) = @_;
269 $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
272 =head2 make_group_accessor
276 =item Arguments: $group, $field, $method
278 Returns: \&accessor_coderef ?
282 Called by mk_group_accessors for each entry in @fieldspec. Either returns
283 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
284 C<undef> if it elects to install the coderef on its own.
288 sub make_group_accessor {
289 my ($class, $group, $field, $name) = @_;
291 if ( $group eq 'simple' && $use_xs->() ) {
292 return $add_xs_accessor->(@_, 'rw');
295 my $set = "set_$group";
296 my $get = "get_$group";
300 # eval for faster fastiness
301 my $code = eval "sub {
303 return shift->$set('$field', \@_);
306 return shift->$get('$field');
309 Carp::croak $@ if $@;
314 =head2 make_group_ro_accessor
318 =item Arguments: $group, $field, $method
320 Returns: \&accessor_coderef ?
324 Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
325 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
326 C<undef> if it elects to install the coderef on its own.
330 sub make_group_ro_accessor {
331 my($class, $group, $field, $name) = @_;
333 if ( $group eq 'simple' && $use_xs->() ) {
334 return $add_xs_accessor->(@_, 'ro');
337 my $get = "get_$group";
341 my $code = eval "sub {
343 my \$caller = caller;
344 Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
345 \"objects of class '$class'\");
348 return shift->$get('$field');
351 Carp::croak $@ if $@;
356 =head2 make_group_wo_accessor
360 =item Arguments: $group, $field, $method
362 Returns: \&accessor_coderef ?
366 Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
367 a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
368 C<undef> if it elects to install the coderef on its own.
372 sub make_group_wo_accessor {
373 my($class, $group, $field, $name) = @_;
375 if ( $group eq 'simple' && $use_xs->() ) {
376 return $add_xs_accessor->(@_, 'wo')
379 my $set = "set_$group";
383 my $code = eval "sub {
385 my \$caller = caller;
386 Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
387 \"objects of class '$class'\");
390 return shift->$set('$field', \@_);
393 Carp::croak $@ if $@;
402 =item Arguments: $field
408 Simple getter for hash-based objects which returns the value for the field
409 name passed as an argument.
414 return $_[0]->{$_[1]};
421 =item Arguments: $field, $new_value
427 Simple setter for hash-based objects which sets and then returns the value
428 for the field name passed as an argument.
433 return $_[0]->{$_[1]} = $_[2];
441 =item Arguments: $field
447 Simple getter for Classes and hash-based objects which returns the value for
448 the field name passed as an argument. This behaves much like
449 L<Class::Data::Accessor> where the field can be set in a base class,
450 inherited and changed in subclasses, and inherited and changed for object
458 if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
459 if (Scalar::Util::reftype $_[0] eq 'HASH') {
460 return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
463 Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
471 no warnings 'uninitialized';
473 my $cag_slot = '::__cag_'. $_[1];
474 return ${$class.$cag_slot} if defined(${$class.$cag_slot});
476 # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
477 my $cur_gen = mro::get_pkg_gen ($class);
478 if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
479 @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
480 ${$class.'::__cag_pkg_gen__'} = $cur_gen;
483 for (@{$class.'::__cag_supers__'}) {
484 return ${$_.$cag_slot} if defined(${$_.$cag_slot});
494 =item Arguments: $field, $new_value
500 Simple setter for Classes and hash-based objects which sets and then returns
501 the value for the field name passed as an argument. When called on a hash-based
502 object it will set the appropriate hash key value. When called on a class, it
503 will set a class level variable.
505 B<Note:>: This method will die if you try to set an object variable on a non
511 if (defined Scalar::Util::blessed $_[0]) {
512 if (Scalar::Util::reftype $_[0] eq 'HASH') {
513 return $_[0]->{$_[1]} = $_[2];
515 Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
520 return ${$_[0].'::__cag_'.$_[1]} = $_[2];
524 =head2 get_component_class
528 =item Arguments: $field
534 Gets the value of the specified component class.
536 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
538 $self->result_class->method();
541 $self->get_component_class('result_class')->method();
545 sub get_component_class {
546 return $_[0]->get_inherited($_[1]);
549 =head2 set_component_class
553 =item Arguments: $field, $class
559 Inherited accessor that automatically loads the specified class before setting
560 it. This method will die if the specified class could not be loaded.
562 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
563 __PACKAGE__->result_class('MyClass');
565 $self->result_class->method();
569 sub set_component_class {
572 require Class::Inspector;
573 if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
576 Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
580 return $_[0]->set_inherited($_[1], $_[2]);
583 =head2 get_super_paths
585 Returns a list of 'parent' or 'super' class names that the current class inherited from.
589 sub get_super_paths {
590 return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
597 To provide total flexibility L<Class::Accessor::Grouped> calls methods
598 internally while performing get/set actions, which makes it noticeably
599 slower than similar modules. To compensate, this module will automatically
600 use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
601 accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is
602 available on your system.
606 This is the result of a set/get/set loop benchmark on perl 5.12.1 with
607 thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
608 L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>
609 and L<XSA|Class::XSAccessor>:
611 Rate CAG moOse CAF HANDMADE CAF_XS moUse_XS CAG_XS XSA
612 CAG 1777/s -- -27% -29% -36% -62% -67% -72% -73%
613 moOse 2421/s 36% -- -4% -13% -48% -55% -61% -63%
614 CAF 2511/s 41% 4% -- -10% -47% -53% -60% -61%
615 HANDMADE 2791/s 57% 15% 11% -- -41% -48% -56% -57%
616 CAF_XS 4699/s 164% 94% 87% 68% -- -13% -25% -28%
617 moUse_XS 5375/s 203% 122% 114% 93% 14% -- -14% -18%
618 CAG_XS 6279/s 253% 159% 150% 125% 34% 17% -- -4%
619 XSA 6515/s 267% 169% 159% 133% 39% 21% 4% --
621 Benchmark program is available in the root of the
622 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
624 =head2 Notes on Class::XSAccessor
626 You can force (or disable) the use of L<Class::XSAccessor> before creating a
627 particular C<simple> accessor by either manipulating the global variable
628 C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
629 L<localization|perlfunc/local>, or you can do so before runtime via the
630 C<CAG_USE_XS> environment variable.
632 Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
633 L</set_simple> this module does its best to detect if you are overriding
634 one of these methods and will fall back to using the perl version of the
635 accessor in order to maintain consistency. However be aware that if you
636 enable use of C<Class::XSAccessor> (automatically or explicitly), create
637 an object, invoke a simple accessor on that object, and B<then> manipulate
638 the symbol table to install a C<get/set_simple> override - you get to keep
641 While L<Class::XSAccessor> works surprisingly well for the amount of black
642 magic it tries to pull off, it's still black magic. At present (Sep 2010)
643 the module is known to have problems on Windows under heavy thread-stress
644 (e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
645 will not be used automatically if you are running under C<MSWin32>.
649 Matt S. Trout <mst@shadowcatsystems.co.uk>
651 Christopher H. Laco <claco@chrislaco.com>
655 Caelum: Rafael Kitover <rkitover@cpan.org>
657 groditi: Guillermo Roditi <groditi@cpan.org>
659 Jason Plum <jason.plum@bmmsi.com>
661 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
664 =head1 COPYRIGHT & LICENSE
666 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
668 This program is free software; you can redistribute it and/or modify
669 it under the same terms as perl itself.