[gitmo/Class-MOP.git] / lib / Class / MOP / Attribute.pm


package Class::MOP::Attribute;

use strict;
use warnings;

use Carp         'confess';
use Scalar::Util 'blessed', 'reftype';

our $VERSION = '0.01';

sub meta { 
    require Class::MOP::Class;
    Class::MOP::Class->initialize($_[0]) 
}

# NOTE: (meta-circularity)
# This method will be replaces in the 
# boostrap section of Class::MOP, by 
# a new version which uses the 
# &Class::MOP::Class::construct_instance
# method to build an attribute meta-object
# which itself is described with attribute
# meta-objects. 
#     - Ain't meta-circularity grand? :)
sub new {
    my $class   = shift;
    my $name    = shift;
    my %options = @_;    
        
    (defined $name && $name)
        || confess "You must provide a name for the attribute";
    (!exists $options{reader} && !exists $options{writer})
        || confess "You cannot declare an accessor and reader and/or writer functions"
            if exists $options{accessor};
            
    bless {
        name      => $name,
        accessor  => $options{accessor},
        reader    => $options{reader},
        writer    => $options{writer},
        predicate => $options{predicate},
        init_arg  => $options{init_arg},
        default   => $options{default}
    } => $class;
}

sub name { $_[0]->{name} }

sub has_accessor  { defined($_[0]->{accessor})  ? 1 : 0 }
sub has_reader    { defined($_[0]->{reader})    ? 1 : 0 }
sub has_writer    { defined($_[0]->{writer})    ? 1 : 0 }
sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
sub has_init_arg  { defined($_[0]->{init_arg})  ? 1 : 0 }
sub has_default   { defined($_[0]->{default})   ? 1 : 0 }

sub accessor  { $_[0]->{accessor}  } 
sub reader    { $_[0]->{reader}    }
sub writer    { $_[0]->{writer}    }
sub predicate { $_[0]->{predicate} }
sub init_arg  { $_[0]->{init_arg}  }

sub default { 
    my $self = shift;
    if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
        # if the default is a CODE ref, then 
        # we pass in the instance and default
        # can return a value based on that 
        # instance. Somewhat crude, but works.
        return $self->{default}->(shift);
    }           
    $self->{default};
}

{
    # this is just a utility routine to 
    # handle the details of accessors
    my $_inspect_accessor = sub {
        my ($attr_name, $type, $accessor) = @_;
    
        my %ACCESSOR_TEMPLATES = (
            'accessor' => qq{sub {
                \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
                \$_[0]->{'$attr_name'};
            }},
            'reader' => qq{sub {
                \$_[0]->{'$attr_name'};
            }},
            'writer' => qq{sub {
                \$_[0]->{'$attr_name'} = \$_[1];
                return;
            }},
            'predicate' => qq{sub {
                return defined \$_[0]->{'$attr_name'} ? 1 : 0;
            }}
        );    
    
        if (reftype($accessor) && reftype($accessor) eq 'HASH') {
            my ($name, $method) = each %{$accessor};
            return ($name, Class::MOP::Attribute::Accessor->wrap($method));        
        }
        else {
            my $method = eval $ACCESSOR_TEMPLATES{$type};
            confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
            return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
        }    
    };

    sub install_accessors {
        my ($self, $class) = @_;
        (blessed($class) && $class->isa('Class::MOP::Class'))
            || confess "You must pass a Class::MOP::Class instance (or a subclass)";    
        $class->add_method(
            $_inspect_accessor->($self->name, 'accessor' => $self->accessor())
        ) if $self->has_accessor();

        $class->add_method(            
            $_inspect_accessor->($self->name, 'reader' => $self->reader())
        ) if $self->has_reader();
    
        $class->add_method(
            $_inspect_accessor->($self->name, 'writer' => $self->writer())
        ) if $self->has_writer();
    
        $class->add_method(
            $_inspect_accessor->($self->name, 'predicate' => $self->predicate())
        ) if $self->has_predicate();
        return;
    }
    
}

{
    my $_remove_accessor = sub {
        my ($accessor, $class) = @_;
        if (reftype($accessor) && reftype($accessor) eq 'HASH') {
            ($accessor) = keys %{$accessor};
        }        
        my $method = $class->get_method($accessor);   
        $class->remove_method($accessor) 
            if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
    };
    
    sub remove_accessors {
        my ($self, $class) = @_;
        (blessed($class) && $class->isa('Class::MOP::Class'))
            || confess "You must pass a Class::MOP::Class instance (or a subclass)";    
        $_remove_accessor->($self->accessor(),  $class) if $self->has_accessor();
        $_remove_accessor->($self->reader(),    $class) if $self->has_reader();
        $_remove_accessor->($self->writer(),    $class) if $self->has_writer();
        $_remove_accessor->($self->predicate(), $class) if $self->has_predicate();
        return;                        
    }

}

package Class::MOP::Attribute::Accessor;

use strict;
use warnings;

use Class::MOP::Method;

our $VERSION = '0.01';

our @ISA = ('Class::MOP::Method');

1;

__END__

=pod

=head1 NAME 

Class::MOP::Attribute - Attribute Meta Object

=head1 SYNOPSIS
  
  Class::MOP::Attribute->new('$foo' => (
      accessor => 'foo',        # dual purpose get/set accessor
      init_arg => '-foo',       # class->new will look for a -foo key
      default  => 'BAR IS BAZ!' # if no -foo key is provided, use this
  ));
  
  Class::MOP::Attribute->new('$.bar' => (
      reader   => 'bar',        # getter
      writer   => 'set_bar',    # setter      
      init_arg => '-bar',       # class->new will look for a -bar key
      # no default value means it is undef
  ));

=head1 DESCRIPTION

The Attribute Protocol is almost entirely an invention of this module. This is
because Perl 5 does not have consistent notion of what is an attribute 
of a class. There are so many ways in which this is done, and very few 
(if any) are discoverable by this module.

So, all that said, this module attempts to inject some order into this 
chaos, by introducing a more consistent approach.

=head1 METHODS

=head2 Creation

=over 4

=item B<new ($name, %accessor_description, $class_initialization_arg, $default_value)>

=back 

=head2 Informational

=over 4

=item B<name>

=item B<accessor>

=item B<reader>

=item B<writer>

=item B<predicate>

=item B<init_arg>

=item B<default>

=back

=head2 Informational predicates

=over 4

=item B<has_accessor>

Returns true if this attribute uses a get/set accessor, and false 
otherwise

=item B<has_reader>

Returns true if this attribute has a reader, and false otherwise

=item B<has_writer>

Returns true if this attribute has a writer, and false otherwise

=item B<has_predicate>

Returns true if this attribute has a predicate, and false otherwise

=item B<has_init_arg>

Returns true if this attribute has a class intialization argument, and 
false otherwise

=item B<has_default>

Returns true if this attribute has a default value, and false 
otherwise.

=back

=head2 Attribute Accessor generation

=over 4

=item B<install_accessors ($class)>

This allows the attribute to generate and install code for it's own 
accessor methods. This is called by C<Class::MOP::Class::add_attribute>.

=item B<remove_accessors ($class)>

This allows the attribute to remove the method for it's own 
accessor. This is called by C<Class::MOP::Class::remove_attribute>.

=back

=head2 Introspection

=over 4

=item B<meta>

=back

=head1 AUTHOR

Stevan Little E<gt>stevan@iinteractive.comE<lt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

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

=cut
Commit	Line	Data
8b978dd5	1
	2	package Class::MOP::Attribute;
	3
	4	use strict;
	5	use warnings;
	6
2eb717d5	7	use Carp 'confess';
c50c603e	8	use Scalar::Util 'blessed', 'reftype';
2eb717d5	9
8b978dd5	10	our $VERSION = '0.01';
8b978dd5	11
727919c5	12	sub meta {
	13	require Class::MOP::Class;
	14	Class::MOP::Class->initialize($_[0])
	15	}
2eb717d5	16
727919c5	17	# NOTE: (meta-circularity)
	18	# This method will be replaces in the
	19	# boostrap section of Class::MOP, by
	20	# a new version which uses the
	21	# &Class::MOP::Class::construct_instance
	22	# method to build an attribute meta-object
	23	# which itself is described with attribute
	24	# meta-objects.
	25	# - Ain't meta-circularity grand? :)
8b978dd5	26	sub new {
	27	my $class = shift;
	28	my $name = shift;
	29	my %options = @_;
	30
cbd9f942	31	(defined $name && $name)
8b978dd5	32	\|\| confess "You must provide a name for the attribute";
2eb717d5	33	(!exists $options{reader} && !exists $options{writer})
	34	\|\| confess "You cannot declare an accessor and reader and/or writer functions"
	35	if exists $options{accessor};
	36
8b978dd5	37	bless {
c50c603e	38	name => $name,
	39	accessor => $options{accessor},
	40	reader => $options{reader},
	41	writer => $options{writer},
	42	predicate => $options{predicate},
	43	init_arg => $options{init_arg},
	44	default => $options{default}
8b978dd5	45	} => $class;
	46	}
	47
c50c603e	48	sub name { $_[0]->{name} }
c50c603e	49
727919c5	50	sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
	51	sub has_reader { defined($_[0]->{reader}) ? 1 : 0 }
	52	sub has_writer { defined($_[0]->{writer}) ? 1 : 0 }
c50c603e	53	sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
727919c5	54	sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
727919c5	55	sub has_default { defined($_[0]->{default}) ? 1 : 0 }
c50c603e	56
	57	sub accessor { $_[0]->{accessor} }
	58	sub reader { $_[0]->{reader} }
	59	sub writer { $_[0]->{writer} }
	60	sub predicate { $_[0]->{predicate} }
	61	sub init_arg { $_[0]->{init_arg} }
	62
	63	sub default {
	64	my $self = shift;
	65	if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
727919c5	66	# if the default is a CODE ref, then
	67	# we pass in the instance and default
	68	# can return a value based on that
	69	# instance. Somewhat crude, but works.
c50c603e	70	return $self->{default}->(shift);
	71	}
	72	$self->{default};
	73	}
8b978dd5	74
727919c5	75	{
	76	# this is just a utility routine to
	77	# handle the details of accessors
	78	my $_inspect_accessor = sub {
	79	my ($attr_name, $type, $accessor) = @_;
	80
	81	my %ACCESSOR_TEMPLATES = (
b51af7f9	82	'accessor' => qq{sub {
	83	\$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
	84	\$_[0]->{'$attr_name'};
	85	}},
	86	'reader' => qq{sub {
	87	\$_[0]->{'$attr_name'};
	88	}},
	89	'writer' => qq{sub {
	90	\$_[0]->{'$attr_name'} = \$_[1];
727919c5	91	return;
b51af7f9	92	}},
	93	'predicate' => qq{sub {
	94	return defined \$_[0]->{'$attr_name'} ? 1 : 0;
	95	}}
727919c5	96	);
727919c5	97
c50c603e	98	if (reftype($accessor) && reftype($accessor) eq 'HASH') {
c50c603e	99	my ($name, $method) = each %{$accessor};
727919c5	100	return ($name, Class::MOP::Attribute::Accessor->wrap($method));
c50c603e	101	}
c50c603e	102	else {
b51af7f9	103	my $method = eval $ACCESSOR_TEMPLATES{$type};
	104	confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
	105	return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
727919c5	106	}
	107	};
	108
	109	sub install_accessors {
	110	my ($self, $class) = @_;
	111	(blessed($class) && $class->isa('Class::MOP::Class'))
	112	\|\| confess "You must pass a Class::MOP::Class instance (or a subclass)";
727919c5	113	$class->add_method(
	114	$_inspect_accessor->($self->name, 'accessor' => $self->accessor())
	115	) if $self->has_accessor();
	116
	117	$class->add_method(
	118	$_inspect_accessor->($self->name, 'reader' => $self->reader())
	119	) if $self->has_reader();
	120
	121	$class->add_method(
	122	$_inspect_accessor->($self->name, 'writer' => $self->writer())
	123	) if $self->has_writer();
	124
	125	$class->add_method(
	126	$_inspect_accessor->($self->name, 'predicate' => $self->predicate())
	127	) if $self->has_predicate();
b51af7f9	128	return;
2eb717d5	129	}
c50c603e	130
2eb717d5	131	}
2eb717d5	132
b51af7f9	133	{
	134	my $_remove_accessor = sub {
	135	my ($accessor, $class) = @_;
c50c603e	136	if (reftype($accessor) && reftype($accessor) eq 'HASH') {
	137	($accessor) = keys %{$accessor};
	138	}
b51af7f9	139	my $method = $class->get_method($accessor);
b51af7f9	140	$class->remove_method($accessor)
2eb717d5	141	if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
b51af7f9	142	};
c50c603e	143
b51af7f9	144	sub remove_accessors {
	145	my ($self, $class) = @_;
	146	(blessed($class) && $class->isa('Class::MOP::Class'))
	147	\|\| confess "You must pass a Class::MOP::Class instance (or a subclass)";
	148	$_remove_accessor->($self->accessor(), $class) if $self->has_accessor();
	149	$_remove_accessor->($self->reader(), $class) if $self->has_reader();
	150	$_remove_accessor->($self->writer(), $class) if $self->has_writer();
	151	$_remove_accessor->($self->predicate(), $class) if $self->has_predicate();
	152	return;
	153	}
	154
8b978dd5	155	}
8b978dd5	156
2eb717d5	157	package Class::MOP::Attribute::Accessor;
	158
	159	use strict;
	160	use warnings;
	161
727919c5	162	use Class::MOP::Method;
727919c5	163
2eb717d5	164	our $VERSION = '0.01';
	165
	166	our @ISA = ('Class::MOP::Method');
	167
8b978dd5	168	1;
	169
	170	__END__
	171
	172	=pod
	173
	174	=head1 NAME
	175
	176	Class::MOP::Attribute - Attribute Meta Object
	177
	178	=head1 SYNOPSIS
	179
	180	Class::MOP::Attribute->new('$foo' => (
	181	accessor => 'foo', # dual purpose get/set accessor
	182	init_arg => '-foo', # class->new will look for a -foo key
	183	default => 'BAR IS BAZ!' # if no -foo key is provided, use this
	184	));
	185
	186	Class::MOP::Attribute->new('$.bar' => (
	187	reader => 'bar', # getter
	188	writer => 'set_bar', # setter
	189	init_arg => '-bar', # class->new will look for a -bar key
	190	# no default value means it is undef
	191	));
	192
	193	=head1 DESCRIPTION
	194
552e3d24	195	The Attribute Protocol is almost entirely an invention of this module. This is
	196	because Perl 5 does not have consistent notion of what is an attribute
	197	of a class. There are so many ways in which this is done, and very few
	198	(if any) are discoverable by this module.
	199
	200	So, all that said, this module attempts to inject some order into this
	201	chaos, by introducing a more consistent approach.
	202
	203	=head1 METHODS
	204
	205	=head2 Creation
	206
	207	=over 4
	208
	209	=item B<new ($name, %accessor_description, $class_initialization_arg, $default_value)>
	210
	211	=back
	212
	213	=head2 Informational
	214
	215	=over 4
	216
	217	=item B<name>
	218
	219	=item B<accessor>
	220
	221	=item B<reader>
	222
	223	=item B<writer>
	224
c50c603e	225	=item B<predicate>
c50c603e	226
552e3d24	227	=item B<init_arg>
	228
	229	=item B<default>
	230
	231	=back
	232
	233	=head2 Informational predicates
	234
	235	=over 4
	236
	237	=item B<has_accessor>
	238
	239	Returns true if this attribute uses a get/set accessor, and false
	240	otherwise
	241
	242	=item B<has_reader>
	243
	244	Returns true if this attribute has a reader, and false otherwise
	245
	246	=item B<has_writer>
	247
	248	Returns true if this attribute has a writer, and false otherwise
	249
c50c603e	250	=item B<has_predicate>
	251
	252	Returns true if this attribute has a predicate, and false otherwise
	253
552e3d24	254	=item B<has_init_arg>
	255
	256	Returns true if this attribute has a class intialization argument, and
	257	false otherwise
	258
	259	=item B<has_default>
	260
	261	Returns true if this attribute has a default value, and false
	262	otherwise.
	263
	264	=back
	265
	266	=head2 Attribute Accessor generation
	267
	268	=over 4
	269
2eb717d5	270	=item B<install_accessors ($class)>
	271
	272	This allows the attribute to generate and install code for it's own
	273	accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
	274
	275	=item B<remove_accessors ($class)>
	276
	277	This allows the attribute to remove the method for it's own
	278	accessor. This is called by C<Class::MOP::Class::remove_attribute>.
	279
	280	=back
	281
	282	=head2 Introspection
	283
	284	=over 4
552e3d24	285
2eb717d5	286	=item B<meta>
552e3d24	287
	288	=back
	289
8b978dd5	290	=head1 AUTHOR
	291
	292	Stevan Little E<gt>stevan@iinteractive.comE<lt>
	293
	294	=head1 COPYRIGHT AND LICENSE
	295
	296	Copyright 2006 by Infinity Interactive, Inc.
	297
	298	L<http://www.iinteractive.com>
	299
	300	This library is free software; you can redistribute it and/or modify
	301	it under the same terms as Perl itself.
	302
	303	=cut