[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.05';
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');

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

        push @source => "}";
    }

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

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