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

our $VERSION = '0.08001';

=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 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 $accessor = $self->$maker($group, $field);
            my $alias = "_${name}_accessor";

            *{$class."\:\:$name"}  = $accessor;
              #unless defined &{$class."\:\:$field"}

            *{$class."\:\:$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 {
    my ($self, $get) = @_;
  return $self->{$get};
  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';
    return ${$class.'::__cag_'.$_[1]} if defined(${$class.'::__cag_'.$_[1]});

    if (!@{$class.'::__cag_supers'}) {
        @{$class.'::__cag_supers'} = $_[0]->get_super_paths;
    };

    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>

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