--- /dev/null
+use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+use Test::Requires {
+ 'Test::Output' => '0.01', # skip all if not installed
+};
+
+{
+ package Foo;
+
+ use Mouse;
+
+ ::stderr_like{ has foo => (
+ is => 'ro',
+ isa => 'Str',
+ coerce => 1,
+ );
+ }
+ qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/,
+ 'Cannot coerce unless the type has a coercion';
+
+ ::stderr_like{ has bar => (
+ is => 'ro',
+ isa => 'Str',
+ coerce => 1,
+ );
+ }
+ qr/\QYou cannot coerce an attribute (bar) unless its type (Str) has a coercion/,
+ 'Cannot coerce unless the type has a coercion - different attribute';
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+use Test::Requires {
+ 'Test::Output' => '0.01', # skip all if not installed
+};
+
+{
+ package HasOwnImmutable;
+
+ use Mouse;
+
+ no Mouse;
+
+ ::stderr_is( sub { eval q[sub make_immutable { return 'foo' }] },
+ '',
+ 'no warning when defining our own make_immutable sub' );
+}
+
+{
+ is( HasOwnImmutable->make_immutable(), 'foo',
+ 'HasOwnImmutable->make_immutable does not get overwritten' );
+}
+
+{
+ package MouseX::Empty;
+
+ use Mouse ();
+ Mouse::Exporter->setup_import_methods( also => 'Mouse' );
+}
+
+{
+ package WantsMouse;
+
+ MouseX::Empty->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsMouse', 'has' );
+ ::can_ok( 'WantsMouse', 'with' );
+ ::can_ok( 'WantsMouse', 'foo' );
+
+ MouseX::Empty->unimport();
+}
+
+{
+ # Note: it's important that these methods be out of scope _now_,
+ # after unimport was called. We tried a
+ # namespace::clean(0.08)-based solution, but had to abandon it
+ # because it cleans the namespace _later_ (when the file scope
+ # ends).
+ ok( ! WantsMouse->can('has'), 'WantsMouse::has() has been cleaned' );
+ ok( ! WantsMouse->can('with'), 'WantsMouse::with() has been cleaned' );
+ can_ok( 'WantsMouse', 'foo' );
+
+ # This makes sure that Mouse->init_meta() happens properly
+ isa_ok( WantsMouse->meta(), 'Mouse::Meta::Class' );
+ isa_ok( WantsMouse->new(), 'Mouse::Object' );
+
+}
+
+{
+ package MouseX::Sugar;
+
+ use Mouse ();
+
+ sub wrapped1 {
+ my $meta = shift;
+ return $meta->name . ' called wrapped1';
+ }
+
+ Mouse::Exporter->setup_import_methods(
+ with_meta => ['wrapped1'],
+ also => 'Mouse',
+ );
+}
+
+{
+ package WantsSugar;
+
+ MouseX::Sugar->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsSugar', 'has' );
+ ::can_ok( 'WantsSugar', 'with' );
+ ::can_ok( 'WantsSugar', 'wrapped1' );
+ ::can_ok( 'WantsSugar', 'foo' );
+ ::is( wrapped1(), 'WantsSugar called wrapped1',
+ 'wrapped1 identifies the caller correctly' );
+
+ MouseX::Sugar->unimport();
+}
+
+{
+ ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' );
+ ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' );
+ ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' );
+ can_ok( 'WantsSugar', 'foo' );
+}
+
+{
+ package MouseX::MoreSugar;
+
+ use Mouse ();
+
+ sub wrapped2 {
+ my $caller = shift->name;
+ return $caller . ' called wrapped2';
+ }
+
+ sub as_is1 {
+ return 'as_is1';
+ }
+
+ Mouse::Exporter->setup_import_methods(
+ with_meta => ['wrapped2'],
+ as_is => ['as_is1'],
+ also => 'MouseX::Sugar',
+ );
+}
+
+{
+ package WantsMoreSugar;
+
+ MouseX::MoreSugar->import();
+
+ sub foo { 1 }
+
+ ::can_ok( 'WantsMoreSugar', 'has' );
+ ::can_ok( 'WantsMoreSugar', 'with' );
+ ::can_ok( 'WantsMoreSugar', 'wrapped1' );
+ ::can_ok( 'WantsMoreSugar', 'wrapped2' );
+ ::can_ok( 'WantsMoreSugar', 'as_is1' );
+ ::can_ok( 'WantsMoreSugar', 'foo' );
+ ::is( wrapped1(), 'WantsMoreSugar called wrapped1',
+ 'wrapped1 identifies the caller correctly' );
+ ::is( wrapped2(), 'WantsMoreSugar called wrapped2',
+ 'wrapped2 identifies the caller correctly' );
+ ::is( as_is1(), 'as_is1',
+ 'as_is1 works as expected' );
+
+ MouseX::MoreSugar->unimport();
+}
+
+{
+ ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' );
+ ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' );
+ ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' );
+ ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' );
+ ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' );
+ can_ok( 'WantsMoreSugar', 'foo' );
+}
+
+{
+ package My::Metaclass;
+ use Mouse;
+ BEGIN { extends 'Mouse::Meta::Class' }
+
+ package My::Object;
+ use Mouse;
+ BEGIN { extends 'Mouse::Object' }
+
+ package HasInitMeta;
+
+ use Mouse ();
+
+ sub init_meta {
+ shift;
+ return Mouse->init_meta( @_,
+ metaclass => 'My::Metaclass',
+ base_class => 'My::Object',
+ );
+ }
+
+ Mouse::Exporter->setup_import_methods( also => 'Mouse' );
+}
+
+{
+ package NewMeta;
+
+ HasInitMeta->import();
+}
+
+{
+ isa_ok( NewMeta->meta(), 'My::Metaclass' );
+ isa_ok( NewMeta->new(), 'My::Object' );
+}
+
+{
+ package MouseX::CircularAlso;
+
+ use Mouse ();
+
+ ::dies_ok(
+ sub {
+ Mouse::Exporter->setup_import_methods(
+ also => [ 'Mouse', 'MouseX::CircularAlso' ],
+ );
+ },
+ 'a circular reference in also dies with an error'
+ );
+
+ ::like(
+ $@,
+ qr/\QCircular reference in 'also' parameter to Mouse::Exporter between MouseX::CircularAlso and MouseX::CircularAlso/,
+ 'got the expected error from circular reference in also'
+ );
+}
+
+{
+ package MouseX::NoAlso;
+
+ use Mouse ();
+
+ ::dies_ok(
+ sub {
+ Mouse::Exporter->setup_import_methods(
+ also => [ 'NoSuchThing' ],
+ );
+ },
+ 'a package which does not use Mouse::Exporter in also dies with an error'
+ );
+
+ ::like(
+ $@,
+ qr/\QPackage in also (NoSuchThing) does not seem to use Mouse::Exporter (is it loaded?) at /,
+ 'got the expected error from a reference in also to a package which is not loaded'
+ );
+}
+
+{
+ package MouseX::NotExporter;
+
+ use Mouse ();
+
+ ::dies_ok(
+ sub {
+ Mouse::Exporter->setup_import_methods(
+ also => [ 'Mouse::Meta::Method' ],
+ );
+ },
+ 'a package which does not use Mouse::Exporter in also dies with an error'
+ );
+
+ ::like(
+ $@,
+ qr/\QPackage in also (Mouse::Meta::Method) does not seem to use Mouse::Exporter at /,
+ 'got the expected error from a reference in also to a package which does not use Mouse::Exporter'
+ );
+}
+
+{
+ package MouseX::OverridingSugar;
+
+ use Mouse ();
+
+ sub has {
+ my $caller = shift->name;
+ return $caller . ' called has';
+ }
+
+ Mouse::Exporter->setup_import_methods(
+ with_meta => ['has'],
+ also => 'Mouse',
+ );
+}
+
+{
+ package WantsOverridingSugar;
+
+ MouseX::OverridingSugar->import();
+
+ ::can_ok( 'WantsOverridingSugar', 'has' );
+ ::can_ok( 'WantsOverridingSugar', 'with' );
+ ::is( has('foo'), 'WantsOverridingSugar called has',
+ 'has from MouseX::OverridingSugar is called, not has from Mouse' );
+
+ MouseX::OverridingSugar->unimport();
+}
+
+{
+ ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' );
+ ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' );
+}
+
+{
+ package NonExistentExport;
+
+ use Mouse ();
+
+ ::stderr_like {
+ Mouse::Exporter->setup_import_methods(
+ also => ['Mouse'],
+ with_meta => ['does_not_exist'],
+ );
+ } qr/^Trying to export undefined sub NonExistentExport::does_not_exist/,
+ "warns when a non-existent method is requested to be exported";
+}
+
+{
+ package WantsNonExistentExport;
+
+ NonExistentExport->import;
+
+ ::ok(!__PACKAGE__->can('does_not_exist'),
+ "undefined subs do not get exported");
+}
+
+{
+ package AllOptions;
+ use Mouse ();
+ use Mouse::Deprecated -api_version => '0.88';
+ use Mouse::Exporter;
+
+ Mouse::Exporter->setup_import_methods(
+ also => ['Mouse'],
+ with_meta => [ 'with_meta1', 'with_meta2' ],
+ with_caller => [ 'with_caller1', 'with_caller2' ],
+ as_is => ['as_is1'],
+ );
+
+ sub with_caller1 {
+ return @_;
+ }
+
+ sub with_caller2 (&) {
+ return @_;
+ }
+
+ sub as_is1 {2}
+
+ sub with_meta1 {
+ return @_;
+ }
+
+ sub with_meta2 (&) {
+ return @_;
+ }
+}
+
+{
+ package UseAllOptions;
+
+ AllOptions->import();
+}
+
+{
+ can_ok( 'UseAllOptions', $_ )
+ for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 );
+
+ {
+ my ( $caller, $arg1 ) = UseAllOptions::with_caller1(42);
+ is( $caller, 'UseAllOptions', 'with_caller wrapped sub gets the right caller' );
+ is( $arg1, 42, 'with_caller wrapped sub returns argument it was passed' );
+ }
+
+ {
+ my ( $meta, $arg1 ) = UseAllOptions::with_meta1(42);
+ isa_ok( $meta, 'Mouse::Meta::Class', 'with_meta first argument' );
+ is( $arg1, 42, 'with_meta1 returns argument it was passed' );
+ }
+
+ is(
+ prototype( UseAllOptions->can('with_caller2') ),
+ prototype( AllOptions->can('with_caller2') ),
+ 'using correct prototype on with_meta function'
+ );
+
+ is(
+ prototype( UseAllOptions->can('with_meta2') ),
+ prototype( AllOptions->can('with_meta2') ),
+ 'using correct prototype on with_meta function'
+ );
+}
+
+{
+ package UseAllOptions;
+ AllOptions->unimport();
+}
+
+{
+ ok( ! UseAllOptions->can($_), "UseAllOptions::$_ has been unimported" )
+ for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 );
+}
+
+done_testing;
--- /dev/null
+use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use warnings;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Mouse::Meta ();
+
+{
+ package My::Role;
+ use Mouse::Role;
+}
+
+{
+ package SomeClass;
+ use Mouse -traits => 'My::Role';
+}
+
+{
+ package SubClassUseBase;
+ use base qw/SomeClass/;
+}
+
+{
+ package SubSubClassUseBase;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'SubClassUseBase';
+ }
+ 'Can extend non-Mouse class with parent class that is a Mouse class with a meta role';
+}
+
+{
+ ok( SubSubClassUseBase->meta->meta->can('does_role')
+ && SubSubClassUseBase->meta->meta->does_role('My::Role'),
+ 'SubSubClassUseBase meta metaclass does the My::Role role' );
+}
+
+# Note, remove metaclasses of the 'use base' classes after each test,
+# so that they have to be re-initialized - otherwise latter tests
+# would not demonstrate the original issue.
+Mouse::Util::remove_metaclass_by_name('SubClassUseBase');
+
+{
+ package OtherClass;
+ use Mouse;
+}
+
+{
+ package OtherSubClassUseBase;
+ use base 'OtherClass';
+}
+
+{
+ package MultiParent1;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( SubClassUseBase OtherSubClassUseBase );
+ }
+ 'Can extend two non-Mouse classes with parents that are different Mouse metaclasses';
+}
+
+{
+ ok( MultiParent1->meta->meta->can('does_role')
+ && MultiParent1->meta->meta->does_role('My::Role'),
+ 'MultiParent1 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiParent2;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( OtherSubClassUseBase SubClassUseBase );
+ }
+ 'Can extend two non-Mouse classes with parents that are different Mouse metaclasses (reverse order)';
+}
+
+{
+ ok( MultiParent2->meta->meta->can('does_role')
+ && MultiParent2->meta->meta->does_role('My::Role'),
+ 'MultiParent2 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiParent3;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( OtherClass SubClassUseBase );
+ }
+ 'Can extend one Mouse class and one non-Mouse class';
+}
+
+{
+ ok( MultiParent3->meta->meta->can('does_role')
+ && MultiParent3->meta->meta->does_role('My::Role'),
+ 'MultiParent3 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiParent4;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( SubClassUseBase OtherClass );
+ }
+ 'Can extend one non-Mouse class and one Mouse class';
+}
+
+{
+ ok( MultiParent4->meta->meta->can('does_role')
+ && MultiParent4->meta->meta->does_role('My::Role'),
+ 'MultiParent4 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild1;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent1';
+ }
+ 'Can extend class that itself extends two non-Mouse classes with Mouse parents';
+}
+
+{
+ ok( MultiChild1->meta->meta->can('does_role')
+ && MultiChild1->meta->meta->does_role('My::Role'),
+ 'MultiChild1 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild2;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent2';
+ }
+ 'Can extend class that itself extends two non-Mouse classes with Mouse parents (reverse order)';
+}
+
+{
+ ok( MultiChild2->meta->meta->can('does_role')
+ && MultiChild2->meta->meta->does_role('My::Role'),
+ 'MultiChild2 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild3;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent3';
+ }
+ 'Can extend class that itself extends one Mouse and one non-Mouse parent';
+}
+
+{
+ ok( MultiChild3->meta->meta->can('does_role')
+ && MultiChild3->meta->meta->does_role('My::Role'),
+ 'MultiChild3 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild4;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent4';
+ }
+ 'Can extend class that itself extends one non-Mouse and one Mouse parent';
+}
+
+{
+ ok( MultiChild4->meta->meta->can('does_role')
+ && MultiChild4->meta->meta->does_role('My::Role'),
+ 'MultiChild4 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+use Test::Requires {
+ 'DBM::Deep' => '1.0003', # skip all if not installed
+ 'DateTime::Format::MySQL' => '0.01',
+};
+
+use Test::Exception;
+
+BEGIN {
+ # in case there are leftovers
+ unlink('newswriter.db') if -e 'newswriter.db';
+}
+
+END {
+ unlink('newswriter.db') if -e 'newswriter.db';
+}
+
+
+=pod
+
+This example creates a very basic Object Database which
+links in the instances created with a backend store
+(a DBM::Deep hash). It is by no means to be taken seriously
+as a real-world ODB, but is a proof of concept of the flexibility
+of the ::Instance protocol.
+
+=cut
+
+BEGIN {
+
+ package Mouse::POOP::Meta::Instance;
+ use Mouse;
+
+ use DBM::Deep;
+
+ extends 'Mouse::Meta::Instance';
+
+ {
+ my %INSTANCE_COUNTERS;
+
+ my $db = DBM::Deep->new({
+ file => "newswriter.db",
+ autobless => 1,
+ locking => 1,
+ });
+
+ sub _reload_db {
+ #use Data::Dumper;
+ #warn Dumper $db;
+ $db = undef;
+ $db = DBM::Deep->new({
+ file => "newswriter.db",
+ autobless => 1,
+ locking => 1,
+ });
+ }
+
+ sub create_instance {
+ my $self = shift;
+ my $class = $self->associated_metaclass->name;
+ my $oid = ++$INSTANCE_COUNTERS{$class};
+
+ $db->{$class}->[($oid - 1)] = {};
+
+ bless {
+ oid => $oid,
+ instance => $db->{$class}->[($oid - 1)]
+ }, $class;
+ }
+
+ sub find_instance {
+ my ($self, $oid) = @_;
+ my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)];
+
+ bless {
+ oid => $oid,
+ instance => $instance,
+ }, $self->associated_metaclass->name;
+ }
+
+ sub clone_instance {
+ my ($self, $instance) = @_;
+
+ my $class = $self->{meta}->name;
+ my $oid = ++$INSTANCE_COUNTERS{$class};
+
+ my $clone = tied($instance)->clone;
+
+ bless {
+ oid => $oid,
+ instance => $clone,
+ }, $class;
+ }
+ }
+
+ sub get_instance_oid {
+ my ($self, $instance) = @_;
+ $instance->{oid};
+ }
+
+ sub get_slot_value {
+ my ($self, $instance, $slot_name) = @_;
+ return $instance->{instance}->{$slot_name};
+ }
+
+ sub set_slot_value {
+ my ($self, $instance, $slot_name, $value) = @_;
+ $instance->{instance}->{$slot_name} = $value;
+ }
+
+ sub is_slot_initialized {
+ my ($self, $instance, $slot_name, $value) = @_;
+ exists $instance->{instance}->{$slot_name} ? 1 : 0;
+ }
+
+ sub weaken_slot_value {
+ confess "Not sure how well DBM::Deep plays with weak refs, Rob says 'Write a test'";
+ }
+
+ sub inline_slot_access {
+ my ($self, $instance, $slot_name) = @_;
+ sprintf "%s->{instance}->{%s}", $instance, $slot_name;
+ }
+
+ package Mouse::POOP::Meta::Class;
+ use Mouse;
+
+ extends 'Mouse::Meta::Class';
+
+ override '_construct_instance' => sub {
+ my $class = shift;
+ my $params = @_ == 1 ? $_[0] : {@_};
+ return $class->get_meta_instance->find_instance($params->{oid})
+ if $params->{oid};
+ super();
+ };
+
+}
+{
+ package Mouse::POOP::Object;
+ use metaclass 'Mouse::POOP::Meta::Class' => (
+ instance_metaclass => 'Mouse::POOP::Meta::Instance'
+ );
+ use Mouse;
+
+ sub oid {
+ my $self = shift;
+ $self->meta
+ ->get_meta_instance
+ ->get_instance_oid($self);
+ }
+
+}
+{
+ package Newswriter::Author;
+ use Mouse;
+
+ extends 'Mouse::POOP::Object';
+
+ has 'first_name' => (is => 'rw', isa => 'Str');
+ has 'last_name' => (is => 'rw', isa => 'Str');
+
+ package Newswriter::Article;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ use DateTime::Format::MySQL;
+
+ extends 'Mouse::POOP::Object';
+
+ subtype 'Headline'
+ => as 'Str'
+ => where { length($_) < 100 };
+
+ subtype 'Summary'
+ => as 'Str'
+ => where { length($_) < 255 };
+
+ subtype 'DateTimeFormatString'
+ => as 'Str'
+ => where { DateTime::Format::MySQL->parse_datetime($_) };
+
+ enum 'Status' => qw(draft posted pending archive);
+
+ has 'headline' => (is => 'rw', isa => 'Headline');
+ has 'summary' => (is => 'rw', isa => 'Summary');
+ has 'article' => (is => 'rw', isa => 'Str');
+
+ has 'start_date' => (is => 'rw', isa => 'DateTimeFormatString');
+ has 'end_date' => (is => 'rw', isa => 'DateTimeFormatString');
+
+ has 'author' => (is => 'rw', isa => 'Newswriter::Author');
+
+ has 'status' => (is => 'rw', isa => 'Status');
+
+ around 'start_date', 'end_date' => sub {
+ my $c = shift;
+ my $self = shift;
+ $c->($self, DateTime::Format::MySQL->format_datetime($_[0])) if @_;
+ DateTime::Format::MySQL->parse_datetime($c->($self) || return undef);
+ };
+}
+
+{ # check the meta stuff first
+ isa_ok(Mouse::POOP::Object->meta, 'Mouse::POOP::Meta::Class');
+ isa_ok(Mouse::POOP::Object->meta, 'Mouse::Meta::Class');
+ isa_ok(Mouse::POOP::Object->meta, 'Mouse::Meta::Class');
+
+ is(Mouse::POOP::Object->meta->instance_metaclass,
+ 'Mouse::POOP::Meta::Instance',
+ '... got the right instance metaclass name');
+
+ isa_ok(Mouse::POOP::Object->meta->get_meta_instance, 'Mouse::POOP::Meta::Instance');
+
+ my $base = Mouse::POOP::Object->new;
+ isa_ok($base, 'Mouse::POOP::Object');
+ isa_ok($base, 'Mouse::Object');
+
+ isa_ok($base->meta, 'Mouse::POOP::Meta::Class');
+ isa_ok($base->meta, 'Mouse::Meta::Class');
+ isa_ok($base->meta, 'Mouse::Meta::Class');
+
+ is($base->meta->instance_metaclass,
+ 'Mouse::POOP::Meta::Instance',
+ '... got the right instance metaclass name');
+
+ isa_ok($base->meta->get_meta_instance, 'Mouse::POOP::Meta::Instance');
+}
+
+my $article_oid;
+my $article_ref;
+{
+ my $article;
+ lives_ok {
+ $article = Newswriter::Article->new(
+ headline => 'Home Office Redecorated',
+ summary => 'The home office was recently redecorated to match the new company colors',
+ article => '...',
+
+ author => Newswriter::Author->new(
+ first_name => 'Truman',
+ last_name => 'Capote'
+ ),
+
+ status => 'pending'
+ );
+ } '... created my article successfully';
+ isa_ok($article, 'Newswriter::Article');
+ isa_ok($article, 'Mouse::POOP::Object');
+
+ lives_ok {
+ $article->start_date(DateTime->new(year => 2006, month => 6, day => 10));
+ $article->end_date(DateTime->new(year => 2006, month => 6, day => 17));
+ } '... add the article date-time stuff';
+
+ ## check some meta stuff
+
+ isa_ok($article->meta, 'Mouse::POOP::Meta::Class');
+ isa_ok($article->meta, 'Mouse::Meta::Class');
+ isa_ok($article->meta, 'Mouse::Meta::Class');
+
+ is($article->meta->instance_metaclass,
+ 'Mouse::POOP::Meta::Instance',
+ '... got the right instance metaclass name');
+
+ isa_ok($article->meta->get_meta_instance, 'Mouse::POOP::Meta::Instance');
+
+ ok($article->oid, '... got a oid for the article');
+
+ $article_oid = $article->oid;
+ $article_ref = "$article";
+
+ is($article->headline,
+ 'Home Office Redecorated',
+ '... got the right headline');
+ is($article->summary,
+ 'The home office was recently redecorated to match the new company colors',
+ '... got the right summary');
+ is($article->article, '...', '... got the right article');
+
+ isa_ok($article->start_date, 'DateTime');
+ isa_ok($article->end_date, 'DateTime');
+
+ isa_ok($article->author, 'Newswriter::Author');
+ is($article->author->first_name, 'Truman', '... got the right author first name');
+ is($article->author->last_name, 'Capote', '... got the right author last name');
+
+ is($article->status, 'pending', '... got the right status');
+}
+
+Mouse::POOP::Meta::Instance->_reload_db();
+
+my $article2_oid;
+my $article2_ref;
+{
+ my $article2;
+ lives_ok {
+ $article2 = Newswriter::Article->new(
+ headline => 'Company wins Lottery',
+ summary => 'An email was received today that informed the company we have won the lottery',
+ article => 'WoW',
+
+ author => Newswriter::Author->new(
+ first_name => 'Katie',
+ last_name => 'Couric'
+ ),
+
+ status => 'posted'
+ );
+ } '... created my article successfully';
+ isa_ok($article2, 'Newswriter::Article');
+ isa_ok($article2, 'Mouse::POOP::Object');
+
+ $article2_oid = $article2->oid;
+ $article2_ref = "$article2";
+
+ is($article2->headline,
+ 'Company wins Lottery',
+ '... got the right headline');
+ is($article2->summary,
+ 'An email was received today that informed the company we have won the lottery',
+ '... got the right summary');
+ is($article2->article, 'WoW', '... got the right article');
+
+ ok(!$article2->start_date, '... these two dates are unassigned');
+ ok(!$article2->end_date, '... these two dates are unassigned');
+
+ isa_ok($article2->author, 'Newswriter::Author');
+ is($article2->author->first_name, 'Katie', '... got the right author first name');
+ is($article2->author->last_name, 'Couric', '... got the right author last name');
+
+ is($article2->status, 'posted', '... got the right status');
+
+ ## orig-article
+
+ my $article;
+ lives_ok {
+ $article = Newswriter::Article->new(oid => $article_oid);
+ } '... (re)-created my article successfully';
+ isa_ok($article, 'Newswriter::Article');
+ isa_ok($article, 'Mouse::POOP::Object');
+
+ is($article->oid, $article_oid, '... got a oid for the article');
+ isnt($article_ref, "$article", '... got a new article instance');
+
+ is($article->headline,
+ 'Home Office Redecorated',
+ '... got the right headline');
+ is($article->summary,
+ 'The home office was recently redecorated to match the new company colors',
+ '... got the right summary');
+ is($article->article, '...', '... got the right article');
+
+ isa_ok($article->start_date, 'DateTime');
+ isa_ok($article->end_date, 'DateTime');
+
+ isa_ok($article->author, 'Newswriter::Author');
+ is($article->author->first_name, 'Truman', '... got the right author first name');
+ is($article->author->last_name, 'Capote', '... got the right author last name');
+
+ lives_ok {
+ $article->author->first_name('Dan');
+ $article->author->last_name('Rather');
+ } '... changed the value ok';
+
+ is($article->author->first_name, 'Dan', '... got the changed author first name');
+ is($article->author->last_name, 'Rather', '... got the changed author last name');
+
+ is($article->status, 'pending', '... got the right status');
+}
+
+Mouse::POOP::Meta::Instance->_reload_db();
+
+{
+ my $article;
+ lives_ok {
+ $article = Newswriter::Article->new(oid => $article_oid);
+ } '... (re)-created my article successfully';
+ isa_ok($article, 'Newswriter::Article');
+ isa_ok($article, 'Mouse::POOP::Object');
+
+ is($article->oid, $article_oid, '... got a oid for the article');
+ isnt($article_ref, "$article", '... got a new article instance');
+
+ is($article->headline,
+ 'Home Office Redecorated',
+ '... got the right headline');
+ is($article->summary,
+ 'The home office was recently redecorated to match the new company colors',
+ '... got the right summary');
+ is($article->article, '...', '... got the right article');
+
+ isa_ok($article->start_date, 'DateTime');
+ isa_ok($article->end_date, 'DateTime');
+
+ isa_ok($article->author, 'Newswriter::Author');
+ is($article->author->first_name, 'Dan', '... got the changed author first name');
+ is($article->author->last_name, 'Rather', '... got the changed author last name');
+
+ is($article->status, 'pending', '... got the right status');
+
+ my $article2;
+ lives_ok {
+ $article2 = Newswriter::Article->new(oid => $article2_oid);
+ } '... (re)-created my article successfully';
+ isa_ok($article2, 'Newswriter::Article');
+ isa_ok($article2, 'Mouse::POOP::Object');
+
+ is($article2->oid, $article2_oid, '... got a oid for the article');
+ isnt($article2_ref, "$article2", '... got a new article instance');
+
+ is($article2->headline,
+ 'Company wins Lottery',
+ '... got the right headline');
+ is($article2->summary,
+ 'An email was received today that informed the company we have won the lottery',
+ '... got the right summary');
+ is($article2->article, 'WoW', '... got the right article');
+
+ ok(!$article2->start_date, '... these two dates are unassigned');
+ ok(!$article2->end_date, '... these two dates are unassigned');
+
+ isa_ok($article2->author, 'Newswriter::Author');
+ is($article2->author->first_name, 'Katie', '... got the right author first name');
+ is($article2->author->last_name, 'Couric', '... got the right author last name');
+
+ is($article2->status, 'posted', '... got the right status');
+
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+use Test::Requires {
+ 'Test::Output' => '0.01', # skip all if not installed
+};
+
+{
+ package NotMouse;
+
+ sub new {
+ my $class = shift;
+
+ return bless { not_moose => 1 }, $class;
+ }
+}
+
+{
+ package Foo;
+ use Mouse;
+
+ extends 'NotMouse';
+
+ ::stderr_like(
+ sub { Foo->meta->make_immutable },
+ qr/\QNot inlining 'new' for Foo since it is not inheriting the default Mouse::Object::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/,
+ 'got a warning that Foo may not have an inlined constructor'
+ );
+}
+
+is(
+ Foo->meta->find_method_by_name('new')->body,
+ NotMouse->can('new'),
+ 'Foo->new is inherited from NotMouse'
+);
+
+{
+ package Bar;
+ use Mouse;
+
+ extends 'NotMouse';
+
+ ::stderr_is(
+ sub { Bar->meta->make_immutable( replace_constructor => 1 ) },
+ q{},
+ 'no warning when replace_constructor is true'
+ );
+}
+
+is(
+ Bar->meta->find_method_by_name('new')->package_name,
+ 'Bar',
+ 'Bar->new is inlined, and not inherited from NotMouse'
+);
+
+{
+ package Baz;
+ use Mouse;
+
+ Baz->meta->make_immutable;
+}
+
+{
+ package Quux;
+ use Mouse;
+
+ extends 'Baz';
+
+ ::stderr_is(
+ sub { Quux->meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
+
+{
+ package My::Constructor;
+ use base 'Mouse::Meta::Method';
+}
+
+{
+ package CustomCons;
+ use Mouse;
+
+ CustomCons->meta->make_immutable( constructor_class => 'My::Constructor' );
+}
+
+{
+ package Subclass;
+ use Mouse;
+
+ extends 'CustomCons';
+
+ ::stderr_is(
+ sub { Subclass->meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+use Test::Requires {
+ 'Test::Output' => '0.01', # skip all if not installed
+};
+
+{
+ package ModdedNew;
+ use Mouse;
+
+ before 'new' => sub { };
+}
+
+{
+ package Foo;
+ use Mouse;
+
+ extends 'ModdedNew';
+
+ ::stderr_like(
+ sub { Foo->meta->make_immutable },
+ qr/\QNot inlining 'new' for Foo since it has method modifiers which would be lost if it were inlined/,
+ 'got a warning that Foo may not have an inlined constructor'
+ );
+}
+
+done_testing;
projects / gitmo/Mouse.git / commitdiff