From: Shawn M Moore Date: Tue, 3 Jun 2008 20:06:58 +0000 (+0000) Subject: Import Mouse X-Git-Tag: 0.04~103 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=c3398f5bd45f2851b7cd40ca9823bcf7d2378469 Import Mouse --- c3398f5bd45f2851b7cd40ca9823bcf7d2378469 diff --git a/Changes b/Changes new file mode 100644 index 0000000..f043459 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Mouse + +0.01 Sun May 18 13:03:21 2008 + First version, released on an unsuspecting world. + diff --git a/Makefile.PL b/Makefile.PL new file mode 100755 index 0000000..d6e9fe3 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,15 @@ +use inc::Module::Install; + +name 'Mouse'; +all_from 'lib/Mouse.pm'; + +requires 'Sub::Exporter'; +requires 'Scalar::Util'; +requires 'MRO::Compat'; + +build_requires 'Test::More'; +build_requires 'Test::Exception'; +build_requires 'Test::Warn'; + +WriteAll; + diff --git a/lib/Mouse.pm b/lib/Mouse.pm new file mode 100644 index 0000000..1c06330 --- /dev/null +++ b/lib/Mouse.pm @@ -0,0 +1,189 @@ +#!perl +package Mouse; +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Sub::Exporter; +use Carp 'confess'; +use Scalar::Util 'blessed'; + +use Mouse::Attribute; +use Mouse::Class; +use Mouse::Object; + +do { + my $CALLER; + + my %exports = ( + meta => sub { + my $meta = Mouse::Class->initialize($CALLER); + return sub { $meta }; + }, + + extends => sub { + my $caller = $CALLER; + return sub { + $caller->meta->superclasses(@_); + }; + }, + + has => sub { + return sub { + my $package = caller; + my $names = shift; + $names = [$names] if !ref($names); + + for my $name (@$names) { + Mouse::Attribute->create($package, $name, @_); + } + }; + }, + + confess => sub { + return \&Carp::confess; + }, + + blessed => sub { + return \&Scalar::Util::blessed; + }, + ); + + my $exporter = Sub::Exporter::build_exporter({ + exports => \%exports, + groups => { default => [':all'] }, + }); + + sub import { + $CALLER = caller; + + strict->import; + warnings->import; + + no strict 'refs'; + @{ $CALLER . '::ISA' } = 'Mouse::Object'; + + goto $exporter; + } + + sub unimport { + my $caller = caller; + + no strict 'refs'; + for my $keyword (keys %exports) { + next if $keyword eq 'meta'; # we don't delete this one + delete ${ $caller . '::' }{$keyword}; + } + } +}; + +sub load_class { + my $class = shift; + + (my $file = "$class.pm") =~ s{::}{/}g; + + eval { CORE::require($file) }; + confess "Could not load class ($class) because : $@" + if $@ + && $@ !~ /^Can't locate .*? at /; + + return 1; +} + +1; + +__END__ + +=head1 NAME + +Mouse - miniature Moose near the speed of light + +=head1 VERSION + +Version 0.01 released ??? + +=head1 SYNOPSIS + + package Point; + use Mouse; + + has x => ( + is => 'rw', + ); + + has y => ( + is => 'rw', + default => 0, + predicate => 'has_y', + clearer => 'clear_y', + ); + +=head1 DESCRIPTION + +Moose. + +=head1 INTERFACE + +=head2 meta -> Mouse::Class + +Returns this class' metaclass instance. + +=head2 extends superclasses + +Sets this class' superclasses. + +=head2 has (name|names) => parameters + +Adds an attribute (or if passed an arrayref of names, multiple attributes) to +this class. + +=head2 confess error -> BOOM + +L for your convenience. + +=head2 blessed value -> ClassName | undef + +L for your convenience. + +=head1 MISC + +=head2 import + +Importing Mouse will set your class' superclass list to L. +You may use L to replace the superclass list. + +=head2 unimport + +Please unimport Mouse so that if someone calls one of the keywords (such as +L) it will break loudly instead breaking subtly. + +=head1 FUNCTIONS + +=head2 load_class Class::Name + +This will load a given Class::Name> (or die if it's not loadable). +This function can be used in place of tricks like +C or using C. + +=head1 AUTHOR + +Shawn M Moore, C<< >> + +=head1 BUGS + +No known bugs. + +Please report any bugs through RT: email +C, or browse +L. + +=head1 COPYRIGHT AND LICENSE + +Copyright 2008 Shawn M Moore. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + diff --git a/lib/Mouse/Attribute.pm b/lib/Mouse/Attribute.pm new file mode 100644 index 0000000..41a56df --- /dev/null +++ b/lib/Mouse/Attribute.pm @@ -0,0 +1,213 @@ +#!/usr/bin/env perl +package Mouse::Attribute; +use strict; +use warnings; + +use Carp 'confess'; + +sub new { + my $class = shift; + my %args = @_; + + $args{init_arg} ||= $args{name}; + $args{is} ||= ''; + + bless \%args, $class; +} + +sub name { $_[0]->{name} } +sub class { $_[0]->{class} } +sub default { $_[0]->{default} } +sub predicate { $_[0]->{predicate} } +sub clearer { $_[0]->{clearer} } +sub handles { $_[0]->{handles} } +sub weak_ref { $_[0]->{weak_ref} } +sub init_arg { $_[0]->{init_arg} } + +sub generate_accessor { + my $attribute = shift; + + my $key = $attribute->{init_arg}; + my $default = $attribute->{default}; + my $trigger = $attribute->{trigger}; + + my $accessor = 'sub { + my $self = shift;'; + + if ($attribute->{is} eq 'rw') { + $accessor .= 'if (@_) { + $self->{$key} = $_[0];'; + + if ($attribute->{weak_ref}) { + $accessor .= 'Scalar::Util::weaken($self->{$key});'; + } + + if ($trigger) { + $accessor .= '$trigger->($self, $_[0], $attribute);'; + } + + $accessor .= '}'; + } + else { + } + + if ($attribute->{lazy}) { + $accessor .= '$self->{$key} = '; + $accessor .= ref($attribute->{default}) eq 'CODE' + ? '$default->($self)' + : '$default'; + $accessor .= ' if !exists($self->{$key});'; + } + + $accessor .= 'return $self->{$key} + }'; + + return eval $accessor; +} + +sub generate_predicate { + my $attribute = shift; + my $key = $attribute->{init_arg}; + + my $predicate = 'sub { exists($_[0]->{$key}) }'; + + return eval $predicate; +} + +sub generate_clearer { + my $attribute = shift; + my $key = $attribute->{init_arg}; + + my $predicate = 'sub { delete($_[0]->{$key}) }'; + + return eval $predicate; +} + +sub generate_handles { + my $attribute = shift; + my $reader = $attribute->{name}; + + my %method_map; + + for my $local_method (keys %{ $attribute->{handles} }) { + my $remote_method = $attribute->{handles}{$local_method}; + + my $method = 'sub { + my $self = shift; + $self->$reader->$remote_method(@_) + }'; + + $method_map{$local_method} = eval $method; + } + + return \%method_map; +} + +sub create { + my ($self, $class, $name, %args) = @_; + + confess "You must specify a default for lazy attribute '$name'" + if $args{lazy} && !exists($args{default}); + + confess "Trigger is not allowed on read-only attribute '$name'" + if $args{trigger} && $args{is} ne 'rw'; + + confess "References are not allowed as default values, you must wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])" + if ref($args{default}) + && ref($args{default}) ne 'CODE'; + + $args{handles} = { map { $_ => $_ } @{ $args{handles} } } + if $args{handles} + && ref($args{handles}) eq 'ARRAY'; + + confess "You must pass a HASH or ARRAY to handles" + if exists($args{handles}) + && ref($args{handles}) ne 'HASH'; + + my $attribute = $self->new(%args, name => $name, class => $class); + my $meta = $class->meta; + + # install an accessor + if ($attribute->{is} eq 'rw' || $attribute->{is} eq 'ro') { + my $accessor = $attribute->generate_accessor; + no strict 'refs'; + *{ $class . '::' . $name } = $accessor; + } + + $meta->add_attribute($attribute); + + for my $method (qw/predicate clearer/) { + if (exists $attribute->{$method}) { + my $generator = "generate_$method"; + my $coderef = $attribute->$generator; + no strict 'refs'; + *{ $class . '::' . $attribute->{$method} } = $coderef; + } + } + + if ($attribute->{handles}) { + my $method_map = $attribute->generate_handles; + for my $method_name (keys %$method_map) { + no strict 'refs'; + *{ $class . '::' . $method_name } = $method_map->{$method_name}; + } + } + + return $attribute; +} + +1; + +__END__ + +=head1 NAME + +Mouse::Attribute - attribute metaclass + +=head1 METHODS + +=head2 new %args -> Mouse::Attribute + +Instantiates a new Mouse::Attribute. Does nothing else. + +=head2 create OwnerClass, AttributeName, %args -> Mouse::Attribute + +Creates a new attribute in OwnerClass. Accessors and helper methods are +installed. Some error checking is done. + +=head2 name -> AttributeName + +=head2 class -> OwnerClass + +=head2 default -> Value + +=head2 predicate -> MethodName + +=head2 clearer -> MethodName + +=head2 handles -> { LocalName => RemoteName } + +=head2 weak_ref -> Bool + +=head2 init_arg -> Str + +Informational methods. + +=head2 generate_accessor -> CODE + +Creates a new code reference for the attribute's accessor. + +=head2 generate_predicate -> CODE + +Creates a new code reference for the attribute's predicate. + +=head2 generate_clearer -> CODE + +Creates a new code reference for the attribute's clearer. + +=head2 generate_handles -> { MethodName => CODE } + +Creates a new code reference for each of the attribute's handles methods. + +=cut + diff --git a/lib/Mouse/Class.pm b/lib/Mouse/Class.pm new file mode 100644 index 0000000..a094887 --- /dev/null +++ b/lib/Mouse/Class.pm @@ -0,0 +1,107 @@ +#!/usr/bin/env perl +package Mouse::Class; +use strict; +use warnings; + +use MRO::Compat; + +do { + my %METACLASS_CACHE; + sub initialize { + my $class = shift; + my $name = shift; + $METACLASS_CACHE{$name} = $class->new(name => $name) + if !exists($METACLASS_CACHE{$name}); + return $METACLASS_CACHE{$name}; + } +}; + +sub new { + my $class = shift; + my %args = @_; + + $args{attributes} = {}; + $args{superclasses} = do { + no strict 'refs'; + \@{ $args{name} . '::ISA' }; + }; + + bless \%args, $class; +} + +sub name { $_[0]->{name} } + +sub superclasses { + my $self = shift; + + if (@_) { + Mouse::load_class($_) for @_; + @{ $self->{superclasses} } = @_; + } + + @{ $self->{superclasses} }; +} + +sub add_attribute { + my $self = shift; + my $attr = shift; + + $self->{'attributes'}{$attr->name} = $attr; +} + +sub attributes { values %{ $_[0]->{'attributes'} } } +sub get_attribute_map { $_[0]->{attributes} } +sub get_attribute { $_[0]->{attributes}->{$_[1]} } + +sub linearized_isa { @{ mro::get_linear_isa($_[0]->name) } } + +1; + +__END__ + +=head1 NAME + +Mouse::Class - hook into the Mouse MOP + +=head1 METHODS + +=head2 initialize ClassName -> Mouse::Class + +Finds or creates a Mouse::Class instance for the given ClassName. Only one +instance should exist for a given class. + +=head2 new %args -> Mouse::Class + +Creates a new Mouse::Class. Don't call this directly. + +=head2 name -> ClassName + +Returns the name of the owner class. + +=head2 superclasses -> [ClassName] + +Gets (or sets) the list of superclasses of the owner class. + +=head2 add_attribute Mouse::Attribute + +Begins keeping track of the existing L for the owner class. + +=head2 attributes -> [Mouse::Attribute] + +Returns a list of L objects. + +=head2 get_attribute_map -> { name => Mouse::Attribute } + +Returns a mapping of attribute names to their corresponding +L objects. + +=head2 get_attribute Name -> Mouse::Attribute | undef + +Returns the L with the given name. + +=head2 linearized_isa -> [ClassNames] + +Returns the list of classes in method dispatch order, with duplicates removed. + +=cut + diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm new file mode 100644 index 0000000..82cbec0 --- /dev/null +++ b/lib/Mouse/Object.pm @@ -0,0 +1,124 @@ +#!/usr/bin/env perl +package Mouse::Object; +use strict; +use warnings; +use MRO::Compat; + +use Scalar::Util 'blessed'; +use Carp 'confess'; + +sub new { + my $class = shift; + my %args = @_; + my $instance = bless {}, $class; + + for my $attribute ($class->meta->attributes) { + my $key = $attribute->init_arg; + my $default; + + if (!exists($args{$key})) { + if (exists($attribute->{default})) { + unless ($attribute->{lazy}) { + if (ref($attribute->{default}) eq 'CODE') { + $instance->{$key} = $attribute->{default}->(); + Scalar::Util::weaken($instance->{$key}) + if $attribute->{weak_ref}; + } + else { + $instance->{$key} = $attribute->{default}; + Scalar::Util::weaken($instance->{$key}) + if $attribute->{weak_ref}; + } + } + } + else { + if ($attribute->{required}) { + confess "Attribute '$attribute->{name}' is required"; + } + } + } + + if (exists($args{$key})) { + $instance->{$key} = $args{$key}; + Scalar::Util::weaken($instance->{$key}) + if $attribute->{weak_ref}; + + if ($attribute->{trigger}) { + $attribute->{trigger}->($instance, $args{$key}, $attribute); + } + } + } + + $instance->BUILDALL(\%args); + + return $instance; +} + +sub DESTROY { shift->DEMOLISHALL } + +sub BUILDALL { + my $self = shift; + + # short circuit + return unless $self->can('BUILD'); + + no strict 'refs'; + + for my $class ($self->meta->linearized_isa) { + my $code = *{ $class . '::BUILD' }{CODE} + or next; + $code->($self, @_); + } +} + +sub DEMOLISHALL { + my $self = shift; + + # short circuit + return unless $self->can('DEMOLISH'); + + no strict 'refs'; + + for my $class ($self->meta->linearized_isa) { + my $code = *{ $class . '::DEMOLISH' }{CODE} + or next; + $code->($self, @_); + } +} + +1; + +__END__ + +=head1 NAME + +Mouse::Object - we don't need to steenkin' constructor + +=head1 METHODS + +=head2 new arguments -> object + +Instantiates a new Mouse::Object. This is obviously intended for subclasses. + +=head2 BUILDALL \%args + +Calls L on each class in the class hierarchy. This is called at the +end of L. + +=head2 BUILD \%args + +You may put any business logic initialization in BUILD methods. You don't +need to redispatch or return any specific value. + +=head2 DEMOLISHALL + +Calls L on each class in the class hierarchy. This is called at +L time. + +=head2 DEMOLISH + +You may put any business logic deinitialization in DEMOLISH methods. You don't +need to redispatch or return any specific value. + +=cut + diff --git a/t/000-load.t b/t/000-load.t new file mode 100644 index 0000000..a075550 --- /dev/null +++ b/t/000-load.t @@ -0,0 +1,7 @@ +#!perl -T +use strict; +use warnings; +use Test::More tests => 1; + +use_ok 'Mouse'; + diff --git a/t/001-strict.t b/t/001-strict.t new file mode 100644 index 0000000..fb82c0e --- /dev/null +++ b/t/001-strict.t @@ -0,0 +1,13 @@ +#!/usr/bin/env perl +use Test::More tests => 1; +use Test::Exception; + +throws_ok { + package Class; + use Mouse; + + my $foo = '$foo'; + chop $$foo; +} qr/Can't use string \("\$foo"\) as a SCALAR ref while "strict refs" in use /, + 'using Mouse turns on strictures'; + diff --git a/t/002-warnings.t b/t/002-warnings.t new file mode 100644 index 0000000..4d57726 --- /dev/null +++ b/t/002-warnings.t @@ -0,0 +1,11 @@ +#!/usr/bin/env perl +use Test::More tests => 1; +use Test::Warn; + +warning_like { + package Class; + use Mouse; + + my $one = 1 + undef; +} qr/uninitialized value/, 'using Mouse turns on warnings'; + diff --git a/t/003-neutrino-object.t b/t/003-neutrino-object.t new file mode 100644 index 0000000..85c6581 --- /dev/null +++ b/t/003-neutrino-object.t @@ -0,0 +1,9 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 2; + +require Mouse; +ok($INC{"Mouse/Object.pm"}, "loading Mouse loads Mouse::Object"); +can_ok('Mouse::Object' => 'new'); + diff --git a/t/004-auto-subclass.t b/t/004-auto-subclass.t new file mode 100644 index 0000000..2f4045b --- /dev/null +++ b/t/004-auto-subclass.t @@ -0,0 +1,17 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 3; + +do { + package Class; + use Mouse; +}; + +can_ok(Class => 'new'); + +my $object = Class->new; + +isa_ok($object => 'Class'); +isa_ok($object => 'Mouse::Object'); + diff --git a/t/005-extends.t b/t/005-extends.t new file mode 100644 index 0000000..c84fd00 --- /dev/null +++ b/t/005-extends.t @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 5; +use lib 't/lib'; + +do { + package Class; + use Mouse; + + package Child; + use Mouse; + extends 'Class'; + + package Mouse::TestClass; + use Mouse; + extends 'Anti::Mouse'; + + sub mouse { 1 } +}; + +can_ok(Child => 'new'); + +my $child = Child->new; + +isa_ok($child => 'Child'); +isa_ok($child => 'Class'); +isa_ok($child => 'Mouse::Object'); + +can_ok('Mouse::TestClass' => qw(mouse antimouse)); + diff --git a/t/006-unimport.t b/t/006-unimport.t new file mode 100644 index 0000000..5245474 --- /dev/null +++ b/t/006-unimport.t @@ -0,0 +1,21 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 2; + +do { + package Class; + use Mouse; + + no Mouse; + + package Child; + use Mouse; + extends 'Class'; + + no Mouse; +}; + +ok(!Child->can('extends'), "extends keyword is unimported"); +ok(!Class->can('extends'), "extends keyword is unimported"); + diff --git a/t/007-attributes.t b/t/007-attributes.t new file mode 100644 index 0000000..cf2b5a7 --- /dev/null +++ b/t/007-attributes.t @@ -0,0 +1,36 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 10; + +do { + package Class; + use Mouse; + + has 'x'; + + has 'y' => ( + is => 'ro', + ); + + has 'z' => ( + is => 'rw', + ); +}; + +ok(!Class->can('x'), "No accessor is injected if 'is' has no value"); +can_ok('Class', 'y', 'z'); + +my $object = Class->new; + +ok(!$object->can('x'), "No accessor is injected if 'is' has no value"); +can_ok($object, 'y', 'z'); + +is($object->y, undef); +is($object->y(10), undef); +is($object->y, undef); + +is($object->z, undef); +is($object->z(10), 10); +is($object->z, 10); + diff --git a/t/008-default.t b/t/008-default.t new file mode 100644 index 0000000..6fc4c20 --- /dev/null +++ b/t/008-default.t @@ -0,0 +1,50 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 18; + +do { + package Class; + use Mouse; + + has 'x' => ( + is => 'rw', + default => 10, + ); + + has 'y' => ( + is => 'rw', + default => 20, + ); + + has 'z' => ( + is => 'rw', + ); +}; + +my $object = Class->new; +is($object->x, 10, "attribute has a default of 10"); +is($object->y, 20, "attribute has a default of 20"); +is($object->z, undef, "attribute has no default"); + +is($object->x(5), 5, "setting a new value"); +is($object->y(25), 25, "setting a new value"); +is($object->z(125), 125, "setting a new value"); + +is($object->x, 5, "setting a new value does not trigger default"); +is($object->y, 25, "setting a new value does not trigger default"); +is($object->z, 125, "setting a new value does not trigger default"); + +my $object2 = Class->new(x => 50); +is($object2->x, 50, "attribute was initialized to 50"); +is($object2->y, 20, "attribute has a default of 20"); +is($object2->z, undef, "attribute has no default"); + +is($object2->x(5), 5, "setting a new value"); +is($object2->y(25), 25, "setting a new value"); +is($object2->z(125), 125, "setting a new value"); + +is($object2->x, 5, "setting a new value does not trigger default"); +is($object2->y, 25, "setting a new value does not trigger default"); +is($object2->z, 125, "setting a new value does not trigger default"); + diff --git a/t/009-default-code.t b/t/009-default-code.t new file mode 100644 index 0000000..9693afb --- /dev/null +++ b/t/009-default-code.t @@ -0,0 +1,37 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 9; + +do { + package Class; + use Mouse; + + has 'x' => ( + is => 'rw', + default => sub { 10 }, + ); + + has 'y' => ( + is => 'rw', + default => sub { 20 }, + ); + + has 'z' => ( + is => 'rw', + ); +}; + +my $object = Class->new; +is($object->x, 10, "attribute has a default of 10"); +is($object->y, 20, "attribute has a default of 20"); +is($object->z, undef, "attribute has no default"); + +is($object->x(5), 5, "setting a new value"); +is($object->y(25), 25, "setting a new value"); +is($object->z(125), 125, "setting a new value"); + +is($object->x, 5, "setting a new value does not trigger default"); +is($object->y, 25, "setting a new value does not trigger default"); +is($object->z, 125, "setting a new value does not trigger default"); + diff --git a/t/010-required.t b/t/010-required.t new file mode 100644 index 0000000..3a8be4c --- /dev/null +++ b/t/010-required.t @@ -0,0 +1,36 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 3; +use Test::Exception; + +do { + package Class; + use Mouse; + + has foo => ( + required => 1, + ); + + has bar => ( + required => 1, + default => 50, + ); + + has baz => ( + required => 1, + default => sub { 10 }, + ); + + has quux => ( + is => "rw", + required => 1, + lazy => 1, + default => sub { "yay" }, + ); +}; + +throws_ok { Class->new } qr/Attribute 'foo' is required/, "required attribute is required"; +lives_ok { Class->new(foo => 5) } "foo is the only required but unfulfilled attribute"; +lives_ok { Class->new(foo => 1, bar => 1, baz => 1, quux => 1) } "all attributes specified"; + diff --git a/t/011-lazy.t b/t/011-lazy.t new file mode 100644 index 0000000..168eaf1 --- /dev/null +++ b/t/011-lazy.t @@ -0,0 +1,57 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 16; +use Test::Exception; + +my $lazy_run = 0; + +do { + package Class; + use Mouse; + + has lazy => ( + is => 'rw', + lazy => 1, + default => sub { ++$lazy_run }, + ); + + has lazy_value => ( + is => 'rw', + lazy => 1, + default => "welp", + ); + + ::throws_ok { + has lazy_no_default => ( + is => 'rw', + lazy => 1, + ); + } qr/You must specify a default for lazy attribute 'lazy_no_default'/; +}; + +my $object = Class->new; +is($lazy_run, 0, "lazy attribute not yet initialized"); + +is($object->lazy, 1, "lazy coderef"); +is($lazy_run, 1, "lazy coderef invoked once"); + +is($object->lazy, 1, "lazy coderef is cached"); +is($lazy_run, 1, "lazy coderef invoked once"); + +is($object->lazy_value, 'welp', "lazy value"); +is($lazy_run, 1, "lazy coderef invoked once"); + +is($object->lazy_value("newp"), "newp", "set new value"); +is($lazy_run, 1, "lazy coderef invoked once"); + +is($object->lazy_value, "newp", "got new value"); +is($lazy_run, 1, "lazy coderef invoked once"); + +my $object2 = Class->new(lazy => 'very', lazy_value => "heh"); +is($lazy_run, 1, "lazy attribute not initialized when an argument is passed to the constructor"); + +is($object2->lazy, 'very', 'value from the constructor'); +is($object2->lazy_value, 'heh', 'value from the constructor'); +is($lazy_run, 1, "lazy coderef not invoked, we already have a value"); + diff --git a/t/012-predicate.t b/t/012-predicate.t new file mode 100644 index 0000000..cb900a8 --- /dev/null +++ b/t/012-predicate.t @@ -0,0 +1,45 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 15; + +my $lazy_run = 0; + +do { + package Class; + use Mouse; + + has lazy => ( + is => 'rw', + lazy => 1, + default => sub { ++$lazy_run }, + predicate => 'has_lazy', + ); +}; + +can_ok(Class => 'has_lazy'); + +my $object = Class->new; +is($lazy_run, 0, "lazy attribute not yet initialized"); + +ok(!$object->has_lazy, "no lazy value yet"); +is($lazy_run, 0, "lazy attribute not initialized by predicate"); + +is($object->lazy, 1, "lazy value"); +is($lazy_run, 1, "lazy coderef invoked once"); + +ok($object->has_lazy, "lazy value now"); +is($lazy_run, 1, "lazy coderef invoked once"); + +is($object->lazy, 1, "lazy value is cached"); +is($lazy_run, 1, "lazy coderef invoked once"); + +my $object2 = Class->new(lazy => 'very'); +is($lazy_run, 1, "lazy attribute not initialized when an argument is passed to the constructor"); + +ok($object2->has_lazy, "lazy value now"); +is($lazy_run, 1, "lazy attribute not initialized when checked with predicate"); + +is($object2->lazy, 'very', 'value from the constructor'); +is($lazy_run, 1, "lazy coderef not invoked, we already have a value"); + diff --git a/t/013-clearer.t b/t/013-clearer.t new file mode 100644 index 0000000..973774b --- /dev/null +++ b/t/013-clearer.t @@ -0,0 +1,70 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 28; + +my $lazy_run = 0; + +do { + package Class; + use Mouse; + + has lazy => ( + is => 'rw', + lazy => 1, + default => sub { ++$lazy_run }, + predicate => 'has_lazy', + clearer => 'clear_lazy', + ); +}; + +can_ok(Class => 'clear_lazy'); + +my $object = Class->new; +is($lazy_run, 0, "lazy attribute not yet initialized"); + +ok(!$object->has_lazy, "no lazy value yet"); +is($lazy_run, 0, "lazy attribute not initialized by predicate"); + +$object->clear_lazy; +is($lazy_run, 0, "lazy attribute not initialized by clearer"); + +ok(!$object->has_lazy, "no lazy value yet"); +is($lazy_run, 0, "lazy attribute not initialized by predicate"); + +is($object->lazy, 1, "lazy value"); +is($lazy_run, 1, "lazy coderef invoked once"); + +ok($object->has_lazy, "lazy value now"); +is($lazy_run, 1, "lazy coderef invoked once"); + +is($object->lazy, 1, "lazy value is cached"); +is($lazy_run, 1, "lazy coderef invoked once"); + +$object->clear_lazy; +is($lazy_run, 1, "lazy coderef not invoked by clearer"); + +ok(!$object->has_lazy, "no value now, clearer removed it"); +is($lazy_run, 1, "lazy attribute not initialized by predicate"); + +is($object->lazy, 2, "new lazy value; previous was cleared"); +is($lazy_run, 2, "lazy coderef invoked twice"); + +my $object2 = Class->new(lazy => 'very'); +is($lazy_run, 2, "lazy attribute not initialized when an argument is passed to the constructor"); + +ok($object2->has_lazy, "lazy value now"); +is($lazy_run, 2, "lazy attribute not initialized when checked with predicate"); + +is($object2->lazy, 'very', 'value from the constructor'); +is($lazy_run, 2, "lazy coderef not invoked, we already have a value"); + +$object2->clear_lazy; +is($lazy_run, 2, "lazy attribute not initialized by clearer"); + +ok(!$object2->has_lazy, "no more lazy value"); +is($lazy_run, 2, "lazy attribute not initialized by predicate"); + +is($object2->lazy, 3, 'new lazy value'); +is($lazy_run, 3, "lazy value re-created"); + diff --git a/t/014-build.t b/t/014-build.t new file mode 100644 index 0000000..0950acc --- /dev/null +++ b/t/014-build.t @@ -0,0 +1,61 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 12; + +my ($class_build, $child_build) = (0, 0); +my ($class_buildall, $child_buildall) = (0, 0); + +do { + package Class; + use Mouse; + + sub BUILD { + ++$class_build; + } + + sub BUILDALL { + my $self = shift; + ++$class_buildall; + $self->SUPER::BUILDALL(@_); + } + + package Child; + use Mouse; + extends 'Class'; + + sub BUILD { + ++$child_build; + } + + sub BUILDALL { + my $self = shift; + ++$child_buildall; + $self->SUPER::BUILDALL(@_); + } + + +}; + +is($class_build, 0, "no calls to Class->BUILD"); +is($child_build, 0, "no calls to Child->BUILD"); + +is($class_buildall, 0, "no calls to Class->BUILDALL"); +is($child_buildall, 0, "no calls to Child->BUILDALL"); + +my $object = Class->new; + +is($class_build, 1, "Class->new calls Class->BUILD"); +is($child_build, 0, "Class->new does not call Child->BUILD"); + +is($class_buildall, 1, "Class->new calls Class->BUILDALL"); +is($child_buildall, 0, "no calls to Child->BUILDALL"); + +my $child = Child->new; + +is($child_build, 1, "Child->new calls Child->BUILD"); +is($class_build, 2, "Child->new also calls Class->BUILD"); + +is($child_buildall, 1, "Child->new calls Child->BUILDALL"); +is($class_buildall, 2, "Child->BUILDALL calls Class->BUILDALL (but not Child->new)"); + diff --git a/t/015-demolish.t b/t/015-demolish.t new file mode 100644 index 0000000..a534c8b --- /dev/null +++ b/t/015-demolish.t @@ -0,0 +1,75 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 20; + +my ($class_demolish, $child_demolish) = (0, 0); +my ($class_demolishall, $child_demolishall) = (0, 0); + +do { + package Class; + use Mouse; + + sub DEMOLISH { + ++$class_demolish; + } + + sub DEMOLISHALL { + my $self = shift; + ++$class_demolishall; + $self->SUPER::DEMOLISHALL(@_); + } + + package Child; + use Mouse; + extends 'Class'; + + sub DEMOLISH { + ++$child_demolish; + } + + sub DEMOLISHALL { + my $self = shift; + ++$child_demolishall; + $self->SUPER::DEMOLISHALL(@_); + } +}; + +is($class_demolish, 0, "no calls to Class->DEMOLISH"); +is($child_demolish, 0, "no calls to Child->DEMOLISH"); + +is($class_demolishall, 0, "no calls to Class->DEMOLISHALL"); +is($child_demolishall, 0, "no calls to Child->DEMOLISHALL"); + +do { + my $object = Class->new; + + is($class_demolish, 0, "Class->new does not call Class->DEMOLISH"); + is($child_demolish, 0, "Class->new does not call Child->DEMOLISH"); + + is($class_demolishall, 0, "Class->new does not call Class->DEMOLISHALL"); + is($child_demolishall, 0, "Class->new does not call Child->DEMOLISHALL"); +}; + +is($class_demolish, 1, "Class->DESTROY calls Class->DEMOLISH"); +is($child_demolish, 0, "Class->DESTROY does not call Child->DEMOLISH"); + +is($class_demolishall, 1, "Class->DESTROY calls Class->DEMOLISHALL"); +is($child_demolishall, 0, "no calls to Child->DEMOLISHALL"); + +do { + my $child = Child->new; + + is($class_demolish, 1, "Child->new does not call Class->DEMOLISH"); + is($child_demolish, 0, "Child->new does not call Child->DEMOLISH"); + + is($class_demolishall, 1, "Child->DEMOLISHALL does not call Class->DEMOLISHALL (but not Child->new)"); + is($child_demolishall, 0, "Child->new does not call Child->DEMOLISHALL"); +}; + +is($child_demolish, 1, "Child->DESTROY calls Child->DEMOLISH"); +is($class_demolish, 2, "Child->DESTROY also calls Class->DEMOLISH"); + +is($child_demolishall, 1, "Child->DESTROY calls Child->DEMOLISHALL"); +is($class_demolishall, 2, "Child->DEMOLISHALL calls Class->DEMOLISHALL (but not Child->DESTROY)"); + diff --git a/t/016-trigger.t b/t/016-trigger.t new file mode 100644 index 0000000..9ce32b8 --- /dev/null +++ b/t/016-trigger.t @@ -0,0 +1,45 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 10; +use Test::Exception; + +my @trigger; + +do { + package Class; + use Mouse; + + has attr => ( + is => 'rw', + default => 10, + trigger => sub { + my ($self, $value, $attr) = @_; + push @trigger, [$self, $value, $attr]; + }, + ); + + ::throws_ok { + has error => ( + is => 'ro', + trigger => sub { }, + ); + } qr/Trigger is not allowed on read-only attribute 'error'/; +}; + +can_ok(Class => 'attr'); + +my $object = Class->new; +is(@trigger, 0, "trigger not called yet"); + +is($object->attr, 10, "default value"); +is(@trigger, 0, "trigger not called on read"); + +is($object->attr(50), 50, "setting the value"); +is(@trigger, 1, "trigger was called on read"); +is_deeply(shift(@trigger), [$object, 50, $object->meta->get_attribute('attr')], "correct arguments to trigger in the accessor"); + +my $object2 = Class->new(attr => 100); +is(@trigger, 1, "trigger was called on new with the attribute specified"); +is_deeply(shift(@trigger), [$object2, 100, $object2->meta->get_attribute('attr')], "correct arguments to trigger in the constructor"); + diff --git a/t/017-default-reference.t b/t/017-default-reference.t new file mode 100644 index 0000000..05f28d2 --- /dev/null +++ b/t/017-default-reference.t @@ -0,0 +1,50 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 8; +use Test::Exception; + +do { + package Class; + use Mouse; + + ::lives_ok { + has a => ( + is => 'rw', + default => sub { [1] }, + ); + }; + + ::lives_ok { + has code => ( + is => 'rw', + default => sub { sub { 1 } }, + ); + }; + + ::throws_ok { + has b => ( + is => 'rw', + default => [], + ); + } qr/References are not allowed as default values/; + + ::throws_ok { + has c => ( + is => 'rw', + default => {}, + ); + } qr/References are not allowed as default values/; + + ::throws_ok { + has d => ( + is => 'rw', + default => meta(), + ); + } qr/References are not allowed as default values/; +}; + +is(ref(Class->new->code), 'CODE', "default => sub { sub { 1 } } stuffs a coderef"); +is(Class->new->code->(), 1, "default => sub sub strips off the first coderef"); +is_deeply(Class->new->a, [1], "default of sub { reference } works"); + diff --git a/t/018-multiattr-has.t b/t/018-multiattr-has.t new file mode 100644 index 0000000..49b4d3d --- /dev/null +++ b/t/018-multiattr-has.t @@ -0,0 +1,25 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 3; + +my %trigger; +do { + package Class; + use Mouse; + + has [qw/a b c/] => ( + is => 'rw', + trigger => sub { + my ($self, $value, $attr) = @_; + $trigger{$attr->name}++; + }, + ); +}; + +can_ok(Class => qw/a b c/); +is(Class->meta->attributes, 3, "three attributes created"); +Class->new(a => 1, b => 2); + +is_deeply(\%trigger, { a => 1, b => 1 }, "correct triggers called"); + diff --git a/t/019-handles.t b/t/019-handles.t new file mode 100644 index 0000000..6d265be --- /dev/null +++ b/t/019-handles.t @@ -0,0 +1,104 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 24; +use Test::Exception; + +do { + package Person; + + sub new { + my $class = shift; + my %args = @_; + + bless \%args, $class; + } + + sub name { $_[0]->{name} = $_[1] if @_ > 1; $_[0]->{name} } + sub age { $_[0]->{age} = $_[1] if @_ > 1; $_[0]->{age} } + + package Class; + use Mouse; + + has person => ( + is => 'rw', + lazy => 1, + default => sub { Person->new(age => 37, name => "Chuck") }, + predicate => 'has_person', + handles => { + person_name => 'name', + person_age => 'age', + }, + ); + + has me => ( + is => 'rw', + default => sub { Person->new(age => 21, name => "Shawn") }, + predicate => 'quid', + handles => [qw/name age/], + ); + + ::throws_ok { + has error => ( + handles => "string", + ); + } qr/You must pass a HASH or ARRAY to handles/; + + ::throws_ok { + has error2 => ( + handles => \"ref_to_string", + ); + } qr/You must pass a HASH or ARRAY to handles/; + + ::throws_ok { + has error3 => ( + handles => qr/regex/, + ); + } qr/You must pass a HASH or ARRAY to handles/; + + ::throws_ok { + has error4 => ( + handles => sub { "code" }, + ); + } qr/You must pass a HASH or ARRAY to handles/; +}; + +can_ok(Class => qw(person has_person person_name person_age name age quid)); + +my $object = Class->new; +ok(!$object->has_person, "don't have a person yet"); +$object->person_name("Todd"); +ok($object->has_person, "calling person_name instantiated person"); +ok($object->person, "we really do have a person"); + +is($object->person_name, "Todd", "handles method"); +is($object->person->name, "Todd", "traditional lookup"); +is($object->person_age, 37, "handles method"); +is($object->person->age, 37, "traditional lookup"); + +my $object2 = Class->new(person => Person->new(name => "Philbert")); +ok($object2->has_person, "we have a person from the constructor"); +is($object2->person_name, "Philbert", "handles method"); +is($object2->person->name, "Philbert", "traditional lookup"); +is($object2->person_age, undef, "no age because we didn't use the default"); +is($object2->person->age, undef, "no age because we didn't use the default"); + + +ok($object->quid, "we have a Shawn"); +is($object->name, "Shawn", "name handle"); +is($object->age, 21, "age handle"); +is($object->me->name, "Shawn", "me->name"); +is($object->me->age, 21, "me->age"); + +is_deeply( + $object->meta->get_attribute('me')->handles, + { name => 'name', age => 'age' }, + "correct handles layout for 'me'", +); + +is_deeply( + $object->meta->get_attribute('person')->handles, + { person_name => 'name', person_age => 'age' }, + "correct handles layout for 'person'", +); + diff --git a/t/020-load-class.t b/t/020-load-class.t new file mode 100644 index 0000000..dd27587 --- /dev/null +++ b/t/020-load-class.t @@ -0,0 +1,29 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 5; +use Test::Exception; + +require Mouse; +use lib 't/lib'; + +ok(Mouse::load_class('Anti::Mouse')); +can_ok('Anti::Mouse' => 'antimouse'); + +do { + package Class; +}; + +ok(Mouse::load_class('Class'), "this should not die!"); + +TODO: { + local $TODO = "can't have the previous test and this test pass.. yet"; + throws_ok { + Mouse::load_class('FakeClassOhNo'); + } qr/Can't locate /; +}; + +throws_ok { + Mouse::load_class('Anti::MouseError'); +} qr/Missing right curly/; + diff --git a/t/021-weak-ref.t b/t/021-weak-ref.t new file mode 100644 index 0000000..1121f49 --- /dev/null +++ b/t/021-weak-ref.t @@ -0,0 +1,84 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 18; +use Test::Exception; +use Scalar::Util 'isweak'; + +my %destroyed; + +do { + do { + package Class; + use Mouse; + + has self => ( + is => 'rw', + weak_ref => 1, + ); + + has type => ( + is => 'rw', + ); + + sub DEMOLISH { + my $self = shift; + $destroyed{ $self->type }++; + } + }; + + my $self = Class->new(type => 'accessor'); + $self->self($self); + + my $self2 = Class->new(type => 'middle'); + my $self3 = Class->new(type => 'constructor', self => $self2); + $self2->self($self3); + + for my $object ($self, $self2, $self3) { + ok(isweak($object->{self}), "weak reference"); + ok($object->self->self->self->self, "we've got circularity"); + } +}; + +is($destroyed{accessor}, 1, "destroyed from the accessor"); +is($destroyed{constructor}, 1, "destroyed from the constructor"); +is($destroyed{middle}, 1, "casuality of war"); + +ok(!Class->meta->get_attribute('type')->weak_ref, "type is not a weakref"); +ok(Class->meta->get_attribute('self')->weak_ref, "self IS a weakref"); + +do { + package Class2; + use Mouse; + + has value => ( + is => 'ro', + default => 10, + weak_ref => 1, + ); +}; + +throws_ok { Class2->new } qr/Can't weaken a nonreference/; +ok(Class2->meta->get_attribute('value')->weak_ref, "value IS a weakref"); + +do { + package Class3; + use Mouse; + + has hashref => ( + is => 'ro', + default => sub { {} }, + weak_ref => 1, + predicate => 'has_hashref', + ); +}; + +my $obj = Class3->new; +is($obj->hashref, undef, "hashref collected immediately because refcount=0"); +ok($obj->has_hashref, 'attribute is turned into undef, not deleted from instance'); + +$obj->hashref({1 => 1}); +is($obj->hashref, undef, "hashref collected between set and get because refcount=0"); +ok($obj->has_hashref, 'attribute is turned into undef, not deleted from instance'); + +ok(Class3->meta->get_attribute('hashref')->weak_ref, "hashref IS a weakref"); diff --git a/t/022-init-arg.t b/t/022-init-arg.t new file mode 100644 index 0000000..0bfc783 --- /dev/null +++ b/t/022-init-arg.t @@ -0,0 +1,30 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 9; + +do { + package Class; + use Mouse; + + has name => ( + is => 'rw', + init_arg => 'key', + default => 'default', + ); +}; + +my $object = Class->new; +is($object->name, 'default', 'accessor uses attribute name'); +is($object->{name}, undef, 'nothing in object->{attribute name}!'); +is($object->{key}, 'default', 'value is in object->{init_arg}'); + +my $object2 = Class->new(name => 'name', key => 'key'); +is($object2->name, 'key', 'attribute value is from init_arg'); +is($object2->{name}, undef, 'no value for the attribute name'); +is($object2->{key}, 'key', 'value is from init_arg parameter'); + +my $attr = $object2->meta->get_attribute('name'); +ok($attr, 'got the attribute object by name (not init_arg)'); +is($attr->name, 'name', 'name is name'); +is($attr->init_arg, 'key', 'init_arg is key'); diff --git a/t/023-builder.t b/t/023-builder.t new file mode 100644 index 0000000..e69de29 diff --git a/t/100-meta-class.t b/t/100-meta-class.t new file mode 100644 index 0000000..53f287e --- /dev/null +++ b/t/100-meta-class.t @@ -0,0 +1,57 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 12; + +do { + package Class; + use Mouse; + + has pawn => ( + is => 'rw', + predicate => 'has_pawn', + ); + + no Mouse; +}; + +my $meta = Class->meta; +isa_ok($meta, 'Mouse::Class'); + +is_deeply([$meta->superclasses], ['Mouse::Object'], "correctly inherting from Mouse::Object"); + +my $meta2 = Class->meta; +is($meta, $meta2, "same metaclass instance"); + +can_ok($meta, 'name', 'attributes', 'get_attribute_map'); + +my $attr = $meta->get_attribute('pawn'); +isa_ok($attr, 'Mouse::Attribute'); +is($attr->name, 'pawn', 'got the correct attribute'); + +my $map = $meta->get_attribute_map; +is_deeply($map, { pawn => $attr }, "attribute map"); + +eval " + package Class; + use Mouse; + no Mouse; +"; + +my $meta3 = Class->meta; +is($meta, $meta3, "same metaclass instance, even if use Mouse is performed again"); + +is($meta->name, 'Class', "name for the metaclass"); + +do { + package Child; + use Mouse; + extends 'Class'; +}; + +my $child_meta = Child->meta; +isa_ok($child_meta, 'Mouse::Class'); + +isnt($meta, $child_meta, "different metaclass instances for the two classes"); + +is_deeply([$child_meta->superclasses], ['Class'], "correct superclasses"); diff --git a/t/101-meta-attribute.t b/t/101-meta-attribute.t new file mode 100644 index 0000000..454b609 --- /dev/null +++ b/t/101-meta-attribute.t @@ -0,0 +1,32 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 8; + +do { + package Class; + use Mouse; + + has pawn => ( + is => 'rw', + predicate => 'has_pawn', + clearer => 'clear_pawn', + default => sub { 10 }, + ); + + no Mouse; +}; + +my $meta = Class->meta; +isa_ok($meta, 'Mouse::Class'); + +my $attr = $meta->get_attribute('pawn'); +isa_ok($attr, 'Mouse::Attribute'); + +can_ok($attr, qw(name class predicate clearer)); +is($attr->name, 'pawn', 'attribute name'); +is($attr->class, 'Class', 'attached class'); +is($attr->predicate, 'has_pawn', 'predicate'); +is($attr->clearer, 'clear_pawn', 'clearer'); +is(ref($attr->default), 'CODE', 'default is a coderef'); + diff --git a/t/lib/Anti/Mouse.pm b/t/lib/Anti/Mouse.pm new file mode 100644 index 0000000..160c72b --- /dev/null +++ b/t/lib/Anti/Mouse.pm @@ -0,0 +1,9 @@ +#!/usr/bin/env perl +package Anti::Mouse; +use strict; +use warnings; + +sub antimouse { 1 } + +1; + diff --git a/t/lib/Anti/MouseError.pm b/t/lib/Anti/MouseError.pm new file mode 100644 index 0000000..6832406 --- /dev/null +++ b/t/lib/Anti/MouseError.pm @@ -0,0 +1,11 @@ +#!/usr/bin/env perl +package Anti::MouseError; +use strict; +use warnings; + +# this syntax error is intentional! + + { + +1; +