[gitmo/Moose.git] / lib / Moose / Meta / Method / Constructor.pm


package Moose::Meta::Method::Constructor;

use strict;
use warnings;

use Carp         'confess';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number';

our $VERSION   = '0.09';
our $AUTHORITY = 'cpan:STEVAN';

use base 'Moose::Meta::Method',
         'Class::MOP::Method::Generated';

sub new {
    my $class   = shift;
    my %options = @_;

    (exists $options{options} && ref $options{options} eq 'HASH')
        || confess "You must pass a hash of options";

    my $self = bless {
        # from our superclass
        '&!body'          => undef,
        # specific to this subclass
        '%!options'       => $options{options},
        '$!meta_instance' => $options{metaclass}->get_meta_instance,
        '@!attributes'    => [ $options{metaclass}->compute_all_applicable_attributes ],
        # ...
        '$!associated_metaclass' => $options{metaclass},
    } => $class;

    # we don't want this creating
    # a cycle in the code, if not
    # needed
    weaken($self->{'$!associated_metaclass'});

    $self->intialize_body;

    return $self;
}

## accessors

sub options       { (shift)->{'%!options'}       }
sub meta_instance { (shift)->{'$!meta_instance'} }
sub attributes    { (shift)->{'@!attributes'}    }

sub associated_metaclass { (shift)->{'$!associated_metaclass'} }

## method

sub intialize_body {
    my $self = shift;
    # TODO:
    # the %options should also include a both
    # a call 'initializer' and call 'SUPER::'
    # options, which should cover approx 90%
    # of the possible use cases (even if it
    # requires some adaption on the part of
    # the author, after all, nothing is free)
    my $source = 'sub {';
    $source .= "\n" . 'my $class = shift;';

    $source .= "\n" . 'return $class->Moose::Object::new(@_)';
    $source .= "\n" . '    if $class ne \'' . $self->associated_metaclass->name . '\';';

    $source .= "\n" . 'my %params = (scalar @_ == 1) ? %{$_[0]} : @_;';

    $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');

    $source .= ";\n" . (join ";\n" => map {
        $self->_generate_slot_initializer($_)
    } 0 .. (@{$self->attributes} - 1));

    $source .= ";\n" . $self->_generate_BUILDALL();

    $source .= ";\n" . 'return $instance';
    $source .= ";\n" . '}';
    warn $source if $self->options->{debug};

    my $code;
    {
        # NOTE:
        # create the nessecary lexicals
        # to be picked up in the eval
        my $attrs = $self->attributes;

        # We need to check if the attribute ->can('type_constraint')
        # since we may be trying to immutabilize a Moose meta class,
        # which in turn has attributes which are Class::MOP::Attribute
        # objects, rather than Moose::Meta::Attribute. And 
        # Class::MOP::Attribute attributes have no type constraints.
        # However we need to make sure we leave an undef value there
        # because the inlined code is using the index of the attributes
        # to determine where to find the type constraint
        
        my @type_constraints = map { 
            $_->can('type_constraint') ? $_->type_constraint : undef
        } @$attrs;
        
        my @type_constraint_bodies = map {
            defined $_ ? $_->_compiled_type_constraint : undef;
        } @type_constraints;

        $code = eval $source;
        confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
    }
    $self->{'&!body'} = $code;
}

sub _generate_BUILDALL {
    my $self = shift;
    my @BUILD_calls;
    foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
        push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params)';
    }
    return join ";\n" => @BUILD_calls;
}

sub _generate_slot_initializer {
    my $self  = shift;
    my $index = shift;

    my $attr = $self->attributes->[$index];

    my @source = ('## ' . $attr->name);

    my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME

    if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
        push @source => ('(exists $params{\'' . $attr->init_arg . '\'}) ' .
                        '|| confess "Attribute (' . $attr->name . ') is required";');
    }

    if (($attr->has_default || $attr->has_builder) && !($is_moose && $attr->is_lazy)) {

        if ( defined( my $init_arg = $attr->init_arg ) ) {
            push @source => 'if (exists $params{\'' . $init_arg . '\'}) {';

                push @source => ('my $val = $params{\'' . $init_arg . '\'};');

                if ($is_moose && $attr->has_type_constraint) {
                    if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
                        push @source => $self->_generate_type_coercion(
                            $attr, 
                            '$type_constraints[' . $index . ']', 
                            '$val', 
                            '$val'
                        );
                    }
                    push @source => $self->_generate_type_constraint_check(
                        $attr, 
                        '$type_constraint_bodies[' . $index . ']', 
                        '$type_constraints[' . $index . ']',                         
                        '$val'
                    );
                }
                push @source => $self->_generate_slot_assignment($attr, '$val', $index);

            push @source => "} else {";
        }
            my $default;
            if ( $attr->has_default ) {
                $default = $self->_generate_default_value($attr, $index);
            } 
            else {
               my $builder = $attr->builder;
               $default = '$instance->' . $builder;
            }
            
            push @source => '{'; # wrap this to avoid my $val overwrite warnings
            push @source => ('my $val = ' . $default . ';');
            push @source => $self->_generate_type_constraint_check(
                $attr,
                ('$type_constraint_bodies[' . $index . ']'),
                ('$type_constraints[' . $index . ']'),                
                '$val'
            ) if ($is_moose && $attr->has_type_constraint);
            
            push @source => $self->_generate_slot_assignment($attr, '$val', $index);
            push @source => '}'; # close - wrap this to avoid my $val overrite warnings           

        push @source => "}" if defined $attr->init_arg;
    }
    elsif ( defined( my $init_arg = $attr->init_arg ) ) {
        push @source => '(exists $params{\'' . $init_arg . '\'}) && do {';

            push @source => ('my $val = $params{\'' . $init_arg . '\'};');
            if ($is_moose && $attr->has_type_constraint) {
                if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
                    push @source => $self->_generate_type_coercion(
                        $attr, 
                        '$type_constraints[' . $index . ']', 
                        '$val', 
                        '$val'
                    );
                }
                push @source => $self->_generate_type_constraint_check(
                    $attr, 
                    '$type_constraint_bodies[' . $index . ']', 
                    '$type_constraints[' . $index . ']',                     
                    '$val'
                );
            }
            push @source => $self->_generate_slot_assignment($attr, '$val', $index);

        push @source => "}";
    }

    return join "\n" => @source;
}

sub _generate_slot_assignment {
    my ($self, $attr, $value, $index) = @_;

    my $source;
    
    if ($attr->has_initializer) {
        $source = (
            '$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
        );        
    }
    else {
        $source = (
            $self->meta_instance->inline_set_slot_value(
                '$instance',
                ("'" . $attr->name . "'"),
                $value
            ) . ';'
        );        
    }
    
    my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME        

    if ($is_moose && $attr->is_weak_ref) {
        $source .= (
            "\n" .
            $self->meta_instance->inline_weaken_slot_value(
                '$instance',
                ("'" . $attr->name . "'")
            ) .
            ' if ref ' . $value . ';'
        );
    }

    return $source;
}

sub _generate_type_coercion {
    my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
    return ($return_value_name . ' = ' . $type_constraint_name .  '->coerce(' . $value_name . ');');
}

sub _generate_type_constraint_check {
    my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
    return (
        $type_constraint_cv . '->(' . $value_name . ')'
        . "\n\t" . '|| confess "Attribute (' 
        . $attr->name 
        . ') does not pass the type constraint because: " . ' 
        . $type_constraint_obj . '->get_message(' . $value_name . ');'
    );
}

sub _generate_default_value {
    my ($self, $attr, $index) = @_;
    # NOTE:
    # default values can either be CODE refs
    # in which case we need to call them. Or
    # they can be scalars (strings/numbers)
    # in which case we can just deal with them
    # in the code we eval.
    if ($attr->is_default_a_coderef) {
        return '$attrs->[' . $index . ']->default($instance)';
    }
    else {
        my $default = $attr->default;
        # make sure to quote strings ...
        unless (looks_like_number($default)) {
            $default = "'$default'";
        }

        return $default;
    }
}

1;

__END__

=pod

=head1 NAME

Moose::Meta::Method::Constructor - Method Meta Object for constructors

=head1 DESCRIPTION

This is a subclass of L<Class::MOP::Method> which handles
constructing an approprate Constructor methods. This is primarily
used in the making of immutable metaclasses, otherwise it is
not particularly useful.

=head1 METHODS

=over 4

=item B<new>

=item B<attributes>

=item B<meta_instance>

=item B<options>

=item B<intialize_body>

=item B<associated_metaclass>

=back

=head1 AUTHORS

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

=head1 COPYRIGHT AND LICENSE

Copyright 2006-2008 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
5cf3dbcf	1
	2	package Moose::Meta::Method::Constructor;
	3
	4	use strict;
	5	use warnings;
	6
	7	use Carp 'confess';
	8	use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
	9
bad76b8e	10	our $VERSION = '0.09';
5cf3dbcf	11	our $AUTHORITY = 'cpan:STEVAN';
5cf3dbcf	12
badb7e89	13	use base 'Moose::Meta::Method',
badb7e89	14	'Class::MOP::Method::Generated';
5cf3dbcf	15
	16	sub new {
	17	my $class = shift;
	18	my %options = @_;
7a5b07b3	19
5cf3dbcf	20	(exists $options{options} && ref $options{options} eq 'HASH')
7a5b07b3	21	\|\| confess "You must pass a hash of options";
7a5b07b3	22
5cf3dbcf	23	my $self = bless {
	24	# from our superclass
	25	'&!body' => undef,
	26	# specific to this subclass
	27	'%!options' => $options{options},
587ae0d2	28	'$!meta_instance' => $options{metaclass}->get_meta_instance,
7a5b07b3	29	'@!attributes' => [ $options{metaclass}->compute_all_applicable_attributes ],
5cf3dbcf	30	# ...
	31	'$!associated_metaclass' => $options{metaclass},
	32	} => $class;
	33
7a5b07b3	34	# we don't want this creating
7a5b07b3	35	# a cycle in the code, if not
5cf3dbcf	36	# needed
7a5b07b3	37	weaken($self->{'$!associated_metaclass'});
5cf3dbcf	38
	39	$self->intialize_body;
	40
7a5b07b3	41	return $self;
5cf3dbcf	42	}
5cf3dbcf	43
7a5b07b3	44	## accessors
5cf3dbcf	45
	46	sub options { (shift)->{'%!options'} }
	47	sub meta_instance { (shift)->{'$!meta_instance'} }
	48	sub attributes { (shift)->{'@!attributes'} }
	49
	50	sub associated_metaclass { (shift)->{'$!associated_metaclass'} }
	51
	52	## method
	53
	54	sub intialize_body {
	55	my $self = shift;
	56	# TODO:
7a5b07b3	57	# the %options should also include a both
	58	# a call 'initializer' and call 'SUPER::'
	59	# options, which should cover approx 90%
	60	# of the possible use cases (even if it
	61	# requires some adaption on the part of
5cf3dbcf	62	# the author, after all, nothing is free)
5cf3dbcf	63	my $source = 'sub {';
1f779926	64	$source .= "\n" . 'my $class = shift;';
7a5b07b3	65
587ae0d2	66	$source .= "\n" . 'return $class->Moose::Object::new(@_)';
7a5b07b3	67	$source .= "\n" . ' if $class ne \'' . $self->associated_metaclass->name . '\';';
	68
	69	$source .= "\n" . 'my %params = (scalar @_ == 1) ? %{$_[0]} : @_;';
	70
5cf3dbcf	71	$source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class');
7a5b07b3	72
	73	$source .= ";\n" . (join ";\n" => map {
	74	$self->_generate_slot_initializer($_)
5cf3dbcf	75	} 0 .. (@{$self->attributes} - 1));
7a5b07b3	76
5cf3dbcf	77	$source .= ";\n" . $self->_generate_BUILDALL();
7a5b07b3	78
5cf3dbcf	79	$source .= ";\n" . 'return $instance';
7a5b07b3	80	$source .= ";\n" . '}';
	81	warn $source if $self->options->{debug};
	82
5cf3dbcf	83	my $code;
	84	{
	85	# NOTE:
	86	# create the nessecary lexicals
7a5b07b3	87	# to be picked up in the eval
5cf3dbcf	88	my $attrs = $self->attributes;
7a5b07b3	89
475042d0	90	# We need to check if the attribute ->can('type_constraint')
	91	# since we may be trying to immutabilize a Moose meta class,
	92	# which in turn has attributes which are Class::MOP::Attribute
7701d0aa	93	# objects, rather than Moose::Meta::Attribute. And
7701d0aa	94	# Class::MOP::Attribute attributes have no type constraints.
238b424d	95	# However we need to make sure we leave an undef value there
	96	# because the inlined code is using the index of the attributes
	97	# to determine where to find the type constraint
	98
	99	my @type_constraints = map {
	100	$_->can('type_constraint') ? $_->type_constraint : undef
	101	} @$attrs;
	102
c9183ffc	103	my @type_constraint_bodies = map {
238b424d	104	defined $_ ? $_->_compiled_type_constraint : undef;
c9183ffc	105	} @type_constraints;
7c4f0d32	106
5cf3dbcf	107	$code = eval $source;
	108	confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
	109	}
	110	$self->{'&!body'} = $code;
	111	}
	112
	113	sub _generate_BUILDALL {
	114	my $self = shift;
	115	my @BUILD_calls;
1f779926	116	foreach my $method (reverse $self->associated_metaclass->find_all_methods_by_name('BUILD')) {
7a5b07b3	117	push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params)';
5cf3dbcf	118	}
7a5b07b3	119	return join ";\n" => @BUILD_calls;
5cf3dbcf	120	}
	121
	122	sub _generate_slot_initializer {
	123	my $self = shift;
	124	my $index = shift;
7a5b07b3	125
5cf3dbcf	126	my $attr = $self->attributes->[$index];
7a5b07b3	127
5cf3dbcf	128	my @source = ('## ' . $attr->name);
d66bea3c	129
d66bea3c	130	my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
7a5b07b3	131
84981146	132	if ($is_moose && defined($attr->init_arg) && $attr->is_required && !$attr->has_default && !$attr->has_builder) {
7a5b07b3	133	push @source => ('(exists $params{\'' . $attr->init_arg . '\'}) ' .
5cf3dbcf	134	'\|\| confess "Attribute (' . $attr->name . ') is required";');
5cf3dbcf	135	}
7a5b07b3	136
ca168e89	137	if (($attr->has_default \|\| $attr->has_builder) && !($is_moose && $attr->is_lazy)) {
7a5b07b3	138
84981146	139	if ( defined( my $init_arg = $attr->init_arg ) ) {
84981146	140	push @source => 'if (exists $params{\'' . $init_arg . '\'}) {';
8ecb1fa0	141
84981146	142	push @source => ('my $val = $params{\'' . $init_arg . '\'};');
	143
	144	if ($is_moose && $attr->has_type_constraint) {
	145	if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
688fcdda	146	push @source => $self->_generate_type_coercion(
	147	$attr,
	148	'$type_constraints[' . $index . ']',
	149	'$val',
	150	'$val'
	151	);
84981146	152	}
688fcdda	153	push @source => $self->_generate_type_constraint_check(
	154	$attr,
	155	'$type_constraint_bodies[' . $index . ']',
	156	'$type_constraints[' . $index . ']',
	157	'$val'
	158	);
8ecb1fa0	159	}
9df136d0	160	push @source => $self->_generate_slot_assignment($attr, '$val', $index);
7a5b07b3	161
84981146	162	push @source => "} else {";
84981146	163	}
ca168e89	164	my $default;
97e11ef5	165	if ( $attr->has_default ) {
ca168e89	166	$default = $self->_generate_default_value($attr, $index);
97e11ef5	167	}
97e11ef5	168	else {
ca168e89	169	my $builder = $attr->builder;
	170	$default = '$instance->' . $builder;
	171	}
688fcdda	172
3db3ea82	173	push @source => '{'; # wrap this to avoid my $val overwrite warnings
5cf3dbcf	174	push @source => ('my $val = ' . $default . ';');
	175	push @source => $self->_generate_type_constraint_check(
	176	$attr,
c9183ffc	177	('$type_constraint_bodies[' . $index . ']'),
688fcdda	178	('$type_constraints[' . $index . ']'),
5cf3dbcf	179	'$val'
7a5b07b3	180	) if ($is_moose && $attr->has_type_constraint);
bad76b8e	181
51c107ef	182	push @source => $self->_generate_slot_assignment($attr, '$val', $index);
bad76b8e	183	push @source => '}'; # close - wrap this to avoid my $val overrite warnings
7a5b07b3	184
84981146	185	push @source => "}" if defined $attr->init_arg;
7a5b07b3	186	}
84981146	187	elsif ( defined( my $init_arg = $attr->init_arg ) ) {
84981146	188	push @source => '(exists $params{\'' . $init_arg . '\'}) && do {';
8ecb1fa0	189
84981146	190	push @source => ('my $val = $params{\'' . $init_arg . '\'};');
d66bea3c	191	if ($is_moose && $attr->has_type_constraint) {
7a5b07b3	192	if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
688fcdda	193	push @source => $self->_generate_type_coercion(
	194	$attr,
	195	'$type_constraints[' . $index . ']',
	196	'$val',
	197	'$val'
	198	);
8ecb1fa0	199	}
688fcdda	200	push @source => $self->_generate_type_constraint_check(
	201	$attr,
	202	'$type_constraint_bodies[' . $index . ']',
	203	'$type_constraints[' . $index . ']',
	204	'$val'
	205	);
8ecb1fa0	206	}
9df136d0	207	push @source => $self->_generate_slot_assignment($attr, '$val', $index);
7a5b07b3	208
7a5b07b3	209	push @source => "}";
5cf3dbcf	210	}
7a5b07b3	211
5cf3dbcf	212	return join "\n" => @source;
	213	}
	214
	215	sub _generate_slot_assignment {
9df136d0	216	my ($self, $attr, $value, $index) = @_;
	217
	218	my $source;
	219
	220	if ($attr->has_initializer) {
	221	$source = (
	222	'$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
	223	);
	224	}
	225	else {
	226	$source = (
	227	$self->meta_instance->inline_set_slot_value(
	228	'$instance',
	229	("'" . $attr->name . "'"),
	230	$value
	231	) . ';'
	232	);
	233	}
	234
	235	my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
7a5b07b3	236
d66bea3c	237	if ($is_moose && $attr->is_weak_ref) {
5cf3dbcf	238	$source .= (
	239	"\n" .
	240	$self->meta_instance->inline_weaken_slot_value(
7a5b07b3	241	'$instance',
5cf3dbcf	242	("'" . $attr->name . "'")
7a5b07b3	243	) .
5cf3dbcf	244	' if ref ' . $value . ';'
7a5b07b3	245	);
	246	}
	247
5cf3dbcf	248	return $source;
	249	}
	250
	251	sub _generate_type_coercion {
	252	my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
	253	return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
	254	}
	255
	256	sub _generate_type_constraint_check {
688fcdda	257	my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
5cf3dbcf	258	return (
c9183ffc	259	$type_constraint_cv . '->(' . $value_name . ')'
688fcdda	260	. "\n\t" . '\|\| confess "Attribute ('
	261	. $attr->name
	262	. ') does not pass the type constraint because: " . '
	263	. $type_constraint_obj . '->get_message(' . $value_name . ');'
7a5b07b3	264	);
5cf3dbcf	265	}
	266
	267	sub _generate_default_value {
	268	my ($self, $attr, $index) = @_;
	269	# NOTE:
	270	# default values can either be CODE refs
7a5b07b3	271	# in which case we need to call them. Or
5cf3dbcf	272	# they can be scalars (strings/numbers)
	273	# in which case we can just deal with them
	274	# in the code we eval.
	275	if ($attr->is_default_a_coderef) {
	276	return '$attrs->[' . $index . ']->default($instance)';
	277	}
	278	else {
	279	my $default = $attr->default;
	280	# make sure to quote strings ...
	281	unless (looks_like_number($default)) {
	282	$default = "'$default'";
	283	}
7a5b07b3	284
5cf3dbcf	285	return $default;
7a5b07b3	286	}
5cf3dbcf	287	}
	288
	289	1;
	290
5cf3dbcf	291	__END__
	292
	293	=pod
	294
7a5b07b3	295	=head1 NAME
5cf3dbcf	296
	297	Moose::Meta::Method::Constructor - Method Meta Object for constructors
	298
5cf3dbcf	299	=head1 DESCRIPTION
5cf3dbcf	300
7a5b07b3	301	This is a subclass of L<Class::MOP::Method> which handles
	302	constructing an approprate Constructor methods. This is primarily
	303	used in the making of immutable metaclasses, otherwise it is
d44714be	304	not particularly useful.
d44714be	305
5cf3dbcf	306	=head1 METHODS
	307
	308	=over 4
	309
	310	=item B<new>
	311
	312	=item B<attributes>
	313
	314	=item B<meta_instance>
	315
	316	=item B<options>
	317
	318	=item B<intialize_body>
	319
	320	=item B<associated_metaclass>
	321
	322	=back
	323
	324	=head1 AUTHORS
	325
	326	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	327
	328	=head1 COPYRIGHT AND LICENSE
	329
778db3ac	330	Copyright 2006-2008 by Infinity Interactive, Inc.
5cf3dbcf	331
	332	L<http://www.iinteractive.com>
	333
	334	This library is free software; you can redistribute it and/or modify
7a5b07b3	335	it under the same terms as Perl itself.
5cf3dbcf	336
	337	=cut
	338