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

use Class::MOP::Class;
use Class::MOP::Method;

our $VERSION = '0.01';

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

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') {
        return $self->{default}->(shift);
    }           
    $self->{default};
}

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)";    
        
    if ($self->has_accessor()) {
        my $accessor = $self->accessor();
        if (reftype($accessor) && reftype($accessor) eq 'HASH') {
            my ($name, $method) = each %{$accessor};
            $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
        }
        else {
            $class->add_method($accessor => Class::MOP::Attribute::Accessor->wrap(sub {
                $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
                $_[0]->{$self->name};
            }));
        }
    }
    else {
        if ($self->has_reader()) {      
            my $reader = $self->reader();
            if (reftype($reader) && reftype($reader) eq 'HASH') {
                my ($name, $method) = each %{$reader};
                $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
            }
            else {             
                $class->add_method($reader => Class::MOP::Attribute::Accessor->wrap(sub { 
                    $_[0]->{$self->name};
                }));        
            }
        }
        if ($self->has_writer()) {
            my $writer = $self->writer();
            if (reftype($writer) && reftype($writer) eq 'HASH') {
                my ($name, $method) = each %{$writer};
                $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
            }
            else {            
                $class->add_method($writer => Class::MOP::Attribute::Accessor->wrap(sub {
                    $_[0]->{$self->name} = $_[1];
                    return;
                }));            
            }
        }
    }
    
    if ($self->has_predicate()) {
        my $predicate = $self->predicate();
        if (reftype($predicate) && reftype($predicate) eq 'HASH') {
            my ($name, $method) = each %{$predicate};
            $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
        }
        else {
            $class->add_method($predicate => Class::MOP::Attribute::Accessor->wrap(sub {
                defined $_[0]->{$self->name} ? 1 : 0;
            }));
        }
    }    
}

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;

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