--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed';
+use Benchmark qw[cmpthese];
+
+use Moose::Util::TypeConstraints;
+
+BEGIN {
+ subtype 'Foo' => as 'Object' => where { blessed($_) && $_->isa('Foo') };
+
+ coerce 'Foo'
+ => from 'ArrayRef'
+ => via { Foo->new(@{$_}) };
+}
+
+{
+ package Foo;
+ use Moose;
+}
+
+{
+ package Foo::Normal;
+ use Moose;
+
+ has 'default' => (is => 'rw', default => 10);
+ has 'default_sub' => (is => 'rw', default => sub { [] });
+ has 'lazy' => (is => 'rw', default => 10, lazy => 1);
+ has 'required' => (is => 'rw', required => 1);
+ has 'weak_ref' => (is => 'rw', weak_ref => 1);
+ has 'type_constraint' => (is => 'rw', isa => 'Foo');
+ has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1);
+
+}
+
+{
+ package Foo::Immutable;
+ use Moose;
+
+ has 'default' => (is => 'rw', default => 10);
+ has 'default_sub' => (is => 'rw', default => sub { [] });
+ has 'lazy' => (is => 'rw', default => 10, lazy => 1);
+ has 'required' => (is => 'rw', required => 1);
+ has 'weak_ref' => (is => 'rw', weak_ref => 1);
+ has 'type_constraint' => (is => 'rw', isa => 'Foo');
+ has 'coercion' => (is => 'rw', isa => 'Foo', coerce => 1);
+
+ sub BUILD {
+ # ...
+ }
+
+ Foo::Immutable->meta->make_immutable(debug => 1);
+}
+
+#__END__
+
+my $foo = Foo->new;
+
+cmpthese(500,
+ {
+ 'normal' => sub {
+ Foo::Normal->new(
+ required => 'BAR',
+ type_constraint => $foo,
+ #coercion => [],
+ );
+ },
+ 'immutable' => sub {
+ Foo::Immutable->new(
+ required => 'BAR',
+ type_constraint => $foo,
+ #coercion => [],
+ );
+ },
+ }
+);
\ No newline at end of file
+use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib';
+
package Moose;
use strict;
}
}
}
+
+
}
## Utility functions
my $class = shift;
my $pkg = shift;
$class->SUPER::initialize($pkg,
- ':attribute_metaclass' => 'Moose::Meta::Attribute',
- ':method_metaclass' => 'Moose::Meta::Method',
- ':instance_metaclass' => 'Moose::Meta::Instance',
+ 'attribute_metaclass' => 'Moose::Meta::Attribute',
+ 'method_metaclass' => 'Moose::Meta::Method',
+ 'instance_metaclass' => 'Moose::Meta::Instance',
@_);
}
# This is ugly
sub get_method_map {
my $self = shift;
- my $map = $self->{'%:methods'};
+ my $map = $self->{'%!methods'};
my $class_name = $self->name;
my $method_metaclass = $self->method_metaclass;
return $map;
}
-#sub find_method_by_name {
-# my ($self, $method_name) = @_;
-# (defined $method_name && $method_name)
-# || confess "You must define a method name to find";
-# # keep a record of what we have seen
-# # here, this will handle all the
-# # inheritence issues because we are
-# # using the &class_precedence_list
-# my %seen_class;
-# foreach my $class ($self->class_precedence_list()) {
-# next if $seen_class{$class};
-# $seen_class{$class}++;
-# # fetch the meta-class ...
-# my $meta = $self->initialize($class);
-# return $meta->get_method($method_name)
-# if $meta->has_method($method_name);
-# }
-#}
-
### ---------------------------------------------
sub add_attribute {
# at this point anyway, so it's very
# much an obscure edge case anyway
$self = $super_meta->reinitialize($self->name => (
- ':attribute_metaclass' => $super_meta->attribute_metaclass,
- ':method_metaclass' => $super_meta->method_metaclass,
- ':instance_metaclass' => $super_meta->instance_metaclass,
+ 'attribute_metaclass' => $super_meta->attribute_metaclass,
+ 'method_metaclass' => $super_meta->method_metaclass,
+ 'instance_metaclass' => $super_meta->instance_metaclass,
));
}
}
return $new_attr;
}
+## -------------------------------------------------
+
+use Moose::Meta::Method::Constructor;
+
+{
+ # NOTE:
+ # the immutable version of a
+ # particular metaclass is
+ # really class-level data so
+ # we don't want to regenerate
+ # it any more than we need to
+ my $IMMUTABLE_METACLASS;
+ sub make_immutable {
+ my $self = shift;
+
+ $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
+ read_only => [qw/superclasses/],
+ cannot_call => [qw/
+ add_method
+ alias_method
+ remove_method
+ add_attribute
+ remove_attribute
+ add_package_symbol
+ remove_package_symbol
+ add_role
+ /],
+ memoize => {
+ class_precedence_list => 'ARRAY',
+ compute_all_applicable_attributes => 'ARRAY',
+ get_meta_instance => 'SCALAR',
+ get_method_map => 'SCALAR',
+ # maybe ....
+ calculate_all_roles => 'ARRAY',
+ }
+ });
+
+ $IMMUTABLE_METACLASS->make_metaclass_immutable(
+ $self,
+ constructor_class => 'Moose::Meta::Method::Constructor',
+ inline_accessors => 0,
+ @_,
+ )
+ }
+}
+
1;
__END__
=item B<initialize>
+=item B<make_immutable>
+
=item B<new_object>
We override this method to support the C<trigger> attribute option.
--- /dev/null
+
+package Moose::Meta::Method::Constructor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::Method';
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+
+ (exists $options{options} && ref $options{options} eq 'HASH')
+ || confess "You must pass a hash of options";
+
+ (blessed $options{meta_instance} && $options{meta_instance}->isa('Class::MOP::Instance'))
+ || confess "You must supply a meta-instance";
+
+ (exists $options{attributes} && ref $options{attributes} eq 'ARRAY')
+ || confess "You must pass an array of options";
+
+ (blessed($_) && $_->isa('Class::MOP::Attribute'))
+ || confess "You must supply a list of attributes which is a 'Class::MOP::Attribute' instance"
+ for @{$options{attributes}};
+
+ my $self = bless {
+ # from our superclass
+ '&!body' => undef,
+ # specific to this subclass
+ '%!options' => $options{options},
+ '$!meta_instance' => $options{meta_instance},
+ '@!attributes' => $options{attributes},
+ # ...
+ '$!associated_metaclass' => $options{metaclass},
+ } => $class;
+
+ # we don't want this creating
+ # a cycle in the code, if not
+ # needed
+ weaken($self->{'$!meta_instance'});
+ 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" . '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;
+
+ $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 ($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);
+
+ if ($attr->is_required && !$attr->has_default) {
+ push @source => ('(exists $params{\'' . $attr->init_arg . '\'}) ' .
+ '|| confess "Attribute (' . $attr->name . ') is required";');
+ }
+
+ push @source => 'if ($params{\'' . $attr->init_arg . '\'}) {';
+
+ push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};');
+ if ($attr->has_type_constraint) {
+ push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;');
+
+ if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
+ push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val');
+ }
+ push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val');
+ }
+ push @source => $self->_generate_slot_assignment($attr, '$val');
+
+ if ($attr->has_default && !$attr->is_lazy) {
+
+ push @source => "} else {";
+
+ my $default = $self->_generate_default_value($attr, $index);
+
+ push @source => ('my $val = ' . $default . ';');
+ push @source => $self->_generate_type_constraint_check(
+ $attr,
+ ('$attrs->[' . $index . ']->type_constraint'),
+ '$val'
+ ) if $attr->has_type_constraint;
+ push @source => $self->_generate_slot_assignment($attr, $default);
+
+ push @source => "}";
+ }
+ else {
+ 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
+ ) . ';'
+ );
+
+ if ($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_name, $value_name) = @_;
+ return (
+ 'defined(' . $type_constraint_name . '->_compiled_type_constraint->(' . $value_name . '))'
+ . "\n\t" . '|| confess "Attribute (' . $attr->name . ') does not pass the type constraint ('
+ . $attr->type_constraint->name . ') with " . (defined() ? "' . $value_name . '" : "undef");'
+ );
+}
+
+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;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Method::Constructor - Method Meta Object for constructors
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=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 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
+
# this is an UGLY hack
sub get_method_map {
my $self = shift;
- $self->{'%:methods'} ||= {};
+ $self->{'%!methods'} ||= {};
$self->Moose::Meta::Class::get_method_map()
}
+use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib';
+
package Moose::Role;
use strict;
+use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib';
+
package Moose::Util::TypeConstraints;
use strict;
use strict;
use warnings;
-use Test::More tests => 56;
+use Test::More tests => 58;
use Test::Exception;
BEGIN {
$self->y(0);
}
+ __PACKAGE__->meta->make_immutable(debug => 0);
+}{
package Point3D;
use Moose;
$self->{z} = 0;
};
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
my $point = Point->new(x => 1, y => 2);
[ 'Moose::Object' ],
'... Point got the automagic base class');
-my @Point_methods = qw(meta x y clear);
+my @Point_methods = qw(meta new x y clear);
my @Point_attrs = ('x', 'y');
is_deeply(
[ 'Point' ],
'... Point3D gets the parent given to it');
-my @Point3D_methods = qw(meta clear);
+my @Point3D_methods = qw(new meta clear);
my @Point3D_attrs = ('z');
is_deeply(
|| confess "Account overdrawn";
$self->balance($current_balance - $amount);
}
-
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
+}{
package CheckingAccount;
use Moose;
$self->deposit($overdraft_amount);
}
};
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
my $savings_account = BankAccount->new(balance => 250);
my ($self, $tree) = @_;
$tree->parent($self) if defined $tree;
};
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
my $root = BinaryTree->new(node => 'root');
has 'state' => (is => 'rw', isa => 'USState');
has 'zip_code' => (is => 'rw', isa => 'USZipCode');
+ __PACKAGE__->meta->make_immutable(debug => 0);
+}{
+
package Company;
use Moose;
use Moose::Util::TypeConstraints;
}
};
+ __PACKAGE__->meta->make_immutable(debug => 0);
+}{
+
package Person;
use Moose;
($self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ') .
$self->last_name;
}
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
+}{
package Employee;
use Moose;
my $self = shift;
super() . ', ' . $self->title
};
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
my $ii;
coerce => 1,
default => sub { HTTP::Headers->new }
);
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
my $r = Request->new;
my $self = shift;
sprintf '$%0.2f USD' => $self->amount
}
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
ok(US::Currency->does('Comparable'), '... US::Currency does Comparable');
use strict;
use warnings;
+use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib';
+
use lib 't/lib', 'lib';
use Test::More tests => 1;
sub create_instance {
my $self = shift;
- my $class = $self->{meta}->name;
+ my $class = $self->associated_metaclass->name;
my $oid = ++$INSTANCE_COUNTERS{$class};
$db->{$class}->[($oid - 1)] = {};
sub find_instance {
my ($self, $oid) = @_;
- my $instance = $db->{$self->{meta}->name}->[($oid - 1)];
+ my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)];
$self->bless_instance_structure({
oid => $oid,
instance => $instance
{
package Moose::POOP::Object;
use metaclass 'Moose::POOP::Meta::Class' => (
- ':instance_metaclass' => 'Moose::POOP::Meta::Instance'
+ instance_metaclass => 'Moose::POOP::Meta::Instance'
);
use Moose;
projects / gitmo/Moose.git / commitdiff