[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;

our $VERSION = '0.09008';
$VERSION = eval $VERSION;

# when changing minimum version don't forget to adjust L</PERFORMANCE> and
# the Makefile.PL as well
our $__minimum_xsa_version;
BEGIN {
    $__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;

# Yes this method is undocumented
# Yes it should be a private coderef like all the rest at the end of this file
# No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
# %$*@!?&!&#*$!!!
sub _mk_group_accessors {
    my($self, $maker, $group, @fields) = @_;
    my $class = Scalar::Util::blessed $self || $self;

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

    # 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 (e.g. lack of Sub::Name)
            my $cref = $self->$maker($group, $field, $meth)
                or next;

            my $fq_meth = "${class}::${meth}";

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

# coderef is setup at the end for clarity
my $gen_accessor;

=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;
}

=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 { $gen_accessor->('rw', @_) }

=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 { $gen_accessor->('ro', @_) }

=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 { $gen_accessor->('wo', @_) }

=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 ( defined( $class = 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 '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 (defined 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 "require $_[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] )};
};

=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

You can force (or disable) 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> to true or false (preferably with
L<localization|perlfunc/local>, or you can do so before runtime via the
C<CAG_USE_XS> environment variable.

Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
L</set_simple> this module does its best to detect if you are overriding
one of these methods and will fall back to using the perl version of the
accessor in order to maintain consistency. However be aware that if you
enable use of C<Class::XSAccessor> (automatically or explicitly), create
an object, invoke a simple accessor on that object, and B<then> manipulate
the symbol table to install a C<get/set_simple> override - you get to keep
all the pieces.

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>.

=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

########################################################################
########################################################################
########################################################################
#
# Here be many angry dragons
# (all code is in private coderefs since everything inherits CAG)
#
########################################################################
########################################################################

BEGIN {

  die "Huh?! No minimum C::XSA version?!\n"
    unless $__minimum_xsa_version;

  local $@;
  my $err;

  $err = eval { require Sub::Name; 1; } ? undef : do {
    delete $INC{'Sub/Name.pm'};   # because older perls suck
    $@;
  };
  *__CAG_NO_SUBNAME = $err
    ? sub () { $err }
    : sub () { 0 }
  ;


  $err = eval {
    require Class::XSAccessor;
    Class::XSAccessor->VERSION($__minimum_xsa_version);
    require Sub::Name;
    1;
  } ? undef : do {
    delete $INC{'Sub/Name.pm'};   # because older perls suck
    delete $INC{'Class/XSAccessor.pm'};
    $@;
  };
  *__CAG_NO_CXSA = $err
    ? sub () { $err }
    : sub () { 0 }
  ;


  *__CAG_BROKEN_GOTO = ($] < '5.008009')
    ? sub () { 1 }
    : sub () { 0 }
  ;


  *__CAG_UNSTABLE_DOLLARAT = ($] < '5.013002')
    ? sub () { 1 }
    : sub () { 0 }
  ;

};

# Autodetect unless flag supplied
# 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
my $xsa_autodetected;
if (! defined $USE_XS) {
  $USE_XS = (!__CAG_NO_CXSA and $^O ne 'MSWin32') ? 1 : 0;
  $xsa_autodetected++;
}

my $maker_templates = {
  rw => {
    xs_call => 'accessors',
    pp_code => sub {
      my $set = "set_$_[0]";
      my $get = "get_$_[0]";
      my $field = $_[1];
      $field =~ s/'/\\'/g;

      "
        \@_ > 1
          ? shift->$set('$field', \@_)
          : shift->$get('$field')
      "
    },
  },
  ro => {
    xs_call => 'getters',
    pp_code => sub {
      my $get = "get_$_[0]";
      my $field = $_[1];
      $field =~ s/'/\\'/g;

      "
        \@_ == 1
          ? shift->$get('$field')
          : do {
            my \$caller = caller;
            my \$class = ref \$_[0] || \$_[0];
            Carp::croak(\"'\$caller' cannot alter the value of '$field' \".
                        \"(read-only attributes of class '\$class')\");
          }
      "
    },
  },
  wo => {
    xs_call => 'setters',
    pp_code => sub {
      my $set = "set_$_[0]";
      my $field = $_[1];
      $field =~ s/'/\\'/g;

      "
        \@_ > 1
          ? shift->$set('$field', \@_)
          : do {
            my \$caller = caller;
            my \$class = ref \$_[0] || \$_[0];
            Carp::croak(\"'\$caller' cannot access the value of '$field' \".
                        \"(write-only attributes of class '\$class')\");
          }
      "
    },
  },
};


my ($accessor_maker_cache, $no_xsa_warned_classes);

# can't use pkg_gen to track this stuff, as it doesn't
# detect superclass mucking
my $original_simple_getter = __PACKAGE__->can ('get_simple');
my $original_simple_setter = __PACKAGE__->can ('set_simple');

# Note!!! Unusual signature
$gen_accessor = sub {
  my ($type, $class, $group, $field, $methname) = @_;
  if (my $c = ref $class) {
    $class = $c;
  }

  my $fq_name = "${class}::${methname}";

  # 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
  if ($USE_XS and $group eq 'simple') {
    ($accessor_maker_cache->{xs}{$field}{$type}{$fq_name} ||= do {
      die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )
        if __CAG_NO_CXSA;

      sub { sub {
        my $current_class = Scalar::Util::blessed( $_[0] ) || $_[0];

        if (
          $current_class->can('get_simple') == $original_simple_getter
            &&
          $current_class->can('set_simple') == $original_simple_setter
        ) {
          # nothing has changed, might as well use the XS crefs
          #
          # note that by the time this code executes, we already have
          # *objects* (since XSA works on 'simple' only by definition).
          # If someone is mucking with the symbol table *after* there
          # are some objects already - look! many, shiny pieces! :)
          Class::XSAccessor->import(
            replace => 1,
            class => $class,
            $maker_templates->{$type}{xs_call} => {
              $methname => $field,
            },
          );
        }
        else {
          if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
            # not using Carp since the line where this happens doesn't mean much
            warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
              . "'$current_class' due to an overriden get_simple and/or set_simple\n";
          }

          no strict qw/refs/;

          *$fq_name = Sub::Name::subname($fq_name, do {
            # that's faster than local
            $USE_XS = 0;
            my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
            $USE_XS = 1;
            $c;
          });
        }

        # older perls segfault if the cref behind the goto throws
        # http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
        return $current_class->can($methname)->(@_) if __CAG_BROKEN_GOTO;

        goto $current_class->can($methname);
      }}
    })->();
  }

  # no Sub::Name - just install the coderefs directly (compiling every time)
  elsif (__CAG_NO_SUBNAME) {
    my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
      $maker_templates->{$type}{pp_code}->($group, $field);

    local $@ if __CAG_UNSTABLE_DOLLARAT;
    eval "sub ${fq_name}{$src}";

    undef;  # so that no attempt will be made to install anything
  }

  # a coderef generator with a variable pad (returns a fresh cref on every invocation)
  else {
    ($accessor_maker_cache->{pp}{$group}{$field}{$type} ||= do {
      my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} ||=
        $maker_templates->{$type}{pp_code}->($group, $field);

      local $@ if __CAG_UNSTABLE_DOLLARAT;
      eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
    })->()
  }
};

1;
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;
331e820d	7
c22782de	8	our $VERSION = '0.09008';
15cf8e32	9	$VERSION = eval $VERSION;
963a69a5	10
85ccab9a	11	# when changing minimum version don't forget to adjust L</PERFORMANCE> and
	12	# the Makefile.PL as well
	13	our $__minimum_xsa_version;
	14	BEGIN {
	15	$__minimum_xsa_version = '1.06';
	16	}
9f562456	17
8019c4d8	18	our $USE_XS;
	19	# the unless defined is here so that we can override the value
	20	# before require/use, regardless of the state of $ENV{CAG_USE_XS}
	21	$USE_XS = $ENV{CAG_USE_XS}
	22	unless defined $USE_XS;
af169484	23
8079caeb	24	# Yes this method is undocumented
85ccab9a	25	# Yes it should be a private coderef like all the rest at the end of this file
8079caeb	26	# No we can't do that (yet) because the DBIC-CDBI compat layer overrides it
	27	# %$@!?&!&#$!!!
	28	sub _mk_group_accessors {
eece2562	29	my($self, $maker, $group, @fields) = @_;
	30	my $class = Scalar::Util::blessed $self \|\| $self;
	31
	32	no strict 'refs';
	33	no warnings 'redefine';
	34
	35	# So we don't have to do lots of lookups inside the loop.
85ccab9a	36	$maker = $self->can($maker) unless ref $maker;
eece2562	37
	38	foreach (@fields) {
	39	if( $_ eq 'DESTROY' ) {
	40	Carp::carp("Having a data accessor named DESTROY in ".
	41	"'$class' is unwise.");
	42	}
	43
	44	my ($name, $field) = (ref $_)
	45	? (@$_)
	46	: ($_, $_)
	47	;
	48
	49	my $alias = "_${name}_accessor";
	50
	51	for my $meth ($name, $alias) {
	52
	53	# the maker may elect to not return anything, meaning it already
85ccab9a	54	# installed the coderef for us (e.g. lack of Sub::Name)
eece2562	55	my $cref = $self->$maker($group, $field, $meth)
	56	or next;
	57
85ccab9a	58	my $fq_meth = "${class}::${meth}";
eece2562	59
	60	*$fq_meth = Sub::Name::subname($fq_meth, $cref);
	61	#unless defined &{$class."\:\:$field"}
	62	}
	63	}
	64	};
	65
85ccab9a	66	# coderef is setup at the end for clarity
85ccab9a	67	my $gen_accessor;
eece2562	68
963a69a5	69	=head1 NAME
963a69a5	70
1ad8d8c6	71	Class::Accessor::Grouped - Lets you build groups of accessors
963a69a5	72
	73	=head1 SYNOPSIS
	74
	75	=head1 DESCRIPTION
	76
	77	This class lets you build groups of accessors that will call different
	78	getters and setters.
	79
	80	=head1 METHODS
	81
	82	=head2 mk_group_accessors
	83
	84	=over 4
	85
	86	=item Arguments: $group, @fieldspec
	87
	88	Returns: none
	89
	90	=back
	91
	92	Creates a set of accessors in a given group.
	93
	94	$group is the name of the accessor group for the generated accessors; they
	95	will call get_$group($field) on get and set_$group($field, $value) on set.
	96
22fa6720	97	If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
	98	to tell Class::Accessor::Grouped to use its own get_simple and set_simple
	99	methods.
	100
963a69a5	101	@fieldspec is a list of field/accessor names; if a fieldspec is a scalar
	102	this is used as both field and accessor name, if a listref it is expected to
	103	be of the form [ $accessor, $field ].
	104
	105	=cut
	106
	107	sub mk_group_accessors {
85ccab9a	108	my ($self, $group, @fields) = @_;
963a69a5	109
85ccab9a	110	$self->_mk_group_accessors('make_group_accessor', $group, @fields);
85ccab9a	111	return;
963a69a5	112	}
963a69a5	113
963a69a5	114	=head2 mk_group_ro_accessors
	115
	116	=over 4
	117
	118	=item Arguments: $group, @fieldspec
	119
	120	Returns: none
	121
	122	=back
	123
	124	Creates a set of read only accessors in a given group. Identical to
a557f8ad	125	L</mk_group_accessors> but accessors will throw an error if passed a value
963a69a5	126	rather than setting the value.
	127
	128	=cut
	129
	130	sub mk_group_ro_accessors {
	131	my($self, $group, @fields) = @_;
	132
8079caeb	133	$self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
963a69a5	134	}
	135
	136	=head2 mk_group_wo_accessors
	137
	138	=over 4
	139
	140	=item Arguments: $group, @fieldspec
	141
	142	Returns: none
	143
	144	=back
	145
	146	Creates a set of write only accessors in a given group. Identical to
a557f8ad	147	L</mk_group_accessors> but accessors will throw an error if not passed a
963a69a5	148	value rather than getting the value.
	149
	150	=cut
	151
	152	sub mk_group_wo_accessors {
	153	my($self, $group, @fields) = @_;
	154
8079caeb	155	$self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
963a69a5	156	}
	157
	158	=head2 make_group_accessor
	159
	160	=over 4
	161
8019c4d8	162	=item Arguments: $group, $field, $method
963a69a5	163
8019c4d8	164	Returns: \&accessor_coderef ?
963a69a5	165
	166	=back
	167
8019c4d8	168	Called by mk_group_accessors for each entry in @fieldspec. Either returns
	169	a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
	170	C<undef> if it elects to install the coderef on its own.
963a69a5	171
	172	=cut
	173
85ccab9a	174	sub make_group_accessor { $gen_accessor->('rw', @_) }
963a69a5	175
	176	=head2 make_group_ro_accessor
	177
	178	=over 4
	179
8019c4d8	180	=item Arguments: $group, $field, $method
963a69a5	181
8019c4d8	182	Returns: \&accessor_coderef ?
963a69a5	183
	184	=back
	185
8019c4d8	186	Called by mk_group_ro_accessors for each entry in @fieldspec. Either returns
	187	a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
	188	C<undef> if it elects to install the coderef on its own.
963a69a5	189
	190	=cut
	191
85ccab9a	192	sub make_group_ro_accessor { $gen_accessor->('ro', @_) }
963a69a5	193
	194	=head2 make_group_wo_accessor
	195
	196	=over 4
	197
8019c4d8	198	=item Arguments: $group, $field, $method
963a69a5	199
8019c4d8	200	Returns: \&accessor_coderef ?
963a69a5	201
	202	=back
	203
8019c4d8	204	Called by mk_group_wo_accessors for each entry in @fieldspec. Either returns
	205	a coderef which will be installed at C<&__PACKAGE__::$method>, or returns
	206	C<undef> if it elects to install the coderef on its own.
963a69a5	207
	208	=cut
	209
85ccab9a	210	sub make_group_wo_accessor { $gen_accessor->('wo', @_) }
963a69a5	211
	212	=head2 get_simple
	213
	214	=over 4
	215
	216	=item Arguments: $field
	217
	218	Returns: $value
	219
	220	=back
	221
	222	Simple getter for hash-based objects which returns the value for the field
	223	name passed as an argument.
	224
	225	=cut
	226
	227	sub get_simple {
85ccab9a	228	return $_[0]->{$_[1]};
963a69a5	229	}
	230
	231	=head2 set_simple
	232
	233	=over 4
	234
	235	=item Arguments: $field, $new_value
	236
	237	Returns: $new_value
	238
	239	=back
	240
	241	Simple setter for hash-based objects which sets and then returns the value
	242	for the field name passed as an argument.
	243
	244	=cut
	245
	246	sub set_simple {
85ccab9a	247	return $_[0]->{$_[1]} = $_[2];
963a69a5	248	}
963a69a5	249
e6f2a0fd	250
	251	=head2 get_inherited
	252
	253	=over 4
	254
	255	=item Arguments: $field
	256
	257	Returns: $value
	258
	259	=back
	260
331e820d	261	Simple getter for Classes and hash-based objects which returns the value for
	262	the field name passed as an argument. This behaves much like
	263	L<Class::Data::Accessor> where the field can be set in a base class,
	264	inherited and changed in subclasses, and inherited and changed for object
	265	instances.
e6f2a0fd	266
	267	=cut
	268
	269	sub get_inherited {
a49c32d9	270	my $class;
e6f2a0fd	271
eece2562	272	if ( defined( $class = Scalar::Util::blessed $_[0] ) ) {
62cf9924	273	if (Scalar::Util::reftype $_[0] eq 'HASH') {
	274	return $_[0]->{$_[1]} if exists $_[0]->{$_[1]};
	275	}
	276	else {
	277	Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
	278	}
	279	}
	280	else {
a0bce8bc	281	$class = $_[0];
62cf9924	282	}
e6f2a0fd	283
e6f2a0fd	284	no strict 'refs';
eece2562	285	no warnings 'uninitialized';
62cf9924	286
	287	my $cag_slot = '::__cag_'. $_[1];
	288	return ${$class.$cag_slot} if defined(${$class.$cag_slot});
e6f2a0fd	289
4f8ce9da	290	# we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
62cf9924	291	my $cur_gen = mro::get_pkg_gen ($class);
	292	if ( $cur_gen != ${$class.'::__cag_pkg_gen__'} ) {
	293	@{$class.'::__cag_supers__'} = $_[0]->get_super_paths;
	294	${$class.'::__cag_pkg_gen__'} = $cur_gen;
	295	}
a49c32d9	296
62cf9924	297	for (@{$class.'::__cag_supers__'}) {
62cf9924	298	return ${$_.$cag_slot} if defined(${$_.$cag_slot});
e6f2a0fd	299	};
c46050d3	300
9c3d5179	301	return undef;
e6f2a0fd	302	}
	303
	304	=head2 set_inherited
	305
	306	=over 4
	307
	308	=item Arguments: $field, $new_value
	309
	310	Returns: $new_value
	311
	312	=back
	313
331e820d	314	Simple setter for Classes and hash-based objects which sets and then returns
	315	the value for the field name passed as an argument. When called on a hash-based
	316	object it will set the appropriate hash key value. When called on a class, it
	317	will set a class level variable.
e6f2a0fd	318
331e820d	319	B<Note:>: This method will die if you try to set an object variable on a non
331e820d	320	hash-based object.
e6f2a0fd	321
	322	=cut
	323
	324	sub set_inherited {
eece2562	325	if (defined Scalar::Util::blessed $_[0]) {
a0bce8bc	326	if (Scalar::Util::reftype $_[0] eq 'HASH') {
a0bce8bc	327	return $_[0]->{$_[1]} = $_[2];
e6f2a0fd	328	} else {
a0bce8bc	329	Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
e6f2a0fd	330	};
	331	} else {
	332	no strict 'refs';
	333
a0bce8bc	334	return ${$_[0].'::__cag_'.$_[1]} = $_[2];
e6f2a0fd	335	};
	336	}
	337
331e820d	338	=head2 get_component_class
	339
	340	=over 4
	341
	342	=item Arguments: $field
	343
	344	Returns: $value
	345
	346	=back
	347
	348	Gets the value of the specified component class.
	349
	350	__PACKAGE__->mk_group_accessors('component_class' => 'result_class');
97d76fb4	351
331e820d	352	$self->result_class->method();
97d76fb4	353
331e820d	354	## same as
	355	$self->get_component_class('result_class')->method();
	356
	357	=cut
	358
	359	sub get_component_class {
a0bce8bc	360	return $_[0]->get_inherited($_[1]);
331e820d	361	};
	362
	363	=head2 set_component_class
	364
	365	=over 4
	366
	367	=item Arguments: $field, $class
	368
	369	Returns: $new_value
	370
	371	=back
	372
	373	Inherited accessor that automatically loads the specified class before setting
	374	it. This method will die if the specified class could not be loaded.
	375
	376	__PACKAGE__->mk_group_accessors('component_class' => 'result_class');
	377	__PACKAGE__->result_class('MyClass');
97d76fb4	378
331e820d	379	$self->result_class->method();
	380
	381	=cut
	382
	383	sub set_component_class {
a0bce8bc	384	if ($_[2]) {
bce7bdf8	385	local $^W = 0;
01249db5	386	require Class::Inspector;
a0bce8bc	387	if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
85ccab9a	388	eval "require $_[2]";
331e820d	389
a0bce8bc	390	Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
331e820d	391	};
	392	};
	393
a0bce8bc	394	return $_[0]->set_inherited($_[1], $_[2]);
331e820d	395	};
331e820d	396
a49c32d9	397	=head2 get_super_paths
	398
	399	Returns a list of 'parent' or 'super' class names that the current class inherited from.
	400
	401	=cut
	402
	403	sub get_super_paths {
62cf9924	404	return @{mro::get_linear_isa( ref($_[0]) \|\| $_[0] )};
a49c32d9	405	};
a49c32d9	406
9d7d52da	407	=head1 PERFORMANCE
15cf8e32	408
8019c4d8	409	To provide total flexibility L<Class::Accessor::Grouped> calls methods
	410	internally while performing get/set actions, which makes it noticeably
	411	slower than similar modules. To compensate, this module will automatically
	412	use the insanely fast L<Class::XSAccessor> to generate the C<simple>-group
	413	accessors, if L<< Class::XSAccessor >= 1.06\|Class::XSAccessor >> is
	414	available on your system.
	415
	416	=head2 Benchmark
	417
	418	This is the result of a set/get/set loop benchmark on perl 5.12.1 with
	419	thread support, showcasing most popular accessor builders: L<Moose>, L<Mouse>,
	420	L<CAF\|Class::Accessor::Fast>, L<CAF_XS\|Class::Accessor::Fast::XS>
	421	and L<XSA\|Class::XSAccessor>:
	422
	423	Rate CAG moOse CAF HANDMADE CAF_XS moUse_XS CAG_XS XSA
	424	CAG 1777/s -- -27% -29% -36% -62% -67% -72% -73%
	425	moOse 2421/s 36% -- -4% -13% -48% -55% -61% -63%
	426	CAF 2511/s 41% 4% -- -10% -47% -53% -60% -61%
	427	HANDMADE 2791/s 57% 15% 11% -- -41% -48% -56% -57%
	428	CAF_XS 4699/s 164% 94% 87% 68% -- -13% -25% -28%
	429	moUse_XS 5375/s 203% 122% 114% 93% 14% -- -14% -18%
	430	CAG_XS 6279/s 253% 159% 150% 125% 34% 17% -- -4%
	431	XSA 6515/s 267% 169% 159% 133% 39% 21% 4% --
	432
	433	Benchmark program is available in the root of the
	434	L<repository\|http://search.cpan.org/dist/Class-Accessor-Grouped/>:
	435
	436	=head2 Notes on Class::XSAccessor
	437
bd83e674	438	You can force (or disable) the use of L<Class::XSAccessor> before creating a
	439	particular C<simple> accessor by either manipulating the global variable
	440	C<$Class::Accessor::Grouped::USE_XS> to true or false (preferably with
	441	L<localization\|perlfunc/local>, or you can do so before runtime via the
	442	C<CAG_USE_XS> environment variable.
	443
	444	Since L<Class::XSAccessor> has no knowledge of L</get_simple> and
	445	L</set_simple> this module does its best to detect if you are overriding
	446	one of these methods and will fall back to using the perl version of the
	447	accessor in order to maintain consistency. However be aware that if you
	448	enable use of C<Class::XSAccessor> (automatically or explicitly), create
	449	an object, invoke a simple accessor on that object, and B<then> manipulate
	450	the symbol table to install a C<get/set_simple> override - you get to keep
	451	all the pieces.
	452
8019c4d8	453	While L<Class::XSAccessor> works surprisingly well for the amount of black
	454	magic it tries to pull off, it's still black magic. At present (Sep 2010)
	455	the module is known to have problems on Windows under heavy thread-stress
	456	(e.g. Win32+Apache+mod_perl). Thus for the time being L<Class::XSAccessor>
	457	will not be used automatically if you are running under C<MSWin32>.
	458
963a69a5	459	=head1 AUTHORS
	460
	461	Matt S. Trout <mst@shadowcatsystems.co.uk>
ba6f7b1b	462
97972dcb	463	Christopher H. Laco <claco@chrislaco.com>
963a69a5	464
8ef9b3ff	465	=head1 CONTRIBUTORS
dfb86526	466
ba6f7b1b	467	Caelum: Rafael Kitover <rkitover@cpan.org>
ba6f7b1b	468
8ef9b3ff	469	groditi: Guillermo Roditi <groditi@cpan.org>
ba6f7b1b	470
6a4c729f	471	Jason Plum <jason.plum@bmmsi.com>
dfb86526	472
ba6f7b1b	473	ribasushi: Peter Rabbitson <ribasushi@cpan.org>
	474
	475
4fe25633	476	=head1 COPYRIGHT & LICENSE
963a69a5	477
af169484	478	Copyright (c) 2006-2010 Matt S. Trout <mst@shadowcatsystems.co.uk>
963a69a5	479
4fe25633	480	This program is free software; you can redistribute it and/or modify
4fe25633	481	it under the same terms as perl itself.
963a69a5	482
4fe25633	483	=cut
85ccab9a	484
	485	########################################################################
	486	########################################################################
	487	########################################################################
	488	#
	489	# Here be many angry dragons
	490	# (all code is in private coderefs since everything inherits CAG)
	491	#
	492	########################################################################
	493	########################################################################
	494
	495	BEGIN {
	496
	497	die "Huh?! No minimum C::XSA version?!\n"
	498	unless $__minimum_xsa_version;
	499
	500	local $@;
	501	my $err;
	502
	503	$err = eval { require Sub::Name; 1; } ? undef : do {
	504	delete $INC{'Sub/Name.pm'}; # because older perls suck
	505	$@;
	506	};
	507	*__CAG_NO_SUBNAME = $err
	508	? sub () { $err }
	509	: sub () { 0 }
	510	;
	511
	512
	513	$err = eval {
	514	require Class::XSAccessor;
	515	Class::XSAccessor->VERSION($__minimum_xsa_version);
	516	require Sub::Name;
	517	1;
	518	} ? undef : do {
	519	delete $INC{'Sub/Name.pm'}; # because older perls suck
	520	delete $INC{'Class/XSAccessor.pm'};
	521	$@;
	522	};
	523	*__CAG_NO_CXSA = $err
	524	? sub () { $err }
	525	: sub () { 0 }
	526	;
	527
	528
	529	*__CAG_BROKEN_GOTO = ($] < '5.008009')
	530	? sub () { 1 }
	531	: sub () { 0 }
	532	;
	533
eda06cc6	534
	535	*__CAG_UNSTABLE_DOLLARAT = ($] < '5.013002')
	536	? sub () { 1 }
	537	: sub () { 0 }
	538	;
	539
85ccab9a	540	};
	541
	542	# Autodetect unless flag supplied
	543	# Class::XSAccessor is segfaulting on win32, in some
	544	# esoteric heavily-threaded scenarios
	545	# Win32 users can set $USE_XS/CAG_USE_XS to try to use it anyway
	546	my $xsa_autodetected;
	547	if (! defined $USE_XS) {
	548	$USE_XS = (!__CAG_NO_CXSA and $^O ne 'MSWin32') ? 1 : 0;
	549	$xsa_autodetected++;
	550	}
	551
	552	my $maker_templates = {
	553	rw => {
	554	xs_call => 'accessors',
	555	pp_code => sub {
98694bf0	556	my $set = "set_$_[0]";
	557	my $get = "get_$_[0]";
	558	my $field = $_[1];
85ccab9a	559	$field =~ s/'/\\'/g;
	560
	561	"
	562	\@_ > 1
	563	? shift->$set('$field', \@_)
	564	: shift->$get('$field')
	565	"
	566	},
	567	},
	568	ro => {
	569	xs_call => 'getters',
	570	pp_code => sub {
98694bf0	571	my $get = "get_$_[0]";
98694bf0	572	my $field = $_[1];
85ccab9a	573	$field =~ s/'/\\'/g;
	574
	575	"
	576	\@_ == 1
	577	? shift->$get('$field')
	578	: do {
	579	my \$caller = caller;
98694bf0	580	my \$class = ref \$_[0] \|\| \$_[0];
	581	Carp::croak(\"'\$caller' cannot alter the value of '$field' \".
	582	\"(read-only attributes of class '\$class')\");
85ccab9a	583	}
	584	"
	585	},
	586	},
	587	wo => {
	588	xs_call => 'setters',
	589	pp_code => sub {
98694bf0	590	my $set = "set_$_[0]";
98694bf0	591	my $field = $_[1];
85ccab9a	592	$field =~ s/'/\\'/g;
	593
	594	"
	595	\@_ > 1
	596	? shift->$set('$field', \@_)
	597	: do {
	598	my \$caller = caller;
98694bf0	599	my \$class = ref \$_[0] \|\| \$_[0];
	600	Carp::croak(\"'\$caller' cannot access the value of '$field' \".
	601	\"(write-only attributes of class '\$class')\");
85ccab9a	602	}
	603	"
	604	},
	605	},
	606	};
	607
	608
	609	my ($accessor_maker_cache, $no_xsa_warned_classes);
	610
	611	# can't use pkg_gen to track this stuff, as it doesn't
	612	# detect superclass mucking
	613	my $original_simple_getter = __PACKAGE__->can ('get_simple');
	614	my $original_simple_setter = __PACKAGE__->can ('set_simple');
	615
	616	# Note!!! Unusual signature
	617	$gen_accessor = sub {
	618	my ($type, $class, $group, $field, $methname) = @_;
	619	if (my $c = ref $class) {
	620	$class = $c;
	621	}
	622
eda06cc6	623	my $fq_name = "${class}::${methname}";
eda06cc6	624
85ccab9a	625	# When installing an XSA simple accessor, we need to make sure we are not
	626	# short-circuiting a (compile or runtime) get_simple/set_simple override.
	627	# What we do here is install a lazy first-access check, which will decide
	628	# the ultimate coderef being placed in the accessor slot
	629	if ($USE_XS and $group eq 'simple') {
85ccab9a	630	($accessor_maker_cache->{xs}{$field}{$type}{$fq_name} \|\|= do {
	631	die sprintf( "Class::XSAccessor requested but not available:\n%s\n", __CAG_NO_CXSA )
	632	if __CAG_NO_CXSA;
	633
	634	sub { sub {
	635	my $current_class = Scalar::Util::blessed( $_[0] ) \|\| $_[0];
	636
	637	if (
	638	$current_class->can('get_simple') == $original_simple_getter
	639	&&
	640	$current_class->can('set_simple') == $original_simple_setter
	641	) {
	642	# nothing has changed, might as well use the XS crefs
	643	#
	644	# note that by the time this code executes, we already have
	645	# objects (since XSA works on 'simple' only by definition).
	646	# If someone is mucking with the symbol table after there
	647	# are some objects already - look! many, shiny pieces! :)
	648	Class::XSAccessor->import(
	649	replace => 1,
	650	class => $class,
	651	$maker_templates->{$type}{xs_call} => {
	652	$methname => $field,
	653	},
	654	);
	655	}
	656	else {
	657	if (! $xsa_autodetected and ! $no_xsa_warned_classes->{$current_class}++) {
	658	# not using Carp since the line where this happens doesn't mean much
	659	warn 'Explicitly requested use of Class::XSAccessor disabled for objects of class '
	660	. "'$current_class' due to an overriden get_simple and/or set_simple\n";
	661	}
	662
	663	no strict qw/refs/;
	664
	665	*$fq_name = Sub::Name::subname($fq_name, do {
	666	# that's faster than local
	667	$USE_XS = 0;
	668	my $c = $gen_accessor->($type, $class, 'simple', $field, $methname);
	669	$USE_XS = 1;
	670	$c;
	671	});
	672	}
	673
	674	# older perls segfault if the cref behind the goto throws
	675	# http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
	676	return $current_class->can($methname)->(@_) if __CAG_BROKEN_GOTO;
	677
	678	goto $current_class->can($methname);
	679	}}
	680	})->();
	681	}
	682
	683	# no Sub::Name - just install the coderefs directly (compiling every time)
	684	elsif (__CAG_NO_SUBNAME) {
eda06cc6	685	my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} \|\|=
	686	$maker_templates->{$type}{pp_code}->($group, $field);
	687
	688	local $@ if __CAG_UNSTABLE_DOLLARAT;
	689	eval "sub ${fq_name}{$src}";
	690
85ccab9a	691	undef; # so that no attempt will be made to install anything
	692	}
	693
	694	# a coderef generator with a variable pad (returns a fresh cref on every invocation)
85ccab9a	695	else {
98694bf0	696	($accessor_maker_cache->{pp}{$group}{$field}{$type} \|\|= do {
eda06cc6	697	my $src = $accessor_maker_cache->{source}{$type}{$group}{$field} \|\|=
	698	$maker_templates->{$type}{pp_code}->($group, $field);
	699
	700	local $@ if __CAG_UNSTABLE_DOLLARAT;
	701	eval "sub { my \$dummy; sub { \$dummy if 0; $src } }" or die $@;
85ccab9a	702	})->()
	703	}
	704	};
	705
	706	1;