[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' => sub {
                $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
                $_[0]->{$attr_name};
            },
            'reader' => sub { 
                $_[0]->{$attr_name};
            },
            'writer' => sub {
                $_[0]->{$attr_name} = $_[1];
                return;
            },
            'predicate' => 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 {
            return ($accessor => Class::MOP::Attribute::Accessor->wrap($ACCESSOR_TEMPLATES{$type}));
        }    
    };

    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();
    }
    
}

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)";    
        
    if ($self->has_accessor()) {
        my $accessor = $self->accessor();
        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'));
    }
    else {
        if ($self->has_reader()) {
            my $reader = $self->reader();
            if (reftype($reader) && reftype($reader) eq 'HASH') {
                ($reader) = keys %{$reader};
            }            
            my $method = $class->get_method($reader);
            $class->remove_method($reader)
                if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
        }
        if ($self->has_writer()) {
            my $writer = $self->writer();
            if (reftype($writer) && reftype($writer) eq 'HASH') {
                ($writer) = keys %{$writer};
            }            
            my $method = $class->get_method($writer);
            $class->remove_method($writer)
                if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
        }
    }  
    
    if ($self->has_predicate()) {
        my $predicate = $self->predicate();
        if (reftype($predicate) && reftype($predicate) eq 'HASH') {
            ($predicate) = keys %{$predicate};
        }        
        my $method = $class->get_method($predicate);
        $class->remove_method($predicate)
            if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
    }          
}

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 = (
	82	'accessor' => sub {
	83	$_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
	84	$_[0]->{$attr_name};
	85	},
	86	'reader' => sub {
	87	$_[0]->{$attr_name};
	88	},
	89	'writer' => sub {
	90	$_[0]->{$attr_name} = $_[1];
	91	return;
	92	},
	93	'predicate' => sub {
	94	return defined $_[0]->{$attr_name} ? 1 : 0;
	95	}
	96	);
	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 {
727919c5	103	return ($accessor => Class::MOP::Attribute::Accessor->wrap($ACCESSOR_TEMPLATES{$type}));
	104	}
	105	};
	106
	107	sub install_accessors {
	108	my ($self, $class) = @_;
	109	(blessed($class) && $class->isa('Class::MOP::Class'))
	110	\|\| confess "You must pass a Class::MOP::Class instance (or a subclass)";
	111
	112	$class->add_method(
	113	$_inspect_accessor->($self->name, 'accessor' => $self->accessor())
	114	) if $self->has_accessor();
	115
	116	$class->add_method(
	117	$_inspect_accessor->($self->name, 'reader' => $self->reader())
	118	) if $self->has_reader();
	119
	120	$class->add_method(
	121	$_inspect_accessor->($self->name, 'writer' => $self->writer())
	122	) if $self->has_writer();
	123
	124	$class->add_method(
	125	$_inspect_accessor->($self->name, 'predicate' => $self->predicate())
	126	) if $self->has_predicate();
2eb717d5	127	}
c50c603e	128
2eb717d5	129	}
	130
	131	sub remove_accessors {
	132	my ($self, $class) = @_;
	133	(blessed($class) && $class->isa('Class::MOP::Class'))
	134	\|\| confess "You must pass a Class::MOP::Class instance (or a subclass)";
	135
	136	if ($self->has_accessor()) {
c50c603e	137	my $accessor = $self->accessor();
	138	if (reftype($accessor) && reftype($accessor) eq 'HASH') {
	139	($accessor) = keys %{$accessor};
	140	}
	141	my $method = $class->get_method($accessor);
	142	$class->remove_method($accessor)
2eb717d5	143	if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
	144	}
	145	else {
	146	if ($self->has_reader()) {
c50c603e	147	my $reader = $self->reader();
	148	if (reftype($reader) && reftype($reader) eq 'HASH') {
	149	($reader) = keys %{$reader};
	150	}
	151	my $method = $class->get_method($reader);
	152	$class->remove_method($reader)
2eb717d5	153	if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
	154	}
	155	if ($self->has_writer()) {
c50c603e	156	my $writer = $self->writer();
	157	if (reftype($writer) && reftype($writer) eq 'HASH') {
	158	($writer) = keys %{$writer};
	159	}
	160	my $method = $class->get_method($writer);
	161	$class->remove_method($writer)
2eb717d5	162	if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
2eb717d5	163	}
c50c603e	164	}
	165
	166	if ($self->has_predicate()) {
	167	my $predicate = $self->predicate();
	168	if (reftype($predicate) && reftype($predicate) eq 'HASH') {
	169	($predicate) = keys %{$predicate};
	170	}
	171	my $method = $class->get_method($predicate);
	172	$class->remove_method($predicate)
	173	if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
	174	}
8b978dd5	175	}
8b978dd5	176
2eb717d5	177	package Class::MOP::Attribute::Accessor;
	178
	179	use strict;
	180	use warnings;
	181
727919c5	182	use Class::MOP::Method;
727919c5	183
2eb717d5	184	our $VERSION = '0.01';
	185
	186	our @ISA = ('Class::MOP::Method');
	187
8b978dd5	188	1;
	189
	190	__END__
	191
	192	=pod
	193
	194	=head1 NAME
	195
	196	Class::MOP::Attribute - Attribute Meta Object
	197
	198	=head1 SYNOPSIS
	199
	200	Class::MOP::Attribute->new('$foo' => (
	201	accessor => 'foo', # dual purpose get/set accessor
	202	init_arg => '-foo', # class->new will look for a -foo key
	203	default => 'BAR IS BAZ!' # if no -foo key is provided, use this
	204	));
	205
	206	Class::MOP::Attribute->new('$.bar' => (
	207	reader => 'bar', # getter
	208	writer => 'set_bar', # setter
	209	init_arg => '-bar', # class->new will look for a -bar key
	210	# no default value means it is undef
	211	));
	212
	213	=head1 DESCRIPTION
	214
552e3d24	215	The Attribute Protocol is almost entirely an invention of this module. This is
	216	because Perl 5 does not have consistent notion of what is an attribute
	217	of a class. There are so many ways in which this is done, and very few
	218	(if any) are discoverable by this module.
	219
	220	So, all that said, this module attempts to inject some order into this
	221	chaos, by introducing a more consistent approach.
	222
	223	=head1 METHODS
	224
	225	=head2 Creation
	226
	227	=over 4
	228
	229	=item B<new ($name, %accessor_description, $class_initialization_arg, $default_value)>
	230
	231	=back
	232
	233	=head2 Informational
	234
	235	=over 4
	236
	237	=item B<name>
	238
	239	=item B<accessor>
	240
	241	=item B<reader>
	242
	243	=item B<writer>
	244
c50c603e	245	=item B<predicate>
c50c603e	246
552e3d24	247	=item B<init_arg>
	248
	249	=item B<default>
	250
	251	=back
	252
	253	=head2 Informational predicates
	254
	255	=over 4
	256
	257	=item B<has_accessor>
	258
	259	Returns true if this attribute uses a get/set accessor, and false
	260	otherwise
	261
	262	=item B<has_reader>
	263
	264	Returns true if this attribute has a reader, and false otherwise
	265
	266	=item B<has_writer>
	267
	268	Returns true if this attribute has a writer, and false otherwise
	269
c50c603e	270	=item B<has_predicate>
	271
	272	Returns true if this attribute has a predicate, and false otherwise
	273
552e3d24	274	=item B<has_init_arg>
	275
	276	Returns true if this attribute has a class intialization argument, and
	277	false otherwise
	278
	279	=item B<has_default>
	280
	281	Returns true if this attribute has a default value, and false
	282	otherwise.
	283
	284	=back
	285
	286	=head2 Attribute Accessor generation
	287
	288	=over 4
	289
2eb717d5	290	=item B<install_accessors ($class)>
	291
	292	This allows the attribute to generate and install code for it's own
	293	accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
	294
	295	=item B<remove_accessors ($class)>
	296
	297	This allows the attribute to remove the method for it's own
	298	accessor. This is called by C<Class::MOP::Class::remove_attribute>.
	299
	300	=back
	301
	302	=head2 Introspection
	303
	304	=over 4
552e3d24	305
2eb717d5	306	=item B<meta>
552e3d24	307
	308	=back
	309
8b978dd5	310	=head1 AUTHOR
	311
	312	Stevan Little E<gt>stevan@iinteractive.comE<lt>
	313
	314	=head1 COPYRIGHT AND LICENSE
	315
	316	Copyright 2006 by Infinity Interactive, Inc.
	317
	318	L<http://www.iinteractive.com>
	319
	320	This library is free software; you can redistribute it and/or modify
	321	it under the same terms as Perl itself.
	322
	323	=cut