for my $klass (qw/Moose Mouse/) {
eval qq{
package ${klass}One;
- use $klass;\r
+ use $klass;
use ${klass}::Util::TypeConstraints;
-\r
+
subtype 'NaturalNumber', as 'Int', where { \$_ > 0 };
coerce 'NaturalNumber',
from 'Str', via { 42 },
- ;\r
-\r
+ ;
+
has n => (
is => 'rw',
isa => 'NaturalNumber',
for my $klass (qw/Moose Mouse/) {
eval qq{
package ${klass}One;
- use $klass;\r
+ use $klass;
use ${klass}::Util::TypeConstraints;
-\r
- subtype 'NaturalNumber', as 'Int', where { \$_ > 0 };\r
-\r
+
+ subtype 'NaturalNumber', as 'Int', where { \$_ > 0 };
+
has n => (
is => 'rw',
isa => 'NaturalNumber',
sub helper_type { 'Num' }
- has 'method_constructors' => (\r
- is => 'ro',\r
- isa => 'HashRef',\r
- lazy => 1,\r
- default => sub {\r
- return +{\r
- set => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $_[1] ) };\r
+ has 'method_constructors' => (
+ is => 'ro',
+ isa => 'HashRef',
+ lazy => 1,
+ default => sub {
+ return +{
+ set => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $_[1] ) };
+ },
+ get => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $reader->( $_[0] ) };
+ },
+ add => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) + $_[1] ) };
},
- get => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $reader->( $_[0] ) };\r
+ sub => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) - $_[1] ) };
},
- add => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) + $_[1] ) };\r
- },\r
- sub => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) - $_[1] ) };\r
- },\r
- mul => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) * $_[1] ) };\r
- },\r
- div => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) / $_[1] ) };\r
- },\r
- mod => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) % $_[1] ) };\r
- },\r
- abs => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], abs( $reader->( $_[0] ) ) ) };\r
- },\r
- };\r
- }\r
- );\r
-\r
+ mul => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) * $_[1] ) };
+ },
+ div => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) / $_[1] ) };
+ },
+ mod => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) % $_[1] ) };
+ },
+ abs => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], abs( $reader->( $_[0] ) ) ) };
+ },
+ };
+ }
+ );
+
package MouseX::AttributeHelpers::Number;
use Mouse;
-#!perl\r
-use strict;\r
-use warnings;\r
-use Test::More tests => 14;\r
-\r
-use Mouse ();\r
-\r
-BEGIN{\r
- package MyMouse;\r
- use Mouse;\r
- Mouse::Exporter->setup_import_methods(\r
- as_is => [qw(foo)],\r
- also => [qw(Mouse)],\r
- );\r
-\r
- sub foo{ 100 }\r
-\r
- $INC{'MyMouse.pm'}++;\r
-\r
- package MyMouseEx;\r
- use Mouse;\r
- Mouse::Exporter->setup_import_methods(\r
- as_is => [\&bar],\r
- also => [qw(MyMouse)],\r
-\r
-# groups => {\r
-# foobar_only => [qw(foo bar)],\r
-# },\r
- );\r
-\r
- sub bar{ 200 }\r
-\r
- $INC{'MyMouseEx.pm'}++;\r
-}\r
-\r
-can_ok 'MyMouse', qw(import unimport);\r
-can_ok 'MyMouseEx', qw(import unimport);\r
-\r
-{\r
- package MyApp;\r
- use Test::More;\r
- use MyMouse;\r
-\r
- can_ok __PACKAGE__, 'meta';\r
- ok defined(&foo), 'foo is imported';\r
- ok defined(&has), 'has is also imported';\r
-\r
- no MyMouse;\r
-\r
- ok !defined(&foo), 'foo is unimported';\r
- ok !defined(&has), 'has is also unimported';\r
-}\r
-{\r
- package MyAppEx;\r
- use Test::More;\r
- use MyMouseEx;\r
-\r
- can_ok __PACKAGE__, 'meta';\r
- ok defined(&foo), 'foo is imported';\r
- ok defined(&bar), 'foo is also imported';\r
- ok defined(&has), 'has is also imported';\r
-\r
- no MyMouseEx;\r
-\r
- ok !defined(&foo), 'foo is unimported';\r
- ok !defined(&bar), 'foo is also unimported';\r
- ok !defined(&has), 'has is also unimported';\r
-}\r
-\r
-# exporting groups are not implemented in Moose::Exporter\r
-#{\r
-# package MyAppExTags;\r
-# use Test::More;\r
-# use MyMouseEx qw(:foobar_only);\r
-#\r
-# can_ok __PACKAGE__, 'meta';\r
-# ok defined(&foo);\r
-# ok defined(&bar);\r
-# ok!defined(&has), "export tags";\r
-#}\r
-\r
+#!perl
+use strict;
+use warnings;
+use Test::More tests => 14;
+
+use Mouse ();
+
+BEGIN{
+ package MyMouse;
+ use Mouse;
+ Mouse::Exporter->setup_import_methods(
+ as_is => [qw(foo)],
+ also => [qw(Mouse)],
+ );
+
+ sub foo{ 100 }
+
+ $INC{'MyMouse.pm'}++;
+
+ package MyMouseEx;
+ use Mouse;
+ Mouse::Exporter->setup_import_methods(
+ as_is => [\&bar],
+ also => [qw(MyMouse)],
+
+# groups => {
+# foobar_only => [qw(foo bar)],
+# },
+ );
+
+ sub bar{ 200 }
+
+ $INC{'MyMouseEx.pm'}++;
+}
+
+can_ok 'MyMouse', qw(import unimport);
+can_ok 'MyMouseEx', qw(import unimport);
+
+{
+ package MyApp;
+ use Test::More;
+ use MyMouse;
+
+ can_ok __PACKAGE__, 'meta';
+ ok defined(&foo), 'foo is imported';
+ ok defined(&has), 'has is also imported';
+
+ no MyMouse;
+
+ ok !defined(&foo), 'foo is unimported';
+ ok !defined(&has), 'has is also unimported';
+}
+{
+ package MyAppEx;
+ use Test::More;
+ use MyMouseEx;
+
+ can_ok __PACKAGE__, 'meta';
+ ok defined(&foo), 'foo is imported';
+ ok defined(&bar), 'foo is also imported';
+ ok defined(&has), 'has is also imported';
+
+ no MyMouseEx;
+
+ ok !defined(&foo), 'foo is unimported';
+ ok !defined(&bar), 'foo is also unimported';
+ ok !defined(&has), 'has is also unimported';
+}
+
+# exporting groups are not implemented in Moose::Exporter
+#{
+# package MyAppExTags;
+# use Test::More;
+# use MyMouseEx qw(:foobar_only);
+#
+# can_ok __PACKAGE__, 'meta';
+# ok defined(&foo);
+# ok defined(&bar);
+# ok!defined(&has), "export tags";
+#}
+
-#!perl\r
-use strict;\r
-use warnings;\r
-use Test::More tests => 2;\r
-use Test::Exception;\r
-{\r
- package RoleA;\r
- use Mouse::Role;\r
-\r
- sub foo { }\r
- sub bar { }\r
-}\r
-{\r
- package RoleB;\r
- use Mouse::Role;\r
-\r
- sub foo { }\r
- sub bar { }\r
-}\r
-{\r
- package Class;\r
- use Mouse;\r
- use Test::More;\r
- use Test::Exception;\r
-\r
- throws_ok {\r
- with qw(RoleA RoleB);\r
- } qr/Due to method name conflicts in roles 'RoleA' and 'RoleB', the methods 'bar' and 'foo' must be/;\r
-\r
- lives_ok {\r
- with RoleA => { -excludes => ['foo'] },\r
- RoleB => { -excludes => ['bar'] },\r
- ;\r
- };\r
-}\r
+#!perl
+use strict;
+use warnings;
+use Test::More tests => 2;
+use Test::Exception;
+{
+ package RoleA;
+ use Mouse::Role;
+
+ sub foo { }
+ sub bar { }
+}
+{
+ package RoleB;
+ use Mouse::Role;
+
+ sub foo { }
+ sub bar { }
+}
+{
+ package Class;
+ use Mouse;
+ use Test::More;
+ use Test::Exception;
+
+ throws_ok {
+ with qw(RoleA RoleB);
+ } qr/Due to method name conflicts in roles 'RoleA' and 'RoleB', the methods 'bar' and 'foo' must be/;
+
+ lives_ok {
+ with RoleA => { -excludes => ['foo'] },
+ RoleB => { -excludes => ['bar'] },
+ ;
+ };
+}
-#!/usr/bin/perl\r
-\r
-use strict;\r
-use warnings;\r
-\r
-\r
-{\r
- package Foo;\r
- use Mouse;\r
-\r
- sub DEMOLISH {\r
- my $self = shift;\r
- my ($igd) = @_;\r
-\r
- print $igd;\r
- }\r
-}\r
-\r
-{\r
- package Bar;\r
- use Mouse;\r
-\r
- sub DEMOLISH {\r
- my $self = shift;\r
- my ($igd) = @_;\r
-\r
- print $igd;\r
- }\r
-\r
- __PACKAGE__->meta->make_immutable;\r
-}\r
-\r
-our $foo = Foo->new;\r
-our $bar = Bar->new;\r
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+
+{
+ package Foo;
+ use Mouse;
+
+ sub DEMOLISH {
+ my $self = shift;
+ my ($igd) = @_;
+
+ print $igd;
+ }
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ sub DEMOLISH {
+ my $self = shift;
+ my ($igd) = @_;
+
+ print $igd;
+ }
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+our $foo = Foo->new;
+our $bar = Bar->new;
-#!/usr/bin/perl\r
-\r
-use strict;\r
-use warnings;\r
-\r
-use Test::More tests => 19;\r
-use Test::Exception;\r
-\r
-BEGIN {\r
- use_ok("Mouse::Util::TypeConstraints");\r
-}\r
-\r
-lives_ok {\r
- subtype 'MyCollections' => as 'ArrayRef | HashRef';\r
-} '... created the subtype special okay';\r
-\r
-{\r
- my $t = find_type_constraint('MyCollections');\r
- isa_ok($t, 'Mouse::Meta::TypeConstraint');\r
-\r
- is($t->name, 'MyCollections', '... name is correct');\r
-\r
- my $p = $t->parent;\r
-# isa_ok($p, 'Mouse::Meta::TypeConstraint::Union');\r
- isa_ok($p, 'Mouse::Meta::TypeConstraint');\r
-\r
- is($p->name, 'ArrayRef|HashRef', '... parent name is correct');\r
-\r
- ok($t->check([]), '... validated it correctly');\r
- ok($t->check({}), '... validated it correctly');\r
- ok(!$t->check(1), '... validated it correctly');\r
-}\r
-\r
-lives_ok {\r
- subtype 'MyCollectionsExtended'\r
- => as 'ArrayRef|HashRef'\r
- => where {\r
- if (ref($_) eq 'ARRAY') {\r
- return if scalar(@$_) < 2;\r
- }\r
- elsif (ref($_) eq 'HASH') {\r
- return if scalar(keys(%$_)) < 2;\r
- }\r
- 1;\r
- };\r
-} '... created the subtype special okay';\r
-\r
-{\r
- my $t = find_type_constraint('MyCollectionsExtended');\r
- isa_ok($t, 'Mouse::Meta::TypeConstraint');\r
-\r
- is($t->name, 'MyCollectionsExtended', '... name is correct');\r
-\r
- my $p = $t->parent;\r
-# isa_ok($p, 'Mouse::Meta::TypeConstraint::Union');\r
- isa_ok($p, 'Mouse::Meta::TypeConstraint');\r
-\r
- is($p->name, 'ArrayRef|HashRef', '... parent name is correct');\r
-\r
- ok(!$t->check([]), '... validated it correctly');\r
- ok($t->check([1, 2]), '... validated it correctly');\r
-\r
- ok(!$t->check({}), '... validated it correctly');\r
- ok($t->check({ one => 1, two => 2 }), '... validated it correctly');\r
-\r
- ok(!$t->check(1), '... validated it correctly');\r
-}\r
-\r
-\r
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 19;
+use Test::Exception;
+
+BEGIN {
+ use_ok("Mouse::Util::TypeConstraints");
+}
+
+lives_ok {
+ subtype 'MyCollections' => as 'ArrayRef | HashRef';
+} '... created the subtype special okay';
+
+{
+ my $t = find_type_constraint('MyCollections');
+ isa_ok($t, 'Mouse::Meta::TypeConstraint');
+
+ is($t->name, 'MyCollections', '... name is correct');
+
+ my $p = $t->parent;
+# isa_ok($p, 'Mouse::Meta::TypeConstraint::Union');
+ isa_ok($p, 'Mouse::Meta::TypeConstraint');
+
+ is($p->name, 'ArrayRef|HashRef', '... parent name is correct');
+
+ ok($t->check([]), '... validated it correctly');
+ ok($t->check({}), '... validated it correctly');
+ ok(!$t->check(1), '... validated it correctly');
+}
+
+lives_ok {
+ subtype 'MyCollectionsExtended'
+ => as 'ArrayRef|HashRef'
+ => where {
+ if (ref($_) eq 'ARRAY') {
+ return if scalar(@$_) < 2;
+ }
+ elsif (ref($_) eq 'HASH') {
+ return if scalar(keys(%$_)) < 2;
+ }
+ 1;
+ };
+} '... created the subtype special okay';
+
+{
+ my $t = find_type_constraint('MyCollectionsExtended');
+ isa_ok($t, 'Mouse::Meta::TypeConstraint');
+
+ is($t->name, 'MyCollectionsExtended', '... name is correct');
+
+ my $p = $t->parent;
+# isa_ok($p, 'Mouse::Meta::TypeConstraint::Union');
+ isa_ok($p, 'Mouse::Meta::TypeConstraint');
+
+ is($p->name, 'ArrayRef|HashRef', '... parent name is correct');
+
+ ok(!$t->check([]), '... validated it correctly');
+ ok($t->check([1, 2]), '... validated it correctly');
+
+ ok(!$t->check({}), '... validated it correctly');
+ ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
+
+ ok(!$t->check(1), '... validated it correctly');
+}
+
+
--- /dev/null
+#!perl -w
+# reported by Christine Spang (RT #53286)
+package Foo;
+use Mouse;
+
+has app_handle => (
+ is => 'rw',
+ isa => 'Baz',
+ required => 1,
+);
+
+has handle => (
+ is => 'rw',
+ isa => 'Int',
+ # app_handle should not be undef here!
+ default => sub { shift->app_handle->handle() },
+);
+
+no Mouse;
+
+1;
+
+package Bar;
+use Mouse;
+
+has app_handle => (
+ is => 'rw',
+ isa => 'Baz',
+ required => 1,
+);
+
+sub do_something {
+ my $self = shift;
+ my $foo = Foo->new( app_handle => $self->app_handle );
+ return $foo->handle;
+}
+
+no Mouse;
+
+1;
+
+package Baz;
+use Mouse;
+
+sub handle {
+ # print "This works correctly.\n";
+ return 1;
+}
+
+no Mouse;
+
+1;
+
+package main;
+use strict;
+use warnings;
+use Test::More tests => 2;
+use Test::Exception;
+
+my $bar = Bar->new( app_handle => Baz->new() );
+ok($bar, "Test class Bar instantiated w/attribute app_handle Baz");
+
+# Trigger the default sub of baz's handle attribute, which tries to call
+# a method on an attribute which was set to an object passed in via the
+# constructor.
+lives_and { is($bar->do_something(), 1, "attribute was passed in okay") };
sv_rvweaken(HeVAL(he));
}
}
-\r
+
MODULE = Mouse::Meta::Method::Accessor::XS PACKAGE = Mouse::Meta::Method::Accessor::XS
PROTOTYPES: DISABLE
projects / gitmo/Mouse.git / commitdiff