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

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

our $VERSION = '0.08999_01';

BEGIN {
    our $hasXS;

    sub _hasXS {
        return $hasXS if defined $hasXS;
    
        $hasXS = 0;
        eval {
            require Class::XSAccessor;
            $hasXS = 1;
        };
    
        return $hasXS;
    }
}

=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;
        
        my $hasXS = _hasXS();

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

            my $name = $field;

            ($name, $field) = @$field if ref $field;
            
            my $alias = "_${name}_accessor";
            my $full_name = join('::', $class, $name);
            my $full_alias = join('::', $class, $alias);
            
            if ( $hasXS && $group eq 'simple' ) {
                Class::XSAccessor::newxs_accessor("${class}::${name}", $field, 0);
                Class::XSAccessor::newxs_accessor("${class}::${alias}", $field, 0);
                
                # XXX: is the alias accessor really necessary?
            }
            else {
                my $accessor = $self->$maker($group, $field);
                my $alias_accessor = $self->$maker($group, $field);
                
                *$full_name = Sub::Name::subname($full_name, $accessor);
                  #unless defined &{$class."\:\:$field"}
                
                *$full_alias = Sub::Name::subname($full_alias, $alias_accessor);
                  #unless defined &{$class."\:\:$alias"}
            }
        }
    }
}

=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

Returns: $sub (\CODE)

=back

Returns a single accessor in a given group; called by mk_group_accessors
for each entry in @fieldspec.

=cut

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

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

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

=head2 make_group_ro_accessor

=over 4

=item Arguments: $group, $field

Returns: $sub (\CODE)

=back

Returns a single read-only accessor in a given group; called by
mk_group_ro_accessors for each entry in @fieldspec.

=cut

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

    my $get = "get_$group";

    return 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');
        }
    };"
}

=head2 make_group_wo_accessor

=over 4

=item Arguments: $group, $field

Returns: $sub (\CODE)

=back

Returns a single write-only accessor in a given group; called by
mk_group_wo_accessors for each entry in @fieldspec.

=cut

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

    my $set = "set_$group";

    return 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', \@_);
        }
    };"
}

=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 (Scalar::Util::blessed $_[0]) {
        my $reftype = Scalar::Util::reftype $_[0];
        $class = ref $_[0];

        if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) {
            return $_[0]->{$_[1]};
        } elsif ($reftype ne 'HASH') {
            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/;
    return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});

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

    foreach (@{$class.'::__cag_supers'}) {
        return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]});
    };

    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;
        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 {
    my $class = Scalar::Util::blessed $_[0] || $_[0];

    return @{mro::get_linear_isa($class)};
};

1;

=head1 AUTHORS

Matt S. Trout <mst@shadowcatsystems.co.uk>
Christopher H. Laco <claco@chrislaco.com>

With contributions from:

Guillermo Roditi <groditi@cpan.org>

=head1 LICENSE

You may distribute this code 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 ();
331e820d	5	use Class::Inspector ();
a0bce8bc	6	use Scalar::Util ();
8787799c	7	use MRO::Compat;
1ee74bdd	8	use Sub::Name ();
331e820d	9
9540f4e4	10	our $VERSION = '0.08999_01';
	11
	12	BEGIN {
	13	our $hasXS;
	14
	15	sub _hasXS {
	16	return $hasXS if defined $hasXS;
	17
	18	$hasXS = 0;
	19	eval {
	20	require Class::XSAccessor;
	21	$hasXS = 1;
	22	};
	23
	24	return $hasXS;
	25	}
	26	}
963a69a5	27
	28	=head1 NAME
	29
1ad8d8c6	30	Class::Accessor::Grouped - Lets you build groups of accessors
963a69a5	31
	32	=head1 SYNOPSIS
	33
	34	=head1 DESCRIPTION
	35
	36	This class lets you build groups of accessors that will call different
	37	getters and setters.
	38
	39	=head1 METHODS
	40
	41	=head2 mk_group_accessors
	42
	43	=over 4
	44
	45	=item Arguments: $group, @fieldspec
	46
	47	Returns: none
	48
	49	=back
	50
	51	Creates a set of accessors in a given group.
	52
	53	$group is the name of the accessor group for the generated accessors; they
	54	will call get_$group($field) on get and set_$group($field, $value) on set.
	55
22fa6720	56	If you want to mimic Class::Accessor's mk_accessors $group has to be 'simple'
	57	to tell Class::Accessor::Grouped to use its own get_simple and set_simple
	58	methods.
	59
963a69a5	60	@fieldspec is a list of field/accessor names; if a fieldspec is a scalar
	61	this is used as both field and accessor name, if a listref it is expected to
	62	be of the form [ $accessor, $field ].
	63
	64	=cut
	65
	66	sub mk_group_accessors {
	67	my ($self, $group, @fields) = @_;
	68
	69	$self->_mk_group_accessors('make_group_accessor', $group, @fields);
	70	return;
	71	}
	72
	73
	74	{
	75	no strict 'refs';
	76	no warnings 'redefine';
	77
	78	sub _mk_group_accessors {
	79	my($self, $maker, $group, @fields) = @_;
a0bce8bc	80	my $class = Scalar::Util::blessed $self \|\| $self;
963a69a5	81
	82	# So we don't have to do lots of lookups inside the loop.
	83	$maker = $self->can($maker) unless ref $maker;
9540f4e4	84
9540f4e4	85	my $hasXS = _hasXS();
963a69a5	86
	87	foreach my $field (@fields) {
	88	if( $field eq 'DESTROY' ) {
a0bce8bc	89	Carp::carp("Having a data accessor named DESTROY in ".
963a69a5	90	"'$class' is unwise.");
	91	}
	92
	93	my $name = $field;
	94
	95	($name, $field) = @$field if ref $field;
9540f4e4	96
963a69a5	97	my $alias = "_${name}_accessor";
1ee74bdd	98	my $full_name = join('::', $class, $name);
1ee74bdd	99	my $full_alias = join('::', $class, $alias);
9540f4e4	100
	101	if ( $hasXS && $group eq 'simple' ) {
	102	Class::XSAccessor::newxs_accessor("${class}::${name}", $field, 0);
	103	Class::XSAccessor::newxs_accessor("${class}::${alias}", $field, 0);
	104
	105	# XXX: is the alias accessor really necessary?
	106	}
	107	else {
	108	my $accessor = $self->$maker($group, $field);
	109	my $alias_accessor = $self->$maker($group, $field);
	110
	111	*$full_name = Sub::Name::subname($full_name, $accessor);
	112	#unless defined &{$class."\:\:$field"}
	113
	114	*$full_alias = Sub::Name::subname($full_alias, $alias_accessor);
	115	#unless defined &{$class."\:\:$alias"}
	116	}
963a69a5	117	}
	118	}
	119	}
	120
	121	=head2 mk_group_ro_accessors
	122
	123	=over 4
	124
	125	=item Arguments: $group, @fieldspec
	126
	127	Returns: none
	128
	129	=back
	130
	131	Creates a set of read only accessors in a given group. Identical to
	132	<L:/mk_group_accessors> but accessors will throw an error if passed a value
	133	rather than setting the value.
	134
	135	=cut
	136
	137	sub mk_group_ro_accessors {
	138	my($self, $group, @fields) = @_;
	139
	140	$self->_mk_group_accessors('make_group_ro_accessor', $group, @fields);
	141	}
	142
	143	=head2 mk_group_wo_accessors
	144
	145	=over 4
	146
	147	=item Arguments: $group, @fieldspec
	148
	149	Returns: none
	150
	151	=back
	152
	153	Creates a set of write only accessors in a given group. Identical to
	154	<L:/mk_group_accessors> but accessors will throw an error if not passed a
	155	value rather than getting the value.
	156
	157	=cut
	158
	159	sub mk_group_wo_accessors {
	160	my($self, $group, @fields) = @_;
	161
	162	$self->_mk_group_accessors('make_group_wo_accessor', $group, @fields);
	163	}
	164
	165	=head2 make_group_accessor
	166
	167	=over 4
	168
	169	=item Arguments: $group, $field
	170
	171	Returns: $sub (\CODE)
	172
	173	=back
	174
	175	Returns a single accessor in a given group; called by mk_group_accessors
	176	for each entry in @fieldspec.
	177
	178	=cut
	179
	180	sub make_group_accessor {
181	my ($class, $group, $field) = @_;
182
183	my $set = "set_$group";
184	my $get = "get_$group";
185
a0bce8bc	186	# eval for faster fastiness
	187	return eval "sub {
	188	if(\@_ > 1) {
	189	return shift->$set('$field', \@_);
963a69a5	190	}
963a69a5	191	else {
a0bce8bc	192	return shift->$get('$field');
963a69a5	193	}
a0bce8bc	194	};"
963a69a5	195	}
	196
	197	=head2 make_group_ro_accessor
	198
	199	=over 4
	200
	201	=item Arguments: $group, $field
	202
	203	Returns: $sub (\CODE)
	204
	205	=back
	206
	207	Returns a single read-only accessor in a given group; called by
	208	mk_group_ro_accessors for each entry in @fieldspec.
	209
	210	=cut
	211
	212	sub make_group_ro_accessor {
	213	my($class, $group, $field) = @_;
	214
	215	my $get = "get_$group";
	216
a0bce8bc	217	return eval "sub {
	218	if(\@_ > 1) {
	219	my \$caller = caller;
	220	Carp::croak(\"'\$caller' cannot alter the value of '$field' on \".
	221	\"objects of class '$class'\");
963a69a5	222	}
963a69a5	223	else {
a0bce8bc	224	return shift->$get('$field');
963a69a5	225	}
a0bce8bc	226	};"
963a69a5	227	}
	228
	229	=head2 make_group_wo_accessor
	230
	231	=over 4
	232
	233	=item Arguments: $group, $field
	234
	235	Returns: $sub (\CODE)
	236
	237	=back
	238
	239	Returns a single write-only accessor in a given group; called by
	240	mk_group_wo_accessors for each entry in @fieldspec.
	241
	242	=cut
	243
	244	sub make_group_wo_accessor {
	245	my($class, $group, $field) = @_;
	246
	247	my $set = "set_$group";
	248
a0bce8bc	249	return eval "sub {
	250	unless (\@_ > 1) {
	251	my \$caller = caller;
	252	Carp::croak(\"'\$caller' cannot access the value of '$field' on \".
	253	\"objects of class '$class'\");
963a69a5	254	}
963a69a5	255	else {
a0bce8bc	256	return shift->$set('$field', \@_);
963a69a5	257	}
a0bce8bc	258	};"
963a69a5	259	}
	260
	261	=head2 get_simple
	262
	263	=over 4
	264
	265	=item Arguments: $field
	266
	267	Returns: $value
	268
	269	=back
	270
	271	Simple getter for hash-based objects which returns the value for the field
	272	name passed as an argument.
	273
	274	=cut
	275
	276	sub get_simple {
a0bce8bc	277	return $_[0]->{$_[1]};
963a69a5	278	}
	279
	280	=head2 set_simple
	281
	282	=over 4
	283
	284	=item Arguments: $field, $new_value
	285
	286	Returns: $new_value
	287
	288	=back
	289
	290	Simple setter for hash-based objects which sets and then returns the value
	291	for the field name passed as an argument.
	292
	293	=cut
	294
	295	sub set_simple {
a0bce8bc	296	return $_[0]->{$_[1]} = $_[2];
963a69a5	297	}
963a69a5	298
e6f2a0fd	299
	300	=head2 get_inherited
	301
	302	=over 4
	303
	304	=item Arguments: $field
	305
	306	Returns: $value
	307
	308	=back
	309
331e820d	310	Simple getter for Classes and hash-based objects which returns the value for
	311	the field name passed as an argument. This behaves much like
	312	L<Class::Data::Accessor> where the field can be set in a base class,
	313	inherited and changed in subclasses, and inherited and changed for object
	314	instances.
e6f2a0fd	315
	316	=cut
	317
	318	sub get_inherited {
a49c32d9	319	my $class;
e6f2a0fd	320
a0bce8bc	321	if (Scalar::Util::blessed $_[0]) {
	322	my $reftype = Scalar::Util::reftype $_[0];
	323	$class = ref $_[0];
a49c32d9	324
a0bce8bc	325	if ($reftype eq 'HASH' && exists $_[0]->{$_[1]}) {
a0bce8bc	326	return $_[0]->{$_[1]};
a49c32d9	327	} elsif ($reftype ne 'HASH') {
a0bce8bc	328	Carp::croak('Cannot get inherited value on an object instance that is not hash-based');
e6f2a0fd	329	};
a49c32d9	330	} else {
a0bce8bc	331	$class = $_[0];
e6f2a0fd	332	};
	333
	334	no strict 'refs';
fe63d727	335	no warnings qw/uninitialized/;
a0bce8bc	336	return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});
e6f2a0fd	337
4f8ce9da	338	# we need to be smarter about recalculation, as @ISA (thus supers) can very well change in-flight
4f8ce9da	339	my $pkg_gen = mro::get_pkg_gen ($class);
fe63d727	340	if ( ${$class.'::__cag_pkg_gen'} != $pkg_gen ) {
a0bce8bc	341	@{$class.'::__cag_supers'} = $_[0]->get_super_paths;
4f8ce9da	342	${$class.'::__cag_pkg_gen'} = $pkg_gen;
a49c32d9	343	};
	344
	345	foreach (@{$class.'::__cag_supers'}) {
a0bce8bc	346	return ${$_.'::__cag_'.$_[1]} if defined(${$_.'::__cag_'.$_[1]});
e6f2a0fd	347	};
c46050d3	348
9c3d5179	349	return undef;
e6f2a0fd	350	}
	351
	352	=head2 set_inherited
	353
	354	=over 4
	355
	356	=item Arguments: $field, $new_value
	357
	358	Returns: $new_value
	359
	360	=back
	361
331e820d	362	Simple setter for Classes and hash-based objects which sets and then returns
	363	the value for the field name passed as an argument. When called on a hash-based
	364	object it will set the appropriate hash key value. When called on a class, it
	365	will set a class level variable.
e6f2a0fd	366
331e820d	367	B<Note:>: This method will die if you try to set an object variable on a non
331e820d	368	hash-based object.
e6f2a0fd	369
	370	=cut
	371
	372	sub set_inherited {
a0bce8bc	373	if (Scalar::Util::blessed $_[0]) {
	374	if (Scalar::Util::reftype $_[0] eq 'HASH') {
	375	return $_[0]->{$_[1]} = $_[2];
e6f2a0fd	376	} else {
a0bce8bc	377	Carp::croak('Cannot set inherited value on an object instance that is not hash-based');
e6f2a0fd	378	};
	379	} else {
	380	no strict 'refs';
	381
a0bce8bc	382	return ${$_[0].'::__cag_'.$_[1]} = $_[2];
e6f2a0fd	383	};
	384	}
	385
331e820d	386	=head2 get_component_class
	387
	388	=over 4
	389
	390	=item Arguments: $field
	391
	392	Returns: $value
	393
	394	=back
	395
	396	Gets the value of the specified component class.
	397
	398	__PACKAGE__->mk_group_accessors('component_class' => 'result_class');
97d76fb4	399
331e820d	400	$self->result_class->method();
97d76fb4	401
331e820d	402	## same as
	403	$self->get_component_class('result_class')->method();
	404
	405	=cut
	406
	407	sub get_component_class {
a0bce8bc	408	return $_[0]->get_inherited($_[1]);
331e820d	409	};
	410
	411	=head2 set_component_class
	412
	413	=over 4
	414
	415	=item Arguments: $field, $class
	416
	417	Returns: $new_value
	418
	419	=back
	420
	421	Inherited accessor that automatically loads the specified class before setting
	422	it. This method will die if the specified class could not be loaded.
	423
	424	__PACKAGE__->mk_group_accessors('component_class' => 'result_class');
	425	__PACKAGE__->result_class('MyClass');
97d76fb4	426
331e820d	427	$self->result_class->method();
	428
	429	=cut
	430
	431	sub set_component_class {
a0bce8bc	432	if ($_[2]) {
bce7bdf8	433	local $^W = 0;
a0bce8bc	434	if (Class::Inspector->installed($_[2]) && !Class::Inspector->loaded($_[2])) {
a0bce8bc	435	eval "use $_[2]";
331e820d	436
a0bce8bc	437	Carp::croak("Could not load $_[1] '$_[2]': ", $@) if $@;
331e820d	438	};
	439	};
	440
a0bce8bc	441	return $_[0]->set_inherited($_[1], $_[2]);
331e820d	442	};
331e820d	443
a49c32d9	444	=head2 get_super_paths
	445
	446	Returns a list of 'parent' or 'super' class names that the current class inherited from.
	447
	448	=cut
	449
	450	sub get_super_paths {
a0bce8bc	451	my $class = Scalar::Util::blessed $_[0] \|\| $_[0];
a49c32d9	452
8787799c	453	return @{mro::get_linear_isa($class)};
a49c32d9	454	};
a49c32d9	455
963a69a5	456	1;
	457
	458	=head1 AUTHORS
	459
	460	Matt S. Trout <mst@shadowcatsystems.co.uk>
97972dcb	461	Christopher H. Laco <claco@chrislaco.com>
963a69a5	462
dfb86526	463	With contributions from:
	464
	465	Guillermo Roditi <groditi@cpan.org>
	466
963a69a5	467	=head1 LICENSE
	468
	469	You may distribute this code under the same terms as Perl itself.
	470
	471	=cut
	472