--- /dev/null
+Revision history for Mouse
+
+0.01 Sun May 18 13:03:21 2008
+ First version, released on an unsuspecting world.
+
--- /dev/null
+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;
+
--- /dev/null
+#!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<Carp/confess> for your convenience.
+
+=head2 blessed value -> ClassName | undef
+
+L<Scalar::Util/blessed> for your convenience.
+
+=head1 MISC
+
+=head2 import
+
+Importing Mouse will set your class' superclass list to L<Mouse::Object>.
+You may use L</extends> to replace the superclass list.
+
+=head2 unimport
+
+Please unimport Mouse so that if someone calls one of the keywords (such as
+L</extends>) 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<eval "use $module"> or using C<require>.
+
+=head1 AUTHOR
+
+Shawn M Moore, C<< <sartak at gmail.com> >>
+
+=head1 BUGS
+
+No known bugs.
+
+Please report any bugs through RT: email
+C<bug-mouse at rt.cpan.org>, or browse
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
+
+=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
+
--- /dev/null
+#!/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
+
--- /dev/null
+#!/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<Mouse::Attribute> for the owner class.
+
+=head2 attributes -> [Mouse::Attribute]
+
+Returns a list of L<Mouse::Attribute> objects.
+
+=head2 get_attribute_map -> { name => Mouse::Attribute }
+
+Returns a mapping of attribute names to their corresponding
+L<Mouse::Attribute> objects.
+
+=head2 get_attribute Name -> Mouse::Attribute | undef
+
+Returns the L<Mouse::Attribute> with the given name.
+
+=head2 linearized_isa -> [ClassNames]
+
+Returns the list of classes in method dispatch order, with duplicates removed.
+
+=cut
+
--- /dev/null
+#!/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</BUILD> on each class in the class hierarchy. This is called at the
+end of L</new>.
+
+=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</DEMOLISH> on each class in the class hierarchy. This is called at
+L</DESTROY> 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
+
--- /dev/null
+#!perl -T
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+use_ok 'Mouse';
+
--- /dev/null
+#!/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';
+
--- /dev/null
+#!/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';
+
--- /dev/null
+#!/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');
+
--- /dev/null
+#!/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');
+
--- /dev/null
+#!/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));
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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);
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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";
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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)");
+
--- /dev/null
+#!/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)");
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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");
+
--- /dev/null
+#!/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'",
+);
+
--- /dev/null
+#!/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/;
+
--- /dev/null
+#!/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");
--- /dev/null
+#!/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');
--- /dev/null
+#!/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");
--- /dev/null
+#!/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');
+
--- /dev/null
+#!/usr/bin/env perl
+package Anti::Mouse;
+use strict;
+use warnings;
+
+sub antimouse { 1 }
+
+1;
+
--- /dev/null
+#!/usr/bin/env perl
+package Anti::MouseError;
+use strict;
+use warnings;
+
+# this syntax error is intentional!
+
+ {
+
+1;
+
projects / gitmo/Mouse.git / commitdiff