[p5sagit/Class-Accessor-Grouped.git] / lib / Class / Accessor / Grouped.pm

package Class::Accessor::Grouped;
use strict;
use warnings;
use Carp ();
use Scalar::Util ();
use MRO::Compat;
use Sub::Name ();

our $VERSION = '0.09006';
$VERSION = eval $VERSION;

# when changing minimum version don't forget to adjust L</PERFROMANCE> as well
our $__minimum_xsa_version = '1.06';

our $USE_XS;
# the unless defined is here so that we can override the value
# before require/use, *regardless* of the state of $ENV{CAG_USE_XS}
$USE_XS = $ENV{CAG_USE_XS}
    unless defined $USE_XS;

my ($xsa_loaded, $xsa_autodetected);

my $load_xsa = sub {
    return if $xsa_loaded++;
    require Class::XSAccessor;
    Class::XSAccessor->VERSION($__minimum_xsa_version);
};

my $use_xs = sub {
    if (defined $USE_XS) {
        $load_xsa->() if ($USE_XS && ! $xsa_loaded);
        return $USE_XS;
    }

    $xsa_autodetected = 1;
    $USE_XS = 0;

    # Class::XSAccessor is segfaulting on win32, in some
    # esoteric heavily-threaded scenarios
    # Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
    if ($^O ne 'MSWin32') {
        local $@;
        eval { $load_xsa->(); $USE_XS = 1 };
    }

    return $USE_XS;
};

my $maker_type_map = {
  rw => {
    xsa => 'accessors',
    cag => 'make_group_accessor',
  },
  ro => {
    xsa => 'getters',
    cag => 'make_group_ro_accessor',
  },
  wo => {
    xsa => 'setters',
    cag => 'make_group_wo_accessor',
  },
};

# When installing an XSA simple accessor, we need to make sure we are not
# short-circuiting a (compile or runtime) get_simple/set_simple override.
# What we do here is install a lazy first-access check, which will decide
# the ultimate coderef being placed in the accessor slot

my $no_xsa_classes_warned;
my $add_xs_accessor = sub {
    my ($class, $group, $field, $name, $type) = @_;

    Class::XSAccessor->import({
        replace => 1,
        class => $class,
        $maker_type_map->{$type}{xsa} => {
            $name => $field,
        },
    });

    my $xs_cref = $class->can($name);

    my $pp_cref = do {
        my $cag_method = $maker_type_map->{$type}{cag};
        local $USE_XS = 0;
        $class->$cag_method ($group, $field, $name, $type);
    };

    # can't use pkg_gen to track this stuff, as it doesn't
    # detect superclass mucking
    my $original_getter = __PACKAGE__->can ("get_$group");
    my $original_setter = __PACKAGE__->can ("set_$group");

    return sub {
        my $self = $_[0];
        my $current_class = (ref $self) || $self;

        my $final_cref;
        if (
            $current_class->can("get_$group") == $original_getter
                &&
            $current_class->can("set_$group") == $original_setter
        ) {
            # nothing has changed, might as well use the XS crefs
            # (if one changes methods that far into runtime - look pieces!)
            $final_cref = $xs_cref;
        }
        else {
            $final_cref = $pp_cref;
            if ($USE_XS and ! $xsa_autodetected and ! $no_xsa_classes_warned->{$current_class}++) {
                warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class'
                  . " '$current_class' due to an overriden get_$group and/or set_$group\n";
            }
        }

        my $fq_meth = "${current_class}::${name}";

        no strict qw/refs/;
        no warnings qw/redefine/;
        *$fq_meth = Sub::Name::subname($fq_meth, $final_cref);

        goto $final_cref;
    };
};

=head1 NAME

Class::Accessor::Grouped - Lets you build groups of accessors

=head1 SYNOPSIS

=head1 DESCRIPTION

This class lets you build groups of accessors that will call different
getters and setters.

=head1 METHODS

=head2 mk_group_accessors

=over 4

=item Arguments: $group, @fieldspec

Returns: none

=back

Creates a set of accessors in a given group.

$group is the name of the accessor group for the generated accessors; they
will call get_$group($field) on get and set_$group($field, $value) on set.

If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
to tell Class::Accessor::Grouped to use its own get_simple and set_simple
methods.

@fieldspec is a list of field/accessor names; if a fieldspec is a scalar
this is used as both field and accessor name, if a listref it is expected to
be of the form [ $accessor, $field ].

=cut

sub mk_group_accessors {
  my ($self, $group, @fields) = @_;

  $self->_mk_group_accessors('make_group_accessor', $group, @fields);
  return;
}


{
    no strict 'refs';
    no warnings 'redefine';

    sub _mk_group_accessors {
        my($self, $maker, $group, @fields) = @_;
        my $class = Scalar::Util::blessed $self || $self;

        # So we don't have to do lots of lookups inside the loop.
        $maker = $self->can($maker) unless ref $maker;

        foreach (@fields) {
            if( $_ eq 'DESTROY' ) {
                Carp::carp("Having a data accessor named DESTROY  in ".
                             "'$class' is unwise.");
            }

            my ($name, $field) = (ref $_)
                ? (@$_)
                : ($_, $_)
            ;

            my $alias = "_${name}_accessor";

            for my $meth ($name, $alias) {

                # the maker may elect to not return anything, meaning it already
                # installed the coderef for us
                my $cref = $self->$maker($group, $field, $meth)
                    or next;

                my $fq_meth = join('::', $class, $meth);

                *$fq_meth = Sub::Name::subname($fq_meth, $cref);
                    #unless defined &{$class."\:\:$field"}
            }
        }
    }
}

=head2 mk_group_ro_accessors

=over 4

=item Arguments: $group, @fieldspec

Returns: none

=back

Creates a set of read only accessors in a given group. Identical to
L</mk_group_accessors> but accessors will throw an error if passed a value
rather than setting the value.

=cut

sub mk_group_ro_accessors {
    my($self, $group, @fields) = @_;

    $self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
}

=head2 mk_group_wo_accessors

=over 4

=item Arguments: $group, @fieldspec

Returns: none

=back

Creates a set of write only accessors in a given group. Identical to
L</mk_group_accessors> but accessors will throw an error if not passed a
value rather than getting the value.

=cut

sub mk_group_wo_accessors {
    my($self, $group, @fields) = @_;

    $self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
}

=head2 make_group_accessor

=over 4

=item Arguments: $group, $field, $method

Returns: \&accessor_coderef ?

=back

Called by mk_group_accessors for each entry in @fieldspec. Either returns
a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
C<undef> if it elects to install the coderef on its own.

=cut

sub make_group_accessor {
    my ($class, $group, $field, $name) = @_;

    if ( $group eq 'simple' && $use_xs->() ) {
        return $add_xs_accessor->(@_, 'rw');
    }

    my $set = "set_$group";
    my $get = "get_$group";

    $field =~ s/'/\\'/g;

    # eval for faster fastiness
    my $code = eval "sub {
        if(\@_ > 1) {
            return shift->$set('$field', \@_);
        }
        else {
            return shift->$get('$field');
        }
    };";
    Carp::croak $@ if $@;

    return $code;
}

=head2 make_group_ro_accessor

=over 4

=item Arguments: $group, $field, $method

Returns: \&accessor_coderef ?

=back

Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
C<undef> if it elects to install the coderef on its own.

=cut

sub make_group_ro_accessor {
    my($class, $group, $field, $name) = @_;

    if ( $group eq 'simple' && $use_xs->() ) {
        return $add_xs_accessor->(@_, 'ro');
    }

    my $get = "get_$group";

    $field =~ s/'/\\'/g;

    my $code = eval "sub {
        if(\@_ > 1) {
            my \$caller = caller;
            Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
                        \"objects of class '$class'\");
        }
        else {
            return shift->$get('$field');
        }
    };";
    Carp::croak $@ if $@;

    return $code;
}

=head2 make_group_wo_accessor

=over 4

=item Arguments: $group, $field, $method

Returns: \&accessor_coderef ?

=back

Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
C<undef> if it elects to install the coderef on its own.

=cut

sub make_group_wo_accessor {
    my($class, $group, $field, $name) = @_;

    if ( $group eq 'simple' && $use_xs->() ) {
        return $add_xs_accessor->(@_, 'wo')
    }

    my $set = "set_$group";

    $field =~ s/'/\\'/g;

    my $code = eval "sub {
        unless (\@_ > 1) {
            my \$caller = caller;
            Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
                        \"objects of class '$class'\");
        }
        else {
            return shift->$set('$field', \@_);
        }
    };";
    Carp::croak $@ if $@;

    return $code;
}

=head2 get_simple

=over 4

=item Arguments: $field

Returns: $value

=back

Simple getter for hash-based objects which returns the value for the field
name passed as an argument.

=cut

sub get_simple {
  return $_[0]->{$_[1]};
}

=head2 set_simple

=over 4

=item Arguments: $field, $new_value

Returns: $new_value

=back

Simple setter for hash-based objects which sets and then returns the value
for the field name passed as an argument.

=cut

sub set_simple {
  return $_[0]->{$_[1]} = $_[2];
}


=head2 get_inherited

=over 4

=item Arguments: $field

Returns: $value

=back

Simple getter for Classes and hash-based objects which returns the value for
the field name passed as an argument. This behaves much like
L<Class::Data::Accessor> where the field can be set in a base class,
inherited and changed in subclasses, and inherited and changed for object
instances.

=cut

sub get_inherited {
    my $class;

    if ( ($class = ref $_[0]) && Scalar::Util::blessed $_[0]) {
        if (Scalar::Util::reftype $_[0] eq 'HASH') {
          return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
        }
        else {
          Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
        }
    }
    else {
        $class = $_[0];
    }

    no strict 'refs';
    no warnings qw/uninitialized/;

    my $cag_slot = '::__cag_'. $_[1];
    return ${$class.$cag_slot} if defined(${$class.$cag_slot});

    # we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
    my $cur_gen = mro::get_pkg_gen ($class);
    if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
        @{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
        ${$class.'::__cag_pkg_gen__'} = $cur_gen;
    }

    for (@{$class.'::__cag_supers__'}) {
        return ${$_.$cag_slot} if defined(${$_.$cag_slot});
    };

    return undef;
}

=head2 set_inherited

=over 4

=item Arguments: $field, $new_value

Returns: $new_value

=back

Simple setter for Classes and hash-based objects which sets and then returns
the value for the field name passed as an argument. When called on a hash-based
object it will set the appropriate hash key value. When called on a class, it
will set a class level variable.

B<Note:>: This method will die if you try to set an object variable on a non
hash-based object.

=cut

sub set_inherited {
    if (Scalar::Util::blessed $_[0]) {
        if (Scalar::Util::reftype $_[0] eq 'HASH') {
            return $_[0]->{$_[1]} = $_[2];
        } else {
            Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
        };
    } else {
        no strict 'refs';

        return ${$_[0].'::__cag_'.$_[1]} = $_[2];
    };
}

=head2 get_component_class

=over 4

=item Arguments: $field

Returns: $value

=back

Gets the value of the specified component class.

    __PACKAGE__->mk_group_accessors('component_class' => 'result_class');

    $self->result_class->method();

    ## same as
    $self->get_component_class('result_class')->method();

=cut

sub get_component_class {
    return $_[0]->get_inherited($_[1]);
};

=head2 set_component_class

=over 4

=item Arguments: $field, $class

Returns: $new_value

=back

Inherited accessor that automatically loads the specified class before setting
it. This method will die if the specified class could not be loaded.

    __PACKAGE__->mk_group_accessors('component_class' => 'result_class');
    __PACKAGE__->result_class('MyClass');

    $self->result_class->method();

=cut

sub set_component_class {
    if ($_[2]) {
        local $^W = 0;
        require Class::Inspector;
        if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
            eval "use $_[2]";

            Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
        };
    };

    return $_[0]->set_inherited($_[1], $_[2]);
};

=head2 get_super_paths

Returns a list of 'parent' or 'super' class names that the current class inherited from.

=cut

sub get_super_paths {
    return @{mro::get_linear_isa( ref($_[0]) || $_[0] )};
};

1;

=head1 PERFORMANCE

To provide total flexibility L<Class::Accessor::Grouped> calls methods
internally while performing get/set actions, which makes it noticeably
slower than similar modules. To compensate, this module will automatically
use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
accessors, if L<< Class::XSAccessor >= 1.06|Class::XSAccessor >> is
available on your system.

=head2 Benchmark

This is the result of a set/get/set loop benchmark on perl 5.12.1 with
thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
L<CAF|Class::Accessor::Fast>, L<CAF_XS|Class::Accessor::Fast::XS>
and L<XSA|Class::XSAccessor>:

            Rate     CAG   moOse     CAF HANDMADE  CAF_XS moUse_XS CAG_XS     XSA
 CAG      1777/s      --    -27%    -29%     -36%    -62%     -67%   -72%    -73%
 moOse    2421/s     36%      --     -4%     -13%    -48%     -55%   -61%    -63%
 CAF      2511/s     41%      4%      --     -10%    -47%     -53%   -60%    -61%
 HANDMADE 2791/s     57%     15%     11%       --    -41%     -48%   -56%    -57%
 CAF_XS   4699/s    164%     94%     87%      68%      --     -13%   -25%    -28%
 moUse_XS 5375/s    203%    122%    114%      93%     14%       --   -14%    -18%
 CAG_XS   6279/s    253%    159%    150%     125%     34%      17%     --     -4%
 XSA      6515/s    267%    169%    159%     133%     39%      21%     4%      --

Benchmark program is available in the root of the
L<repository|http://search.cpan.org/dist/Class-Accessor-Grouped/>:

=head2 Notes on Class::XSAccessor

While L<Class::XSAccessor> works surprisingly well for the amount of black
magic it tries to pull off, it's still black magic. At present (Sep 2010)
the module is known to have problems on Windows under heavy thread-stress
(e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
will not be used automatically if you are running under C<MSWin32>.

You can force the use of L<Class::XSAccessor> before creating a particular
C<simple> accessor by either manipulating the global variable
C<$Class::Accessor::Grouped::USE_XS>, or you can do so before runtime via the
C<CAG_USE_XS> environment variable.

=head1 AUTHORS

Matt S. Trout <mst@shadowcatsystems.co.uk>

Christopher H. Laco <claco@chrislaco.com>

=head1 CONTRIBUTORS

Caelum: Rafael Kitover <rkitover@cpan.org>

groditi: Guillermo Roditi <groditi@cpan.org>

Jason Plum <jason.plum@bmmsi.com>

ribasushi: Peter Rabbitson <ribasushi@cpan.org>


=head1 COPYRIGHT & LICENSE

Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>

This program is free software; you can redistribute it and/or modify
it under the same terms as perl itself.

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