1 package Class::Accessor::Grouped;
9 our $VERSION = '0.09005';
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;
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);
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') {
42 eval { $load_xsa->(); $USE_XS = 1 };
50 Class::Accessor::Grouped - Lets you build groups of accessors
56 This class lets you build groups of accessors that will call different
61 =head2 mk_group_accessors
65 =item Arguments: $group, @fieldspec
71 Creates a set of accessors in a given group.
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.
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
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 ].
86 sub mk_group_accessors {
87 my ($self, $group, @fields) = @_;
89 $self->_mk_group_accessors('make_group_accessor', $group, @fields);
96 no warnings 'redefine';
98 sub _mk_group_accessors {
99 my($self, $maker, $group, @fields) = @_;
100 my $class = Scalar::Util::blessed $self || $self;
102 # So we don't have to do lots of lookups inside the loop.
103 $maker = $self->can($maker) unless ref $maker;
106 if( $_ eq 'DESTROY' ) {
107 Carp::carp("Having a data accessor named DESTROY in ".
108 "'$class' is unwise.");
111 my ($name, $field) = (ref $_)
116 my $alias = "_${name}_accessor";
118 for my $meth ($name, $alias) {
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)
125 my $fq_meth = join('::', $class, $meth);
127 *$fq_meth = Sub::Name::subname($fq_meth, $cref);
128 #unless defined &{$class."\:\:$field"}
134 =head2 mk_group_ro_accessors
138 =item Arguments: $group, @fieldspec
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.
150 sub mk_group_ro_accessors {
151 my($self, $group, @fields) = @_;
153 $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
156 =head2 mk_group_wo_accessors
160 =item Arguments: $group, @fieldspec
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.
172 sub mk_group_wo_accessors {
173 my($self, $group, @fields) = @_;
175 $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
178 =head2 make_group_accessor
182 =item Arguments: $group, $field, $method
184 Returns: \&accessor_coderef ?
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.
194 sub make_group_accessor {
195 my ($class, $group, $field, $name) = @_;
197 if ( $group eq 'simple' && $use_xs->() ) {
198 Class::XSAccessor->import({
208 my $set = "set_$group";
209 my $get = "get_$group";
213 # eval for faster fastiness
214 my $code = eval "sub {
216 return shift->$set('$field', \@_);
219 return shift->$get('$field');
222 Carp::croak $@ if $@;
227 =head2 make_group_ro_accessor
231 =item Arguments: $group, $field, $method
233 Returns: \&accessor_coderef ?
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.
243 sub make_group_ro_accessor {
244 my($class, $group, $field, $name) = @_;
246 if ( $group eq 'simple' && $use_xs->() ) {
247 Class::XSAccessor->import({
257 my $get = "get_$group";
261 my $code = eval "sub {
263 my \$caller = caller;
264 Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
265 \"objects of class '$class'\");
268 return shift->$get('$field');
271 Carp::croak $@ if $@;
276 =head2 make_group_wo_accessor
280 =item Arguments: $group, $field, $method
282 Returns: \&accessor_coderef ?
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.
292 sub make_group_wo_accessor {
293 my($class, $group, $field, $name) = @_;
295 if ( $group eq 'simple' && $use_xs->() ) {
296 Class::XSAccessor->import({
306 my $set = "set_$group";
310 my $code = eval "sub {
312 my \$caller = caller;
313 Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
314 \"objects of class '$class'\");
317 return shift->$set('$field', \@_);
320 Carp::croak $@ if $@;
329 =item Arguments: $field
335 Simple getter for hash-based objects which returns the value for the field
336 name passed as an argument.
341 return $_[0]->{$_[1]};
348 =item Arguments: $field, $new_value
354 Simple setter for hash-based objects which sets and then returns the value
355 for the field name passed as an argument.
360 return $_[0]->{$_[1]} = $_[2];
368 =item Arguments: $field
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
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]};
390 Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
398 no warnings qw/uninitialized/;
400 my $cag_slot = '::__cag_'. $_[1];
401 return ${$class.$cag_slot} if defined(${$class.$cag_slot});
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;
410 for (@{$class.'::__cag_supers__'}) {
411 return ${$_.$cag_slot} if defined(${$_.$cag_slot});
421 =item Arguments: $field, $new_value
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.
432 B<Note:>: This method will die if you try to set an object variable on a non
438 if (Scalar::Util::blessed $_[0]) {
439 if (Scalar::Util::reftype $_[0] eq 'HASH') {
440 return $_[0]->{$_[1]} = $_[2];
442 Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
447 return ${$_[0].'::__cag_'.$_[1]} = $_[2];
451 =head2 get_component_class
455 =item Arguments: $field
461 Gets the value of the specified component class.
463 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
465 $self->result_class->method();
468 $self->get_component_class('result_class')->method();
472 sub get_component_class {
473 return $_[0]->get_inherited($_[1]);
476 =head2 set_component_class
480 =item Arguments: $field, $class
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.
489 __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
490 __PACKAGE__->result_class('MyClass');
492 $self->result_class->method();
496 sub set_component_class {
499 require Class::Inspector;
500 if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
503 Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
507 return $_[0]->set_inherited($_[1], $_[2]);
510 =head2 get_super_paths
512 Returns a list of 'parent' or 'super' class names that the current class inherited from.
516 sub get_super_paths {
517 return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
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.
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>:
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% --
548 Benchmark program is available in the root of the
549 L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
551 =head2 Notes on Class::XSAccessor
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>.
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.
566 Matt S. Trout <mst@shadowcatsystems.co.uk>
568 Christopher H. Laco <claco@chrislaco.com>
572 Caelum: Rafael Kitover <rkitover@cpan.org>
574 groditi: Guillermo Roditi <groditi@cpan.org>
576 Jason Plum <jason.plum@bmmsi.com>
578 ribasushi: Peter Rabbitson <ribasushi@cpan.org>
581 =head1 COPYRIGHT & LICENSE
583 Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
585 This program is free software; you can redistribute it and/or modify
586 it under the same terms as perl itself.