[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.08';
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 overrite 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, $default, $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
c14746bc	10	our $VERSION = '0.08';
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
688fcdda	173	push @source => '{'; # wrap this to avoid my $val overrite 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);
9df136d0	181	push @source => $self->_generate_slot_assignment($attr, $default, $index);
688fcdda	182	push @source => '}'; # close - wrap this to avoid my $val overrite warnings
7a5b07b3	183
84981146	184	push @source => "}" if defined $attr->init_arg;
7a5b07b3	185	}
84981146	186	elsif ( defined( my $init_arg = $attr->init_arg ) ) {
84981146	187	push @source => '(exists $params{\'' . $init_arg . '\'}) && do {';
8ecb1fa0	188
84981146	189	push @source => ('my $val = $params{\'' . $init_arg . '\'};');
d66bea3c	190	if ($is_moose && $attr->has_type_constraint) {
7a5b07b3	191	if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
688fcdda	192	push @source => $self->_generate_type_coercion(
	193	$attr,
	194	'$type_constraints[' . $index . ']',
	195	'$val',
	196	'$val'
	197	);
8ecb1fa0	198	}
688fcdda	199	push @source => $self->_generate_type_constraint_check(
	200	$attr,
	201	'$type_constraint_bodies[' . $index . ']',
	202	'$type_constraints[' . $index . ']',
	203	'$val'
	204	);
8ecb1fa0	205	}
9df136d0	206	push @source => $self->_generate_slot_assignment($attr, '$val', $index);
7a5b07b3	207
7a5b07b3	208	push @source => "}";
5cf3dbcf	209	}
7a5b07b3	210
5cf3dbcf	211	return join "\n" => @source;
	212	}
	213
	214	sub _generate_slot_assignment {
9df136d0	215	my ($self, $attr, $value, $index) = @_;
	216
	217	my $source;
	218
	219	if ($attr->has_initializer) {
	220	$source = (
	221	'$attrs->[' . $index . ']->set_initial_value($instance, ' . $value . ');'
	222	);
	223	}
	224	else {
	225	$source = (
	226	$self->meta_instance->inline_set_slot_value(
	227	'$instance',
	228	("'" . $attr->name . "'"),
	229	$value
	230	) . ';'
	231	);
	232	}
	233
	234	my $is_moose = $attr->isa('Moose::Meta::Attribute'); # XXX FIXME
7a5b07b3	235
d66bea3c	236	if ($is_moose && $attr->is_weak_ref) {
5cf3dbcf	237	$source .= (
	238	"\n" .
	239	$self->meta_instance->inline_weaken_slot_value(
7a5b07b3	240	'$instance',
5cf3dbcf	241	("'" . $attr->name . "'")
7a5b07b3	242	) .
5cf3dbcf	243	' if ref ' . $value . ';'
7a5b07b3	244	);
	245	}
	246
5cf3dbcf	247	return $source;
	248	}
	249
	250	sub _generate_type_coercion {
	251	my ($self, $attr, $type_constraint_name, $value_name, $return_value_name) = @_;
	252	return ($return_value_name . ' = ' . $type_constraint_name . '->coerce(' . $value_name . ');');
	253	}
	254
	255	sub _generate_type_constraint_check {
688fcdda	256	my ($self, $attr, $type_constraint_cv, $type_constraint_obj, $value_name) = @_;
5cf3dbcf	257	return (
c9183ffc	258	$type_constraint_cv . '->(' . $value_name . ')'
688fcdda	259	. "\n\t" . '\|\| confess "Attribute ('
	260	. $attr->name
	261	. ') does not pass the type constraint because: " . '
	262	. $type_constraint_obj . '->get_message(' . $value_name . ');'
7a5b07b3	263	);
5cf3dbcf	264	}
	265
	266	sub _generate_default_value {
	267	my ($self, $attr, $index) = @_;
	268	# NOTE:
	269	# default values can either be CODE refs
7a5b07b3	270	# in which case we need to call them. Or
5cf3dbcf	271	# they can be scalars (strings/numbers)
	272	# in which case we can just deal with them
	273	# in the code we eval.
	274	if ($attr->is_default_a_coderef) {
	275	return '$attrs->[' . $index . ']->default($instance)';
	276	}
	277	else {
	278	my $default = $attr->default;
	279	# make sure to quote strings ...
	280	unless (looks_like_number($default)) {
	281	$default = "'$default'";
	282	}
7a5b07b3	283
5cf3dbcf	284	return $default;
7a5b07b3	285	}
5cf3dbcf	286	}
	287
	288	1;
	289
5cf3dbcf	290	__END__
	291
	292	=pod
	293
7a5b07b3	294	=head1 NAME
5cf3dbcf	295
	296	Moose::Meta::Method::Constructor - Method Meta Object for constructors
	297
5cf3dbcf	298	=head1 DESCRIPTION
5cf3dbcf	299
7a5b07b3	300	This is a subclass of L<Class::MOP::Method> which handles
	301	constructing an approprate Constructor methods. This is primarily
	302	used in the making of immutable metaclasses, otherwise it is
d44714be	303	not particularly useful.
d44714be	304
5cf3dbcf	305	=head1 METHODS
	306
	307	=over 4
	308
	309	=item B<new>
	310
	311	=item B<attributes>
	312
	313	=item B<meta_instance>
	314
	315	=item B<options>
	316
	317	=item B<intialize_body>
	318
	319	=item B<associated_metaclass>
	320
	321	=back
	322
	323	=head1 AUTHORS
	324
	325	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	326
	327	=head1 COPYRIGHT AND LICENSE
	328
778db3ac	329	Copyright 2006-2008 by Infinity Interactive, Inc.
5cf3dbcf	330
	331	L<http://www.iinteractive.com>
	332
	333	This library is free software; you can redistribute it and/or modify
7a5b07b3	334	it under the same terms as Perl itself.
5cf3dbcf	335
	336	=cut
	337