# auto-generated shipit config file.
-steps = FindVersion, ChangeVersion, CheckVersionsMatch, CheckChangeLog, DistTest, Commit, Tag, MakeDist
+steps = FindVersion, ChangeAllVersions, CheckVersionsMatch, CheckChangeLog, DistTest, Commit, Tag, MakeDist
git.tagpattern = %v
git.push_to = origin
Revision history for Mouse
+0.37_06 Mon Oct 12 16:34:18 2009
+ * Mouse::Meta::Attribute
+ - Support handles => qr/pattern/ in has() (gfx)
+
+ * Mouse::Meta::Method::Destructor
+ - Locallize $@ and $? in DESTROY as Moose does (gfx)
+
+ * Mouse::Meta::Role
+ - Fix role application to instances (gfx)
+
+ * Tests
+ - Move t/*.t to t/001_moose/
+
+0.37_05 Fri Oct 9 15:21:43 2009
+ * Mouse::Exporter
+ - Add build_import_methods() (gfx)
+
+ * Mouse::Spec
+ - Add notes about Moose::Cookbook (gfx)
+
+ * Fix some minor bugs (gfx)
+
+0.37_04 Thu Oct 8 20:49:11 2009
+ * Mouse::Meta::Role::Composite
+ - Fix and improve role composition mechanism (gfx)
+
+ * Import a number of tests from Moose, and fix various bugs (gfx)
+
+ * Mouse::Tiny is always generated in Makefile.PL (gfx)
+
+0.37_03 Wed Oct 7 21:10:05 2009
+ * Mouse::Exporter
+ - Add Mouse::Exporter (gfx)
+ * Mouse::Meta::Method::Constructor
+ - Optimize generated constructors (gfx)
+ * Mouse::Meta::Role
+ - Implement role application to instances (gfx)
+
+0.37_02 Sun Oct 4 17:29:15 2009
+ * Mouse
+ - Implement the argument/inner keywords
+ * Mouse::Meta::Attribute
+ - Add get_read_method_ref() and get_write_method_ref() (gfx)
+ - Add find_attribute_by_name() (gfx)
+ - Fix clone_and_inherit_options() to deal with 'traits' (gfx)
+ * Mouse::Util
+ - Fix meta() method, which was not tested (gfx)
+ * Tests
+ - Port t/010_basics/*.t from Moose
+
+0.37_01 Thu Oct 1 15:32:58 2009
+ * Type coercions are stored to type constraints (gfx)
+
+ * Refactor the type parser to parse 'ArrayRef[Object|Int]' (gfx)
+
+ * Remove Class::MOP specific subroutines from Mouse::Meta::Module (gfx)
+ (this change might be reverted in the release version)
+ - version, authority, identifier,
+ get_all_metaclasses, store_metaclass_by_name,
+ weaken_metaclass, does_metaclass_exist, remove_metaclass_by_name
+
+ * Add new public utilities to Mouse::Util (gfx)
+ - class_of, the counterpart for Class::MOP::class_of
+ - get_metaclass_by_name for Class::MOP::get_metaclass_by_name
+
+
0.37 Mon Sep 28 10:48:27 2009
* Ensure backward compatibility by author/test-externa.pl (gfx)
author/benchmarks
author/externals
+
+lib/Mouse/Tiny\.pm$
+
+# Mouse distributions
+Mouse-
use warnings;
use inc::Module::Install;
+system($^X, 'author/generate-mouse-tiny.pl', 'lib/Mouse/Tiny.pm') == 0
+ or warn "Cannot generate Mouse::Tiny: $!";
+
name 'Mouse';
all_from 'lib/Mouse.pm';
} else {
print "you don't have Moose $require_version. skipping moose compatibility test\n";
}
- system("author/generate-mouse-tiny.pl");
}
WriteAll check_nmake => 0;
# some test does not pass... currently skip it.
my %SKIP_TEST = (
'016-trigger.t' => "trigger's argument is incompatble :(",
- '010-isa-or.t' => 'Mouse has a [BUG]',
+ '010-isa-or.t' => "Mouse has a [BUG]",
+
+ '052-undefined-type-in-union.t' => "Mouse accepts undefined type as a member of union types",
+ '054-anon-leak.t' => 'Moose has memory leaks',
'600-tiny-tiny.t' => "Moose doesn't support ::Tiny",
'601-tiny-mouse.t' => "Moose doesn't support ::Tiny",
return if /failing/; # skip tests in failing/ directories which are Moose specific
- return if /100_with_moose/; # tests with Moose
+ return if /with_moose/; # tests with Moose
+ return if /100_bugs/; # some tests require Mouse specific files
return if /deprecated/;
my $basename = File::Basename::basename($_);
+++ /dev/null
-TODO:
-
-Mouse
-
-* smart exporters
-
-MouseX
-
-* MouseX::Role::Parameterized
-
use strict;
use warnings;
use File::Find;
-use File::Slurp 'slurp';
-use List::MoreUtils 'uniq';
-use autodie;
+use Fatal qw(open close);
+#use File::Slurp 'slurp';
+#use List::MoreUtils 'uniq';
+#use autodie;
-unlink 'lib/Mouse/Tiny.pm'
- if -e 'lib/Mouse/Tiny.pm';
+print "Generate Mouse::Tiny ...\n";
+
+sub slurp {
+ open my $in, '<', $_[0];
+ local $/;
+ return scalar <$in>;
+}
+sub uniq{
+ my %seen;
+ return grep{ !$seen{$_}++ } @_;
+}
+
+require 'lib/Mouse/Spec.pm';
+
+my $MouseTinyFile = shift || 'lib/Mouse/Tiny.pm';
my @files;
wanted => sub {
push @files, $_
if -f $_
+ && /\.pm$/
&& !/Squirrel/
- && !/TypeRegistory/
- && !/\bouse/
- && !/\.sw[po]$/
+ && !/Tiny/
+ && !/Spec/ # has no functionality
+ && !/TypeRegistry/ # deprecated
+ && !/\bouse/ # ouse.pm
},
no_chdir => 1,
}, 'lib');
my $mouse_tiny = '';
-for my $file (uniq 'lib/Mouse/Util.pm', sort @files) {
+for my $file (uniq
+ 'lib/Mouse/Exporter.pm',
+ 'lib/Mouse/Util.pm',
+ 'lib/Mouse/Meta/TypeConstraint.pm',
+ 'lib/Mouse/Util/TypeConstraints.pm',
+ sort @files) {
+
my $contents = slurp $file;
$contents =~ s/__END__\b.*//s; # remove documentation
$contents =~ s/1;\n*$//; # remove success indicator
- $contents =~ s/^use Mouse\S*\s*\n//mg; # we're already loading everything
- $contents =~ s/^use (Mouse\S*)\s*(.+);/BEGIN { $1->import($2) }/mg;
-
+ $mouse_tiny .= "BEGIN{ # #file\n";
$mouse_tiny .= $contents;
+ $mouse_tiny .= "}\n";
}
-open my $handle, '>lib/Mouse/Tiny.pm' or die "Can't write lib/Mouse/Tiny.pm: $!";
+open my $handle, ">$MouseTinyFile";
-print { $handle } << 'EOF';
-# THIS FILE IS AUTOGENERATED!
+print { $handle } << "EOF";
+# This file was generated by $0 from Mouse $Mouse::Spec::VERSION.
+#
+# ANY CHANGES MADE HERE WILL BE LOST!
+EOF
+
+print { $handle } << 'EOF';
# if regular Mouse is loaded, bail out
unless ($INC{'Mouse.pm'}) {
-eval <<'END_OF_TINY';
-
-# tell Perl we already have all of the Mouse files loaded:
EOF
for my $file (@files) {
(my $inc = $file) =~ s{^lib/}{};
- print { $handle } "\$INC{'$inc'} = __FILE__;\n";
+ printf { $handle } "%-45s = __FILE__;\n", "\$INC{'$inc'}";
}
+print { $handle } << 'EOF';
+eval sprintf("#line %d %s\n", __LINE__, __FILE__) . <<'END_OF_TINY';
+
+# tell Perl we already have all of the Mouse files loaded:
+EOF
+
print { $handle } "\n# and now their contents\n\n";
print { $handle } $mouse_tiny;
-print { $handle } "END_OF_TINY\n} #unless\n\n";
+print { $handle } << 'EOF';
+END_OF_TINY
+ die $@ if $@;
+} # unless Mouse.pm is loaded
+EOF
print { $handle } << 'EOF';
package Mouse::Tiny;
-use base 'Mouse';
+Mouse::Exporter->setup_import_methods(also => 'Mouse');
+
+1;
EOF
-print { $handle } "1;\n\n";
+close $handle;
+print "done.\n";
'Data-Localize' => q{git://github.com/lestrrat/Data-Localize.git},
- 'AnyEvent-ReverseHTTP'
- => q{git://github.com/miyagawa/AnyEvent-ReverseHTTP.git},
+ 'MouseX-AttributeHelpers'
+ => q{git://github.com/masaki/mousex-attributehelpers.git},
'HTML-Shakan' => q{git://github.com/tokuhirom/html-shakan.git},
);
package ${klass}One;
use $klass;
has n => (
- is => 'rw',
- isa => 'Int',
+ is => 'rw',
+ isa => 'Int',
+ );
+ has m => (
+ is => 'rw',
+ isa => 'Int',
+ default => 42,
);
no $klass;
__PACKAGE__->meta->make_immutable;
--- /dev/null
+#!perl
+use strict;
+use warnings;
+use Benchmark qw/cmpthese/;
+
+
+for my $klass (qw/Moose Mouse/) {
+ eval qq{
+ package ${klass}One;
+ use $klass;\r
+ 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',
+ coerce => 1,
+ );
+ no $klass;
+ __PACKAGE__->meta->make_immutable;
+ };
+ die $@ if $@;
+}
+
+print "Class::MOP: $Class::MOP::VERSION\n";
+print "Moose: $Moose::VERSION\n";
+print "Mouse: $Mouse::VERSION\n";
+print "---- new\n";
+cmpthese(
+ -1 => {
+ map { my $x = $_; $_ => sub { $x->new(n => 'foo') } }
+ map { "${_}One" }
+ qw/Moose Mouse/
+ }
+);
+
+print "---- new,set\n";
+cmpthese(
+ -1 => {
+ map { my $y = $_; $_ => sub { $y->new(n => 'foo')->n('bar') } }
+ map { "${_}One" }
+ qw/Moose Mouse/
+ }
+);
+
+print "---- set\n";
+my %c = map { $_ => "${_}One"->new(n => 'foo') } qw/Moose Mouse/;
+cmpthese(
+ -1 => {
+ map { my $y = $_; $_ => sub { $c{$y}->n('bar') } }
+ qw/Moose Mouse/
+ }
+);
--- /dev/null
+#!perl
+use strict;
+use warnings;
+use Benchmark qw/cmpthese/;
+
+use Class::MOP;
+use Mouse();
+
+print "Class::MOP $Class::MOP::VERSION\n";
+print "Mouse $Mouse::VERSION\n";
+
+cmpthese -1 => {
+ 'Class::MOP::load_class' => sub{
+ Class::MOP::load_class('Class::MOP::Class');
+ },
+ 'Mouse::Util::load_class' => sub{
+ Mouse::Util::load_class('Class::MOP::Class');
+ },
+};
--- /dev/null
+#!perl
+use strict;
+use warnings;
+use Benchmark qw/cmpthese/;
+
+for my $klass (qw/Moose Mouse/) {
+ eval qq{
+ package ${klass}One;
+ use $klass;\r
+ use ${klass}::Util::TypeConstraints;
+\r
+ subtype 'NaturalNumber', as 'Int', where { \$_ > 0 };\r
+\r
+ has n => (
+ is => 'rw',
+ isa => 'NaturalNumber',
+ );
+ no $klass;
+ __PACKAGE__->meta->make_immutable;
+ };
+ die $@ if $@;
+}
+
+use Data::Dumper;
+$Data::Dumper::Deparse = 1;
+$Data::Dumper::Indent = 1;
+print Mouse::Util::TypeConstraints::find_type_constraint('NaturalNumber')->dump(3);
+print Moose::Util::TypeConstraints::find_type_constraint('NaturalNumber')->dump(3);
+
+print "Class::MOP: $Class::MOP::VERSION\n";
+print "Moose: $Moose::VERSION\n";
+print "Mouse: $Mouse::VERSION\n";
+print "---- new\n";
+cmpthese(
+ -1 => {
+ map { my $x = $_; $_ => sub { $x->new(n => 3) } }
+ map { "${_}One" }
+ qw/Moose Mouse/
+ }
+);
+
+print "---- new,set\n";
+cmpthese(
+ -1 => {
+ map { my $y = $_; $_ => sub { $y->new(n => 3)->n(5) } }
+ map { "${_}One" }
+ qw/Moose Mouse/
+ }
+);
+
+print "---- set\n";
+my %c = map { $_ => "${_}One"->new(n => 3) } qw/Moose Mouse/;
+cmpthese(
+ -1 => {
+ map { my $y = $_; $_ => sub { $c{$y}->n(5) } }
+ qw/Moose Mouse/
+ }
+);
package Mouse;
use 5.006_002;
-use strict;
-use warnings;
+use Mouse::Exporter; # enables strict and warnings
-our $VERSION = '0.37';
+our $VERSION = '0.37_06';
-use Exporter;
-
-use Carp 'confess';
-use Scalar::Util 'blessed';
+use Carp qw(confess);
+use Scalar::Util qw(blessed);
use Mouse::Util qw(load_class is_class_loaded get_code_package not_supported);
use Mouse::Object;
use Mouse::Util::TypeConstraints ();
-our @ISA = qw(Exporter);
+Mouse::Exporter->setup_import_methods(
+ as_is => [qw(
+ extends with
+ has
+ before after around
+ override super
+ augment inner
+ ),
+ \&Scalar::Util::blessed,
+ \&Carp::confess,
+ ],
+);
+# XXX: for backward compatibility
our @EXPORT = qw(
extends with
has
before after around
override super
augment inner
-
blessed confess
);
-our %is_removable = map{ $_ => undef } @EXPORT;
-delete $is_removable{blessed};
-delete $is_removable{confess};
-
sub extends { Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_) }
sub has {
my $meta = Mouse::Meta::Class->initialize(scalar caller);
my $name = shift;
+ $meta->throw_error(q{Usage: has 'name' => ( key => value, ... )})\r
+ if @_ % 2; # odd number of arguments
+
$meta->add_attribute($_ => @_) for ref($name) ? @{$name} : $name;
}
sub super {
# This check avoids a recursion loop - see
# t/100_bugs/020_super_recursion.t
- return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
- return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS);
+ return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
+ return if !defined $SUPER_BODY;
+ $SUPER_BODY->(@SUPER_ARGS);
}
sub override {
- my $meta = Mouse::Meta::Class->initialize(caller);
- my $pkg = $meta->name;
-
- my $name = shift;
- my $code = shift;
-
- my $body = $pkg->can($name)
- or confess "You cannot override '$name' because it has no super method";
+ # my($name, $method) = @_;
+ Mouse::Meta::Class->initialize(scalar caller)->add_override_method_modifier(@_);
+}
- $meta->add_method($name => sub {
- local $SUPER_PACKAGE = $pkg;
- local @SUPER_ARGS = @_;
- local $SUPER_BODY = $body;
+our %INNER_BODY;
+our %INNER_ARGS;
- $code->(@_);
- });
+sub inner {
+ my $pkg = caller();
+ if ( my $body = $INNER_BODY{$pkg} ) {
+ my $args = $INNER_ARGS{$pkg};
+ local $INNER_ARGS{$pkg};
+ local $INNER_BODY{$pkg};
+ return $body->(@{$args});
+ }
+ else {
+ return;
+ }
}
-sub inner { not_supported }
-sub augment{ not_supported }
+sub augment {
+ #my($name, $method) = @_;
+ Mouse::Meta::Class->initialize(scalar caller)->add_augment_method_modifier(@_);
+}
sub init_meta {
shift;
my $class = $args{for_class}
or confess("Cannot call init_meta without specifying a for_class");
+
my $base_class = $args{base_class} || 'Mouse::Object';
my $metaclass = $args{metaclass} || 'Mouse::Meta::Class';
- confess("The Metaclass $metaclass must be a subclass of Mouse::Meta::Class.")
- unless $metaclass->isa('Mouse::Meta::Class');
-
- # make a subtype for each Mouse class
- Mouse::Util::TypeConstraints::class_type($class)
- unless Mouse::Util::TypeConstraints::find_type_constraint($class);
-
my $meta = $metaclass->initialize($class);
$meta->add_method(meta => sub{
$meta->superclasses($base_class)
unless $meta->superclasses;
- return $meta;
-}
-
-sub import {
- my $class = shift;
-
- strict->import;
- warnings->import;
-
- my $opts = do {
- if (ref($_[0]) && ref($_[0]) eq 'HASH') {
- shift @_;
- } else {
- +{ };
- }
- };
- my $level = delete $opts->{into_level};
- $level = 0 unless defined $level;
- my $caller = caller($level);
-
- # we should never export to main
- if ($caller eq 'main') {
- warn qq{$class does not export its sugar to the 'main' package.\n};
- return;
- }
-
- $class->init_meta(
- for_class => $caller,
- );
+ # make a class type for each Mouse class
+ Mouse::Util::TypeConstraints::class_type($class)
+ unless Mouse::Util::TypeConstraints::find_type_constraint($class);
- if (@_) {
- __PACKAGE__->export_to_level( $level+1, $class, @_);
- } else {
- # shortcut for the common case of no type character
- no strict 'refs';
- for my $keyword (@EXPORT) {
- *{ $caller . '::' . $keyword } = *{__PACKAGE__ . '::' . $keyword};
- }
- }
+ return $meta;
}
-sub unimport {
- my $caller = caller;
-
- my $stash = do{
- no strict 'refs';
- \%{$caller . '::'}
- };
-
- for my $keyword (@EXPORT) {
- my $code;
- if(exists $is_removable{$keyword}
- && ($code = $caller->can($keyword))
- && get_code_package($code) eq __PACKAGE__){
-
- delete $stash->{$keyword};
- }
- }
-}
1;
-
__END__
=head1 NAME
Mouse - Moose minus the antlers
+=head1 VERSION
+
+This document describes Mouse version 0.37_06
+
=head1 SYNOPSIS
package Point;
If you really must write a Mouse extension, please contact the Moose mailing
list or #moose on IRC beforehand.
-=head2 Maintenance
-
-The original author of this module has mostly stepped down from maintaining
-Mouse. See L<http://www.nntp.perl.org/group/perl.moose/2009/04/msg653.html>.
-If you would like to help maintain this module, please get in touch with us.
-
=head1 KEYWORDS
=head2 C<< $object->meta -> Mouse::Meta::Class >>
--- /dev/null
+package Mouse::Exporter;
+use strict;
+use warnings;
+
+use Carp qw(confess);
+
+my %SPEC;
+
+use constant _strict_bits => strict::bits(qw(subs refs vars));
+
+# it must be "require", because Mouse::Util depends on Mouse::Exporter,
+# which depends on Mouse::Util::import()
+require Mouse::Util;
+
+sub import{
+ $^H |= _strict_bits; # strict->import;
+ ${^WARNING_BITS} = $warnings::Bits{all}; # warnings->import;
+ return;
+}
+
+
+sub setup_import_methods{
+ my($class, %args) = @_;
+
+ my $exporting_package = $args{exporting_package} ||= caller();
+
+ my($import, $unimport) = $class->build_import_methods(%args);
+
+ no strict 'refs';
+
+ *{$exporting_package . '::import'} = $import;
+ *{$exporting_package . '::unimport'} = $unimport;
+
+ # for backward compatibility
+ *{$exporting_package . '::export_to_level'} = sub{
+ my($package, $level, undef, @args) = @_; # the third argument is redundant
+ $package->import({ into_level => $level + 1 }, @args);
+ };
+ *{$exporting_package . '::export'} = sub{
+ my($package, $into, @args) = @_;
+ $package->import({ into => $into }, @args);
+ };
+ return;
+}
+
+sub build_import_methods{
+ my($class, %args) = @_;
+
+ my $exporting_package = $args{exporting_package} ||= caller();
+
+ $SPEC{$exporting_package} = \%args;
+
+ # canonicalize args
+ my @export_from;
+ if($args{also}){
+ my %seen;
+ my @stack = ($exporting_package);
+
+ while(my $current = shift @stack){
+ push @export_from, $current;
+
+ my $also = $SPEC{$current}{also} or next;
+ push @stack, grep{ !$seen{$_}++ } ref($also) ? @{ $also } : $also;
+ }
+ }
+ else{
+ @export_from = ($exporting_package);
+ }
+
+ {
+ my %exports;
+ my @removables;
+ my @all;
+
+ my @init_meta_methods;
+
+ foreach my $package(@export_from){
+ my $spec = $SPEC{$package} or next;
+
+ if(my $as_is = $spec->{as_is}){
+ foreach my $thingy (@{$as_is}){
+ my($code_package, $code_name, $code);
+
+ if(ref($thingy)){
+ $code = $thingy;
+ ($code_package, $code_name) = Mouse::Util::get_code_info($code);
+ }
+ else{
+ no strict 'refs';
+ $code_package = $package;
+ $code_name = $thingy;
+ $code = \&{ $code_package . '::' . $code_name };
+ }
+
+ push @all, $code_name;
+ $exports{$code_name} = $code;
+ if($code_package eq $package){
+ push @removables, $code_name;
+ }
+ }
+ }
+
+ if(my $init_meta = $package->can('init_meta')){
+ if(!grep{ $_ == $init_meta } @init_meta_methods){
+ push @init_meta_methods, $init_meta;
+ }
+ }
+ }
+ $args{EXPORTS} = \%exports;
+ $args{REMOVABLES} = \@removables;
+
+ $args{groups}{all} ||= \@all;
+
+ if(my $default_list = $args{groups}{default}){
+ my %default;
+ foreach my $keyword(@{$default_list}){
+ $default{$keyword} = $exports{$keyword}
+ || confess(qq{The $exporting_package package does not export "$keyword"});
+ }
+ $args{DEFAULT} = \%default;
+ }
+ else{
+ $args{groups}{default} ||= \@all;
+ $args{DEFAULT} = $args{EXPORTS};
+ }
+
+ if(@init_meta_methods){
+ $args{INIT_META} = \@init_meta_methods;
+ }
+ }
+
+ return (\&do_import, \&do_unimport);
+}
+
+
+# the entity of general import()
+sub do_import {
+ my($package, @args) = @_;
+
+ my $spec = $SPEC{$package}
+ || confess("The package $package package does not use Mouse::Exporter");
+
+ my $into = _get_caller_package(ref($args[0]) ? shift @args : undef);
+
+ my @exports;
+
+ foreach my $arg(@args){
+ if($arg =~ s/^-//){
+ Mouse::Util::not_supported("-$arg");
+ }
+ elsif($arg =~ s/^://){
+ my $group = $spec->{groups}{$arg}
+ || confess(qq{The $package package does not export the group "$arg"});
+ push @exports, @{$group};
+ }
+ else{
+ push @exports, $arg;
+ }
+ }
+
+ $^H |= _strict_bits; # strict->import;
+ ${^WARNING_BITS} = $warnings::Bits{all}; # warnings->import;
+
+ if($into eq 'main' && !$spec->{_export_to_main}){
+ warn qq{$package does not export its sugar to the 'main' package.\n};
+ return;
+ }
+
+ if($spec->{INIT_META}){
+ foreach my $init_meta(@{$spec->{INIT_META}}){
+ $into->$init_meta(for_class => $into);
+ }
+
+ # _apply_meta_traits($into); # TODO
+ }
+
+ if(@exports){
+ foreach my $keyword(@exports){
+ no strict 'refs';
+ *{$into.'::'.$keyword} = $spec->{EXPORTS}{$keyword}
+ || confess(qq{The $package package does not export "$keyword"});
+ }
+ }
+ else{
+ my $default = $spec->{DEFAULT};
+ while(my($keyword, $code) = each %{$default}){
+ no strict 'refs';
+ *{$into.'::'.$keyword} = $code;
+ }
+ }
+ return;
+}
+
+# the entity of general unimport()
+sub do_unimport {
+ my($package, $arg) = @_;
+
+ my $spec = $SPEC{$package}
+ || confess("The package $package does not use Mouse::Exporter");
+
+ my $from = _get_caller_package($arg);
+
+ my $stash = do{
+ no strict 'refs';
+ \%{$from . '::'}
+ };
+
+ for my $keyword (@{ $spec->{REMOVABLES} }) {
+ my $gv = \$stash->{$keyword};
+ if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us
+ delete $stash->{$keyword};
+ }
+ }
+ return;
+}
+
+# 1 extra level because it's called by import so there's a layer\r
+# of indirection\r
+sub _LEVEL(){ 1 }
+
+sub _get_caller_package {
+ my($arg) = @_;
+
+ if(ref $arg){
+ return defined($arg->{into}) ? $arg->{into}
+ : defined($arg->{into_level}) ? scalar caller(_LEVEL + $arg->{into_level})
+ : scalar caller(_LEVEL);
+ }
+ else{
+ return scalar caller(_LEVEL);
+ }
+}
+
+#sub _spec{ %SPEC }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Mouse::Exporter - make an import() and unimport() just like Mouse.pm
+
+=head1 SYNOPSIS
+
+ package MyApp::Mouse;\r
+\r
+ use Mouse ();\r
+ use Mouse::Exporter;\r
+\r
+ Mouse::Exporter->setup_import_methods(\r
+ as_is => [ 'has_rw', 'other_sugar', \&Some::Random::thing ],\r
+ also => 'Mouse',\r
+ );\r
+\r
+ sub has_rw {
+ my $meta = caller->meta;\r
+ my ( $name, %options ) = @_;\r
+ $meta->add_attribute(\r
+ $name,\r
+ is => 'rw',\r
+ %options,\r
+ );\r
+ }\r
+\r
+ # then later ...\r
+ package MyApp::User;\r
+
+ use MyApp::Mouse;\r
+\r
+ has 'name';\r
+ has_rw 'size';\r
+ thing;\r
+\r
+ no MyApp::Mouse;
+
+=head1 DESCRIPTION
+
+This module encapsulates the exporting of sugar functions in a\r
+C<Mouse.pm>-like manner. It does this by building custom C<import>,\r
+C<unimport> methods for your module, based on a spec you provide.\r
+
+Note that C<Mouse::Exporter> does not provide the C<with_meta> option,
+but you can easily get the metaclass by C<< caller->meta >> as L</SYNOPSIS> shows.
+
+=head1 METHODS
+
+=head2 C<< setup_import_methods( ARGS ) >>
+
+=head2 C<< build_import_methods( ARGS ) -> (\&import, \&unimport) >>
+
+=head1 SEE ALSO
+
+L<Moose::Exporter>
+
+=cut
+
package Mouse::Meta::Attribute;
-use strict;
-use warnings;
+use Mouse::Util qw(:meta); # enables strict and warnings
use Carp ();
-use Mouse::Util qw(:meta);
-
use Mouse::Meta::TypeConstraint;
use Mouse::Meta::Method::Accessor;
+
sub _process_options{
my($class, $name, $args) = @_;
$args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($args->{isa});
}
elsif(exists $args->{does}){
- # TODO
- # $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
+ $args->{type_constraint} = Mouse::Util::TypeConstraints::find_or_create_does_type_constraint($args->{does});
}
$tc = $args->{type_constraint};
$args{name} = $name;
- my $instance = bless \%args, $class;
+ my $self = bless \%args, $class;
# extra attributes
if($class ne __PACKAGE__){
- $class->meta->_initialize_instance($instance,\%args);
+ $class->meta->_initialize_object($self, \%args);
}
# XXX: there is no fast way to check attribute validity
# Carp::cluck("Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad");
# }
- return $instance
+ return $self;
}
# readers
sub should_auto_deref { $_[0]->{auto_deref} }
sub should_coerce { $_[0]->{coerce} }
-sub get_read_method { $_[0]->{reader} || $_[0]->{accessor} }
-sub get_write_method { $_[0]->{writer} || $_[0]->{accessor} }
-
# predicates
sub has_accessor { exists $_[0]->{accessor} }
sub has_read_method { exists $_[0]->{reader} || exists $_[0]->{accessor} }
sub has_write_method { exists $_[0]->{writer} || exists $_[0]->{accessor} }
-sub _create_args {
+sub _create_args { # DEPRECATED
$_[0]->{_create_args} = $_[1] if @_ > 1;
$_[0]->{_create_args}
}
sub interpolate_class{
- my($class, $name, $args) = @_;
+ my($class, $args) = @_;
if(my $metaclass = delete $args->{metaclass}){
$class = Mouse::Util::resolve_metaclass_alias( Attribute => $metaclass );
return( $class, @traits );
}
-sub canonicalize_args{
+sub canonicalize_args{ # DEPRECATED
my ($self, $name, %args) = @_;
Carp::cluck("$self->canonicalize_args has been deprecated."
return %args;
}
-sub create {
+sub create { # DEPRECATED
my ($self, $class, $name, %args) = @_;
Carp::cluck("$self->create has been deprecated."
return $self;
}
+sub _coerce_and_verify {
+ my($self, $value, $instance) = @_;
+
+ my $type_constraint = $self->{type_constraint};
+ return $value if !defined $type_constraint;
+
+ if ($self->should_coerce && $type_constraint->has_coercion) {
+ $value = $type_constraint->coerce($value);
+ }
+
+ $self->verify_against_type_constraint($value);
+
+ return $value;
+}
+
sub verify_against_type_constraint {
my ($self, $value) = @_;
- my $tc = $self->type_constraint;
- return 1 unless $tc;
- local $_ = $value;
- return 1 if $tc->check($value);
+ my $type_constraint = $self->{type_constraint};
+ return 1 if !$type_constraint;
+ return 1 if $type_constraint->check($value);
- $self->verify_type_constraint_error($self->name, $value, $tc);
+ $self->verify_type_constraint_error($self->name, $value, $type_constraint);
}
sub verify_type_constraint_error {
my($self, $name, $value, $type) = @_;
- $self->throw_error("Attribute ($name) does not pass the type constraint because: " . $type->get_message($value));
+ $self->throw_error("Attribute ($name) does not pass the type constraint because: "
+ . $type->get_message($value));
}
-sub coerce_constraint { ## my($self, $value) = @_;
+sub coerce_constraint { # DEPRECATED
my $type = $_[0]->{type_constraint}
or return $_[1];
- return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $type, $_[1]);
-}
-sub _canonicalize_handles {
- my $self = shift;
- my $handles = shift;
+ Carp::cluck("coerce_constraint() has been deprecated, which was an internal utility anyway");
- if (ref($handles) eq 'HASH') {
- return %$handles;
- }
- elsif (ref($handles) eq 'ARRAY') {
- return map { $_ => $_ } @$handles;
- }
- else {
- $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
- }
+ return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $type, $_[1]);
}
sub clone_and_inherit_options{
- my $self = shift;
- my $name = shift;
+ my($self, %args) = @_;
- return ref($self)->new($name, %{$self}, (@_ == 1) ? %{$_[0]} : @_);
+ my($attribute_class, @traits) = ref($self)->interpolate_class(\%args);
+
+ $args{traits} = \@traits if @traits;
+ return $attribute_class->new($self->name, %{$self}, %args);
}
-sub clone_parent {
+sub clone_parent { # DEPRECATED
my $self = shift;
my $class = shift;
my $name = shift;
$self->clone_and_inherited_args($class, $name, %args);
}
-sub get_parent_args {
+sub get_parent_args { # DEPRECATED
my $self = shift;
my $class = shift;
my $name = shift;
$self->throw_error("Could not find an attribute by the name of '$name' to inherit from");
}
+
+sub get_read_method {
+ $_[0]->{reader} || $_[0]->{accessor}
+}
+sub get_write_method {
+ $_[0]->{writer} || $_[0]->{accessor}
+}
+
+sub get_read_method_ref{
+ my($self) = @_;
+
+ $self->{_read_method_ref} ||= do{
+ my $metaclass = $self->associated_class
+ or $self->throw_error('No asocciated class for ' . $self->name);
+
+ my $reader = $self->{reader} || $self->{accessor};
+ if($reader){
+ $metaclass->name->can($reader);
+ }
+ else{
+ $self->accessor_metaclass->_generate_reader($self, $metaclass);
+ }
+ };
+}
+
+sub get_write_method_ref{
+ my($self) = @_;
+
+ $self->{_write_method_ref} ||= do{
+ my $metaclass = $self->associated_class
+ or $self->throw_error('No asocciated class for ' . $self->name);
+
+ my $reader = $self->{writer} || $self->{accessor};
+ if($reader){
+ $metaclass->name->can($reader);
+ }
+ else{
+ $self->accessor_metaclass->_generate_writer($self, $metaclass);
+ }
+ };
+}
+
+sub _canonicalize_handles {
+ my($self, $handles) = @_;
+
+ if (ref($handles) eq 'HASH') {
+ return %$handles;
+ }
+ elsif (ref($handles) eq 'ARRAY') {
+ return map { $_ => $_ } @$handles;
+ }
+ elsif (ref($handles) eq 'Regexp') {
+ my $class_or_role = ($self->{isa} || $self->{does})
+ || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)");
+
+ my $meta = Mouse::Meta::Class->initialize("$class_or_role"); # "" for stringify
+ return map { $_ => $_ }
+ grep { $_ ne 'meta' && !Mouse::Object->can($_) && $_ =~ $handles }
+ $meta->isa('Mouse::Meta::Class') ? $meta->get_all_method_names : $meta->get_method_list;
+ }
+ else {
+ $self->throw_error("Unable to canonicalize the 'handles' option with $handles");
+ }
+}
+
+
sub associate_method{
my ($attribute, $method) = @_;
$attribute->{associated_methods}++;
return;
}
+sub accessor_metaclass(){ 'Mouse::Meta::Method::Accessor' }
+
sub install_accessors{
my($attribute) = @_;
- my $metaclass = $attribute->{associated_class};
+ my $metaclass = $attribute->{associated_class};
+ my $accessor_class = $attribute->accessor_metaclass;
- foreach my $type(qw(accessor reader writer predicate clearer handles)){
+ foreach my $type(qw(accessor reader writer predicate clearer)){
if(exists $attribute->{$type}){
- my $installer = '_install_' . $type;
+ my $generator = '_generate_' . $type;
+ my $code = $accessor_class->$generator($attribute, $metaclass);
+ $metaclass->add_method($attribute->{$type} => $code);
+ $attribute->associate_method($code);
+ }
+ }
+
+ # install delegation
+ if(exists $attribute->{handles}){
+ my %handles = $attribute->_canonicalize_handles($attribute->{handles});
+ my $reader = $attribute->get_read_method_ref;
- Mouse::Meta::Method::Accessor->$installer($attribute, $attribute->{$type}, $metaclass);
+ while(my($handle_name, $method_to_call) = each %handles){
+ my $code = $accessor_class->_generate_delegation($attribute, $metaclass,
+ $reader, $handle_name, $method_to_call);
- $attribute->{associated_methods}++;
+ $metaclass->add_method($handle_name => $code);
+ $attribute->associate_method($code);
}
}
+
if($attribute->can('create') != \&create){
# backword compatibility
$attribute->create($metaclass, $attribute->name, %{$attribute});
Creates a new attribute in the owner class, inheriting options from parent classes.
Accessors and helper methods are installed. Some error checking is done.
+=head2 C<< get_read_method_ref >>
+
+=head2 C<< get_write_method_ref >>
+
+Returns the subroutine reference of a method suitable for reading or
+writing the attribute's value in the associated class. These methods
+always return a subroutine reference, regardless of whether or not the
+attribute is read- or write-only.
+
=head1 SEE ALSO
L<Moose::Meta::Attribute>
package Mouse::Meta::Class;
-use strict;
-use warnings;
+use Mouse::Util qw/:meta get_linear_isa not_supported/; # enables strict and warnings
use Scalar::Util qw/blessed weaken/;
-use Mouse::Util qw/:meta get_linear_isa not_supported/;
-
use Mouse::Meta::Method::Constructor;
use Mouse::Meta::Method::Destructor;
use Mouse::Meta::Module;
our @ISA = qw(Mouse::Meta::Module);
-sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method()
+sub method_metaclass() { 'Mouse::Meta::Method' }
+sub attribute_metaclass() { 'Mouse::Meta::Attribute' }
+
+sub constructor_class() { 'Mouse::Meta::Method::Constructor' }
+sub destructor_class() { 'Mouse::Meta::Method::Destructor' }
sub _construct_meta {
my($class, %args) = @_;
\@{ $args{package} . '::ISA' };
};
- #return Mouse::Meta::Class->initialize($class)->new_object(%args)
- # if $class ne __PACKAGE__;
-
- return bless \%args, ref($class) || $class;
+ my $self = bless \%args, ref($class) || $class;
+ if(ref($self) ne __PACKAGE__){
+ $self->meta->_initialize_object($self, \%args);
+ }
+ return $self;
}
sub create_anon_class{
my $self = shift;
if (@_) {
- Mouse::load_class($_) for @_;
+ foreach my $super(@_){
+ Mouse::Util::load_class($super);
+ my $meta = Mouse::Util::get_metaclass_by_name($super);
+ if($meta && $meta->isa('Mouse::Meta::Role')){
+ $self->throw_error("You cannot inherit from a Mouse Role ($super)");
+ }
+ }
@{ $self->{superclasses} } = @_;
}
my($self, $method_name) = @_;
defined($method_name)
or $self->throw_error('You must define a method name to find');
+
foreach my $class( $self->linearized_isa ){
my $method = $self->initialize($class)->get_method($method_name);
return $method if defined $method;
$self->linearized_isa;
}
+sub find_attribute_by_name{
+ my($self, $name) = @_;
+ my $attr;
+ foreach my $class($self->linearized_isa){
+ my $meta = Mouse::Util::get_metaclass_by_name($class) or next;
+ $attr = $meta->get_attribute($name) and last;
+ }
+ return $attr;
+}
+
sub add_attribute {
my $self = shift;
or $self->throw_error('You must provide a name for the attribute');
if ($name =~ s/^\+//) { # inherited attributes
- my $inherited_attr;
-
- foreach my $class($self->linearized_isa){
- my $meta = Mouse::Meta::Module::get_metaclass_by_name($class) or next;
- $inherited_attr = $meta->get_attribute($name) and last;
- }
-
- defined($inherited_attr)
+ my $inherited_attr = $self->find_attribute_by_name($name)
or $self->throw_error("Could not find an attribute by the name of '$name' to inherit from in ".$self->name);
- $attr = $inherited_attr->clone_and_inherit_options($name, \%args);
+ $attr = $inherited_attr->clone_and_inherit_options(%args);
}
else{
- my($attribute_class, @traits) = Mouse::Meta::Attribute->interpolate_class($name, \%args);
+ my($attribute_class, @traits) = $self->attribute_metaclass->interpolate_class(\%args);
$args{traits} = \@traits if @traits;
- $attr = $attribute_class->new($name, \%args);
+ $attr = $attribute_class->new($name, %args);
}
}
return $attr;
}
-sub compute_all_applicable_attributes { shift->get_all_attributes(@_) }
+sub compute_all_applicable_attributes {
+ Carp::cluck('compute_all_applicable_attributes() has been deprecated')
+ if _MOUSE_VERBOSE;
+ return shift->get_all_attributes(@_)
+}
+
sub get_all_attributes {
my $self = shift;
my (@attr, %seen);
for my $class ($self->linearized_isa) {
- my $meta = $self->_metaclass_cache($class)
+ my $meta = Mouse::Util::get_metaclass_by_name($class)
or next;
- for my $name (keys %{ $meta->get_attribute_map }) {
+ for my $name ($meta->get_attribute_list) {
next if $seen{$name}++;
push @attr, $meta->get_attribute($name);
}
my $self = shift;
my %args = (@_ == 1 ? %{$_[0]} : @_);
- my $instance = bless {}, $self->name;
+ my $object = bless {}, $self->name;
- $self->_initialize_instance($instance, \%args);
- return $instance;
+ $self->_initialize_object($object, \%args);
+ return $object;
}
-sub _initialize_instance{
- my($self, $instance, $args) = @_;
+sub _initialize_object{
+ my($self, $object, $args) = @_;
my @triggers_queue;
my $key = $attribute->name;
if (defined($from) && exists($args->{$from})) {
- $args->{$from} = $attribute->coerce_constraint($args->{$from})
- if $attribute->should_coerce;
-
- $attribute->verify_against_type_constraint($args->{$from});
-
- $instance->{$key} = $args->{$from};
+ $object->{$key} = $attribute->_coerce_and_verify($args->{$from}, $object);
- weaken($instance->{$key})
- if ref($instance->{$key}) && $attribute->is_weak_ref;
+ weaken($object->{$key})
+ if ref($object->{$key}) && $attribute->is_weak_ref;
if ($attribute->has_trigger) {
- push @triggers_queue, [ $attribute->trigger, $args->{$from} ];
+ push @triggers_queue, [ $attribute->trigger, $object->{$key} ];
}
}
else {
unless ($attribute->is_lazy) {
my $default = $attribute->default;
my $builder = $attribute->builder;
- my $value = $attribute->has_builder
- ? $instance->$builder
- : ref($default) eq 'CODE'
- ? $default->($instance)
- : $default;
+ my $value = $builder ? $object->$builder()
+ : ref($default) eq 'CODE' ? $object->$default()
+ : $default;
- $value = $attribute->coerce_constraint($value)
- if $attribute->should_coerce;
- $attribute->verify_against_type_constraint($value);
+ $object->{$key} = $attribute->_coerce_and_verify($value, $object);
- $instance->{$key} = $value;
-
- weaken($instance->{$key})
- if ref($instance->{$key}) && $attribute->is_weak_ref;
+ weaken($object->{$key})
+ if ref($object->{$key}) && $attribute->is_weak_ref;
}
}
else {
foreach my $trigger_and_value(@triggers_queue){
my($trigger, $value) = @{$trigger_and_value};
- $trigger->($instance, $value);
+ $trigger->($object, $value);
}
if($self->is_anon_class){
- $instance->{__METACLASS__} = $self;
+ $object->{__METACLASS__} = $self;
}
- return $instance;
+ return $object;
}
sub clone_object {
- my $class = shift;
- my $instance = shift;
- my %params = (@_ == 1) ? %{$_[0]} : @_;
-
- (blessed($instance) && $instance->isa($class->name))
- || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($instance)");
+ my $class = shift;
+ my $object = shift;
+ my %params = (@_ == 1) ? %{$_[0]} : @_;
- my $clone = bless { %$instance }, ref $instance;
+ (blessed($object) && $object->isa($class->name))
+ || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)");
- foreach my $attr ($class->get_all_attributes()) {
- if ( defined( my $init_arg = $attr->init_arg ) ) {
- if (exists $params{$init_arg}) {
- $clone->{ $attr->name } = $params{$init_arg};
- }
- }
- }
+ my $cloned = bless { %$object }, ref $object;
+ $class->_initialize_object($cloned, \%params);
- return $clone;
+ return $cloned;
}
sub clone_instance {
my %args = (
inline_constructor => 1,
inline_destructor => 1,
+ constructor_name => 'new',
@_,
);
$self->{is_immutable}++;
if ($args{inline_constructor}) {
- $self->add_method('new' => Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self ));
+ $self->add_method($args{constructor_name} =>
+ $self->constructor_class->_generate_constructor($self, \%args));
}
if ($args{inline_destructor}) {
- $self->add_method('DESTROY' => Mouse::Meta::Method::Destructor->generate_destructor_method_inline( $self ));
+ $self->add_method(DESTROY =>
+ $self->destructor_class->_generate_destructor($self, \%args));
}
# Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
sub is_mutable { !$_[0]->{is_immutable} }
sub _install_modifier_pp{
- my( $self, $into, $type, $name, $code ) = @_;
+ my( $self, $type, $name, $code ) = @_;
+ my $into = $self->name;
my $original = $into->can($name)
or $self->throw_error("The method '$name' is not found in the inheritance hierarchy for class $into");
}
sub _install_modifier {
- my ( $self, $into, $type, $name, $code ) = @_;
+ my ( $self, $type, $name, $code ) = @_;
# load Class::Method::Modifiers first
my $no_cmm_fast = do{
else{
my $install_modifier = Class::Method::Modifiers::Fast->can('_install_modifier');
$impl = sub {
- my ( $self, $into, $type, $name, $code ) = @_;
- $install_modifier->(
- $into,
- $type,
- $name,
- $code
- );
- $self->{methods}{$name}++; # register it to the method map
+ my ( $self, $type, $name, $code ) = @_;
+ my $into = $self->name;
+ $install_modifier->($into, $type, $name, $code);
+
+ $self->add_method($name => do{
+ no strict 'refs';
+ \&{ $into . '::' . $name };
+ });
return;
};
}
*_install_modifier = $impl;
}
- $self->$impl( $into, $type, $name, $code );
+ $self->$impl( $type, $name, $code );
}
sub add_before_method_modifier {
my ( $self, $name, $code ) = @_;
- $self->_install_modifier( $self->name, 'before', $name, $code );
+ $self->_install_modifier( 'before', $name, $code );
}
sub add_around_method_modifier {
my ( $self, $name, $code ) = @_;
- $self->_install_modifier( $self->name, 'around', $name, $code );
+ $self->_install_modifier( 'around', $name, $code );
}
sub add_after_method_modifier {
my ( $self, $name, $code ) = @_;
- $self->_install_modifier( $self->name, 'after', $name, $code );
+ $self->_install_modifier( 'after', $name, $code );
}
sub add_override_method_modifier {
my ($self, $name, $code) = @_;
+ if($self->has_method($name)){
+ $self->throw_error("Cannot add an override method if a local method is already present");
+ }
+
my $package = $self->name;
- my $body = $package->can($name)
+ my $super_body = $package->can($name)
or $self->throw_error("You cannot override '$name' because it has no super method");
- $self->add_method($name => sub { $code->($package, $body, @_) });
+ $self->add_method($name => sub {
+ local $Mouse::SUPER_PACKAGE = $package;
+ local $Mouse::SUPER_BODY = $super_body;
+ local @Mouse::SUPER_ARGS = @_;
+
+ $code->(@_);
+ });
+ return;
+}
+
+sub add_augment_method_modifier {
+ my ($self, $name, $code) = @_;
+ if($self->has_method($name)){
+ $self->throw_error("Cannot add an augment method if a local method is already present");
+ }
+
+ my $super = $self->find_method_by_name($name)
+ or $self->throw_error("You cannot augment '$name' because it has no super method");
+
+ my $super_package = $super->package_name;
+ my $super_body = $super->body;
+
+ $self->add_method($name => sub{
+ local $Mouse::INNER_BODY{$super_package} = $code;
+ local $Mouse::INNER_ARGS{$super_package} = [@_];
+ $super_body->(@_);
+ });
+ return;
}
sub does_role {
|| $self->throw_error("You must supply a role name to look for");
for my $class ($self->linearized_isa) {
- my $meta = Mouse::Meta::Module::class_of($class);
- next unless $meta && $meta->can('roles');
+ my $meta = Mouse::Util::get_metaclass_by_name($class)
+ or next;
for my $role (@{ $meta->roles }) {
}
1;
-
__END__
=head1 NAME
package Mouse::Meta::Method;
-use strict;
-use warnings;
-
-use Mouse::Util qw(:meta);
+use Mouse::Util qw(:meta); # enables strict and warnings
use overload
'&{}' => 'body',
package Mouse::Meta::Method::Accessor;
-use strict;
-use warnings;
+use Mouse::Util; # enables strict and warnings
use Scalar::Util qw(blessed);
-sub _install_accessor{
- my (undef, $attribute, $method_name, $class, $type) = @_;
+sub _generate_accessor{
+ my (undef, $attribute, $class, $type) = @_;
my $name = $attribute->name;
my $default = $attribute->default;
my $trigger = $attribute->trigger;
my $is_weak = $attribute->is_weak_ref;
my $should_deref = $attribute->should_auto_deref;
- my $should_coerce = $attribute->should_coerce;
+ my $should_coerce = (defined($constraint) && $constraint->has_coercion && $attribute->should_coerce);
- my $compiled_type_constraint = $constraint ? $constraint->{_compiled_type_constraint} : undef;
+ my $compiled_type_constraint = defined($constraint) ? $constraint->_compiled_type_constraint : undef;
my $self = '$_[0]';
- my $key = sprintf q{"%s"}, quotemeta $name;
+ my $key = "q{$name}";
+ my $slot = "$self\->{$key}";
$type ||= 'accessor';
- my $accessor =
- '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
- "sub {\n";
+ my $accessor = sprintf(qq{#line 1 "%s for %s (%s)"\n}, $type, $name, __FILE__)
+ . "sub {\n";
+
if ($type eq 'accessor' || $type eq 'writer') {
if($type eq 'accessor'){
$accessor .=
- '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
'if (scalar(@_) >= 2) {' . "\n";
}
else{ # writer
$accessor .=
- '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
- 'if(@_ < 2){ Carp::confess("Not enough arguments for writer '.$method_name.'") }'.
+ 'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'.
'{' . "\n";
}
my $value = '$_[1]';
- if ($constraint) {
+ if (defined $constraint) {
if ($should_coerce) {
$accessor .=
"\n".
- '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
- 'my $val = Mouse::Util::TypeConstraints->typecast_constraints("'.$attribute->associated_class->name.'", $attribute->{type_constraint}, '.$value.');';
+ 'my $val = $constraint->coerce('.$value.');';
$value = '$val';
}
- if ($compiled_type_constraint) {
- $accessor .=
- "\n".
- '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
- 'unless ($compiled_type_constraint->('.$value.')) {
- $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint});
- }' . "\n";
- } else {
- $accessor .=
- "\n".
- '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
- 'unless ($constraint->check('.$value.')) {
- $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint});
- }' . "\n";
- }
+ $accessor .=
+ "\n".
+ '$compiled_type_constraint->('.$value.') or
+ $attribute->verify_type_constraint_error($name, '.$value.', $constraint);' . "\n";
}
# if there's nothing left to do for the attribute we can return during
# this setter
$accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref;
- $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n";
+ $accessor .= "$slot = $value;\n";
if ($is_weak) {
- $accessor .= 'Scalar::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n";
+ $accessor .= "Scalar::Util::weaken($slot) if ref $slot;\n";
}
if ($trigger) {
}
if ($attribute->is_lazy) {
- $accessor .= $self.'->{'.$key.'} = ';
-
- $accessor .= $attribute->has_builder
- ? $self.'->$builder'
- : ref($default) eq 'CODE'
- ? '$default->('.$self.')'
- : '$default';
- $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n";
+ my $value;
+
+ if (defined $builder){
+ $value = "$self->\$builder()";
+ }
+ elsif (ref($default) eq 'CODE'){
+ $value = "$self->\$default()";
+ }
+ else{
+ $value = '$default';
+ }
+
+ $accessor .= "if(!exists $slot){\n";
+ if($should_coerce){
+ $accessor .= "$slot = \$constraint->coerce($value)";
+ }
+ elsif(defined $constraint){
+ $accessor .= "my \$tmp = $value;\n";
+ #XXX: The following 'defined and' check is for backward compatibility
+ $accessor .= "defined(\$tmp) and ";
+
+ $accessor .= "\$compiled_type_constraint->(\$tmp)";
+ $accessor .= " || \$attribute->verify_type_constraint_error(\$name, \$tmp, \$constraint);\n";
+ $accessor .= "$slot = \$tmp;\n";
+ }
+ else{
+ $accessor .= "$slot = $value;\n";
+ }
+ $accessor .= "}\n";
}
if ($should_deref) {
if ($constraint->is_a_type_of('ArrayRef')) {
- $accessor .= 'if (wantarray) {
- return @{ '.$self.'->{'.$key.'} || [] };
- }';
+ $accessor .= "return \@{ $slot || [] } if wantarray;\n";
}
elsif($constraint->is_a_type_of('HashRef')){
- $accessor .= 'if (wantarray) {
- return %{ '.$self.'->{'.$key.'} || {} };
- }';
+ $accessor .= "return \%{ $slot || {} } if wantarray;\n";
}
else{
$class->throw_error("Can not auto de-reference the type constraint " . $constraint->name);
}
}
- $accessor .= 'return '.$self.'->{'.$key."};\n}";
+ $accessor .= "return $slot;\n}\n";
- #print $accessor, "\n";
- my $code = eval $accessor;
- $attribute->throw_error($@) if $@;
+ #print "# class ", $class->name, "\n", $accessor, "\n";
+ my $code;
+ my $e = do{
+ local $@;
+ $code = eval $accessor;
+ $@;
+ };
+ die $e if $e;
- $class->add_method($method_name => $code);
- return;
+ return $code;
}
-sub _install_reader{
+sub _generate_reader{
my $class = shift;
- $class->_install_accessor(@_, 'reader');
- return;
+ return $class->_generate_accessor(@_, 'reader');
}
-sub _install_writer{
+sub _generate_writer{
my $class = shift;
- $class->_install_accessor(@_, 'writer');
- return;
+ return $class->_generate_accessor(@_, 'writer');
}
-sub _install_predicate {
- my (undef, $attribute, $method_name, $class) = @_;
+sub _generate_predicate {
+ my (undef, $attribute, $class) = @_;
my $slot = $attribute->name;
-
- $class->add_method($method_name => sub{
+ return sub{
return exists $_[0]->{$slot};
- });
- return;
+ };
}
-sub _install_clearer {
- my (undef, $attribute, $method_name, $class) = @_;
+sub _generate_clearer {
+ my (undef, $attribute, $class) = @_;
my $slot = $attribute->name;
- $class->add_method($method_name => sub{
+ return sub{
delete $_[0]->{$slot};
- });
- return;
+ };
}
-sub _install_handles {
- my (undef, $attribute, $handles, $class) = @_;
-
- my $reader = $attribute->reader || $attribute->accessor
- or $class->throw_error("You must pass a reader method for '".$attribute->name."'");
-
- my %handles = $attribute->_canonicalize_handles($handles);
-
- foreach my $handle_name (keys %handles) {
- my $method_to_call = $handles{$handle_name};
-
- my $code = sub {
- my $instance = shift;
- my $proxy = $instance->$reader();
-
- my $error = !defined($proxy) ? ' is not defined'
- : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
- : undef;
- if ($error) {
- $instance->meta->throw_error(
- "Cannot delegate $handle_name to $method_to_call because "
- . "the value of "
- . $attribute->name
- . $error
- );
- }
- $proxy->$method_to_call(@_);
- };
- $class->add_method($handle_name => $code);
- }
- return;
+sub _generate_delegation{
+ my (undef, $attribute, $class, $reader, $handle_name, $method_to_call) = @_;
+
+ return sub {
+ my $instance = shift;
+ my $proxy = $instance->$reader();
+
+ my $error = !defined($proxy) ? ' is not defined'
+ : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
+ : undef;
+ if ($error) {
+ $instance->meta->throw_error(
+ "Cannot delegate $handle_name to $method_to_call because "
+ . "the value of "
+ . $attribute->name
+ . $error
+ );
+ }
+ $proxy->$method_to_call(@_);
+ };
}
1;
+__END__
package Mouse::Meta::Method::Constructor;
-use strict;
-use warnings;
+use Mouse::Util; # enables strict and warnings
-sub generate_constructor_method_inline {
- my ($class, $metaclass) = @_;
+sub _generate_constructor {
+ my ($class, $metaclass, $args) = @_;
my $associated_metaclass_name = $metaclass->name;
+
my @attrs = $metaclass->get_all_attributes;
my $buildall = $class->_generate_BUILDALL($metaclass);
my $buildargs = $class->_generate_BUILDARGS($metaclass);
my $processattrs = $class->_generate_processattrs($metaclass, \@attrs);
- my @compiled_constraints = map { $_ ? $_->{_compiled_type_constraint} : undef } map { $_->{type_constraint} } @attrs;
-
- my $code = <<"...";
- sub {
- my \$class = shift;
- return \$class->Mouse::Object::new(\@_)
- if \$class ne q{$associated_metaclass_name};
- $buildargs;
- my \$instance = bless {}, \$class;
- $processattrs;
- $buildall;
- return \$instance;
- }
+ my @checks = map { $_ && $_->_compiled_type_constraint }
+ map { $_->type_constraint } @attrs;
+
+ my $source = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"...";
+ sub \{
+ my \$class = shift;
+ return \$class->Mouse::Object::new(\@_)
+ if \$class ne q{$associated_metaclass_name};
+ # BUILDARGS
+ $buildargs;
+ my \$instance = bless {}, \$class;
+ # process attributes
+ $processattrs;
+ # BUILDALL
+ $buildall;
+ return \$instance;
+ }
...
-
- local $@;
- my $res = eval $code;
- die $@ if $@;
- $res;
+ #warn $source;
+ my $code;
+ my $e = do{
+ local $@;
+ $code = eval $source;
+ $@;
+ };
+ die $e if $e;
+ return $code;
}
sub _generate_processattrs {
my $has_triggers;
for my $index (0 .. @$attrs - 1) {
+ my $code = '';
+
my $attr = $attrs->[$index];
my $key = $attr->name;
- my $code = '';
- if (defined $attr->init_arg) {
- my $from = $attr->init_arg;
+ my $init_arg = $attr->init_arg;
+ my $type_constraint = $attr->type_constraint;
+ my $need_coercion;
- $code .= "if (exists \$args->{'$from'}) {\n";
+ my $instance_slot = "\$instance->{q{$key}}";
+ my $attr_var = "\$attrs[$index]";
+ my $constraint_var;
- if ($attr->should_coerce && $attr->type_constraint) {
- $code .= "my \$value = Mouse::Util::TypeConstraints->typecast_constraints('".$attr->associated_class->name."', \$attrs[$index]->{type_constraint}, \$args->{'$from'});\n";
- }
- else {
- $code .= "my \$value = \$args->{'$from'};\n";
- }
+ if(defined $type_constraint){
+ $constraint_var = "$attr_var\->{type_constraint}";
+ $need_coercion = ($attr->should_coerce && $type_constraint->has_coercion);
+ }
- if ($attr->has_type_constraint) {
- if ($attr->type_constraint->{_compiled_type_constraint}) {
- $code .= "unless (\$compiled_constraints[$index](\$value)) {";
- } else {
- $code .= "unless (\$attrs[$index]->{type_constraint}->check(\$value)) {";
- }
- $code .= "
- \$attrs[$index]->verify_type_constraint_error(
- q{$key}, \$value, \$attrs[$index]->type_constraint
- )
- }
- ";
- }
+ $code .= "# initialize $key\n";
+
+ my $post_process = '';
+ if(defined $type_constraint){
+ $post_process .= "\$checks[$index]->($instance_slot)";
+ $post_process .= " or $attr_var->verify_type_constraint_error(q{$key}, $instance_slot, $constraint_var);\n";
+ }
+ if($attr->is_weak_ref){
+ $post_process .= "Scalar::Util::weaken($instance_slot) if ref $instance_slot;\n";
+ }
+
+ if (defined $init_arg) {
+ my $value = "\$args->{q{$init_arg}}";
- $code .= "\$instance->{q{$key}} = \$value;\n";
+ $code .= "if (exists $value) {\n";
- if ($attr->is_weak_ref) {
- $code .= "Scalar::Util::weaken( \$instance->{q{$key}} ) if ref( \$value );\n";
+ if($need_coercion){
+ $value = "$constraint_var->coerce($value)";
}
+ $code .= "$instance_slot = $value;\n";
+ $code .= $post_process;
+
if ($attr->has_trigger) {
$has_triggers++;
- $code .= "push \@triggers, [\$attrs[$index]->{trigger}, \$value];\n";
+ $code .= "push \@triggers, [$attr_var\->{trigger}, $instance_slot];\n";
}
$code .= "\n} else {\n";
my $default = $attr->default;
my $builder = $attr->builder;
- $code .= "my \$value = ";
-
- if ($attr->should_coerce && $attr->type_constraint) {
- $code .= "Mouse::Util::TypeConstraints->typecast_constraints('".$attr->associated_class->name."', \$attrs[$index]->{type_constraint}, ";
+ my $value;
+ if (defined($builder)) {
+ $value = "\$instance->$builder()";
}
-
- if ($attr->has_builder) {
- $code .= "\$instance->$builder";
- }
- elsif (ref($default) eq 'CODE') {
- $code .= "\$attrs[$index]->{default}->(\$instance)";
- }
- elsif (!defined($default)) {
- $code .= 'undef';
- }
- elsif ($default =~ /^\-?[0-9]+(?:\.[0-9]+)$/) {
- $code .= $default;
- }
- else {
- $code .= "'$default'";
- }
-
- if ($attr->should_coerce) {
- $code .= ");\n";
+ elsif (ref($default) eq 'CODE') {
+ $value = "$attr_var\->{default}->(\$instance)";
+ }
+ elsif (defined($default)) {
+ $value = "$attr_var\->{default}";
}
else {
- $code .= ";\n";
+ $value = 'undef';
}
- if ($attr->has_type_constraint) {
- $code .= "{
- unless (\$attrs[$index]->{type_constraint}->check(\$value)) {
- \$attrs[$index]->verify_type_constraint_error(q{$key}, \$value, \$attrs[$index]->type_constraint)
- }
- }";
+ if($need_coercion){
+ $value = "$constraint_var->coerce($value)";
}
- $code .= "\$instance->{q{$key}} = \$value;\n";
-
- if ($attr->is_weak_ref) {
- $code .= "Scalar::Util::weaken( \$instance->{q{$key}} ) if ref( \$value );\n";
- }
+ $code .= "$instance_slot = $value;\n";
}
}
elsif ($attr->is_required) {
$code .= "Carp::confess('Attribute ($key) is required');";
}
- $code .= "}\n" if defined $attr->init_arg;
+ $code .= "}\n" if defined $init_arg;
push @res, $code;
}
if($metaclass->is_anon_class){
- push @res, q{$instnace->{__METACLASS__} = $metaclass;};
+ push @res, q{$instance->{__METACLASS__} = $metaclass;};
}
if($has_triggers){
}
sub _generate_BUILDARGS {
- my($self, $metaclass) = @_;
+ my(undef, $metaclass) = @_;
- if ($metaclass->name->can('BUILDARGS') && $metaclass->name->can('BUILDARGS') != \&Mouse::Object::BUILDARGS) {
+ my $class = $metaclass->name;
+ if ( $class->can('BUILDARGS') && $class->can('BUILDARGS') != \&Mouse::Object::BUILDARGS ) {
return 'my $args = $class->BUILDARGS(@_)';
}
}
sub _generate_BUILDALL {
- my ($class, $metaclass) = @_;
+ my (undef, $metaclass) = @_;
return '' unless $metaclass->name->can('BUILD');
}
1;
+__END__
package Mouse::Meta::Method::Destructor;
-use strict;
-use warnings;
-
-sub generate_destructor_method_inline {
- my ($class, $meta) = @_;
-
- my $demolishall = do {
- if ($meta->name->can('DEMOLISH')) {
- my @code = ();
- for my $class ($meta->linearized_isa) {
- no strict 'refs';
- if (*{$class . '::DEMOLISH'}{CODE}) {
- push @code, "${class}::DEMOLISH(\$self);";
- }
- }
- join "\n", @code;
- } else {
- return sub { }; # no demolish =)
+use Mouse::Util; # enables strict and warnings
+
+sub _empty_DESTROY{ }
+
+sub _generate_destructor{
+ my (undef, $metaclass) = @_;
+
+ if(!$metaclass->name->can('DEMOLISH')){
+ return \&_empty_DESTROY;
+ }
+
+ my $demolishall = '';
+ for my $class ($metaclass->linearized_isa) {
+ no strict 'refs';
+ if (*{$class . '::DEMOLISH'}{CODE}) {
+ $demolishall .= "${class}::DEMOLISH(\$self);\n";
}
- };
+ }
- my $code = <<"...";
+ my $source = sprintf("#line %d %s\n", __LINE__, __FILE__) . <<"...";
sub {
my \$self = shift;
- $demolishall;
+ local \$?;
+
+ my \$e = do{
+ local \$@;
+ eval{
+ $demolishall;
+ };
+ \$@;
+ };
+ no warnings 'misc';
+ die \$e if \$e; # rethrow
}
...
- local $@;
- my $res = eval $code;
- die $@ if $@;
- return $res;
+ my $code;
+ my $e = do{
+ local $@;
+ $code = eval $source;
+ $@;
+ };
+ die $e if $e;
+ return $code;
}
1;
+__END__
package Mouse::Meta::Module;
-use strict;
-use warnings;
+use Mouse::Util qw/:meta get_code_package load_class not_supported/; # enables strict and warnings
use Carp ();
use Scalar::Util qw/blessed weaken/;
-use Mouse::Util qw/:meta get_code_package not_supported load_class/;
+my %METAS;
-{
- my %METACLASS_CACHE;
-
- # because Mouse doesn't introspect existing classes, we're forced to
- # only pay attention to other Mouse classes
- sub _metaclass_cache {
- my($class, $name) = @_;
- return $METACLASS_CACHE{$name};
- }
+sub _metaclass_cache { # DEPRECATED
+ my($class, $name) = @_;
+ return $METAS{$name};
+}
- sub initialize {
- my($class, $package_name, @args) = @_;
+sub initialize {
+ my($class, $package_name, @args) = @_;
- ($package_name && !ref($package_name))
- || $class->throw_error("You must pass a package name and it cannot be blessed");
+ ($package_name && !ref($package_name))
+ || $class->throw_error("You must pass a package name and it cannot be blessed");
- return $METACLASS_CACHE{$package_name}
- ||= $class->_construct_meta(package => $package_name, @args);
- }
+ return $METAS{$package_name}
+ ||= $class->_construct_meta(package => $package_name, @args);
+}
- sub class_of{
- my($class_or_instance) = @_;
- return undef unless defined $class_or_instance;
- return $METACLASS_CACHE{ blessed($class_or_instance) || $class_or_instance };
- }
+sub class_of{
+ my($class_or_instance) = @_;
+ return undef unless defined $class_or_instance;
+ return $METAS{ ref($class_or_instance) || $class_or_instance };
+}
- # Means of accessing all the metaclasses that have
- # been initialized thus far
- sub get_all_metaclasses { %METACLASS_CACHE }
- sub get_all_metaclass_instances { values %METACLASS_CACHE }
- sub get_all_metaclass_names { keys %METACLASS_CACHE }
- sub get_metaclass_by_name { $METACLASS_CACHE{$_[0]} }
- sub store_metaclass_by_name { $METACLASS_CACHE{$_[0]} = $_[1] }
- sub weaken_metaclass { weaken($METACLASS_CACHE{$_[0]}) }
- sub does_metaclass_exist { defined $METACLASS_CACHE{$_[0]} }
- sub remove_metaclass_by_name { delete $METACLASS_CACHE{$_[0]} }
+# Means of accessing all the metaclasses that have
+# been initialized thus far
+#sub get_all_metaclasses { %METAS }
+sub get_all_metaclass_instances { values %METAS }
+sub get_all_metaclass_names { keys %METAS }
+sub get_metaclass_by_name { $METAS{$_[0]} }
+#sub store_metaclass_by_name { $METAS{$_[0]} = $_[1] }
+#sub weaken_metaclass { weaken($METAS{$_[0]}) }
+#sub does_metaclass_exist { defined $METAS{$_[0]} }
+#sub remove_metaclass_by_name { delete $METAS{$_[0]} }
-}
-sub _new{ Carp::croak("Mouse::Meta::Module is an abstract class") }
sub name { $_[0]->{package} }
-sub version { no strict 'refs'; ${shift->name.'::VERSION'} }
-sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
-sub identifier {
- my $self = shift;
- return join '-' => (
- $self->name,
- ($self->version || ()),
- ($self->authority || ()),
- );
-}
+# The followings are Class::MOP specific methods
+
+#sub version { no strict 'refs'; ${shift->name.'::VERSION'} }
+#sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
+#sub identifier {
+# my $self = shift;
+# return join '-' => (
+# $self->name,
+# ($self->version || ()),
+# ($self->authority || ()),
+# );
+#}
# add_attribute is an abstract method
-sub get_attribute_map { $_[0]->{attributes} }
+sub get_attribute_map { # DEPRECATED
+ Carp::cluck('get_attribute_map() has been deprecated');
+ return $_[0]->{attributes};
+}
+
sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
sub get_attribute { $_[0]->{attributes}->{$_[1]} }
sub get_attribute_list{ keys %{$_[0]->{attributes}} }
}
if(ref($code) ne 'CODE'){
- not_supported 'add_method for a method object';
+ $code = \&{$code}; # coerce
}
- $self->{methods}->{$name}++; # Moose stores meta object here.
+ $self->{methods}->{$name} = $code; # Moose stores meta object here.
my $pkg = $self->name;
no strict 'refs';
sub has_method {
my($self, $method_name) = @_;
- return 1 if $self->{methods}->{$method_name};
+ defined($method_name)
+ or $self->throw_error('You must define a method name');
- my $code = do{ no strict 'refs'; *{$self->{package} . '::' . $method_name}{CODE} };
+ return 1 if $self->{methods}{$method_name};
+
+ my $code = do{
+ no strict 'refs';
+ *{ $self->{package} . '::' . $method_name }{CODE};
+ };
return $code && $self->_code_is_mine($code);
}
+sub get_method_body{
+ my($self, $method_name) = @_;
+
+ defined($method_name)
+ or $self->throw_error('You must define a method name');
+
+ return $self->{methods}{$method_name} ||= do{
+ my $code = do{ no strict 'refs'; *{$self->{package} . '::' . $method_name}{CODE} };
+
+ ($code && $self->_code_is_mine($code)) ? $code : undef;
+ };
+}
+
sub get_method{
my($self, $method_name) = @_;
{
my $ANON_SERIAL = 0;
- my $ANON_PREFIX = 'Mouse::Meta::Module::__ANON__::';
my %IMMORTALS;
sub create {
- my ($class, $package_name, %options) = @_;
-
- $class->throw_error('You must pass a package name') if @_ == 1;
+ my($self, $package_name, %options) = @_;
+ my $class = ref($self) || $self;
+ $self->throw_error('You must pass a package name') if @_ < 2;
+ my $superclasses;
if(exists $options{superclasses}){
- if($class->isa('Mouse::Meta::Class')){
- (ref $options{superclasses} eq 'ARRAY')
- || $class->throw_error("You must pass an ARRAY ref of superclasses");
- }
- else{ # role
+ if($self->isa('Mouse::Meta::Role')){
delete $options{superclasses};
}
+ else{
+ $superclasses = delete $options{superclasses};
+ (ref $superclasses eq 'ARRAY')
+ || $self->throw_error("You must pass an ARRAY ref of superclasses");
+ }
}
- my $attributes;
- if(exists $options{attributes}){
- $attributes = delete $options{attributes};
- (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
- || $class->throw_error("You must pass an ARRAY ref of attributes")
- }
-
- (ref $options{methods} eq 'HASH')
- || $class->throw_error("You must pass a HASH ref of methods")
- if exists $options{methods};
-
- (ref $options{roles} eq 'ARRAY')
- || $class->throw_error("You must pass an ARRAY ref of roles")
- if exists $options{roles};
-
-
- my @extra_options;
+ my $attributes = delete $options{attributes};
+ if(defined $attributes){
+ (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
+ || $self->throw_error("You must pass an ARRAY ref of attributes");
+ }
+ my $methods = delete $options{methods};
+ if(defined $methods){
+ (ref $methods eq 'HASH')
+ || $self->throw_error("You must pass a HASH ref of methods");
+ }
+ my $roles = delete $options{roles};
+ if(defined $roles){
+ (ref $roles eq 'ARRAY')
+ || $self->throw_error("You must pass an ARRAY ref of roles");
+ }
my $mortal;
my $cache_key;
if(!$mortal){
# something like Super::Class|Super::Class::2=Role|Role::1
$cache_key = join '=' => (
- join('|', @{$options{superclasses} || []}),
- join('|', sort @{$options{roles} || []}),
+ join('|', @{$superclasses || []}),
+ join('|', sort @{$roles || []}),
);
return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
}
- $package_name = $ANON_PREFIX . ++$ANON_SERIAL;
-
- push @extra_options, (anon_serial_id => $ANON_SERIAL);
+ $options{anon_serial_id} = ++$ANON_SERIAL;
+ $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
}
# instantiate a module
${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
}
- my %initialize_options = %options;
- delete @initialize_options{qw(
- package
- superclasses
- attributes
- methods
- roles
- )};
- my $meta = $class->initialize( $package_name, %initialize_options, @extra_options);
-
- Mouse::Meta::Module::weaken_metaclass($package_name)
+ my $meta = $self->initialize( $package_name, %options);
+
+ weaken $METAS{$package_name}
if $mortal;
- # FIXME totally lame
- $meta->add_method('meta' => sub {
- $class->initialize(ref($_[0]) || $_[0]);
+ $meta->add_method(meta => sub{
+ $self->initialize(ref($_[0]) || $_[0]);
});
- $meta->superclasses(@{$options{superclasses}})
- if exists $options{superclasses};
+ $meta->superclasses(@{$superclasses})
+ if defined $superclasses;
# NOTE:
# process attributes first, so that they can
# I think this should be the order of things.
if (defined $attributes) {
if(ref($attributes) eq 'ARRAY'){
+ # array of Mouse::Meta::Attribute
foreach my $attr (@{$attributes}) {
- $meta->add_attribute($attr->{name} => $attr);
+ $meta->add_attribute($attr);
}
}
else{
+ # hash map of name and attribute spec pairs
while(my($name, $attr) = each %{$attributes}){
$meta->add_attribute($name => $attr);
}
}
}
- if (exists $options{methods}) {
- foreach my $method_name (keys %{$options{methods}}) {
- $meta->add_method($method_name, $options{methods}->{$method_name});
+ if (defined $methods) {
+ while(my($method_name, $method_body) = each %{$methods}){
+ $meta->add_method($method_name, $method_body);
}
}
- if (exists $options{roles}){
- Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
+ if (defined $roles){
+ Mouse::Util::apply_all_roles($package_name, @{$roles});
}
- if(!$mortal && exists $meta->{anon_serial_id}){
+ if($cache_key){
$IMMORTALS{$cache_key} = $meta;
}
return if !$serial_id;
- my $stash = $self->namespace;
-
+ # @ISA is a magical variable, so we clear it manually.
@{$self->{superclasses}} = () if exists $self->{superclasses};
- %{$stash} = ();
- Mouse::Meta::Module::remove_metaclass_by_name($self->name);
+
+ # Then, clear the symbol table hash
+ %{$self->namespace} = ();
+
+ my $name = $self->name;
+ delete $METAS{$name};
+
+ $name =~ s/ $serial_id \z//xms;
no strict 'refs';
- delete ${$ANON_PREFIX}{ $serial_id . '::' };
+ delete ${$name}{ $serial_id . '::' };
return;
}
package Mouse::Meta::Role;
-use strict;
-use warnings;
+use Mouse::Util qw(:meta not_supported english_list); # enables strict and warnings
-use Mouse::Util qw(:meta not_supported english_list get_code_info);
use Mouse::Meta::Module;
our @ISA = qw(Mouse::Meta::Module);
$args{required_methods} ||= [];
$args{roles} ||= [];
-# return Mouse::Meta::Class->initialize($class)->new_object(%args)
-# if $class ne __PACKAGE__;
+ my $self = bless \%args, ref($class) || $class;
+ if($class ne __PACKAGE__){
+ $self->meta->_initialize_object($self, \%args);
+ }
- return bless \%args, ref($class) || $class;
+ return $self;
}
sub create_anon_role{
sub add_required_methods {
my($self, @methods) = @_;
- push @{$self->{required_methods}}, @methods;
+ my %required = map{ $_ => 1 } @{$self->{required_methods}};
+ push @{$self->{required_methods}}, grep{ !$required{$_}++ && !$self->has_method($_) } @methods;
+ return;
}
sub requires_method {
my $name = shift;
$self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
+ return;
}
-sub _canonicalize_apply_args{
- my($self, $applicant, %args) = @_;
-
- if($applicant->isa('Mouse::Meta::Class')){
- $args{_to} = 'class';
- }
- elsif($applicant->isa('Mouse::Meta::Role')){
- $args{_to} = 'role';
- }
- else{
- $args{_to} = 'instance';
-
- not_supported 'Application::ToInstance';
- }
-
- if($args{alias} && !exists $args{-alias}){
- $args{-alias} = $args{alias};
- }
- if($args{excludes} && !exists $args{-excludes}){
- $args{-excludes} = $args{excludes};
- }
+sub _check_required_methods{
+ my($role, $applicant, $args) = @_;
- if(my $excludes = $args{-excludes}){
- $args{-excludes} = {}; # replace with a hash ref
- if(ref $excludes){
- %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
- }
- else{
- $args{-excludes}{$excludes} = undef;
- }
+ if($args->{_to} eq 'role'){
+ $applicant->add_required_methods($role->get_required_method_list);
}
+ else{ # to class or instance
+ my $applicant_class_name = $applicant->name;
- return \%args;
-}
-
-sub _check_required_methods{
- my($role, $class, $args, @other_roles) = @_;
-
- if($args->{_to} eq 'class'){
- my $class_name = $class->name;
- my $role_name = $role->name;
my @missing;
foreach my $method_name(@{$role->{required_methods}}){
- if(!$class_name->can($method_name)){
- my $has_method = 0;
-
- foreach my $another_role_spec(@other_roles){
- my $another_role_name = $another_role_spec->[0];
- if($role_name ne $another_role_name && $another_role_name->can($method_name)){
- $has_method = 1;
- last;
- }
- }
-
- push @missing, $method_name if !$has_method;
- }
+ next if exists $args->{aliased_methods}{$method_name};
+ next if exists $role->{methods}{$method_name};
+ next if $applicant_class_name->can($method_name);
+
+ push @missing, $method_name;
}
if(@missing){
- $class->throw_error("'$role_name' requires the "
- . (@missing == 1 ? 'method' : 'methods')
- . " "
- . english_list(map{ sprintf q{'%s'}, $_ } @missing)
- . " to be implemented by '$class_name'");
- }
- }
- elsif($args->{_to} eq 'role'){
- # apply role($role) to role($class)
- foreach my $method_name($role->get_required_method_list){
- next if $class->has_method($method_name); # already has it
- $class->add_required_methods($method_name);
+ $role->throw_error(sprintf "'%s' requires the method%s %s to be implemented by '%s'",
+ $role->name,
+ (@missing == 1 ? '' : 's'), # method or methods
+ english_list(map{ sprintf q{'%s'}, $_ } @missing),
+ $applicant_class_name);
}
}
}
sub _apply_methods{
- my($role, $class, $args) = @_;
-
- my $role_name = $role->name;
- my $class_name = $class->name;
+ my($role, $applicant, $args) = @_;
my $alias = $args->{-alias};
my $excludes = $args->{-excludes};
foreach my $method_name($role->get_method_list){
next if $method_name eq 'meta';
- my $code = $role_name->can($method_name);
+ my $code = $role->get_method_body($method_name);
if(!exists $excludes->{$method_name}){
- if(!$class->has_method($method_name)){
- $class->add_method($method_name => $code);
+ if(!$applicant->has_method($method_name)){
+ # The third argument $role is used in Role::Composite
+ $applicant->add_method($method_name => $code, $role);
}
}
- if($alias && $alias->{$method_name}){
+ if(exists $alias->{$method_name}){
my $dstname = $alias->{$method_name};
- my $dstcode = do{ no strict 'refs'; *{$class_name . '::' . $dstname}{CODE} };
+ my $dstcode = $applicant->get_method_body($dstname);
if(defined($dstcode) && $dstcode != $code){
- $class->throw_error("Cannot create a method alias if a local method of the same name exists");
+ $role->throw_error("Cannot create a method alias if a local method of the same name exists");
}
else{
- $class->add_method($dstname => $code);
+ $applicant->add_method($dstname => $code, $role);
}
}
}
}
sub _apply_attributes{
- my($role, $class, $args) = @_;
+ my($role, $applicant, $args) = @_;
- if ($args->{_to} eq 'class') {
- # apply role to class
- for my $attr_name ($role->get_attribute_list) {
- next if $class->has_attribute($attr_name);
-
- my $spec = $role->get_attribute($attr_name);
-
- $class->add_attribute($attr_name => %{$spec});
- }
- }
- elsif($args->{_to} eq 'role'){
- # apply role to role
- for my $attr_name ($role->get_attribute_list) {
- next if $class->has_attribute($attr_name);
+ for my $attr_name ($role->get_attribute_list) {
+ next if $applicant->has_attribute($attr_name);
- my $spec = $role->get_attribute($attr_name);
- $class->add_attribute($attr_name => $spec);
- }
+ $applicant->add_attribute($attr_name => $role->get_attribute($attr_name));
}
-
return;
}
sub _apply_modifiers{
- my($role, $class, $args) = @_;
+ my($role, $applicant, $args) = @_;
+
+ if(my $modifiers = $role->{override_method_modifiers}){
+ foreach my $method_name (keys %{$modifiers}){
+ $applicant->add_override_method_modifier($method_name => $modifiers->{$method_name});
+ }
+ }
+
+ for my $modifier_type (qw/before around after/) {
+ my $modifiers = $role->{"${modifier_type}_method_modifiers"}
+ or next;
- for my $modifier_type (qw/override before around after/) {
my $add_modifier = "add_${modifier_type}_method_modifier";
- my $modifiers = $role->{"${modifier_type}_method_modifiers"};
- while(my($method_name, $modifier_codes) = each %{$modifiers}){
- foreach my $code(ref($modifier_codes) eq 'ARRAY' ? @{$modifier_codes} : $modifier_codes){
- $class->$add_modifier($method_name => $code);
+ foreach my $method_name (keys %{$modifiers}){
+ foreach my $code(@{ $modifiers->{$method_name} }){
+ next if $applicant->{"_applied_$modifier_type"}{$method_name, $code}++; # skip applied modifiers
+ $applicant->$add_modifier($method_name => $code);
}
}
}
}
sub _append_roles{
- my($role, $class, $args) = @_;
+ my($role, $applicant, $args) = @_;
- my $roles = ($args->{_to} eq 'class') ? $class->roles : $class->get_roles;
+ my $roles = ($args->{_to} eq 'role') ? $applicant->get_roles : $applicant->roles;
foreach my $r($role, @{$role->get_roles}){
- if(!$class->does_role($r->name)){
+ if(!$applicant->does_role($r->name)){
push @{$roles}, $r;
}
}
my $self = shift;
my $applicant = shift;
- my $args = $self->_canonicalize_apply_args($applicant, @_);
+ my %args = (@_ == 1) ? %{ $_[0] } : @_;
- $self->_check_required_methods($applicant, $args);
- $self->_apply_methods($applicant, $args);
- $self->_apply_attributes($applicant, $args);
- $self->_apply_modifiers($applicant, $args);
- $self->_append_roles($applicant, $args);
- return;
-}
+ my $instance;
-sub combine_apply {
- my(undef, $class, @roles) = @_;
+ if($applicant->isa('Mouse::Meta::Class')){ # Application::ToClass
+ $args{_to} = 'class';
+ }
+ elsif($applicant->isa('Mouse::Meta::Role')){ # Application::ToRole
+ $args{_to} = 'role';
+ }
+ else{ # Appplication::ToInstance
+ $args{_to} = 'instance';
+ $instance = $applicant;
- if($class->isa('Mouse::Object')){
- not_supported 'Application::ToInstance';
+ $applicant = (Mouse::Util::class_of($instance) || 'Mouse::Meta::Class')->create_anon_class(
+ superclasses => [ref $instance],
+ cache => 1,
+ );
}
- # check conflicting
- my %method_provided;
- my @method_conflicts;
- my %attr_provided;
- my %override_provided;
+ if($args{alias} && !exists $args{-alias}){
+ $args{-alias} = $args{alias};
+ }
+ if($args{excludes} && !exists $args{-excludes}){
+ $args{-excludes} = $args{excludes};
+ }
- foreach my $role_spec (@roles) {
- my $role = $role_spec->[0]->meta;
- my $role_name = $role->name;
+ $args{aliased_methods} = {};
+ if(my $alias = $args{-alias}){
+ @{$args{aliased_methods}}{ values %{$alias} } = ();
+ }
- # methods
- foreach my $method_name($role->get_method_list){
- next if $class->has_method($method_name); # manually resolved
+ if(my $excludes = $args{-excludes}){
+ $args{-excludes} = {}; # replace with a hash ref
+ if(ref $excludes){
+ %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
+ }
+ else{
+ $args{-excludes}{$excludes} = undef;
+ }
+ }
- my $code = do{ no strict 'refs'; \&{ $role_name . '::' . $method_name } };
+ $self->_check_required_methods($applicant, \%args);
+ $self->_apply_attributes($applicant, \%args);
+ $self->_apply_methods($applicant, \%args);
+ $self->_apply_modifiers($applicant, \%args);
+ $self->_append_roles($applicant, \%args);
- my $c = $method_provided{$method_name};
- if($c && $c->[0] != $code){
- push @{$c}, $role;
- push @method_conflicts, $c;
- }
- else{
- $method_provided{$method_name} = [$code, $method_name, $role];
- }
- }
+ if(defined $instance){ # Application::ToInstance
+ # rebless instance
+ bless $instance, $applicant->name;
+ $applicant->_initialize_object($instance, $instance);
+ }
- # attributes
- foreach my $attr_name($role->get_attribute_list){
- my $attr = $role->get_attribute($attr_name);
- my $c = $attr_provided{$attr_name};
- if($c && $c != $attr){
- $class->throw_error("We have encountered an attribute conflict with '$attr_name' "
- . "during composition. This is fatal error and cannot be disambiguated.")
- }
- else{
- $attr_provided{$attr_name} = $attr;
- }
- }
+ return;
+}
- # override modifiers
- foreach my $method_name($role->get_method_modifier_list('override')){
- my $override = $role->get_override_method_modifier($method_name);
- my $c = $override_provided{$method_name};
- if($c && $c != $override){
- $class->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
- . "composition (Two 'override' methods of the same name encountered). "
- . "This is fatal error.")
- }
- else{
- $override_provided{$method_name} = $override;
- }
- }
- }
- if(@method_conflicts){
- my $error;
-
- if(@method_conflicts == 1){
- my($code, $method_name, @roles) = @{$method_conflicts[0]};
- $class->throw_error(
- sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
- english_list(map{ sprintf q{'%s'}, $_->name } @roles), $method_name, $class->name
- );
- }
- else{
- @method_conflicts = sort { $a->[0] cmp $b->[0] } @method_conflicts; # to avoid hash-ordering bugs
- my $methods = english_list(map{ sprintf q{'%s'}, $_->[1] } @method_conflicts);
- my $roles = english_list(
- map{ sprintf q{'%s'}, $_->name }
- map{ my($code, $method_name, @roles) = @{$_}; @roles } @method_conflicts
- );
-
- $class->throw_error(
- sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
- $roles, $methods, $class->name
- );
- }
- }
- foreach my $role_spec (@roles) {
- my($role_name, $args) = @{$role_spec};
+sub combine {
+ my($role_class, @role_specs) = @_;
- my $role = $role_name->meta;
+ require 'Mouse/Meta/Role/Composite.pm'; # we don't want to create its namespace
- $args = $role->_canonicalize_apply_args($class, %{$args});
+ my $composite = Mouse::Meta::Role::Composite->create_anon_role();
- $role->_check_required_methods($class, $args, @roles);
- $role->_apply_methods($class, $args);
- $role->_apply_attributes($class, $args);
- $role->_apply_modifiers($class, $args);
- $role->_append_roles($class, $args);
+ foreach my $role_spec (@role_specs) {
+ my($role_name, $args) = @{$role_spec};
+ $role_name->meta->apply($composite, %{$args});
}
- return;
+ return $composite;
}
for my $modifier_type (qw/before after around/) {
my $modifier = "${modifier_type}_method_modifiers";
+
my $add_method_modifier = sub {
my ($self, $method_name, $method) = @_;
push @{ $self->{$modifier}->{$method_name} ||= [] }, $method;
return;
};
- my $has_method_modifiers = sub{
- my($self, $method_name) = @_;
- my $m = $self->{$modifier}->{$method_name};
- return $m && @{$m} != 0;
- };
+
my $get_method_modifiers = sub {
my ($self, $method_name) = @_;
return @{ $self->{$modifier}->{$method_name} ||= [] }
no strict 'refs';
*{ 'add_' . $modifier_type . '_method_modifier' } = $add_method_modifier;
- *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
*{ 'get_' . $modifier_type . '_method_modifiers' } = $get_method_modifiers;
+
+ # has_${modifier_type}_method_modifiers is moved into t::lib::Test::Mouse
}
sub add_override_method_modifier{
$self->{override_method_modifiers}->{$method_name} = $method;
}
-sub has_override_method_modifier {
- my ($self, $method_name) = @_;
- return exists $self->{override_method_modifiers}->{$method_name};
-}
-
sub get_override_method_modifier {
my ($self, $method_name) = @_;
return $self->{override_method_modifiers}->{$method_name};
}
-sub get_method_modifier_list {
- my($self, $modifier_type) = @_;
-
- return keys %{ $self->{$modifier_type . '_method_modifiers'} };
-}
-
-# This is currently not passing all the Moose tests.
sub does_role {
my ($self, $role_name) = @_;
return 0;
}
-
1;
-
__END__
=head1 NAME
--- /dev/null
+package Mouse::Meta::Role::Composite;
+use Mouse::Util qw(english_list); # enables strict and warnings
+use Mouse::Meta::Role;
+our @ISA = qw(Mouse::Meta::Role);
+
+sub get_method_list{
+ my($self) = @_;
+ return keys %{ $self->{methods} };
+}
+
+sub add_method {
+ my($self, $method_name, $code, $role) = @_;
+
+ if( ($self->{methods}{$method_name} || 0) == $code){
+ # This role already has the same method.
+ return;
+ }
+
+ if($method_name ne 'meta'){
+ my $roles = $self->{composed_roles_by_method}{$method_name} ||= [];
+ push @{$roles}, $role;
+ if(@{$roles} > 1){
+ $self->{conflicting_methods}{$method_name}++;
+ }
+ }
+
+ $self->{methods}{$method_name} = $code;
+ # no need to add a subroutine to the stash
+ return;
+}
+
+sub get_method_body {
+ my($self, $method_name) = @_;
+ return $self->{methods}{$method_name};
+}
+
+sub has_method {
+ # my($self, $method_name) = @_;
+ return 0; # to fool _apply_methods() in combine()
+}
+
+sub has_attribute{
+ # my($self, $method_name) = @_;
+ return 0; # to fool _appply_attributes() in combine()
+}
+
+sub has_override_method_modifier{
+ # my($self, $method_name) = @_;
+ return 0; # to fool _apply_modifiers() in combine()
+}
+
+sub add_attribute{
+ my($self, $attr_name, $spec) = @_;
+
+ my $existing = $self->{attributes}{$attr_name};
+ if($existing && $existing != $spec){
+ $self->throw_error("We have encountered an attribute conflict with '$attr_name' "
+ . "during composition. This is fatal error and cannot be disambiguated.");
+ }
+ $self->SUPER::add_attribute($attr_name, $spec);
+ return;
+}
+
+sub add_override_method_modifier{
+ my($self, $method_name, $code) = @_;
+
+ my $existing = $self->{override_method_modifiers}{$method_name};
+ if($existing && $existing != $code){
+ $self->throw_error( "We have encountered an 'override' method conflict with '$method_name' during "
+ . "composition (Two 'override' methods of the same name encountered). "
+ . "This is fatal error.")
+ }
+ $self->SUPER::add_override_method_modifier($method_name, $code);
+ return;
+}
+
+# components of apply()
+
+sub _apply_methods{
+ my($self, $applicant, $args) = @_;
+
+ if(exists $self->{conflicting_methods}){
+ my $applicant_class_name = $applicant->name;
+
+ my @conflicting = sort grep{ !$applicant_class_name->can($_) } keys %{ $self->{conflicting_methods} };
+
+ if(@conflicting == 1){
+ my $method_name = $conflicting[0];
+ my @roles = sort @{ $self->{composed_roles_by_method}{$method_name} };
+ $self->throw_error(
+ sprintf q{Due to a method name conflict in roles %s, the method '%s' must be implemented or excluded by '%s'},
+ english_list(map{ sprintf q{'%s'}, $_->name } @roles), $method_name, $applicant->name
+ );
+ }
+ elsif(@conflicting > 1){
+ my $methods = english_list(map{ sprintf q{'%s'}, $_ } @conflicting);
+
+ my %seen;
+ my $roles = english_list(
+ sort map{ my $name = $_->name; $seen{$name}++ ? () : sprintf q{'%s'}, $name }
+ map{ @{$_} } @{ $self->{composed_roles_by_method} }{@conflicting}
+ );
+
+ $self->throw_error(
+ sprintf q{Due to method name conflicts in roles %s, the methods %s must be implemented or excluded by '%s'},
+ $roles, $methods, $applicant->name
+ );
+ }
+ }
+
+ $self->SUPER::_apply_methods($applicant, $args);
+ return;
+}
+1;
+__END__
+
package Mouse::Meta::Role::Method;
-use strict;
-use warnings;
+use Mouse::Util; # enables strict and warnings
use Mouse::Meta::Method;
our @ISA = qw(Mouse::Meta::Method);
1;
-
__END__
=head1 NAME
package Mouse::Meta::TypeConstraint;
-use strict;
-use warnings;
+use Mouse::Util qw(:meta); # enables strict and warnings
-use overload '""' => sub { shift->{name} }, # stringify to tc name
- fallback => 1;
+use overload
+ '""' => sub { shift->{name} }, # stringify to tc name
+ fallback => 1;
-use Carp ();
+use Carp qw(confess);
+use Scalar::Util qw(blessed reftype);
-use Mouse::Util qw(:meta);
+my $null_check = sub { 1 };
sub new {
- my $class = shift;
- my %args = @_;
- my $name = $args{name} || '__ANON__';
+ my($class, %args) = @_;
- my $check = $args{_compiled_type_constraint} or Carp::croak("missing _compiled_type_constraint");
- if (ref $check eq 'Mouse::Meta::TypeConstraint') {
- $check = $check->{_compiled_type_constraint};
+ $args{name} = '__ANON__' if !defined $args{name};
+
+ my $check = delete $args{optimized};
+
+ if($args{_compiled_type_constraint}){
+ Carp::cluck("'_compiled_type_constraint' has been deprecated, use 'optimized' instead")
+ if _MOUSE_VERBOSE;
+
+ $check = $args{_compiled_type_constraint};
}
- bless +{
- name => $name,
- _compiled_type_constraint => $check,
- message => $args{message}
- }, $class;
-}
+ if($check){
+ $args{hand_optimized_type_constraint} = $check;
+ $args{compiled_type_constraint} = $check;
+ }
-sub name { shift->{name} }
+ $check = $args{constraint};
-sub check {
+ if(blessed($check)){
+ Carp::cluck("Constraint for $args{name} must be a CODE reference");
+ $check = $check->{compiled_type_constraint};
+ }
+
+ if(defined($check) && ref($check) ne 'CODE'){
+ confess("Constraint for $args{name} is not a CODE reference");
+ }
+
+ $args{package_defined_in} ||= caller;
+
+ my $self = bless \%args, $class;
+ $self->compile_type_constraint() if !$self->{hand_optimized_type_constraint};
+
+ if($self->{type_constraints}){ # Union
+ my @coercions;
+ foreach my $type(@{$self->{type_constraints}}){
+ if($type->has_coercion){
+ push @coercions, $type;
+ }
+ }
+ if(@coercions){
+ $self->{_compiled_type_coercion} = sub {
+ my($thing) = @_;
+ foreach my $type(@coercions){
+ my $value = $type->coerce($thing);
+ return $value if $self->check($value);
+ }
+ return $thing;
+ };
+ }
+ }
+
+ return $self;
+}
+
+sub create_child_type{
my $self = shift;
- $self->{_compiled_type_constraint}->(@_);
+ # XXX: FIXME
+ return ref($self)->new(
+ # a child inherits its parent's attributes
+ %{$self},
+
+ # but does not inherit 'compiled_type_constraint' and 'hand_optimized_type_constraint'
+ compiled_type_constraint => undef,
+ hand_optimized_type_constraint => undef,
+
+ # and is given child-specific args, of course.
+ @_,
+
+ # and its parent
+ parent => $self,
+ );
}
-sub validate {
- my ($self, $value) = @_;
- if ($self->{_compiled_type_constraint}->($value)) {
- return undef;
+sub name { $_[0]->{name} }
+sub parent { $_[0]->{parent} }
+sub message { $_[0]->{message} }
+
+sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
+
+sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
+
+sub compile_type_constraint{
+ my($self) = @_;
+
+ # add parents first
+ my @checks;
+ for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
+ if($parent->{hand_optimized_type_constraint}){
+ push @checks, $parent->{hand_optimized_type_constraint};
+ last; # a hand optimized constraint must include all the parents
+ }
+ elsif($parent->{constraint}){
+ push @checks, $parent->{constraint};
+ }
}
- else {
- $self->get_message($value);
+
+ # then add child
+ if($self->{constraint}){
+ push @checks, $self->{constraint};
+ }
+
+ if($self->{type_constraints}){ # Union
+ my @types = map{ $_->_compiled_type_constraint } @{ $self->{type_constraints} };
+ push @checks, sub{
+ foreach my $c(@types){
+ return 1 if $c->($_[0]);
+ }
+ return 0;
+ };
+ }
+
+ if(@checks == 0){
+ $self->{compiled_type_constraint} = $null_check;
+ }
+ elsif(@checks == 1){
+ my $c = $checks[0];
+ $self->{compiled_type_constraint} = sub{
+ my(@args) = @_;
+ local $_ = $args[0];
+ return $c->(@args);
+ };
}
+ else{
+ $self->{compiled_type_constraint} = sub{
+ my(@args) = @_;
+ local $_ = $args[0];
+ foreach my $c(@checks){
+ return undef if !$c->(@args);
+ }
+ return 1;
+ };
+ }
+ return;
}
-sub assert_valid {
- my ($self, $value) = @_;
+sub _add_type_coercions{
+ my $self = shift;
+
+ my $coercions = ($self->{_coercion_map} ||= []);
+ my %has = map{ $_->[0] => undef } @{$coercions};
+
+ for(my $i = 0; $i < @_; $i++){
+ my $from = $_[ $i];
+ my $action = $_[++$i];
- my $error = $self->validate($value);
- return 1 if ! defined $error;
+ if(exists $has{$from}){
+ confess("A coercion action already exists for '$from'");
+ }
- Carp::confess($error);
+ my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint($from)
+ or confess("Could not find the type constraint ($from) to coerce from");
+
+ push @{$coercions}, [ $type => $action ];
+ }
+
+ # compile
+ if(exists $self->{type_constraints}){ # union type
+ confess("Cannot add additional type coercions to Union types");
+ }
+ else{
+ $self->{_compiled_type_coercion} = sub {
+ my($thing) = @_;\r
+ foreach my $pair (@{$coercions}) {\r
+ #my ($constraint, $converter) = @$pair;\r
+ if ($pair->[0]->check($thing)) {\r
+ local $_ = $thing;
+ return $pair->[1]->($thing);
+ }\r
+ }\r
+ return $thing;\r
+ };
+ }
+ return;
}
+sub check {
+ my $self = shift;
+ return $self->_compiled_type_constraint->(@_);
+}
+
+sub coerce {
+ my $self = shift;
+ if(!$self->{_compiled_type_coercion}){
+ confess("Cannot coerce without a type coercion ($self)");
+ }
-sub message {
- return $_[0]->{message};
+ return $_[0] if $self->_compiled_type_constraint->(@_);
+
+ return $self->{_compiled_type_coercion}->(@_);
}
sub get_message {
}
else {
$value = ( defined $value ? overload::StrVal($value) : 'undef' );
- return
- "Validation failed for '"
- . $self->name
- . "' failed with value $value";
+ return "Validation failed for '$self' failed with value $value";
}
}
sub is_a_type_of{
- my($self, $tc_name) = @_;
+ my($self, $other) = @_;
+
+ # ->is_a_type_of('__ANON__') is always false
+ return 0 if !blessed($other) && $other eq '__ANON__';
+
+ (my $other_name = $other) =~ s/\s+//g;
- return $self->name eq $tc_name
- || $self->name =~ /\A $tc_name \[/xms; # "ArrayRef" =~ "ArrayRef[Foo]"
+ return 1 if $self->name eq $other_name;
+
+ if(exists $self->{type_constraints}){ # union
+ foreach my $type(@{$self->{type_constraints}}){
+ return 1 if $type->name eq $other_name;
+ }
+ }
+
+ for(my $parent = $self->parent; defined $parent; $parent = $parent->parent){
+ return 1 if $parent->name eq $other_name;
+ }
+
+ return 0;
}
+
1;
__END__
package Mouse::Object;
-use strict;
-use warnings;
-
-use Mouse::Util qw(does dump);
+use Mouse::Util qw(does dump); # enables strict and warnings
sub new {
my $class = shift;
sub DESTROY {
my $self = shift;
- $self->DEMOLISHALL();
+ local $?;
+
+ my $e = do{
+ local $@;
+ eval{
+ $self->DEMOLISHALL();
+ };
+ $@;
+ };
+
+ no warnings 'misc';
+ die $e if $e; # rethrow
}
sub BUILDALL {
package Mouse::Role;
-use strict;
-use warnings;
+use Mouse::Util qw(not_supported); # enables strict and warnings
-use Exporter;
+use Carp qw(confess);
+use Scalar::Util qw(blessed);
-use Carp 'confess';
-use Scalar::Util 'blessed';
-
-use Mouse::Util qw(load_class get_code_package not_supported);
use Mouse ();
+use Mouse::Exporter;
+
+Mouse::Exporter->setup_import_methods(
+ as_is => [qw(
+ extends with
+ has
+ before after around
+ override super
+ augment inner
+
+ requires excludes
+ ),
+ \&Scalar::Util::blessed,
+ \&Carp::confess,
+ ],
+);
-our @ISA = qw(Exporter);
-
+# XXX: for backward compatibility
our @EXPORT = qw(
extends with
has
blessed confess
);
-our %is_removable = map{ $_ => undef } @EXPORT;
-delete $is_removable{confess};
-delete $is_removable{blessed};
-
sub before {
my $meta = Mouse::Meta::Role->initialize(scalar caller);
sub super {
- return unless $Mouse::SUPER_BODY;
+ return if !defined $Mouse::SUPER_BODY;
$Mouse::SUPER_BODY->(@Mouse::SUPER_ARGS);
}
sub override {
- my $classname = caller;
- my $meta = Mouse::Meta::Role->initialize($classname);
-
- my $name = shift;
- my $code = shift;
- my $fullname = "${classname}::${name}";
-
- defined &$fullname
- && $meta->throw_error("Cannot add an override of method '$fullname' "
- . "because there is a local version of '$fullname'");
-
- $meta->add_override_method_modifier($name => sub {
- local $Mouse::SUPER_PACKAGE = shift;
- local $Mouse::SUPER_BODY = shift;
- local @Mouse::SUPER_ARGS = @_;
-
- $code->(@_);
- });
+ # my($name, $code) = @_;
+ Mouse::Meta::Role->initialize(scalar caller)->add_override_method_modifier(@_);
}
# We keep the same errors messages as Moose::Role emits, here.
not_supported;
}
-sub import {
- my $class = shift;
+sub init_meta{
+ shift;
+ my %args = @_;
- strict->import;
- warnings->import;
+ my $class = $args{for_class}
+ or Carp::confess("Cannot call init_meta without specifying a for_class");
- my $caller = caller;
+ my $metaclass = $args{metaclass} || 'Mouse::Meta::Role';
- # we should never export to main
- if ($caller eq 'main') {
- warn qq{$class does not export its sugar to the 'main' package.\n};
- return;
- }
+ my $meta = $metaclass->initialize($class);
- Mouse::Meta::Role->initialize($caller)->add_method(meta => sub {
- return Mouse::Meta::Role->initialize(ref($_[0]) || $_[0]);
+ $meta->add_method(meta => sub{
+ $metaclass->initialize(ref($_[0]) || $_[0]);
});
- Mouse::Role->export_to_level(1, @_);
-}
-
-sub unimport {
- my $caller = caller;
-
- my $stash = do{
- no strict 'refs';
- \%{$caller . '::'}
- };
+ # make a role type for each Mouse role
+ Mouse::Util::TypeConstraints::role_type($class)
+ unless Mouse::Util::TypeConstraints::find_type_constraint($class);
- for my $keyword (@EXPORT) {
- my $code;
- if(exists $is_removable{$keyword}
- && ($code = $caller->can($keyword))
- && get_code_package($code) eq __PACKAGE__){
-
- delete $stash->{$keyword};
- }
- }
- return;
+ return $meta;
}
1;
use strict;
use warnings;
-our $VERSION = '0.37';
+our $VERSION = '0.37_06';
our $MouseVersion = $VERSION;
our $MooseVersion = '0.90';
1;
__END__
+
+=head1 NAME
+
+Mouse::Spec - To what extent Mouse is compatible with Moose
+
+=head1 DESCRIPTION
+
+=head2 Notes about Moose::Cookbook
+
+Many recipes in L<Moose::Cookbook> fit L<Mouse>, including:
+
+=over 4
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe1> - The (always classic) B<Point> example
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe2> - A simple B<BankAccount> example\r
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe3> - A lazy B<BinaryTree> example
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe4> - Subtypes, and modeling a simple B<Company> class hierarchy
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe5> - More subtypes, coercion in a B<Request> class\r
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe6> - The augment/inner example\r
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe7> - Making Moose fast with immutable\r
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe8> - Builder methods and lazy_build\r
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe9> - Operator overloading, subtypes, and coercion\r
+
+=item *
+
+L<Moose::Cookbook::Basics::Recipe10> - Using BUILDARGS and BUILD to hook into object construction\r
+
+=item *
+
+L<Moose::Cookbook::Roles::Recipe1> - The Moose::Role example\r
+
+=item *
+
+L<Moose::Cookbook::Roles::Recipe2> - Advanced Role Composition - method exclusion and aliasing
+
+=item *
+
+L<Moose::Cookbook::Roles::Recipe3> - Applying a role to an object instance\r
+
+=item *
+
+L<Moose::Cookbook::Meta::Recipe2> - A meta-attribute, attributes with labels\r
+
+=item *
+
+L<Moose::Cookbook::Meta::Recipe3> - Labels implemented via attribute traits\r
+
+=item *
+
+L<Moose::Cookbook::Extending::Recipe3> - Providing an alternate base object class\r
+
+=back
+
+=head1 SEE ALSO
+
+L<Mouse>
+
+=cut
+
package Mouse::Util;
-use strict;
-use warnings;
-
-use Exporter;
+use Mouse::Exporter; # enables strict and warnings
use Carp qw(confess);
+use Scalar::Util qw(blessed);
use B ();
use constant _MOUSE_VERBOSE => !!$ENV{MOUSE_VERBOSE};
-our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(
- find_meta
- does_role
- resolve_metaclass_alias
- apply_all_roles
- english_list
+Mouse::Exporter->setup_import_methods(
+ as_is => [qw(
+ find_meta
+ does_role
+ resolve_metaclass_alias
+ apply_all_roles
+ english_list
- load_class
- is_class_loaded
+ load_class
+ is_class_loaded
- get_linear_isa
- get_code_info
+ get_linear_isa
+ get_code_info
- get_code_package
+ get_code_package
- not_supported
+ not_supported
- does meta dump
- _MOUSE_VERBOSE
-);
-our %EXPORT_TAGS = (
- all => \@EXPORT_OK,
- meta => [qw(does meta dump _MOUSE_VERBOSE)],
+ does meta dump
+ _MOUSE_VERBOSE
+ )],
+ groups => {
+ default => [], # export no functions by default
+
+ # The ':meta' group is 'use metaclass' for Mouse
+ meta => [qw(does meta dump _MOUSE_VERBOSE)],
+ },
+ _export_to_main => 1,
);
+# aliases as public APIs
+# it must be 'require', not 'use', because Mouse::Meta::Module depends on Mouse::Util
+require Mouse::Meta::Module; # for the entities of metaclass cache utilities
+
+BEGIN {
+ *class_of = \&Mouse::Meta::Module::class_of;
+ *get_metaclass_by_name = \&Mouse::Meta::Module::get_metaclass_by_name;
+ *get_all_metaclass_instances = \&Mouse::Meta::Module::get_all_metaclass_instances;
+ *get_all_metaclass_names = \&Mouse::Meta::Module::get_all_metaclass_names;
+}
+
# Moose::Util compatible utilities
sub find_meta{
- return Mouse::Meta::Module::class_of( $_[0] );
+ return class_of( $_[0] );
}
sub does_role{
my ($class_or_obj, $role_name) = @_;
- my $meta = Mouse::Meta::Module::class_of($class_or_obj);
+ my $meta = class_of($class_or_obj);
(defined $role_name)
|| ($meta || 'Mouse::Meta::Class')->throw_error("You must supply a role name to does()");
return defined($meta) && $meta->does_role($role_name);
}
-
-
BEGIN {
my $impl;
if ($] >= 5.009_005) {
}
}
+# Utilities from Class::MOP
+
+
# taken from Class/MOP.pm
sub is_valid_class_name {
my $class = shift;
}
# taken from Class/MOP.pm
+my %is_class_loaded_cache;
sub _try_load_one_class {
my $class = shift;
confess "Invalid class name ($display)";
}
- return if is_class_loaded($class);
+ return undef if $is_class_loaded_cache{$class} ||= is_class_loaded($class);
my $file = $class . '.pm';
$file =~ s{::}{/}g;
return 1;
}
-my %is_class_loaded_cache;
+
sub is_class_loaded {
my $class = shift;
return 0 if ref($class) || !defined($class) || !length($class);
- return 1 if $is_class_loaded_cache{$class};
-
# walk the symbol table tree to avoid autovififying
# \*{${main::}{"Foo::"}} == \*main::Foo::
}
# check for $VERSION or @ISA
- return ++$is_class_loaded_cache{$class} if exists $pack->{VERSION}
+ return 1 if exists $pack->{VERSION}
&& defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
- return ++$is_class_loaded_cache{$class} if exists $pack->{ISA}
+ return 1 if exists $pack->{ISA}
&& defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
# check for any method
foreach my $name( keys %{$pack} ) {
my $entry = \$pack->{$name};
- return ++$is_class_loaded_cache{$class} if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
+ return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
}
# fail
sub apply_all_roles {
- my $meta = Mouse::Meta::Class->initialize(shift);
+ my $applicant = blessed($_[0]) ? shift : Mouse::Meta::Class->initialize(shift);
my @roles;
my $max = scalar(@_);
for (my $i = 0; $i < $max ; $i++) {
if ($i + 1 < $max && ref($_[$i + 1])) {
- push @roles, [ $_[$i++] => $_[$i] ];
+ push @roles, [ $_[$i] => $_[++$i] ];
} else {
- push @roles, [ $_[$i] => undef ];
+ push @roles, [ $_[$i] => undef ];
}
my $role_name = $roles[-1][0];
load_class($role_name);
- ( $role_name->can('meta') && $role_name->meta->isa('Mouse::Meta::Role') )
- || $meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role");
+
+ my $metarole = get_metaclass_by_name($role_name);
+ ( $metarole && $metarole->isa('Mouse::Meta::Role') )
+ || $applicant->meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role");
}
if ( scalar @roles == 1 ) {
- my ( $role, $params ) = @{ $roles[0] };
- $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
+ my ( $role_name, $params ) = @{ $roles[0] };
+ get_metaclass_by_name($role_name)->apply( $applicant, defined $params ? $params : () );
}
else {
- Mouse::Meta::Role->combine_apply($meta, @roles);
+ Mouse::Meta::Role->combine(@roles)->apply($applicant);
}
return;
}
Carp::confess("Mouse does not currently support $feature");
}
-sub meta{
- return Mouse::Meta::Class->initialize($_[0]);
+# general meta() method
+sub meta :method{
+ return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
}
-sub dump {
+# general dump() method
+sub dump :method {
my($self, $maxdepth) = @_;
require 'Data/Dumper.pm'; # we don't want to create its namespace
return $dd->Dump();
}
+# general does() method
sub does :method;
*does = \&does_role; # alias
=head3 C<< load_class(ClassName) >>
-This will load a given C<ClassName> (or die if it's not loadable).
+This will load a given C<ClassName> (or die if it is not loadable).
This function can be used in place of tricks like
C<eval "use $module"> or using C<require>.
+=head3 C<< Mouse::Util::class_of(ClassName or Object) >>
+
+=head3 C<< Mouse::Util::get_metaclass_by_name(ClassName) >>
+
+=head3 C<< Mouse::Util::get_all_metaclass_instances() >>
+
+=head3 C<< Mouse::Util::get_all_metaclass_names() >>
+
=head2 MRO::Compat
=head3 C<get_linear_isa>
L<Moose::Util>
-L<Scalar::Util>
+L<Class::MOP>
L<Sub::Identify>
package Mouse::Util::TypeConstraints;
-use strict;
-use warnings;
+use Mouse::Util qw(does_role not_supported); # enables strict and warnings
-use Exporter;
-
-use Carp ();
+use Carp qw(confess);
use Scalar::Util qw/blessed looks_like_number openhandle/;
-use Mouse::Util qw(does_role not_supported);
-use Mouse::Meta::Module; # class_of
use Mouse::Meta::TypeConstraint;
+use Mouse::Exporter;
+
+Mouse::Exporter->setup_import_methods(
+ as_is => [qw(
+ as where message optimize_as
+ from via
+ type subtype coerce class_type role_type enum
+ find_type_constraint
+ )],
-our @ISA = qw(Exporter);
-our @EXPORT = qw(
- as where message from via type subtype coerce class_type role_type enum
- find_type_constraint
+ _export_to_main => 1,
);
my %TYPE;
-my %TYPE_SOURCE;
-my %COERCE;
-my %COERCE_KEYS;
-sub as ($) {
- return(as => $_[0]);
-}
-sub where (&) {
- return(where => $_[0])
-}
-sub message (&) {
- return(message => $_[0])
-}
+sub as ($) { (as => $_[0]) }
+sub where (&) { (where => $_[0]) }
+sub message (&) { (message => $_[0]) }
+sub optimize_as (&) { (optimize_as => $_[0]) }
sub from { @_ }
sub via (&) { $_[0] }
BEGIN {
my %builtins = (
- Any => sub { 1 },
- Item => sub { 1 },
+ Any => undef, # null check
+ Item => undef, # null check
+ Maybe => undef, # null check
Bool => sub { $_[0] ? $_[0] eq '1' : 1 },
Undef => sub { !defined($_[0]) },
while (my ($name, $code) = each %builtins) {
$TYPE{$name} = Mouse::Meta::TypeConstraint->new(
- name => $name,
- _compiled_type_constraint => $code,
+ name => $name,
+ optimized => $code,
);
- $TYPE_SOURCE{$name} = __PACKAGE__;
}
- sub optimized_constraints { \%TYPE }
+ sub optimized_constraints { # DEPRECATED
+ Carp::cluck('optimized_constraints() has been deprecated');
+ return \%TYPE;
+ }
my @builtins = keys %TYPE;
sub list_all_builtin_type_constraints { @builtins }
sub list_all_type_constraints { keys %TYPE }
}
-sub type {
+sub _create_type{
+ my $mode = shift;
+
my $name;
- my %conf;
+ my %args;
- if(@_ == 1 && ref $_[0]){ # type { where => ... }
- %conf = %{$_[0]};
+ if(@_ == 1 && ref $_[0]){ # @_ : { name => $name, where => ... }
+ %args = %{$_[0]};
}
- elsif(@_ == 2 && ref $_[1]){ # type $name => { where => ... }*
+ elsif(@_ == 2 && ref $_[1]){ # @_ : $name => { where => ... }
$name = $_[0];
- %conf = %{$_[1]};
+ %args = %{$_[1]};
}
- elsif(@_ % 2){ # odd number of arguments
- $name = shift;
- %conf = @_;
+ elsif(@_ % 2){ # @_ : $name => ( where => ... )
+ ($name, %args) = @_;
}
- else{
- %conf = @_;
+ else{ # @_ : (name => $name, where => ...)
+ %args = @_;
}
- $name = '__ANON__' if !defined $name;
-
- my $pkg = caller;
-
- if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
- Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
+ if(!defined $name){
+ if(!defined($name = $args{name})){
+ $name = '__ANON__';
+ }
}
- my $constraint = $conf{where} || do {
- my $as = delete $conf{as} || 'Any';
- ($TYPE{$as} ||= _build_type_constraint($as))->{_compiled_type_constraint};
- };
-
- my $tc = Mouse::Meta::TypeConstraint->new(
- name => $name,
- _compiled_type_constraint => sub {
- local $_ = $_[0];
- return &{$constraint};
- },
- );
+ $args{name} = $name;
+ my $parent;
+ if($mode eq 'subtype'){
+ $parent = delete $args{as};
+ if(!$parent){
+ $parent = delete $args{name};
+ $name = '__ANON__';
+ }
+ }
- $TYPE_SOURCE{$name} = $pkg;
- $TYPE{$name} = $tc;
+ my $package_defined_in = $args{package_defined_in} ||= caller(1);
- return $tc;
-}
+ my $existing = $TYPE{$name};
+ if($existing && $existing->{package_defined_in} ne $package_defined_in){
+ confess("The type constraint '$name' has already been created in "
+ . "$existing->{package_defined_in} and cannot be created again in $package_defined_in");
+ }
-sub subtype {
- my $name;
- my %conf;
+ $args{constraint} = delete $args{where} if exists $args{where};
+ $args{optimized} = delete $args{optimized_as} if exists $args{optimized_as};
- if(@_ == 1 && ref $_[0]){ # type { where => ... }
- %conf = %{$_[0]};
- }
- elsif(@_ == 2 && ref $_[1]){ # type $name => { where => ... }*
- $name = $_[0];
- %conf = %{$_[1]};
- }
- elsif(@_ % 2){ # odd number of arguments
- $name = shift;
- %conf = @_;
+ my $constraint;
+ if($mode eq 'subtype'){
+ $constraint = find_or_create_isa_type_constraint($parent)->create_child_type(%args);
}
else{
- %conf = @_;
- }
-
- $name = '__ANON__' if !defined $name;
-
- my $pkg = caller;
-
- if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
- Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
+ $constraint = Mouse::Meta::TypeConstraint->new(%args);
}
- my $constraint = delete $conf{where};
- my $as_constraint = find_or_create_isa_type_constraint(delete $conf{as} || 'Any')
- ->{_compiled_type_constraint};
-
- my $tc = Mouse::Meta::TypeConstraint->new(
- name => $name,
- _compiled_type_constraint => (
- $constraint ?
- sub {
- local $_ = $_[0];
- $as_constraint->($_[0]) && $constraint->($_[0])
- } :
- sub {
- local $_ = $_[0];
- $as_constraint->($_[0]);
- }
- ),
- %conf,
- );
+ return $TYPE{$name} = $constraint;
+}
- $TYPE_SOURCE{$name} = $pkg;
- $TYPE{$name} = $tc;
+sub type {
+ return _create_type('type', @_);
+}
- return $tc;
+sub subtype {
+ return _create_type('subtype', @_);
}
sub coerce {
- my $name = shift;
-
- Carp::croak "Cannot find type '$name', perhaps you forgot to load it."
- unless $TYPE{$name};
+ my $type_name = shift;
- unless ($COERCE{$name}) {
- $COERCE{$name} = {};
- $COERCE_KEYS{$name} = [];
- }
-
- while (my($type, $code) = splice @_, 0, 2) {
- Carp::croak "A coercion action already exists for '$type'"
- if $COERCE{$name}->{$type};
-
- if (! $TYPE{$type}) {
- # looks parameterized
- if ($type =~ /^[^\[]+\[.+\]$/) {
- $TYPE{$type} = _build_type_constraint($type);
- } else {
- Carp::croak "Could not find the type constraint ($type) to coerce from"
- }
- }
+ my $type = find_type_constraint($type_name)
+ or confess("Cannot find type '$type_name', perhaps you forgot to load it.");
- push @{ $COERCE_KEYS{$name} }, $type;
- $COERCE{$name}->{$type} = $code;
- }
+ $type->_add_type_coercions(@_);
return;
}
if ($conf && $conf->{class}) {
# No, you're using this wrong
warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
- subtype $name => (as => $conf->{class});
+ _create_type 'type', $name => (
+ as => $conf->{class},
+
+ type => 'Class',
+ );
}
else {
- subtype $name => (
- where => sub { blessed($_) && $_->isa($name) },
+ _create_type 'type', $name => (
+ optimized_as => sub { blessed($_[0]) && $_[0]->isa($name) },
+
+ type => 'Class',
);
}
}
sub role_type {
my($name, $conf) = @_;
- my $role = $conf->{role};
- subtype $name => (
- where => sub { does_role($_, $role) },
+ my $role = ($conf && $conf->{role}) ? $conf->{role} : $name;
+ _create_type 'type', $name => (
+ optimized_as => sub { blessed($_[0]) && does_role($_[0], $role) },
+
+ type => 'Role',
);
}
-# this is an original method for Mouse
-sub typecast_constraints {
- my($class, $pkg, $types, $value) = @_;
+sub typecast_constraints { # DEPRECATED
+ my($class, $pkg, $type, $value) = @_;
Carp::croak("wrong arguments count") unless @_ == 4;
- local $_;
- for my $type ( split /\|/, $types ) {
- next unless $COERCE{$type};
- for my $coerce_type (@{ $COERCE_KEYS{$type}}) {
- $_ = $value;
- next unless $TYPE{$coerce_type}->check($value);
- $_ = $value;
- $_ = $COERCE{$type}->{$coerce_type}->($value);
- return $_ if $types->check($_);
- }
- }
- return $value;
+ Carp::cluck("typecast_constraints() has been deprecated, which was an internal utility anyway");
+
+ return $type->coerce($value);
}
-my $serial_enum = 0;
sub enum {
+ my($name, %valid);
+
# enum ['small', 'medium', 'large']
if (ref($_[0]) eq 'ARRAY') {
- my @elements = @{ shift @_ };
+ %valid = map{ $_ => undef } @{ $_[0] };
+ $name = sprintf '(%s)', join '|', sort @{$_[0]};
+ }
+ # enum size => 'small', 'medium', 'large'
+ else{
+ $name = shift;
+ %valid = map{ $_ => undef } @_;
+ }
+ return _create_type 'type', $name => (
+ optimized_as => sub{ defined($_[0]) && !ref($_[0]) && exists $valid{$_[0]} },
+
+ type => 'Enum',
+ );
+}
- my $name = 'Mouse::Util::TypeConstaints::Enum::Serial::'
- . ++$serial_enum;
- enum($name, @elements);
- return $name;
+sub _find_or_create_regular_type{
+ my($spec) = @_;
+
+ return $TYPE{$spec} if exists $TYPE{$spec};
+
+ my $meta = Mouse::Util::get_metaclass_by_name($spec);
+
+ if(!$meta){
+ return;
}
- # enum size => 'small', 'medium', 'large'
- my $name = shift;
- my %is_valid = map { $_ => 1 } @_;
+ my $check;
+ my $type;
+ if($meta->isa('Mouse::Meta::Role')){
+ $check = sub{
+ return blessed($_[0]) && $_[0]->does($spec);
+ };
+ $type = 'Role';
+ }
+ else{
+ $check = sub{
+ return blessed($_[0]) && $_[0]->isa($spec);
+ };
+ $type = 'Class';
+ }
- subtype(
- $name => where => sub { $is_valid{$_} }
+ return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new(
+ name => $spec,
+ optimized => $check,
+
+ type => $type,
);
}
-sub _build_type_constraint {
- my($spec) = @_;
+$TYPE{ArrayRef}{constraint_generator} = sub {
+ my($type_parameter) = @_;
+ my $check = $type_parameter->_compiled_type_constraint;
- my $code;
- $spec =~ s/\s+//g;
+ return sub{
+ foreach my $value (@{$_}) {
+ return undef unless $check->($value);
+ }
+ return 1;
+ }
+};
+$TYPE{HashRef}{constraint_generator} = sub {
+ my($type_parameter) = @_;
+ my $check = $type_parameter->_compiled_type_constraint;
+
+ return sub{
+ foreach my $value(values %{$_}){
+ return undef unless $check->($value);
+ }
+ return 1;
+ };
+};
+
+# 'Maybe' type accepts 'Any', so it requires parameters
+$TYPE{Maybe}{constraint_generator} = sub {
+ my($type_parameter) = @_;
+ my $check = $type_parameter->_compiled_type_constraint;
+
+ return sub{
+ return !defined($_) || $check->($_);
+ };
+};
- if ($spec =~ /\A (\w+) \[ (.+) \] \z/xms) {
- # parameterized
- my $constraint = $1;
- my $param = $2;
- my $parent;
+sub _find_or_create_parameterized_type{
+ my($base, $param) = @_;
- if ($constraint eq 'Maybe') {
- $parent = _build_type_constraint('Undef');
+ my $name = sprintf '%s[%s]', $base->name, $param->name;
+
+ $TYPE{$name} ||= do{
+ my $generator = $base->{constraint_generator};
+
+ if(!$generator){
+ confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
}
- else {
- $parent = _build_type_constraint($constraint);
+
+ Mouse::Meta::TypeConstraint->new(
+ name => $name,
+ parent => $base,
+ constraint => $generator->($param),
+
+ type => 'Parameterized',
+ );
+ }
+}
+sub _find_or_create_union_type{
+ my @types = sort{ $a cmp $b } map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
+
+ my $name = join '|', @types;
+
+ $TYPE{$name} ||= do{
+ return Mouse::Meta::TypeConstraint->new(
+ name => $name,
+ type_constraints => \@types,
+
+ type => 'Union',
+ );
+ };
+}
+
+# The type parser
+sub _parse_type{
+ my($spec, $start) = @_;
+
+ my @list;
+ my $subtype;
+
+ my $len = length $spec;
+ my $i;
+
+ for($i = $start; $i < $len; $i++){
+ my $char = substr($spec, $i, 1);
+
+ if($char eq '['){
+ my $base = _find_or_create_regular_type( substr($spec, $start, $i - $start) )
+ or return;
+
+ ($i, $subtype) = _parse_type($spec, $i+1)
+ or return;
+ $start = $i+1; # reset
+
+ push @list, _find_or_create_parameterized_type($base => $subtype);
}
- my $child = _build_type_constraint($param);
- if ($constraint eq 'ArrayRef') {
- my $code_str =
- "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
- "sub {\n" .
- " if (\$parent->check(\$_[0])) {\n" .
- " foreach my \$e (\@{\$_[0]}) {\n" .
- " return () unless \$child->check(\$e);\n" .
- " }\n" .
- " return 1;\n" .
- " }\n" .
- " return ();\n" .
- "};\n"
- ;
- $code = eval $code_str or Carp::confess("Failed to generate inline type constraint: $@");
- } elsif ($constraint eq 'HashRef') {
- my $code_str =
- "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
- "sub {\n" .
- " if (\$parent->check(\$_[0])) {\n" .
- " foreach my \$e (values \%{\$_[0]}) {\n" .
- " return () unless \$child->check(\$e);\n" .
- " }\n" .
- " return 1;\n" .
- " }\n" .
- " return ();\n" .
- "};\n"
- ;
- $code = eval $code_str or Carp::confess($@);
- } elsif ($constraint eq 'Maybe') {
- my $code_str =
- "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
- "sub {\n" .
- " return \$child->check(\$_[0]) || \$parent->check(\$_[0]);\n" .
- "};\n"
- ;
- $code = eval $code_str or Carp::confess($@);
- } else {
- Carp::confess("Support for parameterized types other than Maybe, ArrayRef or HashRef is not implemented yet");
+ elsif($char eq ']'){
+ $len = $i+1;
+ last;
}
- $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
- } else {
- $code = $TYPE{ $spec };
- if (! $code) {
- # is $spec a known role? If so, constrain with 'does' instead of 'isa'
- require Mouse::Meta::Role;
- my $check = Mouse::Meta::Role->_metaclass_cache($spec)?
- 'does' : 'isa';
- my $code_str =
- "#line " . __LINE__ . ' "' . __FILE__ . "\"\n" .
- "sub {\n" .
- " Scalar::Util::blessed(\$_[0]) && \$_[0]->$check('$spec');\n" .
- "}"
- ;
- $code = eval $code_str or Carp::confess($@);
- $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
+ elsif($char eq '|'){
+ my $type = _find_or_create_regular_type( substr($spec, $start, $i - $start) );
+
+ if(!defined $type){
+ # XXX: Mouse creates a new class type, but Moose does not.
+ $type = class_type( substr($spec, $start, $i - $start) );
+ }
+
+ push @list, $type;
+
+ ($i, $subtype) = _parse_type($spec, $i+1)
+ or return;
+
+ $start = $i+1; # reset
+
+ push @list, $subtype;
}
}
- return Mouse::Meta::TypeConstraint->new( _compiled_type_constraint => $code, name => $spec );
-}
+ if($i - $start){
+ push @list, _find_or_create_regular_type(substr $spec, $start, $i - $start);
+ }
-sub find_type_constraint {
- my($type) = @_;
- if(blessed($type) && $type->isa('Mouse::Meta::TypeConstraint')){
- return $type;
+ if(@list == 0){
+ return;
+ }
+ elsif(@list == 1){
+ return ($len, $list[0]);
}
else{
- return $TYPE{$type};
+ return ($len, _find_or_create_union_type(@list));
}
}
-sub find_or_create_does_type_constraint{
- not_supported;
-}
-sub find_or_create_isa_type_constraint {
- my $type_constraint = shift;
+sub find_type_constraint {
+ my($spec) = @_;
+ return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
- Carp::confess("Got isa => type_constraints, but Mouse does not yet support parameterized types for containers other than ArrayRef and HashRef and Maybe (rt.cpan.org #39795)")
- if $type_constraint =~ /\A ( [^\[]+ ) \[\.+\] \z/xms &&
- $1 ne 'ArrayRef' &&
- $1 ne 'HashRef' &&
- $1 ne 'Maybe'
- ;
+ $spec =~ s/\s+//g;
+ return $TYPE{$spec};
+}
+sub find_or_parse_type_constraint {
+ my($spec) = @_;
+ return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
- $type_constraint =~ s/\s+//g;
+ $spec =~ s/\s+//g;
+ return $TYPE{$spec} || do{
+ my($pos, $type) = _parse_type($spec, 0);
+ $type;
+ };
+}
- my $tc = find_type_constraint($type_constraint);
- if (!$tc) {
- my @type_constraints = split /\|/, $type_constraint;
- if (@type_constraints == 1) {
- $tc = $TYPE{$type_constraints[0]} ||
- _build_type_constraint($type_constraints[0]);
- }
- else {
- my @code_list = map {
- $TYPE{$_} || _build_type_constraint($_)
- } @type_constraints;
-
- $tc = Mouse::Meta::TypeConstraint->new(
- name => $type_constraint,
-
- _compiled_type_constraint => sub {
- foreach my $code (@code_list) {
- return 1 if $code->check($_[0]);
- }
- return 0;
- },
- );
- }
- }
- return $tc;
+sub find_or_create_does_type_constraint{
+ return find_or_parse_type_constraint(@_) || role_type(@_);
+}
+
+sub find_or_create_isa_type_constraint {
+ return find_or_parse_type_constraint(@_) || class_type(@_);
}
1;
GlobRef
FileHandle
Object
- Role
B<NOTE:> Any type followed by a type parameter C<[`a]> can be
parameterized, this means you can say:
=head1 METHODS
-=head2 optimized_constraints -> HashRef[CODE]
+=head2 C<< list_all_builtin_type_constraints -> (Names) >>
+
+Returns the names of builtin type constraints.
+
+=head2 C<< list_all_type_constraints -> (Names) >>
-Returns the simple type constraints that Mouse understands.
+Returns the names of all the type constraints.
=head1 FUNCTIONS
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 59;
-
-use Mouse::Util;
-use Test::Exception;
-
-{
- package Point;
- use Mouse;
-
- has 'x' => (isa => 'Int', is => 'ro');
- has 'y' => (isa => 'Int', is => 'rw');
-
- sub clear {
- my $self = shift;
- $self->{x} = 0;
- $self->y(0);
- }
-
- __PACKAGE__->meta->make_immutable();
-}{
- package Point3D;
- use Mouse;
-
- extends 'Point';
-
- has 'z' => (isa => 'Int', is => 'bare');
-
- after 'clear' => sub {
- my $self = shift;
- $self->{z} = 0;
- };
-
- __PACKAGE__->meta->make_immutable();
-}
-
-my $point = Point->new(x => 1, y => 2);
-isa_ok($point, 'Point');
-isa_ok($point, 'Mouse::Object');
-
-is($point->x, 1, '... got the right value for x');
-is($point->y, 2, '... got the right value for y');
-
-$point->y(10);
-is($point->y, 10, '... got the right (changed) value for y');
-
-dies_ok {
- $point->y('Foo');
-} '... cannot assign a non-Int to y';
-
-dies_ok {
- $point->x(1000);
-} '... cannot assign to a read-only method';
-is($point->x, 1, '... got the right (un-changed) value for x');
-
-$point->clear();
-
-is($point->x, 0, '... got the right (cleared) value for x');
-is($point->y, 0, '... got the right (cleared) value for y');
-
-# check the type constraints on the constructor
-
-lives_ok {
- Point->new(x => 0, y => 0);
-} '... can assign a 0 to x and y';
-
-dies_ok {
- Point->new(x => 10, y => 'Foo');
-} '... cannot assign a non-Int to y';
-
-dies_ok {
- Point->new(x => 'Foo', y => 10);
-} '... cannot assign a non-Int to x';
-
-# Point3D
-
-my $point3d = Point3D->new({ x => 10, y => 15, z => 3 });
-isa_ok($point3d, 'Point3D');
-isa_ok($point3d, 'Point');
-isa_ok($point3d, 'Mouse::Object');
-
-is($point3d->x, 10, '... got the right value for x');
-is($point3d->y, 15, '... got the right value for y');
-is($point3d->{'z'}, 3, '... got the right value for z');
-
-dies_ok {
- $point3d->z;
-} '... there is no method for z';
-
-$point3d->clear();
-
-is($point3d->x, 0, '... got the right (cleared) value for x');
-is($point3d->y, 0, '... got the right (cleared) value for y');
-is($point3d->{'z'}, 0, '... got the right (cleared) value for z');
-
-dies_ok {
- Point3D->new(x => 10, y => 'Foo', z => 3);
-} '... cannot assign a non-Int to y';
-
-dies_ok {
- Point3D->new(x => 'Foo', y => 10, z => 3);
-} '... cannot assign a non-Int to x';
-
-dies_ok {
- Point3D->new(x => 0, y => 10, z => 'Bar');
-} '... cannot assign a non-Int to z';
-
-# test some class introspection
-
-can_ok('Point', 'meta');
-isa_ok(Point->meta, 'Mouse::Meta::Class');
-
-can_ok('Point3D', 'meta');
-isa_ok(Point3D->meta, 'Mouse::Meta::Class');
-
-isnt(Point->meta, Point3D->meta, '... they are different metaclasses as well');
-
-# poke at Point
-
-is_deeply(
- [ Point->meta->superclasses ],
- [ 'Mouse::Object' ],
- '... Point got the automagic base class');
-
-my @Point_methods = qw(meta new x y clear DESTROY);
-my @Point_attrs = ('x', 'y');
-
-is_deeply(
- [ sort @Point_methods ],
- [ sort Point->meta->get_method_list() ],
- '... we match the method list for Point');
-
-SKIP: {
- skip "Mouse has no method introspection", 1 + @Point_methods;
-
- is_deeply(
- [ sort @Point_attrs ],
- [ sort Point->meta->get_attribute_list() ],
- '... we match the attribute list for Point');
-
- foreach my $method (@Point_methods) {
- ok(Point->meta->has_method($method), '... Point has the method "' . $method . '"');
- }
-}
-
-foreach my $attr_name (@Point_attrs ) {
- ok(Point->meta->has_attribute($attr_name), '... Point has the attribute "' . $attr_name . '"');
- my $attr = Point->meta->get_attribute($attr_name);
- ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
-
- SKIP: {
- skip "Mouse type constraints are not objects", 2;
- isa_ok($attr->type_constraint, 'Mouse::Meta::TypeConstraint');
- is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
- }
-}
-
-# poke at Point3D
-
-is_deeply(
- [ Point3D->meta->superclasses ],
- [ 'Point' ],
- '... Point3D gets the parent given to it');
-
-my @Point3D_methods = qw(new meta clear DESTROY);
-my @Point3D_attrs = ('z');
-
-SKIP: {
- skip "Mouse has no method introspection", 2 + @Point3D_methods;
-
- is_deeply(
- [ sort @Point3D_methods ],
- [ sort Point3D->meta->get_method_list() ],
- '... we match the method list for Point3D');
-
- is_deeply(
- [ sort @Point3D_attrs ],
- [ sort Point3D->meta->get_attribute_list() ],
- '... we match the attribute list for Point3D');
-
- foreach my $method (@Point3D_methods) {
- ok(Point3D->meta->has_method($method), '... Point3D has the method "' . $method . '"');
- }
-};
-
-foreach my $attr_name (@Point3D_attrs ) {
- ok(Point3D->meta->has_attribute($attr_name), '... Point3D has the attribute "' . $attr_name . '"');
- my $attr = Point3D->meta->get_attribute($attr_name);
- ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
- SKIP: {
- skip "Mouse type constraints are not objects", 2;
- isa_ok($attr->type_constraint, 'Mouse::Meta::TypeConstraint');
- is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
- };
-}
-
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+{
+
+ package Point;
+ use Mouse;
+
+ has 'x' => (isa => 'Int', is => 'rw', required => 1);
+ has 'y' => (isa => 'Int', is => 'rw', required => 1);
+
+ sub clear {
+ my $self = shift;
+ $self->x(0);
+ $self->y(0);
+ }
+
+ package Point3D;
+ use Mouse;
+
+ extends 'Point';
+
+ has 'z' => (isa => 'Int', is => 'rw', required => 1);
+
+ after 'clear' => sub {
+ my $self = shift;
+ $self->z(0);
+ };
+
+ package main;
+
+ # hash or hashrefs are ok for the constructor
+ my $point1 = Point->new(x => 5, y => 7);
+ my $point2 = Point->new({x => 5, y => 7});
+
+ my $point3d = Point3D->new(x => 5, y => 42, z => -5);
+}
+
+
+
+# =begin testing
+{
+my $point = Point->new( x => 1, y => 2 );
+isa_ok( $point, 'Point' );
+isa_ok( $point, 'Mouse::Object' );
+
+is( $point->x, 1, '... got the right value for x' );
+is( $point->y, 2, '... got the right value for y' );
+
+$point->y(10);
+is( $point->y, 10, '... got the right (changed) value for y' );
+
+dies_ok {
+ $point->y('Foo');
+}
+'... cannot assign a non-Int to y';
+
+dies_ok {
+ Point->new();
+}
+'... must provide required attributes to new';
+
+$point->clear();
+
+is( $point->x, 0, '... got the right (cleared) value for x' );
+is( $point->y, 0, '... got the right (cleared) value for y' );
+
+# check the type constraints on the constructor
+
+lives_ok {
+ Point->new( x => 0, y => 0 );
+}
+'... can assign a 0 to x and y';
+
+dies_ok {
+ Point->new( x => 10, y => 'Foo' );
+}
+'... cannot assign a non-Int to y';
+
+dies_ok {
+ Point->new( x => 'Foo', y => 10 );
+}
+'... cannot assign a non-Int to x';
+
+# Point3D
+
+my $point3d = Point3D->new( { x => 10, y => 15, z => 3 } );
+isa_ok( $point3d, 'Point3D' );
+isa_ok( $point3d, 'Point' );
+isa_ok( $point3d, 'Mouse::Object' );
+
+is( $point3d->x, 10, '... got the right value for x' );
+is( $point3d->y, 15, '... got the right value for y' );
+is( $point3d->{'z'}, 3, '... got the right value for z' );
+
+$point3d->clear();
+
+is( $point3d->x, 0, '... got the right (cleared) value for x' );
+is( $point3d->y, 0, '... got the right (cleared) value for y' );
+is( $point3d->z, 0, '... got the right (cleared) value for z' );
+
+dies_ok {
+ Point3D->new( x => 10, y => 'Foo', z => 3 );
+}
+'... cannot assign a non-Int to y';
+
+dies_ok {
+ Point3D->new( x => 'Foo', y => 10, z => 3 );
+}
+'... cannot assign a non-Int to x';
+
+dies_ok {
+ Point3D->new( x => 0, y => 10, z => 'Bar' );
+}
+'... cannot assign a non-Int to z';
+
+dies_ok {
+ Point3D->new( x => 10, y => 3 );
+}
+'... z is a required attribute for Point3D';
+
+# test some class introspection
+
+can_ok( 'Point', 'meta' );
+isa_ok( Point->meta, 'Mouse::Meta::Class' );
+
+can_ok( 'Point3D', 'meta' );
+isa_ok( Point3D->meta, 'Mouse::Meta::Class' );
+
+isnt( Point->meta, Point3D->meta,
+ '... they are different metaclasses as well' );
+
+# poke at Point
+
+is_deeply(
+ [ Point->meta->superclasses ],
+ ['Mouse::Object'],
+ '... Point got the automagic base class'
+);
+
+my @Point_methods = qw(meta x y clear);
+my @Point_attrs = ( 'x', 'y' );
+
+is_deeply(
+ [ sort @Point_methods ],
+ [ sort Point->meta->get_method_list() ],
+ '... we match the method list for Point'
+);
+
+is_deeply(
+ [ sort @Point_attrs ],
+ [ sort Point->meta->get_attribute_list() ],
+ '... we match the attribute list for Point'
+);
+
+foreach my $method (@Point_methods) {
+ ok( Point->meta->has_method($method),
+ '... Point has the method "' . $method . '"' );
+}
+
+foreach my $attr_name (@Point_attrs) {
+ ok( Point->meta->has_attribute($attr_name),
+ '... Point has the attribute "' . $attr_name . '"' );
+ my $attr = Point->meta->get_attribute($attr_name);
+ ok( $attr->has_type_constraint,
+ '... Attribute ' . $attr_name . ' has a type constraint' );
+ isa_ok( $attr->type_constraint, 'Mouse::Meta::TypeConstraint' );
+ is( $attr->type_constraint->name, 'Int',
+ '... Attribute ' . $attr_name . ' has an Int type constraint' );
+}
+
+# poke at Point3D
+
+is_deeply(
+ [ Point3D->meta->superclasses ],
+ ['Point'],
+ '... Point3D gets the parent given to it'
+);
+
+my @Point3D_methods = qw( meta z clear );
+my @Point3D_attrs = ('z');
+
+is_deeply(
+ [ sort @Point3D_methods ],
+ [ sort Point3D->meta->get_method_list() ],
+ '... we match the method list for Point3D'
+);
+
+is_deeply(
+ [ sort @Point3D_attrs ],
+ [ sort Point3D->meta->get_attribute_list() ],
+ '... we match the attribute list for Point3D'
+);
+
+foreach my $method (@Point3D_methods) {
+ ok( Point3D->meta->has_method($method),
+ '... Point3D has the method "' . $method . '"' );
+}
+
+foreach my $attr_name (@Point3D_attrs) {
+ ok( Point3D->meta->has_attribute($attr_name),
+ '... Point3D has the attribute "' . $attr_name . '"' );
+ my $attr = Point3D->meta->get_attribute($attr_name);
+ ok( $attr->has_type_constraint,
+ '... Attribute ' . $attr_name . ' has a type constraint' );
+ isa_ok( $attr->type_constraint, 'Mouse::Meta::TypeConstraint' );
+ is( $attr->type_constraint->name, 'Int',
+ '... Attribute ' . $attr_name . ' has an Int type constraint' );
+}
+}
+
+
+
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+{
+
+ package Document::Page;
+ use Mouse;
+
+ has 'body' => ( is => 'rw', isa => 'Str', default => sub {''} );
+
+ sub create {
+ my $self = shift;
+ $self->open_page;
+ inner();
+ $self->close_page;
+ }
+
+ sub append_body {
+ my ( $self, $appendage ) = @_;
+ $self->body( $self->body . $appendage );
+ }
+
+ sub open_page { (shift)->append_body('<page>') }
+ sub close_page { (shift)->append_body('</page>') }
+
+ package Document::PageWithHeadersAndFooters;
+ use Mouse;
+
+ extends 'Document::Page';
+
+ augment 'create' => sub {
+ my $self = shift;
+ $self->create_header;
+ inner();
+ $self->create_footer;
+ };
+
+ sub create_header { (shift)->append_body('<header/>') }
+ sub create_footer { (shift)->append_body('<footer/>') }
+
+ package TPSReport;
+ use Mouse;
+
+ extends 'Document::PageWithHeadersAndFooters';
+
+ augment 'create' => sub {
+ my $self = shift;
+ $self->create_tps_report;
+ inner();
+ };
+
+ sub create_tps_report {
+ (shift)->append_body('<report type="tps"/>');
+ }
+
+ # <page><header/><report type="tps"/><footer/></page>
+ my $report_xml = TPSReport->new->create;
+}
+
+
+
+# =begin testing
+{
+my $tps_report = TPSReport->new;
+isa_ok( $tps_report, 'TPSReport' );
+
+is(
+ $tps_report->create,
+ q{<page><header/><report type="tps"/><footer/></page>},
+ '... got the right TPS report'
+);
+}
+
+
+
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+BEGIN {
+ eval 'use Test::Output;';
+ if ($@) {
+ diag 'Test::Output is required for this test';
+ ok(1);
+ exit 0;
+ }
+}
+
+
+
+# =begin testing SETUP
+{
+
+ package MyApp::Base;
+ use Mouse;
+
+ extends 'Mouse::Object';
+
+ before 'new' => sub { warn "Making a new " . $_[0] };
+
+ no Mouse;
+
+ package MyApp::UseMyBase;
+ use Mouse ();
+ use Mouse::Exporter;
+
+ Mouse::Exporter->setup_import_methods( also => 'Mouse' );
+
+ sub init_meta {
+ shift;
+ return Mouse->init_meta( @_, base_class => 'MyApp::Base' );
+ }
+}
+
+
+
+# =begin testing
+{
+{
+ package Foo;
+
+ MyApp::UseMyBase->import;
+
+ has( 'size' => ( is => 'rw' ) );
+}
+
+ok( Foo->isa('MyApp::Base'), 'Foo isa MyApp::Base' );
+
+ok( Foo->can('size'), 'Foo has a size method' );
+
+my $foo;
+stderr_like(
+ sub { $foo = Foo->new( size => 2 ) },
+ qr/^Making a new Foo/,
+ 'got expected warning when calling Foo->new'
+);
+
+is( $foo->size(), 2, '$foo->size is 2' );
+}
+
+
+
+
+1;
# =begin testing SETUP
{
- package MyApp::Meta::Attribute::Trait::Labeled;
- use Mouse::Role;
+ package MyApp::Meta::Attribute::Labeled;
+ use Mouse;
+ extends 'Mouse::Meta::Attribute';
has label => (
is => 'rw',
predicate => 'has_label',
);
- package Mouse::Meta::Attribute::Custom::Trait::Labeled;
- sub register_implementation {'MyApp::Meta::Attribute::Trait::Labeled'}
+ package Mouse::Meta::Attribute::Custom::Labeled;
+ sub register_implementation {'MyApp::Meta::Attribute::Labeled'}
package MyApp::Website;
use Mouse;
has url => (
- traits => [qw/Labeled/],
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
+ metaclass => 'Labeled',
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
);
has name => (
my $dump = '';
- my %attributes = %{ $self->meta->get_attribute_map };
- for my $name ( sort keys %attributes ) {
- my $attribute = $attributes{$name};
+ for my $name ( sort $self->meta->get_attribute_list ) {
+ my $attribute = $self->meta->get_attribute($name);
- if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
+ if ( $attribute->isa('MyApp::Meta::Attribute::Labeled')
&& $attribute->has_label ) {
$dump .= $attribute->label;
}
# =begin testing
{
-my $app2
- = MyApp::Website->new( url => "http://google.com", name => "Google" );
+my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
is(
- $app2->dump, q{name: Google
+ $app->dump, q{name: Google
The site's URL: http://google.com
}, '... got the expected dump value'
);
my $dump = '';
- my %attributes = %{ $self->meta->get_attribute_map };
- for my $name ( sort keys %attributes ) {
- my $attribute = $attributes{$name};
+ for my $name ( sort $self->meta->get_attribute_list ) {
+ my $attribute = $self->meta->get_attribute($name);
if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
&& $attribute->has_label ) {
$dump .= $name;
}
- my $reader = $attribute->get_read_method;
- $dump .= ": " . $self->$reader . "\n";
+ my $reader = $attribute->get_read_method_ref;
+ $dump .= ": " . $reader->($self) . "\n";
}
return $dump;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+{
+
+ package Eq;
+ use Mouse::Role;
+
+ requires 'equal_to';
+
+ sub not_equal_to {
+ my ( $self, $other ) = @_;
+ not $self->equal_to($other);
+ }
+
+ package Comparable;
+ use Mouse::Role;
+
+ with 'Eq';
+
+ requires 'compare';
+
+ sub equal_to {
+ my ( $self, $other ) = @_;
+ $self->compare($other) == 0;
+ }
+
+ sub greater_than {
+ my ( $self, $other ) = @_;
+ $self->compare($other) == 1;
+ }
+
+ sub less_than {
+ my ( $self, $other ) = @_;
+ $self->compare($other) == -1;
+ }
+
+ sub greater_than_or_equal_to {
+ my ( $self, $other ) = @_;
+ $self->greater_than($other) || $self->equal_to($other);
+ }
+
+ sub less_than_or_equal_to {
+ my ( $self, $other ) = @_;
+ $self->less_than($other) || $self->equal_to($other);
+ }
+
+ package Printable;
+ use Mouse::Role;
+
+ requires 'to_string';
+
+ package US::Currency;
+ use Mouse;
+
+ with 'Comparable', 'Printable';
+
+ has 'amount' => ( is => 'rw', isa => 'Num', default => 0 );
+
+ sub compare {
+ my ( $self, $other ) = @_;
+ $self->amount <=> $other->amount;
+ }
+
+ sub to_string {
+ my $self = shift;
+ sprintf '$%0.2f USD' => $self->amount;
+ }
+}
+
+
+
+# =begin testing
+{
+ok( US::Currency->does('Comparable'), '... US::Currency does Comparable' );
+ok( US::Currency->does('Eq'), '... US::Currency does Eq' );
+ok( US::Currency->does('Printable'), '... US::Currency does Printable' );
+
+my $hundred = US::Currency->new( amount => 100.00 );
+isa_ok( $hundred, 'US::Currency' );
+{
+local $TODO = 'UNIVERSAL::DOES is not supported';
+ok( eval{ $hundred->DOES("US::Currency") }, "UNIVERSAL::DOES for class" );
+ok( eval{ $hundred->DOES("Comparable") }, "UNIVERSAL::DOES for role" );
+}
+can_ok( $hundred, 'amount' );
+is( $hundred->amount, 100, '... got the right amount' );
+
+can_ok( $hundred, 'to_string' );
+is( $hundred->to_string, '$100.00 USD',
+ '... got the right stringified value' );
+
+ok( $hundred->does('Comparable'), '... US::Currency does Comparable' );
+ok( $hundred->does('Eq'), '... US::Currency does Eq' );
+ok( $hundred->does('Printable'), '... US::Currency does Printable' );
+
+my $fifty = US::Currency->new( amount => 50.00 );
+isa_ok( $fifty, 'US::Currency' );
+
+can_ok( $fifty, 'amount' );
+is( $fifty->amount, 50, '... got the right amount' );
+
+can_ok( $fifty, 'to_string' );
+is( $fifty->to_string, '$50.00 USD', '... got the right stringified value' );
+
+ok( $hundred->greater_than($fifty), '... 100 gt 50' );
+ok( $hundred->greater_than_or_equal_to($fifty), '... 100 ge 50' );
+ok( !$hundred->less_than($fifty), '... !100 lt 50' );
+ok( !$hundred->less_than_or_equal_to($fifty), '... !100 le 50' );
+ok( !$hundred->equal_to($fifty), '... !100 eq 50' );
+ok( $hundred->not_equal_to($fifty), '... 100 ne 50' );
+
+ok( !$fifty->greater_than($hundred), '... !50 gt 100' );
+ok( !$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100' );
+ok( $fifty->less_than($hundred), '... 50 lt 100' );
+ok( $fifty->less_than_or_equal_to($hundred), '... 50 le 100' );
+ok( !$fifty->equal_to($hundred), '... !50 eq 100' );
+ok( $fifty->not_equal_to($hundred), '... 50 ne 100' );
+
+ok( !$fifty->greater_than($fifty), '... !50 gt 50' );
+ok( $fifty->greater_than_or_equal_to($fifty), '... !50 ge 50' );
+ok( !$fifty->less_than($fifty), '... 50 lt 50' );
+ok( $fifty->less_than_or_equal_to($fifty), '... 50 le 50' );
+ok( $fifty->equal_to($fifty), '... 50 eq 50' );
+ok( !$fifty->not_equal_to($fifty), '... !50 ne 50' );
+
+## ... check some meta-stuff
+
+# Eq
+
+my $eq_meta = Eq->meta;
+isa_ok( $eq_meta, 'Mouse::Meta::Role' );
+
+ok( $eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to' );
+ok( $eq_meta->requires_method('equal_to'),
+ '... Eq requires_method not_equal_to' );
+
+# Comparable
+
+my $comparable_meta = Comparable->meta;
+isa_ok( $comparable_meta, 'Mouse::Meta::Role' );
+
+ok( $comparable_meta->does_role('Eq'), '... Comparable does Eq' );
+
+foreach my $method_name (
+ qw(
+ equal_to not_equal_to
+ greater_than greater_than_or_equal_to
+ less_than less_than_or_equal_to
+ )
+ ) {
+ ok( $comparable_meta->has_method($method_name),
+ '... Comparable has_method ' . $method_name );
+}
+
+ok( $comparable_meta->requires_method('compare'),
+ '... Comparable requires_method compare' );
+
+# Printable
+
+my $printable_meta = Printable->meta;
+isa_ok( $printable_meta, 'Mouse::Meta::Role' );
+
+ok( $printable_meta->requires_method('to_string'),
+ '... Printable requires_method to_string' );
+
+# US::Currency
+
+my $currency_meta = US::Currency->meta;
+isa_ok( $currency_meta, 'Mouse::Meta::Class' );
+
+ok( $currency_meta->does_role('Comparable'),
+ '... US::Currency does Comparable' );
+ok( $currency_meta->does_role('Eq'), '... US::Currency does Eq' );
+ok( $currency_meta->does_role('Printable'),
+ '... US::Currency does Printable' );
+
+foreach my $method_name (
+ qw(
+ amount
+ equal_to not_equal_to
+ compare
+ greater_than greater_than_or_equal_to
+ less_than less_than_or_equal_to
+ to_string
+ )
+ ) {
+ ok( $currency_meta->has_method($method_name),
+ '... US::Currency has_method ' . $method_name );
+}
+}
+
+
+
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+{
+ # Not in the recipe, but needed for writing tests.
+ package Employee;
+
+ use Mouse;
+
+ has 'name' => (
+ is => 'ro',
+ isa => 'Str',
+ required => 1,
+ );
+
+ has 'work' => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_work',
+ );
+}
+
+
+
+# =begin testing SETUP
+{
+
+ package MyApp::Role::Job::Manager;
+
+ use List::Util qw( first );
+
+ use Mouse::Role;
+
+ has 'employees' => (
+ is => 'rw',
+ isa => 'ArrayRef[Employee]',
+ );
+
+ sub assign_work {
+ my $self = shift;
+ my $work = shift;
+
+ my $employee = first { !$_->has_work } @{ $self->employees };
+
+ die 'All my employees have work to do!' unless $employee;
+
+ $employee->work($work);
+ }
+
+ package main;
+
+ my $lisa = Employee->new( name => 'Lisa' );
+ MyApp::Role::Job::Manager->meta->apply($lisa);
+
+ my $homer = Employee->new( name => 'Homer' );
+ my $bart = Employee->new( name => 'Bart' );
+ my $marge = Employee->new( name => 'Marge' );
+
+ $lisa->employees( [ $homer, $bart, $marge ] );
+ $lisa->assign_work('mow the lawn');
+}
+
+
+
+# =begin testing
+{
+{
+ my $lisa = Employee->new( name => 'Lisa' );
+ MyApp::Role::Job::Manager->meta->apply($lisa);
+
+ my $homer = Employee->new( name => 'Homer' );
+ my $bart = Employee->new( name => 'Bart' );
+ my $marge = Employee->new( name => 'Marge' );
+
+ $lisa->employees( [ $homer, $bart, $marge ] );
+ $lisa->assign_work('mow the lawn');
+
+ ok( $lisa->does('MyApp::Role::Job::Manager'),
+ 'lisa now does the manager role' );
+
+ is( $homer->work, 'mow the lawn',
+ 'homer was assigned a task by lisa' );
+}
+}
+
+
+
+
+1;
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More tests => 18;
use Test::Exception;
+use lib 't/lib';
+use Test::Mouse;
+
do {
package Class;
use Mouse;
ok(!Class->can('x'), "No accessor is injected if 'is' has no value");
can_ok('Class', 'y', 'z');
+has_attribute_ok 'Class', 'x';
+has_attribute_ok 'Class', 'y';
+has_attribute_ok 'Class', 'z';
+
my $object = Class->new;
ok(!$object->can('x'), "No accessor is injected if 'is' has no value");
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 36;
+
+do {
+ package Class;
+ use Mouse;
+
+ has 'x' => (
+ is => 'rw',
+ default => 10,
+ );
+
+ has 'y' => (
+ is => 'rw',
+ default => 20,
+ );
+
+ has 'z' => (
+ is => 'rw',
+ );
+};
+
+for(1 .. 2){
+ 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");
+
+ Class->meta->make_immutable;
+}
};
can_ok(Class => qw/a b c/);
-is(keys %{ Class->meta->get_attribute_map }, 3, "three attributes created");
+is_deeply([sort Class->meta->get_attribute_list], [sort qw/a b c/], "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 => 20;
+
+do {
+ package Class;
+ use Mouse;
+
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ init_arg => 'key',
+ default => 'default',
+ );
+
+ has no_init_arg => (
+ is => 'rw',
+ isa => 'Str',
+ init_arg => undef,
+ default => 'default',
+ );
+
+};
+
+for('mutable', 'immutable'){
+ my $object = Class->new;
+ is($object->name, 'default', "accessor uses attribute name ($_)");
+ is($object->{key}, undef, 'nothing in object->{init_arg}!');
+ is($object->{name}, 'default', 'value is in object->{name}');
+
+ my $object2 = Class->new(name => 'name', key => 'key');
+ is($object2->name, 'key', 'attribute value is from name');
+ is($object2->{key}, undef, 'no value for the init_arg');
+ is($object2->{name}, 'key', 'value is in key from name');
+
+ 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');
+
+ my $object3 = Class->new(no_init_arg => 'joe');
+ is($object3->no_init_arg, 'default', 'init_arg => undef ignores attribute name in the constructor');
+
+ Class->meta->make_immutable;
+}
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 12;
use Test::Exception;
+my %triggered;
do {
package Foo;
use Mouse;
has quux => (
is => 'rw',
init_arg => 'quuux',
+ trigger => sub{
+ my($self, $value) = @_;
+ $triggered{$self} = $value;
+ },
);
sub clone {
is($foo->foo, "foo", "attr 1",);
is($foo->quux, "indeed", "init_arg respected");
+
+is $triggered{$foo}, "indeed";
+
is_deeply($foo->bar, [ 1 .. 3 ], "attr 2");
$foo->baz("foo");
my $clone = $foo->clone(foo => "dancing", baz => "bar", quux => "nope", quuux => "yes");
+is $triggered{$foo}, "indeed";
+is $triggered{$clone}, "yes", 'clone_object() invokes triggers';
+
is($clone->foo, "dancing", "overridden attr");
is_deeply($clone->bar, [ 1 .. 3 ], "clone attr");
is($clone->baz, "foo", "init_arg=undef means the attr is ignored");
throws_ok {
Foo->meta->clone_object(Foo->meta)
-} qr/You must pass an instance of the metaclass \(Foo\), not \(Mo.se::Meta::Class=HASH\(\w+\)\)/;
+} qr/You must pass an instance of the metaclass \(Foo\), not \(Mouse::Meta::Class=HASH\(\w+\)\)/;
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 7;
use Test::Exception;
+use Mouse::Util::TypeConstraints;
+
do {
package My::Class;
use Mouse;
throws_ok { My::Class->new(name => '') } qr/^Attribute \(name\) does not pass the type constraint because: The string is empty!/;
+my $st = subtype as 'Str', where{ length };
+
+ok $st->is_a_type_of('Str');
+ok!$st->is_a_type_of('NoemptyStr');
+
+ok $st->check('Foo');
+ok!$st->check(undef);
+ok!$st->check('');
+
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 16;
+use Test::More tests => 46;
use Test::Exception;
{
package Bar;
use Mouse;
use Mouse::Util::TypeConstraints;
-
+
subtype 'Bar::List'
=> as 'ArrayRef[HashRef]'
;
} qr/Attribute \(list\) does not pass the type constraint because: Validation failed for 'Bar::List' failed with value/, "Bad coercion parameter throws an error";
}
+use Mouse::Util::TypeConstraints;
+
+my $t = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]');
+ok $t->is_a_type_of($t), "$t is a type of $t";
+ok $t->is_a_type_of('Maybe'), "$t is a type of Maybe";
+
+# XXX: how about 'MaybeInt[ Int ]'?
+ok $t->is_a_type_of('Maybe[Int]'), "$t is a type of Maybe[Int]";
+
+ok!$t->is_a_type_of('Int');
+
+ok $t->check(10);
+ok $t->check(undef);
+ok!$t->check(3.14);
+
+my $u = subtype 'MaybeInt', as 'Maybe[Int]';
+ok $u->is_a_type_of($t), "$t is a type of $t";
+ok $u->is_a_type_of('Maybe'), "$t is a type of Maybe";
+
+# XXX: how about 'MaybeInt[ Int ]'?
+ok $u->is_a_type_of('Maybe[Int]'), "$t is a type of Maybe[Int]";
+
+ok!$u->is_a_type_of('Int');
+
+ok $u->check(10);
+ok $u->check(undef);
+ok!$u->check(3.14);
+
+# XXX: undefined hehaviour
+# ok $t->is_a_type_of($u);
+# ok $u->is_a_type_of($t);
+
+my $w = subtype as 'Maybe[ ArrayRef | HashRef ]';
+
+ok $w->check(undef);
+ok $w->check([]);
+ok $w->check({});
+ok!$w->check(sub{});
+
+ok $w->is_a_type_of('Maybe');
+ok $w->is_a_type_of('Maybe[ArrayRef|HashRef]');
+ok!$w->is_a_type_of('ArrayRef');
+
+my $x = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[ ArrayRef[ Int | Undef ] ]');
+
+ok $x->is_a_type_of('ArrayRef');
+ok $x->is_a_type_of('ArrayRef[ArrayRef[Int|Undef]]');
+ok!$x->is_a_type_of('ArrayRef[ArrayRef[Str]]');
+
+ok $x->check([]);
+ok $x->check([[]]);
+ok $x->check([[10]]);
+ok $x->check([[10, undef]]);
+ok!$x->check([[10, 3.14]]);
+ok!$x->check({});
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 7;
use lib 't/lib';
do {
- # copied from MouseX::AttributeHelpers;
+ # copied from MooseX::AttributeHelpers;
package MouseX::AttributeHelpers::Trait::Base;
use Mouse::Role;
use Mouse::Util::TypeConstraints;
# extend the parents stuff to make sure
# certain bits are now required ...
- #has '+default' => (required => 1);
- #has '+type_constraint' => (required => 1);
+ #has 'default' => (required => 1);
+ has 'type_constraint' => (is => 'rw', required => 1);
## Methods called prior to instantiation
# grab the reader and writer methods
# as well, this will be useful for
# our method provider constructors
- my $attr_reader = $attr->get_read_method;
- my $attr_writer = $attr->get_write_method;
+ my $attr_reader = $attr->get_read_method_ref;
+ my $attr_writer = $attr->get_write_method_ref;
# before we install them, lets
sub helper_type { 'Num' }
- has 'method_constructors' => (
- is => 'ro',
- isa => 'HashRef',
- lazy => 1,
- default => sub {
- return +{
- set => sub {
- my ($attr, $reader, $writer) = @_;
- return sub { $_[0]->$writer($_[1]) };
- },
- add => sub {
- my ($attr, $reader, $writer) = @_;
- return sub { $_[0]->$writer($_[0]->$reader() + $_[1]) };
- },
- sub => sub {
- my ($attr, $reader, $writer) = @_;
- return sub { $_[0]->$writer($_[0]->$reader() - $_[1]) };
+ 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
},
- mul => sub {
- my ($attr, $reader, $writer) = @_;
- return sub { $_[0]->$writer($_[0]->$reader() * $_[1]) };
+ get => sub {\r
+ my ( $attr, $reader, $writer ) = @_;\r
+ return sub { $reader->( $_[0] ) };\r
},
- div => sub {
- my ($attr, $reader, $writer) = @_;
- return sub { $_[0]->$writer($_[0]->$reader() / $_[1]) };
- },
- mod => sub {
- my ($attr, $reader, $writer) = @_;
- return sub { $_[0]->$writer($_[0]->$reader() % $_[1]) };
- },
- abs => sub {
- my ($attr, $reader, $writer) = @_;
- return sub { $_[0]->$writer(abs($_[0]->$reader()) ) };
- },
- }
- }
- );
+ 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
package MouseX::AttributeHelpers::Number;
use Mouse;
use Mouse;
has 'ii' => (
- is => 'rw',
isa => 'Num',
+ predicate => 'has_ii',
+
provides => {
sub => 'ii_minus',
abs => 'ii_abs',
+ get => 'get_ii',
+ set => 'set_ii',
},
traits => [qw(MyNumber)],
$k = MyClassWithTraits->new(ii => 10);
$k->ii_minus(100);
-is $k->ii, -90;
-is $k->ii_abs, 90;
+is $k->get_ii, -90;
+$k->ii_abs;
+is $k->get_ii, 90;
+
+$k->set_ii(10);
+is $k->get_ii, 10;
+$k->ii_abs;
+is $k->get_ii, 10;
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+use Test::More tests => 6;
+
+use Mouse::Util::TypeConstraints;
+
+{
+ package Foo;
+ use Mouse;
+
+ has my_class => (
+ is => 'rw',
+ isa => 'My::New::Class | Str',
+ );
+}
+my $t = Foo->meta->get_attribute('my_class')->type_constraint;
+
+eval q{
+ package My::New::Class;
+ use Mouse;
+ package My::New::DerivedClass;
+ use Mouse;
+ extends 'My::New::Class';
+};
+
+isa_ok $t, 'Mouse::Meta::TypeConstraint';
+ok $t->check(My::New::Class->new);
+ok $t->check(My::New::DerivedClass->new);
+ok $t->check('Foo');
+ok!$t->check(undef);
+ok!$t->check(bless {}, 'Foo');
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 14;
+use Test::Exception;
+{
+ package My::Meta::Class;
+ use Mouse;
+ extends 'Mouse::Meta::Class';
+
+ has my_class_attr => (
+ is => 'rw',
+ default => 42,
+ );
+ package My::Meta::Role;
+ use Mouse;
+ extends 'Mouse::Meta::Role';
+
+ has my_role_attr => (
+ is => 'rw',
+ default => 43,
+ );
+ package My::Meta::Attribute;
+ use Mouse;
+ extends 'Mouse::Meta::Attribute';
+
+ has my_attr_attr => (
+ is => 'rw',
+ default => 44,
+ );
+}
+
+my $meta = My::Meta::Class->initialize('Foo');
+isa_ok $meta, 'My::Meta::Class';
+isa_ok $meta->meta, 'Mouse::Meta::Class';
+can_ok $meta, qw(name my_class_attr);
+is $meta->name, 'Foo';
+lives_and{
+ is $meta->my_class_attr, 42;
+};
+
+$meta = My::Meta::Role->initialize('Bar');
+isa_ok $meta, 'My::Meta::Role';
+isa_ok $meta->meta, 'Mouse::Meta::Class';
+can_ok $meta, qw(name my_role_attr);
+is $meta->name, 'Bar';
+lives_and{
+ is $meta->my_role_attr, 43;
+};
+
+$meta = My::Meta::Attribute->new('baz');
+isa_ok $meta, 'My::Meta::Attribute';
+can_ok $meta, qw(name my_attr_attr);
+is $meta->name, 'baz';
+lives_and{
+ is $meta->my_attr_attr, 44;
+};
+
--- /dev/null
+#!perl\r
+# This is based on Class-MOP/t/312_anon_class_leak.t\r
+use strict;\r
+use warnings;\r
+use Test::More;\r
+\r
+BEGIN {\r
+ eval "use Test::LeakTrace 0.10;";\r
+ plan skip_all => "Test::LeakTrace 0.10 is required for this test" if $@;\r
+}\r
+\r
+plan tests => 6;\r
+\r
+use Mouse ();\r
+{\r
+ package MyRole;\r
+ use Mouse::Role;\r
+\r
+ sub my_role_method{ }\r
+}\r
+\r
+# 5.10.0 has a bug on weaken($hash_ref) which leaks an AV.\r
+my $expected = ( $] == 5.010_000 ? 1 : 0 );\r
+\r
+leaks_cmp_ok {\r
+ Mouse::Meta::Class->create_anon_class();\r
+} '<=', $expected, 'create_anon_class()';\r
+\r
+leaks_cmp_ok {\r
+ Mouse::Meta::Class->create_anon_class(superclasses => ['Mouse::Meta::Class']);\r
+} '<=', $expected, 'create_anon_class() with superclasses';\r
+\r
+leaks_cmp_ok {\r
+ Mouse::Meta::Class->create_anon_class(attributes => [\r
+ Mouse::Meta::Attribute->new('foo', is => 'bare'),\r
+ ]);\r
+} '<=', $expected, 'create_anon_class() with attributes';\r
+\r
+leaks_cmp_ok {\r
+ Mouse::Meta::Class->create_anon_class(roles => [qw(MyRole)]);\r
+} '<=', $expected, 'create_anon_class() with roles';\r
+\r
+\r
+leaks_cmp_ok {\r
+ Mouse::Meta::Role->create_anon_role();\r
+} '<=', $expected, 'create_anon_role()';\r
+\r
+leaks_cmp_ok {\r
+ Mouse::Meta::Role->create_anon_role(roles => [qw(MyRole)]);\r
+} '<=', $expected, 'create_anon_role() with roles';\r
+\r
--- /dev/null
+#!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
--- /dev/null
+#!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
is $child_meta->find_method_by_name('child_method')->fully_qualified_name, 'Child::child_method';
is $child_meta->find_method_by_name('pawn')->fully_qualified_name, 'Class::pawn';
-{
- local $TODO = 'should be Class::MY_CONST';
- is( join(' ', sort map{ $_->fully_qualified_name } grep{ $_->package_name ne 'Mouse::Object' } $child_meta->get_all_methods),
- join(' ', sort qw(
- Child::bishop Child::child_method Child::meta
- Class::MY_CONST Class::has_pawn Class::pawn Class::stub Class::stub_with_attr
- ))
- );
-}
+is( join(' ', sort map{ $_->fully_qualified_name } grep{ $_->package_name ne 'Mouse::Object' } $child_meta->get_all_methods),
+ join(' ', sort qw(
+ Child::bishop Child::child_method Child::meta
+
+ Class::MY_CONST Class::has_pawn Class::pawn Class::stub Class::stub_with_attr
+ ))
+);
+
+++ /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/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+}
+
+can_ok('Foo', 'meta');
+isa_ok(Foo->meta, 'Mouse::Meta::Class');
+
+ok(Foo->meta->has_method('meta'), '... we got the &meta method');
+ok(Foo->isa('Mouse::Object'), '... Foo is automagically a Mouse::Object');
+
+dies_ok {
+ Foo->meta->has_method()
+} '... has_method requires an arg';
+
+can_ok('Foo', 'does');
+
+foreach my $function (qw(
+ extends
+ has
+ before after around
+ blessed confess
+ type subtype as where
+ coerce from via
+ find_type_constraint
+ )) {
+ ok(!Foo->meta->has_method($function), '... the meta does not treat "' . $function . '" as a method');
+}
+
+foreach my $import (qw(
+ blessed
+ try
+ catch
+ in_global_destruction
+)) {
+ ok(!Mouse::Object->can($import), "no namespace pollution in Mouse::Object ($import)" );
+
+ local $TODO = $import eq 'blessed' ? "no automatic namespace cleaning yet" : undef;
+ ok(!Foo->can($import), "no namespace pollution in Mouse::Object ($import)" );
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib';
+
+use Test::More tests => 4;
+use Test::Exception;
+
+
+
+{
+
+ package Bar;
+ use Mouse;
+
+ ::lives_ok { extends 'Foo' } 'loaded Foo superclass correctly';
+}
+
+{
+
+ package Baz;
+ use Mouse;
+
+ ::lives_ok { extends 'Bar' } 'loaded (inline) Bar superclass correctly';
+}
+
+{
+
+ package Foo::Bar;
+ use Mouse;
+
+ ::lives_ok { extends 'Foo', 'Bar' }
+ 'loaded Foo and (inline) Bar superclass correctly';
+}
+
+{
+
+ package Bling;
+ use Mouse;
+
+ ::throws_ok { extends 'No::Class' }
+ qr{Can't locate No/Class\.pm in \@INC},
+ 'correct error when superclass could not be found';
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ sub foo { 'Foo::foo' }
+ sub bar { 'Foo::bar' }
+ sub baz { 'Foo::baz' }
+
+ package Bar;
+ use Mouse;
+
+ extends 'Foo';
+
+ override bar => sub { 'Bar::bar -> ' . super() };
+
+ package Baz;
+ use Mouse;
+
+ extends 'Bar';
+
+ override bar => sub { 'Baz::bar -> ' . super() };
+ override baz => sub { 'Baz::baz -> ' . super() };
+
+ no Mouse; # ensure super() still works after unimport
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+is($baz->foo(), 'Foo::foo', '... got the right value from &foo');
+is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar');
+is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz');
+
+my $bar = Bar->new();
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is($bar->foo(), 'Foo::foo', '... got the right value from &foo');
+is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar');
+is($bar->baz(), 'Foo::baz', '... got the right value from &baz');
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is($foo->foo(), 'Foo::foo', '... got the right value from &foo');
+is($foo->bar(), 'Foo::bar', '... got the right value from &bar');
+is($foo->baz(), 'Foo::baz', '... got the right value from &baz');
+
+# some error cases
+
+{
+ package Bling;
+ use Mouse;
+
+ sub bling { 'Bling::bling' }
+
+ package Bling::Bling;
+ use Mouse;
+
+ extends 'Bling';
+
+ sub bling { 'Bling::bling' }
+
+ ::dies_ok {
+ override 'bling' => sub {};
+ } '... cannot override a method which has a local equivalent';
+
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ sub foo { 'Foo::foo(' . (inner() || '') . ')' }
+ sub bar { 'Foo::bar(' . (inner() || '') . ')' }
+ sub baz { 'Foo::baz(' . (inner() || '') . ')' }
+
+ package Bar;
+ use Mouse;
+
+ extends 'Foo';
+
+ augment foo => sub { 'Bar::foo(' . (inner() || '') . ')' };
+ augment bar => sub { 'Bar::bar' };
+
+ no Mouse; # ensure inner() still works after unimport
+
+ package Baz;
+ use Mouse;
+
+ extends 'Bar';
+
+ augment foo => sub { 'Baz::foo' };
+ augment baz => sub { 'Baz::baz' };
+
+ # this will actually never run,
+ # because Bar::bar does not call inner()
+ augment bar => sub { 'Baz::bar' };
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+is($baz->foo(), 'Foo::foo(Bar::foo(Baz::foo))', '... got the right value from &foo');
+is($baz->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar');
+is($baz->baz(), 'Foo::baz(Baz::baz)', '... got the right value from &baz');
+
+my $bar = Bar->new();
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is($bar->foo(), 'Foo::foo(Bar::foo())', '... got the right value from &foo');
+is($bar->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar');
+is($bar->baz(), 'Foo::baz()', '... got the right value from &baz');
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is($foo->foo(), 'Foo::foo()', '... got the right value from &foo');
+is($foo->bar(), 'Foo::bar()', '... got the right value from &bar');
+is($foo->baz(), 'Foo::baz()', '... got the right value from &baz');
+
+# some error cases
+
+{
+ package Bling;
+ use Mouse;
+
+ sub bling { 'Bling::bling' }
+
+ package Bling::Bling;
+ use Mouse;
+
+ extends 'Bling';
+
+ sub bling { 'Bling::bling' }
+
+ ::dies_ok {
+ augment 'bling' => sub {};
+ } '... cannot augment a method which has a local equivalent';
+
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ sub foo { 'Foo::foo(' . (inner() || '') . ')' };
+ sub bar { 'Foo::bar(' . (inner() || '') . ')' }
+
+ package Bar;
+ use Mouse;
+
+ extends 'Foo';
+
+ augment 'foo' => sub { 'Bar::foo' };
+ override 'bar' => sub { 'Bar::bar -> ' . super() };
+
+ package Baz;
+ use Mouse;
+
+ extends 'Bar';
+
+ override 'foo' => sub { 'Baz::foo -> ' . super() };
+ augment 'bar' => sub { 'Baz::bar' };
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+=pod
+
+Let em clarify what is happening here. Baz::foo is calling
+super(), which calls Bar::foo, which is an augmented sub
+that calls Foo::foo, then calls inner() which actually
+then calls Bar::foo. Confusing I know,.. but this is
+*exactly* what is it supposed to do :)
+
+=cut
+
+is($baz->foo,
+ 'Baz::foo -> Foo::foo(Bar::foo)',
+ '... got the right value from mixed augment/override foo');
+
+=pod
+
+Allow me to clarify this one now ...
+
+Since Baz::bar is an augment routine, it needs to find the
+correct inner() to be called by. In this case it is Foo::bar.
+However, Bar::bar is in-between us, so it should actually be
+called first. Bar::bar is an overriden sub, and calls super()
+which in turn then calls our Foo::bar, which calls inner(),
+which calls Baz::bar.
+
+Confusing I know, but it is correct :)
+
+=cut
+
+{
+ local $TODO = 'mixed augment/override is not supported';
+ is($baz->bar,
+ 'Bar::bar -> Foo::bar(Baz::bar)',
+ '... got the right value from mixed augment/override bar');
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+
+
+
+=pod
+
+This just tests the interaction of override/super
+with non-Mouse superclasses. It really should not
+cause issues, the only thing it does is to create
+a metaclass for Foo so that it can find the right
+super method.
+
+This may end up being a sensitive issue for some
+non-Mouse classes, but in 99% of the cases it
+should be just fine.
+
+=cut
+
+{
+ package Foo;
+ use strict;
+ use warnings;
+
+ sub new { bless {} => shift() }
+
+ sub foo { 'Foo::foo' }
+ sub bar { 'Foo::bar' }
+ sub baz { 'Foo::baz' }
+
+ package Bar;
+ use Mouse;
+
+ extends 'Foo';
+
+ override bar => sub { 'Bar::bar -> ' . super() };
+
+ package Baz;
+ use Mouse;
+
+ extends 'Bar';
+
+ override bar => sub { 'Baz::bar -> ' . super() };
+ override baz => sub { 'Baz::baz -> ' . super() };
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+is($baz->foo(), 'Foo::foo', '... got the right value from &foo');
+is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar');
+is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz');
+
+my $bar = Bar->new();
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is($bar->foo(), 'Foo::foo', '... got the right value from &foo');
+is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar');
+is($bar->baz(), 'Foo::baz', '... got the right value from &baz');
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is($foo->foo(), 'Foo::foo', '... got the right value from &foo');
+is($foo->bar(), 'Foo::bar', '... got the right value from &bar');
+is($foo->baz(), 'Foo::baz', '... got the right value from &baz');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use Test::More tests => 15;
+
+# for classes ...
+{
+ package Foo;
+ use Mouse;
+
+ eval '$foo = 5;';
+ ::ok($@, '... got an error because strict is on');
+ ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error');
+
+ {
+ my $warn;
+ local $SIG{__WARN__} = sub { $warn = $_[0] };
+
+ ::ok(!$warn, '... no warning yet');
+
+ eval 'my $bar = 1 + "hello"';
+
+ ::ok($warn, '... got a warning');
+ ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning');
+ }
+}
+
+# and for roles ...
+{
+ package Bar;
+ use Mouse::Role;
+
+ eval '$foo = 5;';
+ ::ok($@, '... got an error because strict is on');
+ ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error');
+
+ {
+ my $warn;
+ local $SIG{__WARN__} = sub { $warn = $_[0] };
+
+ ::ok(!$warn, '... no warning yet');
+
+ eval 'my $bar = 1 + "hello"';
+
+ ::ok($warn, '... got a warning');
+ ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning');
+ }
+}
+
+# and for exporters
+{
+ package Bar;
+ use Mouse::Exporter;
+
+ eval '$foo = 5;';
+ ::ok($@, '... got an error because strict is on');
+ ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error');
+
+ {
+ my $warn;
+ local $SIG{__WARN__} = sub { $warn = $_[0] };
+
+ ::ok(!$warn, '... no warning yet');
+
+ eval 'my $bar = 1 + "hello"';
+
+ ::ok($warn, '... got a warning');
+ ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning');
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+
+
+{
+ package TouchyBase;
+ use Mouse;
+
+ has x => ( is => 'rw', default => 0 );
+
+ sub inc { $_[0]->x( 1 + $_[0]->x ) }
+
+ sub scalar_or_array {
+ wantarray ? (qw/a b c/) : "x";
+ }
+
+ sub void {
+ die "this must be void context" if defined wantarray;
+ }
+
+ package AfterSub;
+ use Mouse;
+
+ extends "TouchyBase";
+
+ after qw/scalar_or_array void/ => sub {
+ my $self = shift;
+ $self->inc;
+ }
+}
+
+my $base = TouchyBase->new;
+my $after = AfterSub->new;
+
+foreach my $obj ( $base, $after ) {
+ my $class = ref $obj;
+ my @array = $obj->scalar_or_array;
+ my $scalar = $obj->scalar_or_array;
+
+ is_deeply(\@array, [qw/a b c/], "array context ($class)");
+ is($scalar, "x", "scalar context ($class)");
+
+ {
+ local $@;
+ eval { $obj->void };
+ ok( !$@, "void context ($class)" );
+ }
+
+ if ( $obj->isa("AfterSub") ) {
+ is( $obj->x, 3, "methods were wrapped" );
+ }
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 41;
+
+
+my @moose_exports = qw(
+ extends with
+ has
+ before after around
+ override
+ augment
+ super inner
+);
+
+{
+ package Foo;
+
+ eval 'use Mouse';
+ die $@ if $@;
+}
+
+can_ok('Foo', $_) for @moose_exports;
+
+{
+ package Foo;
+
+ eval 'no Mouse';
+ die $@ if $@;
+}
+
+ok(!Foo->can($_), '... Foo can no longer do ' . $_) for @moose_exports;
+
+# and check the type constraints as well
+
+my @moose_type_constraint_exports = qw(
+ type subtype as where message
+ coerce from via
+ enum
+ find_type_constraint
+);
+
+{
+ package Bar;
+
+ eval 'use Mouse::Util::TypeConstraints';
+ die $@ if $@;
+}
+
+can_ok('Bar', $_) for @moose_type_constraint_exports;
+
+{
+ package Bar;
+
+ eval 'no Mouse::Util::TypeConstraints';
+ die $@ if $@;
+}
+
+
+ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_exports;
+
+{
+ package Baz;
+
+ use Scalar::Util qw( blessed );
+ use Mouse;
+
+ no Mouse;
+}
+
+can_ok( 'Baz', 'blessed' );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+use Test::Exception;
+
+use Mouse::Util::TypeConstraints;
+
+=pod
+
+This tests demonstrates that Mouse will not override
+a preexisting type constraint of the same name when
+making constraints for a Mouse-class.
+
+It also tests that an attribute which uses a 'Foo' for
+it's isa option will get the subtype Foo, and not a
+type representing the Foo moose class.
+
+=cut
+
+BEGIN {
+ # create this subtype first (in BEGIN)
+ subtype Foo
+ => as 'Value'
+ => where { $_ eq 'Foo' };
+}
+
+{ # now seee if Mouse will override it
+ package Foo;
+ use Mouse;
+}
+
+my $foo_constraint = find_type_constraint('Foo');
+isa_ok($foo_constraint, 'Mouse::Meta::TypeConstraint');
+
+is($foo_constraint->parent->name, 'Value', '... got the Value subtype for Foo');
+
+ok($foo_constraint->check('Foo'), '... my constraint passed correctly');
+ok(!$foo_constraint->check('Bar'), '... my constraint failed correctly');
+
+{
+ package Bar;
+ use Mouse;
+
+ has 'foo' => (is => 'rw', isa => 'Foo');
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+
+lives_ok {
+ $bar->foo('Foo');
+} '... checked the type constraint correctly';
+
+dies_ok {
+ $bar->foo(Foo->new);
+} '... checked the type constraint correctly';
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+use Test::Exception;
+
+{
+ package Class;
+ use Mouse;
+
+ package Foo;
+ use Mouse::Role;
+ sub foo_role_applied { 1 }
+
+ package Conflicts::With::Foo;
+ use Mouse::Role;
+ sub foo_role_applied { 0 }
+
+ package Not::A::Role;
+ sub lol_wut { 42 }
+}
+
+my $new_class;
+
+lives_ok {
+ $new_class = Mouse::Meta::Class->create(
+ 'Class::WithFoo',
+ superclasses => ['Class'],
+ roles => ['Foo'],
+ );
+} 'creating lives';
+ok $new_class;
+
+my $with_foo = Class::WithFoo->new;
+
+ok $with_foo->foo_role_applied;
+isa_ok $with_foo, 'Class', '$with_foo';
+
+throws_ok {
+ Mouse::Meta::Class->create(
+ 'Made::Of::Fail',
+ superclasses => ['Class'],
+ roles => 'Foo', # "oops"
+ );
+} qr/You must pass an ARRAY ref of roles/;
+
+ok !Mouse::Util::is_class_loaded('Made::Of::Fail'), "did not create Made::Of::Fail";
+
+dies_ok {
+ Mouse::Meta::Class->create(
+ 'Continuing::To::Fail',
+ superclasses => ['Class'],
+ roles => ['Foo', 'Conflicts::With::Foo'],
+ );
+} 'conflicting roles == death';
+
+# XXX: Continuing::To::Fail gets created anyway
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+use Mouse::Meta::Class;
+
+{
+ package Class;
+ use Mouse;
+
+ package Foo;
+ use Mouse::Role;
+ sub foo_role_applied { 1 }
+
+ package Bar;
+ use Mouse::Role;
+ sub bar_role_applied { 1 }
+}
+
+# try without caching first
+
+{
+ my $class_and_foo_1 = Mouse::Meta::Class->create_anon_class(
+ superclasses => ['Class'],
+ roles => ['Foo'],
+ );
+
+ my $class_and_foo_2 = Mouse::Meta::Class->create_anon_class(
+ superclasses => ['Class'],
+ roles => ['Foo'],
+ );
+
+ isnt $class_and_foo_1->name, $class_and_foo_2->name,
+ 'creating the same class twice without caching results in 2 classes';
+
+ map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2);
+}
+
+# now try with caching
+
+{
+ my $class_and_foo_1 = Mouse::Meta::Class->create_anon_class(
+ superclasses => ['Class'],
+ roles => ['Foo'],
+ cache => 1,
+ );
+
+ my $class_and_foo_2 = Mouse::Meta::Class->create_anon_class(
+ superclasses => ['Class'],
+ roles => ['Foo'],
+ cache => 1,
+ );
+
+ is $class_and_foo_1->name, $class_and_foo_2->name,
+ 'with cache, the same class is the same class';
+
+ map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2);
+
+ my $class_and_bar = Mouse::Meta::Class->create_anon_class(
+ superclasses => ['Class'],
+ roles => ['Bar'],
+ cache => 1,
+ );
+
+ isnt $class_and_foo_1->name, $class_and_bar,
+ 'class_and_foo and class_and_bar are different';
+
+ ok $class_and_bar->name->bar_role_applied;
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+{
+ package Foo;
+ use Mouse;
+
+ has bar => ( is => "rw" );
+ has baz => ( is => "rw" );
+
+ sub BUILDARGS {
+ my ( $self, @args ) = @_;
+ unshift @args, "bar" if @args % 2 == 1;
+ return {@args};
+ }
+
+ package Bar;
+ use Mouse;
+
+ extends qw(Foo);
+}
+
+foreach my $class qw(Foo Bar) {
+ is( $class->new->bar, undef, "no args" );
+ is( $class->new( bar => 42 )->bar, 42, "normal args" );
+ is( $class->new( 37 )->bar, 37, "single arg" );
+ {
+ my $o = $class->new(bar => 42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+ {
+ my $o = $class->new(42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+BEGIN {
+ eval "use Test::Output;";
+ plan skip_all => "Test::Output is required for this test" if $@;
+ plan tests => 2;
+}
+
+stderr_like( sub { package main; eval 'use Mouse' },
+ qr/\QMouse does not export its sugar to the 'main' package/,
+ 'Mouse warns when loaded from the main package' );
+
+stderr_like( sub { package main; eval 'use Mouse::Role' },
+ qr/\QMouse::Role does not export its sugar to the 'main' package/,
+ 'Mouse::Role warns when loaded from the main package' );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+use Test::Exception;
+
+# This tests the error handling in Mouse::Object only
+
+{
+ package Foo;
+ use Mouse;
+}
+
+throws_ok { Foo->new('bad') } qr/^\QSingle parameters to new() must be a HASH ref/,
+ 'A single non-hashref arg to a constructor throws an error';
+throws_ok { Foo->new(undef) } qr/^\QSingle parameters to new() must be a HASH ref/,
+ 'A single non-hashref arg to a constructor throws an error';
+
+throws_ok { Foo->does() } qr/^\QYou must supply a role name to does()/,
+ 'Cannot call does() without a role name';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+our @demolished;
+package Foo;
+use Mouse;
+
+sub DEMOLISH {
+ my $self = shift;
+ push @::demolished, __PACKAGE__;
+}
+
+package Foo::Sub;
+use Mouse;
+extends 'Foo';
+
+sub DEMOLISH {
+ my $self = shift;
+ push @::demolished, __PACKAGE__;
+}
+
+package Foo::Sub::Sub;
+use Mouse;
+extends 'Foo::Sub';
+
+sub DEMOLISH {
+ my $self = shift;
+ push @::demolished, __PACKAGE__;
+}
+
+package main;
+{
+ my $foo = Foo->new;
+}
+is_deeply(\@demolished, ['Foo'], "Foo demolished properly");
+@demolished = ();
+{
+ my $foo_sub = Foo::Sub->new;
+}
+is_deeply(\@demolished, ['Foo::Sub', 'Foo'], "Foo::Sub demolished properly");
+@demolished = ();
+{
+ my $foo_sub_sub = Foo::Sub::Sub->new;
+}
+is_deeply(\@demolished, ['Foo::Sub::Sub', 'Foo::Sub', 'Foo'],
+ "Foo::Sub::Sub demolished properly");
+@demolished = ();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+use Test::Exception;
+
+{
+
+ package Dog;
+ use Mouse;
+
+ sub bark_once {
+ my $self = shift;
+ return 'bark';
+ }
+
+ sub bark_twice {
+ return 'barkbark';
+ }
+
+ around qr/bark.*/ => sub {
+ 'Dog::around(' . $_[0]->() . ')';
+ };
+
+}
+
+my $dog = Dog->new;
+is( $dog->bark_once, 'Dog::around(bark)', 'around modifier is called' );
+is( $dog->bark_twice, 'Dog::around(barkbark)', 'around modifier is called' );
+
+{
+
+ package Cat;
+ use Mouse;
+ our $BEFORE_BARK_COUNTER = 0;
+ our $AFTER_BARK_COUNTER = 0;
+
+ sub bark_once {
+ my $self = shift;
+ return 'bark';
+ }
+
+ sub bark_twice {
+ return 'barkbark';
+ }
+
+ before qr/bark.*/ => sub {
+ $BEFORE_BARK_COUNTER++;
+ };
+
+ after qr/bark.*/ => sub {
+ $AFTER_BARK_COUNTER++;
+ };
+
+}
+
+my $cat = Cat->new;
+$cat->bark_once;
+is( $Cat::BEFORE_BARK_COUNTER, 1, 'before modifier is called once' );
+is( $Cat::AFTER_BARK_COUNTER, 1, 'after modifier is called once' );
+$cat->bark_twice;
+is( $Cat::BEFORE_BARK_COUNTER, 2, 'before modifier is called twice' );
+is( $Cat::AFTER_BARK_COUNTER, 2, 'after modifier is called twice' );
+
+{
+ package Dog::Role;
+ use Mouse::Role;
+
+ ::dies_ok {
+ before qr/bark.*/ => sub {};
+ } '... this is not currently supported';
+
+ ::dies_ok {
+ around qr/bark.*/ => sub {};
+ } '... this is not currently supported';
+
+ ::dies_ok {
+ after qr/bark.*/ => sub {};
+ } '... this is not currently supported';
+
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+use Test::Exception;
+use Scalar::Util 'blessed';
+
+use Mouse::Util::TypeConstraints;
+
+subtype 'Positive'
+ => as 'Num'
+ => where { $_ > 0 };
+
+{
+ package Parent;
+ use Mouse;
+
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+ has lazy_classname => (
+ is => 'ro',
+ lazy => 1,
+ default => sub { "Parent" },
+ );
+
+ has type_constrained => (
+ is => 'rw',
+ isa => 'Num',
+ default => 5.5,
+ );
+
+ package Child;
+ use Mouse;
+ extends 'Parent';
+
+ has '+name' => (
+ default => 'Junior',
+ );
+
+ has '+lazy_classname' => (
+ default => sub { "Child" },
+ );
+
+ has '+type_constrained' => (
+ isa => 'Int',
+ default => 100,
+ );
+}
+
+my $foo = Parent->new;
+my $bar = Parent->new;
+
+is(blessed($foo), 'Parent', 'Parent->new gives a Parent object');
+is($foo->name, undef, 'No name yet');
+is($foo->lazy_classname, 'Parent', "lazy attribute initialized");
+lives_ok { $foo->type_constrained(10.5) } "Num type constraint for now..";
+
+# try to rebless, except it will fail due to Child's stricter type constraint
+throws_ok { Child->meta->rebless_instance($foo) }
+qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/,
+'... this failed cause of type check';
+throws_ok { Child->meta->rebless_instance($bar) }
+qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 5\.5/,
+'... this failed cause of type check';;
+
+$foo->type_constrained(10);
+$bar->type_constrained(5);
+
+Child->meta->rebless_instance($foo);
+Child->meta->rebless_instance($bar);
+
+is(blessed($foo), 'Child', 'successfully reblessed into Child');
+is($foo->name, 'Junior', "Child->name's default came through");
+
+is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized");
+is($bar->lazy_classname, 'Child', "lazy attribute just now initialized");
+
+throws_ok { $foo->type_constrained(10.5) }
+qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/,
+'... this failed cause of type check';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+
+my $test1 = Mouse::Meta::Class->create_anon_class;
+$test1->add_method( 'foo1', sub { } );
+
+my $t1 = $test1->new_object;
+my $t1_am = $t1->meta->get_method('foo1')->associated_metaclass;
+
+ok( $t1_am, 'associated_metaclass is defined' );
+
+isa_ok(
+ $t1_am, 'Mouse::Meta::Class',
+ 'associated_metaclass is correct class'
+);
+
+like( $t1_am->name(), qr/::__ANON__::/,
+ 'associated_metaclass->name looks like an anonymous class' );
+
+{
+ package Test2;
+
+ use Mouse;
+
+ sub foo2 { }
+}
+
+my $t2 = Test2->new;
+my $t2_am = $t2->meta->get_method('foo2')->associated_metaclass;
+
+ok( $t2_am, 'associated_metaclass is defined' );
+
+isa_ok(
+ $t2_am, 'Mouse::Meta::Class',
+ 'associated_metaclass is correct class'
+);
+
+is( $t2_am->name(), 'Test2',
+ 'associated_metaclass->name is Test2' );
--- /dev/null
+#!/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
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+{
+ package Foo;
+ use Mouse;
+
+ sub DEMOLISH {
+ my $self = shift;
+ my ($igd) = @_;
+ ::ok(
+ !$igd,
+ 'in_global_destruction state is passed to DEMOLISH properly (false)'
+ );
+ }
+}
+
+{
+ my $foo = Foo->new;
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ sub DEMOLISH {
+ my $self = shift;
+ my ($igd) = @_;
+ ::ok(
+ !$igd,
+ 'in_global_destruction state is passed to DEMOLISH properly (false)'
+ );
+ }
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ my $bar = Bar->new;
+}
+
+ok(
+ $_,
+ 'in_global_destruction state is passed to DEMOLISH properly (true)'
+) for split //, `$^X t/010_basics/020-global-destruction-helper.pl`;
+
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+BEGIN {
+ eval "use Test::Output;";
+ plan skip_all => "Test::Output is required for this test" if $@;
+ plan tests => 2;
+}
+
+{
+ package Foo;
+ use Mouse;
+}
+
+{
+ my $foo = Foo->new();
+ stderr_like { $foo->new() }
+ qr/\QCalling new() on an instance is deprecated/,
+ '$object->new() is deprecated';
+
+ Foo->meta->make_immutable, redo
+ if Foo->meta->is_mutable;
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ );
+ };
+ ::ok(!$@, '... created the writer method okay');
+
+ eval {
+ has 'foo_required' => (
+ reader => 'get_foo_required',
+ writer => 'set_foo_required',
+ required => 1,
+ );
+ };
+ ::ok(!$@, '... created the required writer method okay');
+
+ eval {
+ has 'foo_int' => (
+ reader => 'get_foo_int',
+ writer => 'set_foo_int',
+ isa => 'Int',
+ );
+ };
+ ::ok(!$@, '... created the writer method with type constraint okay');
+
+ eval {
+ has 'foo_weak' => (
+ reader => 'get_foo_weak',
+ writer => 'set_foo_weak',
+ weak_ref => 1
+ );
+ };
+ ::ok(!$@, '... created the writer method with weak_ref okay');
+}
+
+{
+ my $foo = Foo->new(foo_required => 'required');
+ isa_ok($foo, 'Foo');
+
+ # regular writer
+
+ can_ok($foo, 'set_foo');
+ is($foo->get_foo(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo(100);
+ } '... set_foo wrote successfully';
+ is($foo->get_foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
+ # required writer
+
+ dies_ok {
+ Foo->new;
+ } '... cannot create without the required attribute';
+
+ can_ok($foo, 'set_foo_required');
+ is($foo->get_foo_required(), 'required', '... got an unset value');
+ lives_ok {
+ $foo->set_foo_required(100);
+ } '... set_foo_required wrote successfully';
+ is($foo->get_foo_required(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->set_foo_required();
+ } '... set_foo_required died successfully with no value';
+
+ lives_ok {
+ $foo->set_foo_required(undef);
+ } '... set_foo_required did accept undef';
+
+ ok(!isweak($foo->{foo_required}), '... it is not a weak reference');
+
+ # with type constraint
+
+ can_ok($foo, 'set_foo_int');
+ is($foo->get_foo_int(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo_int(100);
+ } '... set_foo_int wrote successfully';
+ is($foo->get_foo_int(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->set_foo_int("Foo");
+ } '... set_foo_int died successfully';
+
+ ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
+
+ # with weak_ref
+
+ my $test = [];
+
+ can_ok($foo, 'set_foo_weak');
+ is($foo->get_foo_weak(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo_weak($test);
+ } '... set_foo_weak wrote successfully';
+ is($foo->get_foo_weak(), $test, '... got the correct set value');
+
+ ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 57;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ accessor => 'foo',
+ );
+ };
+ ::ok(!$@, '... created the accessor method okay');
+
+ eval {
+ has 'lazy_foo' => (
+ accessor => 'lazy_foo',
+ lazy => 1,
+ default => sub { 10 }
+ );
+ };
+ ::ok(!$@, '... created the lazy accessor method okay');
+
+
+ eval {
+ has 'foo_required' => (
+ accessor => 'foo_required',
+ required => 1,
+ );
+ };
+ ::ok(!$@, '... created the required accessor method okay');
+
+ eval {
+ has 'foo_int' => (
+ accessor => 'foo_int',
+ isa => 'Int',
+ );
+ };
+ ::ok(!$@, '... created the accessor method with type constraint okay');
+
+ eval {
+ has 'foo_weak' => (
+ accessor => 'foo_weak',
+ weak_ref => 1
+ );
+ };
+ ::ok(!$@, '... created the accessor method with weak_ref okay');
+
+ eval {
+ has 'foo_deref' => (
+ accessor => 'foo_deref',
+ isa => 'ArrayRef',
+ auto_deref => 1,
+ );
+ };
+ ::ok(!$@, '... created the accessor method with auto_deref okay');
+
+ eval {
+ has 'foo_deref_ro' => (
+ reader => 'foo_deref_ro',
+ isa => 'ArrayRef',
+ auto_deref => 1,
+ );
+ };
+ ::ok(!$@, '... created the reader method with auto_deref okay');
+
+ eval {
+ has 'foo_deref_hash' => (
+ accessor => 'foo_deref_hash',
+ isa => 'HashRef',
+ auto_deref => 1,
+ );
+ };
+ ::ok(!$@, '... created the reader method with auto_deref okay');
+}
+
+{
+ my $foo = Foo->new(foo_required => 'required');
+ isa_ok($foo, 'Foo');
+
+ # regular accessor
+
+ can_ok($foo, 'foo');
+ is($foo->foo(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo(100);
+ } '... foo wrote successfully';
+ is($foo->foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
+ # required writer
+
+ dies_ok {
+ Foo->new;
+ } '... cannot create without the required attribute';
+
+ can_ok($foo, 'foo_required');
+ is($foo->foo_required(), 'required', '... got an unset value');
+ lives_ok {
+ $foo->foo_required(100);
+ } '... foo_required wrote successfully';
+ is($foo->foo_required(), 100, '... got the correct set value');
+
+ lives_ok {
+ $foo->foo_required(undef);
+ } '... foo_required did not die with undef';
+
+ is($foo->foo_required, undef, "value is undef");
+
+ ok(!isweak($foo->{foo_required}), '... it is not a weak reference');
+
+ # lazy
+
+ ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot');
+
+ can_ok($foo, 'lazy_foo');
+ is($foo->lazy_foo(), 10, '... got an deferred value');
+
+ # with type constraint
+
+ can_ok($foo, 'foo_int');
+ is($foo->foo_int(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo_int(100);
+ } '... foo_int wrote successfully';
+ is($foo->foo_int(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->foo_int("Foo");
+ } '... foo_int died successfully';
+
+ ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
+
+ # with weak_ref
+
+ my $test = [];
+
+ can_ok($foo, 'foo_weak');
+ is($foo->foo_weak(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo_weak($test);
+ } '... foo_weak wrote successfully';
+ is($foo->foo_weak(), $test, '... got the correct set value');
+
+ ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+
+ can_ok( $foo, 'foo_deref');
+ is_deeply( [$foo->foo_deref()], [], '... default default value');
+ my @list;
+ lives_ok {
+ @list = $foo->foo_deref();
+ } "... doesn't deref undef value";
+ is_deeply( \@list, [], "returns empty list in list context");
+
+ lives_ok {
+ $foo->foo_deref( [ qw/foo bar gorch/ ] );
+ } '... foo_deref wrote successfully';
+
+ is( Scalar::Util::reftype( scalar $foo->foo_deref() ), "ARRAY", "returns an array reference in scalar context" );
+ is_deeply( scalar($foo->foo_deref()), [ qw/foo bar gorch/ ], "correct array" );
+
+ is( scalar( () = $foo->foo_deref() ), 3, "returns list in list context" );
+ is_deeply( [ $foo->foo_deref() ], [ qw/foo bar gorch/ ], "correct list" );
+
+
+ can_ok( $foo, 'foo_deref' );
+ is_deeply( [$foo->foo_deref_ro()], [], "... default default value" );
+
+ dies_ok {
+ $foo->foo_deref_ro( [] );
+ } "... read only";
+
+ $foo->{foo_deref_ro} = [qw/la la la/];
+
+ is_deeply( scalar($foo->foo_deref_ro()), [qw/la la la/], "scalar context ro" );
+ is_deeply( [ $foo->foo_deref_ro() ], [qw/la la la/], "list context ro" );
+
+ can_ok( $foo, 'foo_deref_hash' );
+ is_deeply( { $foo->foo_deref_hash() }, {}, "... default default value" );
+
+ my %hash;
+ lives_ok {
+ %hash = $foo->foo_deref_hash();
+ } "... doesn't deref undef value";
+ is_deeply( \%hash, {}, "returns empty list in list context");
+
+ lives_ok {
+ $foo->foo_deref_hash( { foo => 1, bar => 2 } );
+ } '... foo_deref_hash wrote successfully';
+
+ is_deeply( scalar($foo->foo_deref_hash), { foo => 1, bar => 2 }, "scalar context" );
+
+ %hash = $foo->foo_deref_hash;
+ is_deeply( \%hash, { foo => 1, bar => 2 }, "list context");
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+use Test::Exception;
+
+
+
+{
+ package Foo::Role;
+ use Mouse::Role;
+ use Mouse::Util::TypeConstraints;
+
+ # if does() exists on its own, then
+ # we create a type constraint for
+ # it, just as we do for isa()
+ has 'bar' => (is => 'rw', does => 'Bar::Role');
+ has 'baz' => (
+ is => 'rw',
+ does => 'Bar::Role'
+ );
+
+ package Bar::Role;
+ use Mouse::Role;
+
+ # if isa and does appear together, then see if Class->does(Role)
+ # if it does work... then the does() check is actually not needed
+ # since the isa() check will imply the does() check
+ has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role');
+
+ package Foo::Class;
+ use Mouse;
+
+ with 'Foo::Role';
+
+ package Bar::Class;
+ use Mouse;
+
+ with 'Bar::Role';
+
+}
+
+my $foo = Foo::Class->new;
+isa_ok($foo, 'Foo::Class');
+
+my $bar = Bar::Class->new;
+isa_ok($bar, 'Bar::Class');
+
+lives_ok {
+ $foo->bar($bar);
+} '... bar passed the type constraint okay';
+
+dies_ok {
+ $foo->bar($foo);
+} '... foo did not pass the type constraint okay';
+
+lives_ok {
+ $foo->baz($bar);
+} '... baz passed the type constraint okay';
+
+dies_ok {
+ $foo->baz($foo);
+} '... foo did not pass the type constraint okay';
+
+lives_ok {
+ $bar->foo($foo);
+} '... foo passed the type constraint okay';
+
+
+
+# some error conditions
+
+{
+ package Baz::Class;
+ use Test::More;
+ use Mouse;
+
+ local $TODO = 'setting both isa and does';
+
+ # if isa and does appear together, then see if Class->does(Role)
+ # if it does not,.. we have a conflict... so we die loudly
+ ::dies_ok {
+ has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class');
+ } '... cannot have a does() which is not done by the isa()';
+}
+
+{
+ package Bling;
+ use strict;
+ use warnings;
+
+ sub bling { 'Bling::bling' }
+
+ package Bling::Bling;
+ use Test::More;
+ use Mouse;
+
+ local $TODO = 'setting both isa and does';
+
+ # if isa and does appear together, then see if Class->does(Role)
+ # if it does not,.. we have a conflict... so we die loudly
+ ::dies_ok {
+ has 'foo' => (isa => 'Bling', does => 'Bar::Class');
+ } '... cannot have a isa() which is cannot does()';
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'ro', required => 1);
+ has 'baz' => (is => 'rw', default => 100, required => 1);
+ has 'boo' => (is => 'rw', lazy => 1, default => 50, required => 1);
+}
+
+{
+ my $foo = Foo->new(bar => 10, baz => 20, boo => 100);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 20, '... got the right baz');
+ is($foo->boo, 100, '... got the right boo');
+}
+
+{
+ my $foo = Foo->new(bar => 10, boo => 5);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 100, '... got the right baz');
+ is($foo->boo, 5, '... got the right boo');
+}
+
+{
+ my $foo = Foo->new(bar => 10);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 100, '... got the right baz');
+ is($foo->boo, 50, '... got the right boo');
+}
+
+#Yeah.. this doesn't work like this anymore, see below. (groditi)
+#throws_ok {
+# Foo->new(bar => 10, baz => undef);
+#} qr/^Attribute \(baz\) is required and cannot be undef/, '... must supply all the required attribute';
+
+#throws_ok {
+# Foo->new(bar => 10, boo => undef);
+#} qr/^Attribute \(boo\) is required and cannot be undef/, '... must supply all the required attribute';
+
+lives_ok {
+ Foo->new(bar => 10, baz => undef);
+} '... undef is a valid attribute value';
+
+lives_ok {
+ Foo->new(bar => 10, boo => undef);
+} '... undef is a valid attribute value';
+
+
+throws_ok {
+ Foo->new;
+} qr/^Attribute \(bar\) is required/, '... must supply all the required attribute';
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+use Test::Exception;
+
+
+
+{
+ package Foo::Meta::Attribute;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+
+ around 'new' => sub {
+ my $next = shift;
+ my $self = shift;
+ my $name = shift;
+ $next->($self, $name, (is => 'rw', isa => 'Foo'), @_);
+ };
+
+ package Foo;
+ use Mouse;
+
+ has 'foo' => (metaclass => 'Foo::Meta::Attribute');
+}
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ my $foo_attr = Foo->meta->get_attribute('foo');
+ isa_ok($foo_attr, 'Foo::Meta::Attribute');
+ isa_ok($foo_attr, 'Mouse::Meta::Attribute');
+
+ is($foo_attr->name, 'foo', '... got the right name for our meta-attribute');
+ ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us');
+
+ ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us');
+
+ my $foo_attr_type_constraint = $foo_attr->type_constraint;
+ isa_ok($foo_attr_type_constraint, 'Mouse::Meta::TypeConstraint');
+
+ is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name');
+
+ local $TODO = '$type_constraint->parent is not reliable';
+ is($foo_attr_type_constraint->parent, 'Object', '... got the right type constraint parent name');
+}
+{
+ package Bar::Meta::Attribute;
+ use Mouse;
+
+ #extends 'Class::MOP::Attribute';
+ extends 'Foo::Meta::Attribute';
+
+ package Bar;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (metaclass => 'Bar::Meta::Attribute');
+ } '... the attribute metaclass need not be a Mouse::Meta::Attribute as long as it behaves';
+}
+
+{
+ package Mouse::Meta::Attribute::Custom::Foo;
+ sub register_implementation { 'Foo::Meta::Attribute' }
+
+ package Mouse::Meta::Attribute::Custom::Bar;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+
+ package Another::Foo;
+ use Mouse;
+
+ ::lives_ok {
+ has 'foo' => (metaclass => 'Foo');
+ } '... the attribute metaclass alias worked correctly';
+
+ ::lives_ok {
+ has 'bar' => (metaclass => 'Bar', is => 'bare');
+ } '... the attribute metaclass alias worked correctly';
+}
+
+{
+ my $foo_attr = Another::Foo->meta->get_attribute('foo');
+ isa_ok($foo_attr, 'Foo::Meta::Attribute');
+ isa_ok($foo_attr, 'Mouse::Meta::Attribute');
+
+ my $bar_attr = Another::Foo->meta->get_attribute('bar');
+ isa_ok($bar_attr, 'Mouse::Meta::Attribute::Custom::Bar');
+ isa_ok($bar_attr, 'Mouse::Meta::Attribute');
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef');
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+lives_ok {
+ $foo->bar([])
+} '... set bar successfully with an ARRAY ref';
+
+lives_ok {
+ $foo->bar({})
+} '... set bar successfully with a HASH ref';
+
+dies_ok {
+ $foo->bar(100)
+} '... couldnt set bar successfully with a number';
+
+dies_ok {
+ $foo->bar(sub {})
+} '... couldnt set bar successfully with a CODE ref';
+
+# check the constructor
+
+lives_ok {
+ Foo->new(bar => [])
+} '... created new Foo with bar successfully set with an ARRAY ref';
+
+lives_ok {
+ Foo->new(bar => {})
+} '... created new Foo with bar successfully set with a HASH ref';
+
+dies_ok {
+ Foo->new(bar => 50)
+} '... didnt create a new Foo with bar as a number';
+
+dies_ok {
+ Foo->new(bar => sub {})
+} '... didnt create a new Foo with bar as a CODE ref';
+
+{
+ package Bar;
+ use Mouse;
+
+ has 'baz' => (is => 'rw', isa => 'Str | CodeRef');
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+
+lives_ok {
+ $bar->baz('a string')
+} '... set baz successfully with a string';
+
+lives_ok {
+ $bar->baz(sub { 'a sub' })
+} '... set baz successfully with a CODE ref';
+
+dies_ok {
+ $bar->baz(\(my $var1))
+} '... couldnt set baz successfully with a SCALAR ref';
+
+dies_ok {
+ $bar->baz({})
+} '... couldnt set bar successfully with a HASH ref';
+
+# check the constructor
+
+lives_ok {
+ Bar->new(baz => 'a string')
+} '... created new Bar with baz successfully set with a string';
+
+lives_ok {
+ Bar->new(baz => sub { 'a sub' })
+} '... created new Bar with baz successfully set with a CODE ref';
+
+dies_ok {
+ Bar->new(baz => \(my $var2))
+} '... didnt create a new Bar with baz as a number';
+
+dies_ok {
+ Bar->new(baz => {})
+} '... didnt create a new Bar with baz as a HASH ref';
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 39;
+use Test::Exception;
+
+=pod
+
+This tests the more complex
+delegation cases and that they
+do not fail at compile time.
+
+=cut
+
+{
+
+ package ChildASuper;
+ use Mouse;
+
+ sub child_a_super_method { "as" }
+
+ package ChildA;
+ use Mouse;
+
+ extends "ChildASuper";
+
+ sub child_a_method_1 { "a1" }
+ sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" }
+
+ package ChildASub;
+ use Mouse;
+
+ extends "ChildA";
+
+ sub child_a_method_3 { "a3" }
+
+ package ChildB;
+ use Mouse;
+
+ sub child_b_method_1 { "b1" }
+ sub child_b_method_2 { "b2" }
+ sub child_b_method_3 { "b3" }
+
+ package ChildC;
+ use Mouse;
+
+ sub child_c_method_1 { "c1" }
+ sub child_c_method_2 { "c2" }
+ sub child_c_method_3_la { "c3" }
+ sub child_c_method_4_la { "c4" }
+
+ package ChildD;
+ use Mouse;
+
+ sub child_d_method_1 { "d1" }
+ sub child_d_method_2 { "d2" }
+
+ package ChildE;
+ # no Mouse
+
+ sub new { bless {}, shift }
+ sub child_e_method_1 { "e1" }
+ sub child_e_method_2 { "e2" }
+
+ package ChildF;
+ # no Mouse
+
+ sub new { bless {}, shift }
+ sub child_f_method_1 { "f1" }
+ sub child_f_method_2 { "f2" }
+
+ package ChildG;
+ use Mouse;
+
+ sub child_g_method_1 { "g1" }
+
+ package Parent;
+ use Mouse;
+
+ ::dies_ok {
+ has child_a => (
+ is => "ro",
+ default => sub { ChildA->new },
+ handles => qr/.*/,
+ );
+ } "all_methods requires explicit isa";
+
+ ::lives_ok {
+ has child_a => (
+ isa => "ChildA",
+ is => "ro",
+ default => sub { ChildA->new },
+ handles => qr/.*/,
+ );
+ } "allow all_methods with explicit isa";
+
+ ::lives_ok {
+ has child_b => (
+ is => 'ro',
+ default => sub { ChildB->new },
+ handles => [qw/child_b_method_1/],
+ );
+ } "don't need to declare isa if method list is predefined";
+
+ ::lives_ok {
+ has child_c => (
+ isa => "ChildC",
+ is => "ro",
+ default => sub { ChildC->new },
+ handles => qr/_la$/,
+ );
+ } "can declare regex collector";
+
+ ::dies_ok {
+ has child_d => (
+ is => "ro",
+ default => sub { ChildD->new },
+ handles => sub {
+ my ( $class, $delegate_class ) = @_;
+ }
+ );
+ } "can't create attr with generative handles parameter and no isa";
+
+ our $TODO;
+{
+ local $TODO = 'handles => CODE is not supported';
+ ::lives_ok {
+ has child_d => (
+ isa => "ChildD",
+ is => "ro",
+ default => sub { ChildD->new },
+ handles => sub {
+ my ( $class, $delegate_class ) = @_;
+ return;
+ }
+ );
+ } "can't create attr with generative handles parameter and no isa";
+}
+
+ ::lives_ok {
+ has child_e => (
+ isa => "ChildE",
+ is => "ro",
+ default => sub { ChildE->new },
+ handles => ["child_e_method_2"],
+ );
+ } "can delegate to non moose class using explicit method list";
+
+{
+ local $TODO = 'handles => CODE is not supported';
+ my $delegate_class;
+ ::lives_ok {
+ has child_f => (
+ isa => "ChildF",
+ is => "ro",
+ default => sub { ChildF->new },
+ handles => sub {
+ $delegate_class = $_[1]->name;
+ return;
+ },
+ );
+ } "subrefs on non moose class give no meta";
+
+ ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
+}
+
+ ::lives_ok {
+ has child_g => (
+ isa => "ChildG",
+ default => sub { ChildG->new },
+ handles => ["child_g_method_1"],
+ );
+ } "can delegate to object even without explicit reader";
+
+ sub parent_method { "p" }
+}
+
+# sanity
+
+isa_ok( my $p = Parent->new, "Parent" );
+isa_ok( $p->child_a, "ChildA" );
+isa_ok( $p->child_b, "ChildB" );
+isa_ok( $p->child_c, "ChildC" );
+isa_ok( $p->child_d, "ChildD" );
+isa_ok( $p->child_e, "ChildE" );
+isa_ok( $p->child_f, "ChildF" );
+
+ok(!$p->can('child_g'), '... no child_g accessor defined');
+
+
+is( $p->parent_method, "p", "parent method" );
+is( $p->child_a->child_a_super_method, "as", "child supermethod" );
+is( $p->child_a->child_a_method_1, "a1", "child method" );
+
+can_ok( $p, "child_a_super_method" );
+can_ok( $p, "child_a_method_1" );
+can_ok( $p, "child_a_method_2" );
+ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" );
+
+is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" );
+is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" );
+
+
+can_ok( $p, "child_b_method_1" );
+ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" );
+
+
+ok( !$p->can($_), "none of ChildD's methods ($_)" )
+ for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods();
+
+can_ok( $p, "child_c_method_3_la" );
+can_ok( $p, "child_c_method_4_la" );
+
+is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" );
+
+can_ok( $p, "child_e_method_2" );
+ok( !$p->can("child_e_method_1"), "but not child_e_method_1");
+
+is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" );
+
+can_ok( $p, "child_g_method_1" );
+is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 43;
+use Test::Exception;
+
+use lib 't/lib';
+use Test::Mouse;
+
+{
+ {
+ package Test::Attribute::Inline::Documentation;
+ use Mouse;
+
+ has 'foo' => (
+ documentation => q{
+ The 'foo' attribute is my favorite
+ attribute in the whole wide world.
+ },
+ is => 'bare',
+ );
+ }
+
+ my $foo_attr = Test::Attribute::Inline::Documentation->meta->get_attribute('foo');
+
+ ok($foo_attr->has_documentation, '... the foo has docs');
+ is($foo_attr->documentation,
+ q{
+ The 'foo' attribute is my favorite
+ attribute in the whole wide world.
+ },
+ '... got the foo docs');
+}
+
+{
+ {
+ package Test::For::Lazy::TypeConstraint;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'bad_lazy_attr' => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ lazy => 1,
+ default => sub { "test" },
+ );
+
+ has 'good_lazy_attr' => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ lazy => 1,
+ default => sub { [] },
+ );
+
+ }
+
+ my $test = Test::For::Lazy::TypeConstraint->new;
+ isa_ok($test, 'Test::For::Lazy::TypeConstraint');
+
+ dies_ok {
+ $test->bad_lazy_attr;
+ } '... this does not work';
+
+ lives_ok {
+ $test->good_lazy_attr;
+ } '... this does work';
+}
+
+{
+ {
+ package Test::Arrayref::Attributes;
+ use Mouse;
+
+ has [qw(foo bar baz)] => (
+ is => 'rw',
+ );
+
+ }
+
+ my $test = Test::Arrayref::Attributes->new;
+ isa_ok($test, 'Test::Arrayref::Attributes');
+ can_ok($test, qw(foo bar baz));
+
+}
+
+{
+ {
+ package Test::Arrayref::RoleAttributes::Role;
+ use Mouse::Role;
+
+ has [qw(foo bar baz)] => (
+ is => 'rw',
+ );
+
+ }
+ {
+ package Test::Arrayref::RoleAttributes;
+ use Mouse;
+ with 'Test::Arrayref::RoleAttributes::Role';
+ }
+
+ my $test = Test::Arrayref::RoleAttributes->new;
+ isa_ok($test, 'Test::Arrayref::RoleAttributes');
+ can_ok($test, qw(foo bar baz));
+
+}
+
+{
+ {
+ package Test::UndefDefault::Attributes;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'ro',
+ isa => 'Str',
+ default => sub { return }
+ );
+
+ }
+
+ dies_ok {
+ Test::UndefDefault::Attributes->new;
+ } '... default must return a value which passes the type constraint';
+
+}
+
+{
+ {
+ package OverloadedStr;
+ use Mouse;
+ use overload '""' => sub { 'this is *not* a string' };
+
+ has 'a_str' => ( isa => 'Str' , is => 'rw' );
+ }
+
+ my $moose_obj = OverloadedStr->new;
+
+ is($moose_obj->a_str( 'foobar' ), 'foobar', 'setter took string');
+ ok($moose_obj, 'this is a *not* a string');
+
+ throws_ok {
+ $moose_obj->a_str( $moose_obj )
+ } qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' failed with value OverloadedStr=HASH\(0x.+?\)/,
+ '... dies without overloading the string';
+
+}
+
+{
+ {
+ package OverloadBreaker;
+ use Mouse;
+
+ has 'a_num' => ( isa => 'Int' , is => 'rw', default => 7.5 );
+ }
+
+ throws_ok {
+ OverloadBreaker->new;
+ } qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 7\.5/,
+ '... this doesnt trip overload to break anymore ';
+
+ lives_ok {
+ OverloadBreaker->new(a_num => 5);
+ } '... this works fine though';
+
+}
+
+{
+ {
+ package Test::Builder::Attribute;
+ use Mouse;
+
+ has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro');
+ sub build_foo { return "works" };
+ }
+
+ my $meta = Test::Builder::Attribute->meta;
+ my $foo_attr = $meta->get_attribute("foo");
+
+ ok($foo_attr->is_required, "foo is required");
+ ok($foo_attr->has_builder, "foo has builder");
+ is($foo_attr->builder, "build_foo", ".. and it's named build_foo");
+
+ my $instance = Test::Builder::Attribute->new;
+ is($instance->foo, 'works', "foo builder works");
+}
+
+{
+ {
+ package Test::Builder::Attribute::Broken;
+ use Mouse;
+
+ has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro');
+ }
+
+ dies_ok {
+ Test::Builder::Attribute::Broken->new;
+ } '... no builder, wtf';
+}
+
+
+{
+ {
+ package Test::LazyBuild::Attribute;
+ use Mouse;
+
+ has 'foo' => ( lazy_build => 1, is => 'ro');
+ has '_foo' => ( lazy_build => 1, is => 'ro');
+ has 'fool' => ( lazy_build => 1, is => 'ro');
+ sub _build_foo { return "works" };
+ sub _build__foo { return "works too" };
+ }
+
+ my $meta = Test::LazyBuild::Attribute->meta;
+ my $foo_attr = $meta->get_attribute("foo");
+ my $_foo_attr = $meta->get_attribute("_foo");
+
+ ok($foo_attr->is_lazy, "foo is lazy");
+ ok($foo_attr->is_lazy_build, "foo is lazy_build");
+
+ ok($foo_attr->has_clearer, "foo has clearer");
+ is($foo_attr->clearer, "clear_foo", ".. and it's named clear_foo");
+
+ ok($foo_attr->has_builder, "foo has builder");
+ is($foo_attr->builder, "_build_foo", ".. and it's named build_foo");
+
+ ok($foo_attr->has_predicate, "foo has predicate");
+ is($foo_attr->predicate, "has_foo", ".. and it's named has_foo");
+
+ ok($_foo_attr->is_lazy, "_foo is lazy");
+ ok(!$_foo_attr->is_required, "lazy_build attributes are no longer automatically required");
+ ok($_foo_attr->is_lazy_build, "_foo is lazy_build");
+
+ ok($_foo_attr->has_clearer, "_foo has clearer");
+ is($_foo_attr->clearer, "_clear_foo", ".. and it's named _clear_foo");
+
+ ok($_foo_attr->has_builder, "_foo has builder");
+ is($_foo_attr->builder, "_build__foo", ".. and it's named _build_foo");
+
+ ok($_foo_attr->has_predicate, "_foo has predicate");
+ is($_foo_attr->predicate, "_has_foo", ".. and it's named _has_foo");
+
+ my $instance = Test::LazyBuild::Attribute->new;
+ ok(!$instance->has_foo, "noo foo value yet");
+ ok(!$instance->_has_foo, "noo _foo value yet");
+ is($instance->foo, 'works', "foo builder works");
+ is($instance->_foo, 'works too', "foo builder works too");
+ dies_ok { $instance->fool }
+# throws_ok { $instance->fool }
+# qr/Test::LazyBuild::Attribute does not support builder method \'_build_fool\' for attribute \'fool\'/,
+ "Correct error when a builder method is not present";
+
+}
+
+{
+ package OutOfClassTest;
+
+ use Mouse;
+}
+
+# Mouse::Exporter does not support 'with_meta'
+#lives_ok { OutOfClassTest::has('foo', is => 'bare'); } 'create attr via direct sub call';
+#lives_ok { OutOfClassTest->can('has')->('bar', is => 'bare'); } 'create attr via can';
+
+#ok(OutOfClassTest->meta->get_attribute('foo'), 'attr created from sub call');
+#ok(OutOfClassTest->meta->get_attribute('bar'), 'attr created from can');
+
+
+{
+ {
+ package Foo;
+ use Mouse;
+
+ ::throws_ok { has 'foo' => ( 'ro', isa => 'Str' ) }
+ qr/^Usage/, 'has throws error with odd number of attribute options';
+ }
+
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+use Test::Exception;
+
+
+
+{
+ package Customer;
+ use Mouse;
+
+ package Firm;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ ::lives_ok {
+ has 'customers' => (
+ is => 'ro',
+ isa => subtype('ArrayRef' => where {
+ (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }),
+ auto_deref => 1,
+ );
+ } '... successfully created attr';
+}
+
+{
+ my $customer = Customer->new;
+ isa_ok($customer, 'Customer');
+
+ my $firm = Firm->new(customers => [ $customer ]);
+ isa_ok($firm, 'Firm');
+
+ can_ok($firm, 'customers');
+
+ is_deeply(
+ [ $firm->customers ],
+ [ $customer ],
+ '... got the right dereferenced value'
+ );
+}
+
+{
+ my $firm = Firm->new();
+ isa_ok($firm, 'Firm');
+
+ can_ok($firm, 'customers');
+
+ is_deeply(
+ [ $firm->customers ],
+ [],
+ '... got the right dereferenced value'
+ );
+}
+
+{
+ package AutoDeref;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'rw',
+ isa => 'ArrayRef[Int]',
+ auto_deref => 1,
+ );
+}
+
+{
+ my $autoderef = AutoDeref->new;
+
+ dies_ok {
+ $autoderef->bar(1, 2, 3);
+ } '... its auto-de-ref-ing, not auto-en-ref-ing';
+
+ lives_ok {
+ $autoderef->bar([ 1, 2, 3 ])
+ } '... set the results of bar correctly';
+
+ is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+
+
+{
+ package HTTPHeader;
+ use Mouse;
+
+ has 'array' => (is => 'ro');
+ has 'hash' => (is => 'ro');
+}
+
+{
+ package Request;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype Header =>
+ => as Object
+ => where { $_->isa('HTTPHeader') };
+
+ coerce Header
+ => from ArrayRef
+ => via { HTTPHeader->new(array => $_[0]) }
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+
+ has 'headers' => (
+ is => 'rw',
+ isa => 'Header',
+ coerce => 1,
+ lazy => 1,
+ default => sub { [ 'content-type', 'text/html' ] }
+ );
+}
+
+my $r = Request->new;
+isa_ok($r, 'Request');
+
+lives_ok {
+ $r->headers;
+} '... this coerces and passes the type constraint even with lazy';
+
+
+
#!/usr/bin/perl
-use lib 't/lib';
use strict;
use warnings;
-use Test::More tests => 12;
+use lib 't/lib';
+use Test::More tests => 12;
use Test::Exception;
use Test::Mouse;
-
-
{
package My::Attribute::Trait;
use Mouse::Role;
after 'install_accessors' => sub {
my $self = shift;
- my $reader = $self->get_read_method;
-
$self->associated_class->add_method(
$self->alias_to,
- sub { shift->$reader(@_) },
+ $self->get_read_method_ref
);
};
}
is($c->baz, 100, '... got the right value for baz');
my $bar_attr = $c->meta->get_attribute('bar');
-
does_ok($bar_attr, 'My::Attribute::Trait');
ok($bar_attr->has_applied_traits, '... got the applied traits');
is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Test::More tests => 23;
+use Test::Exception;
+use Test::Mouse;
+
+
+
+{
+ package My::Attribute::Trait;
+ use Mouse::Role;
+
+ has 'alias_to' => (is => 'ro', isa => 'Str');
+
+ has foo => ( is => "ro", default => "blah" );
+
+ after 'install_accessors' => sub {
+ my $self = shift;
+ $self->associated_class->add_method(
+ $self->alias_to,
+ $self->get_read_method_ref
+ );
+ };
+
+ package Mouse::Meta::Attribute::Custom::Trait::Aliased;
+ sub register_implementation { 'My::Attribute::Trait' }
+}
+
+{
+ package My::Other::Attribute::Trait;
+ use Mouse::Role;
+
+ my $method = sub {
+ 42;
+ };
+
+ has the_other_attr => ( isa => "Str", is => "rw", default => "oink" );
+
+ after 'install_accessors' => sub {
+ my $self = shift;
+ $self->associated_class->add_method(
+ 'additional_method',
+ $method
+ );
+ };
+
+ package Mouse::Meta::Attribute::Custom::Trait::Other;
+ sub register_implementation { 'My::Other::Attribute::Trait' }
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ has 'bar' => (
+ traits => [qw/Aliased/],
+ is => 'ro',
+ isa => 'Int',
+ alias_to => 'baz',
+ );
+}
+
+{
+ package My::Derived::Class;
+ use Mouse;
+
+ extends 'My::Class';
+
+ has '+bar' => (
+ traits => [qw/Other/],
+ );
+}
+
+my $c = My::Class->new(bar => 100);
+isa_ok($c, 'My::Class');
+
+is($c->bar, 100, '... got the right value for bar');
+
+can_ok($c, 'baz') and
+is($c->baz, 100, '... got the right value for baz');
+
+my $bar_attr = $c->meta->get_attribute('bar');
+does_ok($bar_attr, 'My::Attribute::Trait');
+is($bar_attr->foo, "blah", "attr initialized");
+
+ok(!$bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity");
+{
+local $TODO = 'aliased name is not supported';
+ok($bar_attr->does('Aliased'), "attr->does uses aliases");
+}
+ok(!$bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles");
+ok(!$bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles");
+
+my $quux = My::Derived::Class->new(bar => 1000);
+
+is($quux->bar, 1000, '... got the right value for bar');
+
+can_ok($quux, 'baz');
+is($quux->baz, 1000, '... got the right value for baz');
+
+my $derived_bar_attr = $quux->meta->get_attribute("bar");
+does_ok($derived_bar_attr, 'My::Attribute::Trait' );
+
+is( $derived_bar_attr->foo, "blah", "attr initialized" );
+
+does_ok($derived_bar_attr, 'My::Other::Attribute::Trait' );
+
+is($derived_bar_attr->the_other_attr, "oink", "attr initialized" );
+
+ok(!$derived_bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity");
+{
+local $TODO = 'aliased name is not supported';
+ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases");
+}
+ok(!$derived_bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles");
+ok(!$derived_bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles");
+
+can_ok($quux, 'additional_method');
+is(eval { $quux->additional_method }, 42, '... got the right value for additional_method');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Test::More tests => 7;
+use Test::Exception;
+use Test::Mouse;
+
+
+
+{
+ package My::Meta::Attribute::DefaultReadOnly;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+
+ around 'new' => sub {
+ my $next = shift;
+ my ($self, $name, %options) = @_;
+ $options{is} = 'ro'
+ unless exists $options{is};
+ $next->($self, $name, %options);
+ };
+}
+
+{
+ package My::Attribute::Trait;
+ use Mouse::Role;
+
+ has 'alias_to' => (is => 'ro', isa => 'Str');
+
+ after 'install_accessors' => sub {
+ my $self = shift;
+ $self->associated_class->add_method(
+ $self->alias_to,
+ $self->get_read_method_ref
+ );
+ };
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ has 'bar' => (
+ metaclass => 'My::Meta::Attribute::DefaultReadOnly',
+ traits => [qw/My::Attribute::Trait/],
+ isa => 'Int',
+ alias_to => 'baz',
+ );
+}
+
+my $c = My::Class->new(bar => 100);
+isa_ok($c, 'My::Class');
+
+is($c->bar, 100, '... got the right value for bar');
+
+can_ok($c, 'baz');
+is($c->baz, 100, '... got the right value for baz');
+
+isa_ok($c->meta->get_attribute('bar'), 'My::Meta::Attribute::DefaultReadOnly');
+does_ok($c->meta->get_attribute('bar'), 'My::Attribute::Trait');
+is($c->meta->get_attribute('bar')->_is_metadata, 'ro', '... got the right metaclass customization');
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ is => "rw",
+ init_arg => undef,
+ );
+ };
+ ::ok(!$@, '... created the attr okay');
+}
+
+{
+ my $foo = Foo->new( foo => "bar" );
+ isa_ok($foo, 'Foo');
+
+ is( $foo->foo, undef, "field is not set via init arg" );
+
+ $foo->foo("blah");
+
+ is( $foo->foo, "blah", "field is set via setter" );
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+use Test::Exception;
+
+
+
+{
+
+ package Fake::DateTime;
+ use Mouse;
+
+ has 'string_repr' => ( is => 'ro' );
+
+ package Mortgage;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'Fake::DateTime' => from 'Str' =>
+ via { Fake::DateTime->new( string_repr => $_ ) };
+
+ has 'closing_date' => (
+ is => 'rw',
+ isa => 'Fake::DateTime',
+ coerce => 1,
+ trigger => sub {
+ my ( $self, $val ) = @_;
+ ::pass('... trigger is being called');
+ ::isa_ok( $self->closing_date, 'Fake::DateTime' );
+ ::isa_ok( $val, 'Fake::DateTime' );
+ }
+ );
+}
+
+{
+ my $mtg = Mortgage->new( closing_date => 'yesterday' );
+ isa_ok( $mtg, 'Mortgage' );
+
+ # check that coercion worked
+ isa_ok( $mtg->closing_date, 'Fake::DateTime' );
+}
+
+Mortgage->meta->make_immutable;
+ok( Mortgage->meta->is_immutable, '... Mortgage is now immutable' );
+
+{
+ my $mtg = Mortgage->new( closing_date => 'yesterday' );
+ isa_ok( $mtg, 'Mortgage' );
+
+ # check that coercion worked
+ isa_ok( $mtg->closing_date, 'Fake::DateTime' );
+}
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+{
+ package My::Attribute::Trait;
+ use Mouse::Role;
+
+ sub reversed_name {
+ my $self = shift;
+ scalar reverse $self->name;
+ }
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ -alias => {
+ reversed_name => 'eman',
+ },
+ },
+ ],
+ is => 'bare',
+ );
+}
+
+{
+ package My::Other::Class;
+ use Mouse;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ -alias => {
+ reversed_name => 'reversed',
+ },
+ -excludes => 'reversed_name',
+ },
+ ],
+ is => 'bare',
+ );
+}
+
+my $attr = My::Class->meta->get_attribute('foo');
+is($attr->eman, 'oof', 'the aliased method is in the attribute');
+ok(!$attr->can('reversed'), "the method was not installed under the other class' alias");
+
+my $other_attr = My::Other::Class->meta->get_attribute('foo');
+is($other_attr->reversed, 'oof', 'the aliased method is in the attribute');
+ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias");
+ok(!$other_attr->can('reversed_name'), "the method was not installed under the original name when that was excluded");
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::Exception;
+
+{
+ package Baz;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'Baz' => from 'HashRef' => via { Baz->new($_) };
+
+ has 'hello' => (
+ is => 'ro',
+ isa => 'Str',
+ );
+
+ package Bar;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'Bar' => from 'HashRef' => via { Bar->new($_) };
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ coerce => 1
+ );
+
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Bar',
+ coerce => 1,
+ );
+}
+
+my $foo = Foo->new(bar => { baz => { hello => 'World' } });
+isa_ok($foo, 'Foo');
+isa_ok($foo->bar, 'Bar');
+isa_ok($foo->bar->baz, 'Baz');
+is($foo->bar->baz->hello, 'World', '... this all worked fine');
+
+
--- /dev/null
+#!/usr/bin/perl
+BEGIN{ $ENV{MOUSE_VERBOSE} = 1 }
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+use Mouse ();
+use Mouse::Meta::Class;
+
+my $meta = Mouse::Meta::Class->create('Banana');
+
+my $warn;
+$SIG{__WARN__} = sub { $warn = "@_" };
+
+$meta->add_attribute('foo');
+like $warn, qr/Attribute \(foo\) of class Banana has no associated methods/,
+ 'correct error message';
+
+$warn = '';
+$meta->add_attribute('bar', is => 'bare');
+is $warn, '', 'add attribute with no methods and is => "bare"';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 14;
+use Test::Exception;
+
+lives_ok {
+ package My::Class;
+ use Mouse;
+
+ has s_rw => (
+ is => 'rw',
+ );
+
+ has s_ro => (
+ is => 'ro',
+ );
+
+ has a_rw => (
+ is => 'rw',
+ isa => 'ArrayRef',
+
+ auto_deref => 1,
+ );
+
+ has a_ro => (
+ is => 'ro',
+ isa => 'ArrayRef',
+
+ auto_deref => 1,
+ );
+
+ has h_rw => (
+ is => 'rw',
+ isa => 'HashRef',
+
+ auto_deref => 1,
+ );
+
+ has h_ro => (
+ is => 'ro',
+ isa => 'HashRef',
+
+ auto_deref => 1,
+ );
+} 'class definition';
+
+lives_ok {
+ my $o = My::Class->new();
+
+ is_deeply [scalar $o->s_rw], [undef], 'uninitialized scalar attribute/rw in scalar context';
+ is_deeply [$o->s_rw], [undef], 'uninitialized scalar attribute/rw in list context';
+ is_deeply [scalar $o->s_ro], [undef], 'uninitialized scalar attribute/ro in scalar context';
+ is_deeply [$o->s_ro], [undef], 'uninitialized scalar attribute/ro in list context';
+
+
+ is_deeply [scalar $o->a_rw], [undef], 'uninitialized ArrayRef attribute/rw in scalar context';
+ is_deeply [$o->a_rw], [], 'uninitialized ArrayRef attribute/rw in list context';
+ is_deeply [scalar $o->a_ro], [undef], 'uninitialized ArrayRef attribute/ro in scalar context';
+ is_deeply [$o->a_ro], [], 'uninitialized ArrayRef attribute/ro in list context';
+
+ is_deeply [scalar $o->h_rw], [undef], 'uninitialized HashRef attribute/rw in scalar context';
+ is_deeply [$o->h_rw], [], 'uninitialized HashRef attribute/rw in list context';
+ is_deeply [scalar $o->h_ro], [undef], 'uninitialized HashRef attribute/ro in scalar context';
+ is_deeply [$o->h_ro], [], 'uninitialized HashRef attribute/ro in list context';
+
+} 'testing';
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+
+{
+ package Foo;
+ use Mouse;
+ has 'type' => (
+ required => 0,
+ reader => 'get_type',
+ default => 1,
+ );
+
+ has '@type' => (
+ required => 0,
+ reader => 'get_at_type',
+ default => 2,
+ );
+
+ has 'has spaces' => (
+ required => 0,
+ reader => 'get_hs',
+ default => 42,
+ );
+
+ no Mouse;
+}
+
+{
+ my $foo = Foo->new;
+
+ ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" )
+ for 'type', '@type', 'has spaces';
+
+ is( $foo->get_type, 1, q{'type' attribute default is 1} );
+ is( $foo->get_at_type, 2, q{'@type' attribute default is 1} );
+ is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} );
+
+ Foo->meta->make_immutable, redo if Foo->meta->is_mutable;
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ reader => 'get_foo'
+ );
+ };
+ ::ok(!$@, '... created the reader method okay');
+
+ eval {
+ has 'lazy_foo' => (
+ reader => 'get_lazy_foo',
+ lazy => 1,
+ default => sub { 10 }
+ );
+ };
+ ::ok(!$@, '... created the lazy reader method okay') or warn $@;
+
+ my $warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { $warn = $_[0] };
+ has 'mtfnpy' => (
+ reder => 'get_mftnpy'
+ );
+ };
+ ::ok($warn, '... got a warning for mispelled attribute argument');
+}
+
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ can_ok($foo, 'get_foo');
+ is($foo->get_foo(), undef, '... got an undefined value');
+ dies_ok {
+ $foo->get_foo(100);
+ } '... get_foo is a read-only';
+
+ ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot');
+
+ can_ok($foo, 'get_lazy_foo');
+ is($foo->get_lazy_foo(), 10, '... got an deferred value');
+ dies_ok {
+ $foo->get_lazy_foo(100);
+ } '... get_lazy_foo is a read-only';
+}
+
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ my $attr = $foo->meta->find_attribute_by_name("lazy_foo");
+
+ isa_ok( $attr, "Mouse::Meta::Attribute" );
+
+ ok( $attr->is_lazy, "it's lazy" );
+
+ is( $attr->get_raw_value($foo), undef, "raw value" );
+
+ is( $attr->get_value($foo), 10, "lazy value" );
+
+ is( $attr->get_raw_value($foo), 10, "raw value" );
+}
+
+{
+ my $foo = Foo->new(foo => 10, lazy_foo => 100);
+ isa_ok($foo, 'Foo');
+
+ is($foo->get_foo(), 10, '... got the correct value');
+ is($foo->get_lazy_foo(), 100, '... got the correct value');
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Scalar::Util 'isweak';
+
+use Test::More tests => 43;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'rw',
+ isa => 'Maybe[Bar]',
+ trigger => sub {
+ my ($self, $bar) = @_;
+ $bar->foo($self) if defined $bar;
+ });
+
+ has 'baz' => (writer => 'set_baz',
+ reader => 'get_baz',
+ isa => 'Baz',
+ trigger => sub {
+ my ($self, $baz) = @_;
+ $baz->foo($self);
+ });
+
+
+ package Bar;
+ use Mouse;
+
+ has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
+
+ package Baz;
+ use Mouse;
+
+ has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
+}
+
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ my $bar = Bar->new;
+ isa_ok($bar, 'Bar');
+
+ my $baz = Baz->new;
+ isa_ok($baz, 'Baz');
+
+ lives_ok {
+ $foo->bar($bar);
+ } '... did not die setting bar';
+
+ is($foo->bar, $bar, '... set the value foo.bar correctly');
+ is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
+
+ ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
+
+ lives_ok {
+ $foo->bar(undef);
+ } '... did not die un-setting bar';
+
+ is($foo->bar, undef, '... set the value foo.bar correctly');
+ is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
+
+ # test the writer
+
+ lives_ok {
+ $foo->set_baz($baz);
+ } '... did not die setting baz';
+
+ is($foo->get_baz, $baz, '... set the value foo.baz correctly');
+ is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
+
+ ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
+}
+
+{
+ my $bar = Bar->new;
+ isa_ok($bar, 'Bar');
+
+ my $baz = Baz->new;
+ isa_ok($baz, 'Baz');
+
+ my $foo = Foo->new(bar => $bar, baz => $baz);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, $bar, '... set the value foo.bar correctly');
+ is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
+
+ ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
+
+ is($foo->get_baz, $baz, '... set the value foo.baz correctly');
+ is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
+
+ ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
+}
+
+# some errors
+
+{
+ package Bling;
+ use Mouse;
+
+ ::dies_ok {
+ has('bling' => (is => 'rw', trigger => 'Fail'));
+ } '... a trigger must be a CODE ref';
+
+ ::dies_ok {
+ has('bling' => (is => 'rw', trigger => []));
+ } '... a trigger must be a CODE ref';
+}
+
+# Triggers do not fire on built values
+
+{
+ package Blarg;
+ use Mouse;
+
+ our %trigger_calls;
+ our %trigger_vals;
+ has foo => (is => 'rw', default => sub { 'default foo value' },
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{foo}++;
+ $trigger_vals{foo} = $val });
+ has bar => (is => 'rw', lazy_build => 1,
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{bar}++;
+ $trigger_vals{bar} = $val });
+ sub _build_bar { return 'default bar value' }
+ has baz => (is => 'rw', builder => '_build_baz',
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{baz}++;
+ $trigger_vals{baz} = $val });
+ sub _build_baz { return 'default baz value' }
+}
+
+{
+ my $blarg;
+ lives_ok { $blarg = Blarg->new; } 'Blarg->new() lives';
+ ok($blarg, 'Have a $blarg');
+ foreach my $attr (qw/foo bar baz/) {
+ is($blarg->$attr(), "default $attr value", "$attr has default value");
+ }
+ is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired');
+ foreach my $attr (qw/foo bar baz/) {
+ $blarg->$attr("Different $attr value");
+ }
+ is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign');
+ is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
+
+ lives_ok { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) } '->new() with parameters';
+ is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct');
+ is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
+}
+
+# Triggers do not receive the meta-attribute as an argument, but do
+# receive the old value
+
+{
+ package Foo;
+ use Mouse;
+ our @calls;
+ has foo => (is => 'rw', trigger => sub { push @calls, [@_] });
+}
+
+{
+ my $attr = Foo->meta->get_attribute('foo');
+
+ my $foo = Foo->new;
+ $attr->set_value( $foo, 2 );
+
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 2 ] ],
+ 'trigger called correctly on initial set via meta-API',
+ );
+ @Foo::calls = ();
+
+ $attr->set_value( $foo, 3 );
+
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 3, 2 ] ],
+ 'trigger called correctly on second set via meta-API',
+ );
+ @Foo::calls = ();
+
+ $attr->set_raw_value( $foo, 4 );
+
+ is_deeply(
+ \@Foo::calls,
+ [ ],
+ 'trigger not called using set_raw_value method',
+ );
+ @Foo::calls = ();
+}
+
+{
+ my $foo = Foo->new(foo => 2);
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 2 ] ],
+ 'trigger called correctly on construction',
+ );
+ @Foo::calls = ();
+
+ $foo->foo(3);
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 3, 2 ] ],
+ 'trigger called correctly on set (with old value)',
+ );
+ @Foo::calls = ();
+ Foo->meta->make_immutable, redo if Foo->meta->is_mutable;
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 84;
+use Test::Exception;
+
+
+
+{
+ package Thing;
+ use Mouse;
+
+ sub hello { 'Hello World (from Thing)' }
+ sub goodbye { 'Goodbye World (from Thing)' }
+
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype 'FooStr'
+ => as 'Str'
+ => where { /Foo/ };
+
+ coerce 'FooStr'
+ => from ArrayRef
+ => via { 'FooArrayRef' };
+
+ has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar');
+ has 'baz' => (is => 'rw', isa => 'Ref');
+ has 'foo' => (is => 'rw', isa => 'FooStr');
+
+ has 'gorch' => (is => 'ro');
+ has 'gloum' => (is => 'ro', default => sub {[]});
+ has 'fleem' => (is => 'ro');
+
+ has 'bling' => (is => 'ro', isa => 'Thing');
+ has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']);
+
+ has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef');
+
+ has 'one_last_one' => (is => 'rw', isa => 'Ref');
+
+ # this one will work here ....
+ has 'fail' => (isa => 'CodeRef', is => 'bare');
+ has 'other_fail' => (is => 'bare');
+
+ package Bar;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ extends 'Foo';
+
+ ::lives_ok {
+ has '+bar' => (default => 'Bar::bar');
+ } '... we can change the default attribute option';
+
+ ::lives_ok {
+ has '+baz' => (isa => 'ArrayRef');
+ } '... we can add change the isa as long as it is a subtype';
+
+ ::lives_ok {
+ has '+foo' => (coerce => 1);
+ } '... we can change/add coerce as an attribute option';
+
+ ::lives_ok {
+ has '+gorch' => (required => 1);
+ } '... we can change/add required as an attribute option';
+
+ ::lives_ok {
+ has '+gloum' => (lazy => 1);
+ } '... we can change/add lazy as an attribute option';
+
+ ::lives_ok {
+ has '+gloum' => (lazy_build => 1);
+ } '... we can add lazy_build as an attribute option';
+
+ ::lives_ok {
+ has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]');
+ } '... extend an attribute with parameterized type';
+
+ ::lives_ok {
+ has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' }));
+ } '... extend an attribute with anon-subtype';
+
+ ::lives_ok {
+ has '+one_last_one' => (isa => 'Value');
+ } '... now can extend an attribute with a non-subtype';
+
+ ::lives_ok {
+ has '+fleem' => (weak_ref => 1);
+ } '... now allowed to add the weak_ref option via inheritance';
+
+ ::lives_ok {
+ has '+bling' => (handles => ['hello']);
+ } '... we can add the handles attribute option';
+
+ # this one will *not* work here ....
+ ::dies_ok {
+ has '+blang' => (handles => ['hello']);
+ } '... we can not alter the handles attribute option';
+ ::lives_ok {
+ has '+fail' => (isa => 'Ref');
+ } '... can now create an attribute with an improper subtype relation';
+ ::dies_ok {
+ has '+other_fail' => (trigger => sub {});
+ } '... cannot create an attribute with an illegal option';
+ ::throws_ok {
+ has '+does_not_exist' => (isa => 'Str');
+ } qr/in Bar/, '... cannot extend a non-existing attribute';
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+is($foo->foo, undef, '... got the right undef default value');
+lives_ok { $foo->foo('FooString') } '... assigned foo correctly';
+is($foo->foo, 'FooString', '... got the right value for foo');
+
+dies_ok { $foo->foo([]) } '... foo is not coercing (as expected)';
+
+is($foo->bar, 'Foo::bar', '... got the right default value');
+dies_ok { $foo->bar(10) } '... Foo::bar is a read/only attr';
+
+is($foo->baz, undef, '... got the right undef default value');
+
+{
+ my $hash_ref = {};
+ lives_ok { $foo->baz($hash_ref) } '... Foo::baz accepts hash refs';
+ is($foo->baz, $hash_ref, '... got the right value assigned to baz');
+
+ my $array_ref = [];
+ lives_ok { $foo->baz($array_ref) } '... Foo::baz accepts an array ref';
+ is($foo->baz, $array_ref, '... got the right value assigned to baz');
+
+ my $scalar_ref = \(my $var);
+ lives_ok { $foo->baz($scalar_ref) } '... Foo::baz accepts scalar ref';
+ is($foo->baz, $scalar_ref, '... got the right value assigned to baz');
+
+ lives_ok { $foo->bunch_of_stuff([qw[one two three]]) } '... Foo::bunch_of_stuff accepts an array of strings';
+
+ lives_ok { $foo->one_last_one(sub { 'Hello World'}) } '... Foo::one_last_one accepts a code ref';
+
+ my $code_ref = sub { 1 };
+ lives_ok { $foo->baz($code_ref) } '... Foo::baz accepts a code ref';
+ is($foo->baz, $code_ref, '... got the right value assigned to baz');
+}
+
+dies_ok {
+ Bar->new;
+} '... cannot create Bar without required gorch param';
+
+my $bar = Bar->new(gorch => 'Bar::gorch');
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is($bar->foo, undef, '... got the right undef default value');
+lives_ok { $bar->foo('FooString') } '... assigned foo correctly';
+is($bar->foo, 'FooString', '... got the right value for foo');
+lives_ok { $bar->foo([]) } '... assigned foo correctly';
+is($bar->foo, 'FooArrayRef', '... got the right value for foo');
+
+is($bar->gorch, 'Bar::gorch', '... got the right default value');
+
+is($bar->bar, 'Bar::bar', '... got the right default value');
+dies_ok { $bar->bar(10) } '... Bar::bar is a read/only attr';
+
+is($bar->baz, undef, '... got the right undef default value');
+
+{
+ my $hash_ref = {};
+ dies_ok { $bar->baz($hash_ref) } '... Bar::baz does not accept hash refs';
+
+ my $array_ref = [];
+ lives_ok { $bar->baz($array_ref) } '... Bar::baz can accept an array ref';
+ is($bar->baz, $array_ref, '... got the right value assigned to baz');
+
+ my $scalar_ref = \(my $var);
+ dies_ok { $bar->baz($scalar_ref) } '... Bar::baz does not accept a scalar ref';
+
+ lives_ok { $bar->bunch_of_stuff([1, 2, 3]) } '... Bar::bunch_of_stuff accepts an array of ints';
+ dies_ok { $bar->bunch_of_stuff([qw[one two three]]) } '... Bar::bunch_of_stuff does not accept an array of strings';
+
+ my $code_ref = sub { 1 };
+ dies_ok { $bar->baz($code_ref) } '... Bar::baz does not accept a code ref';
+}
+
+# check some meta-stuff
+
+ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr');
+ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr');
+ok(Bar->meta->has_attribute('baz'), '... Bar has a baz attr');
+ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch attr');
+ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr');
+ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr');
+ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr');
+{
+local $TODO = 'not supported';
+ok(!Bar->meta->has_attribute('blang'), '... Bar does not have a blang attr');
+}
+ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr');
+{
+local $TODO = 'not supported';
+ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have an other_fail attr');
+}
+
+isnt(Foo->meta->get_attribute('foo'),
+ Bar->meta->get_attribute('foo'),
+ '... Foo and Bar have different copies of foo');
+isnt(Foo->meta->get_attribute('bar'),
+ Bar->meta->get_attribute('bar'),
+ '... Foo and Bar have different copies of bar');
+isnt(Foo->meta->get_attribute('baz'),
+ Bar->meta->get_attribute('baz'),
+ '... Foo and Bar have different copies of baz');
+isnt(Foo->meta->get_attribute('gorch'),
+ Bar->meta->get_attribute('gorch'),
+ '... Foo and Bar have different copies of gorch');
+isnt(Foo->meta->get_attribute('gloum'),
+ Bar->meta->get_attribute('gloum'),
+ '... Foo and Bar have different copies of gloum');
+isnt(Foo->meta->get_attribute('bling'),
+ Bar->meta->get_attribute('bling'),
+ '... Foo and Bar have different copies of bling');
+isnt(Foo->meta->get_attribute('bunch_of_stuff'),
+ Bar->meta->get_attribute('bunch_of_stuff'),
+ '... Foo and Bar have different copies of bunch_of_stuff');
+
+ok(Bar->meta->get_attribute('bar')->has_type_constraint,
+ '... Bar::bar inherited the type constraint too');
+ok(Bar->meta->get_attribute('baz')->has_type_constraint,
+ '... Bar::baz inherited the type constraint too');
+
+is(Bar->meta->get_attribute('bar')->type_constraint->name,
+ 'Str', '... Bar::bar inherited the right type constraint too');
+
+is(Foo->meta->get_attribute('baz')->type_constraint->name,
+ 'Ref', '... Foo::baz inherited the right type constraint too');
+is(Bar->meta->get_attribute('baz')->type_constraint->name,
+ 'ArrayRef', '... Bar::baz inherited the right type constraint too');
+
+ok(!Foo->meta->get_attribute('gorch')->is_required,
+ '... Foo::gorch is not a required attr');
+ok(Bar->meta->get_attribute('gorch')->is_required,
+ '... Bar::gorch is a required attr');
+
+is(Foo->meta->get_attribute('bunch_of_stuff')->type_constraint->name,
+ 'ArrayRef',
+ '... Foo::bunch_of_stuff is an ArrayRef');
+is(Bar->meta->get_attribute('bunch_of_stuff')->type_constraint->name,
+ 'ArrayRef[Int]',
+ '... Bar::bunch_of_stuff is an ArrayRef[Int]');
+
+ok(!Foo->meta->get_attribute('gloum')->is_lazy,
+ '... Foo::gloum is not a required attr');
+ok(Bar->meta->get_attribute('gloum')->is_lazy,
+ '... Bar::gloum is a required attr');
+
+ok(!Foo->meta->get_attribute('foo')->should_coerce,
+ '... Foo::foo should not coerce');
+ok(Bar->meta->get_attribute('foo')->should_coerce,
+ '... Bar::foo should coerce');
+
+ok(!Foo->meta->get_attribute('bling')->has_handles,
+ '... Foo::foo should not handles');
+ok(Bar->meta->get_attribute('bling')->has_handles,
+ '... Bar::foo should handles');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 92;
+use Test::Exception;
+
+
+
+# -------------------------------------------------------------------
+# HASH handles
+# -------------------------------------------------------------------
+# the canonical form of of the 'handles'
+# option is the hash ref mapping a
+# method name to the delegated method name
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'rw', default => 10);
+
+ sub baz { 42 }
+
+ package Bar;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo->new },
+ handles => {
+ 'foo_bar' => 'bar',
+ foo_baz => 'baz',
+ 'foo_bar_to_20' => [ bar => 20 ],
+ },
+ );
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+
+ok($bar->foo, '... we have something in bar->foo');
+isa_ok($bar->foo, 'Foo');
+
+my $meth = Bar->meta->get_method('foo_bar');
+isa_ok($meth, 'Mouse::Meta::Method::Delegation');
+is($meth->associated_attribute->name, 'foo',
+ 'associated_attribute->name for this method is foo');
+
+is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
+
+can_ok($bar, 'foo_bar');
+is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
+
+# change the value ...
+
+$bar->foo->bar(30);
+
+# and make sure the delegation picks it up
+
+is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
+is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
+
+# change the value through the delegation ...
+
+$bar->foo_bar(50);
+
+# and make sure everyone sees it
+
+is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
+is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
+
+# change the object we are delegating too
+
+my $foo = Foo->new(bar => 25);
+isa_ok($foo, 'Foo');
+
+is($foo->bar, 25, '... got the right foo->bar');
+
+lives_ok {
+ $bar->foo($foo);
+} '... assigned the new Foo to Bar->foo';
+
+is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+
+is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
+is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+
+# curried handles
+$bar->foo_bar_to_20;
+is($bar->foo_bar, 20, '... correctly curried a single argument');
+
+# -------------------------------------------------------------------
+# ARRAY handles
+# -------------------------------------------------------------------
+# we also support an array based format
+# which assumes that the name is the same
+# on either end
+
+{
+ package Engine;
+ use Mouse;
+
+ sub go { 'Engine::go' }
+ sub stop { 'Engine::stop' }
+
+ package Car;
+ use Mouse;
+
+ has 'engine' => (
+ is => 'rw',
+ default => sub { Engine->new },
+ handles => [ 'go', 'stop' ]
+ );
+}
+
+my $car = Car->new;
+isa_ok($car, 'Car');
+
+isa_ok($car->engine, 'Engine');
+can_ok($car->engine, 'go');
+can_ok($car->engine, 'stop');
+
+is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
+is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
+
+can_ok($car, 'go');
+can_ok($car, 'stop');
+
+is($car->go, 'Engine::go', '... got the right value from ->go');
+is($car->stop, 'Engine::stop', '... got the right value from ->stop');
+
+# -------------------------------------------------------------------
+# REGEXP handles
+# -------------------------------------------------------------------
+# and we support regexp delegation
+
+{
+ package Baz;
+ use Mouse;
+
+ sub foo { 'Baz::foo' }
+ sub bar { 'Baz::bar' }
+ sub boo { 'Baz::boo' }
+
+ package Baz::Proxy1;
+ use Mouse;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/.*/
+ );
+
+ package Baz::Proxy2;
+ use Mouse;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/.oo/
+ );
+
+ package Baz::Proxy3;
+ use Mouse;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/b.*/
+ );
+}
+
+{
+ my $baz_proxy = Baz::Proxy1->new;
+ isa_ok($baz_proxy, 'Baz::Proxy1');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'foo');
+ can_ok($baz_proxy, 'bar');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
+ is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+{
+ my $baz_proxy = Baz::Proxy2->new;
+ isa_ok($baz_proxy, 'Baz::Proxy2');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'foo');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+{
+ my $baz_proxy = Baz::Proxy3->new;
+ isa_ok($baz_proxy, 'Baz::Proxy3');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'bar');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+
+# -------------------------------------------------------------------
+# ROLE handles
+# -------------------------------------------------------------------
+
+{
+ package Foo::Bar;
+ use Mouse::Role;
+
+ requires 'foo';
+ requires 'bar';
+
+ package Foo::Baz;
+ use Mouse;
+
+ sub foo { 'Foo::Baz::FOO' }
+ sub bar { 'Foo::Baz::BAR' }
+ sub baz { 'Foo::Baz::BAZ' }
+
+ package Foo::Thing;
+ use Mouse;
+
+ has 'thing' => (
+ is => 'rw',
+ isa => 'Foo::Baz',
+ handles => 'Foo::Bar',
+ );
+
+}
+
+{
+ my $foo = Foo::Thing->new(thing => Foo::Baz->new);
+ isa_ok($foo, 'Foo::Thing');
+ isa_ok($foo->thing, 'Foo::Baz');
+
+ ok($foo->meta->has_method('foo'), '... we have the method we expect');
+ ok($foo->meta->has_method('bar'), '... we have the method we expect');
+ ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
+
+ is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
+ is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
+ is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
+}
+
+# -------------------------------------------------------------------
+# AUTOLOAD & handles
+# -------------------------------------------------------------------
+
+{
+ package Foo::Autoloaded;
+ use Mouse;
+
+ sub AUTOLOAD {
+ my $self = shift;
+
+ my $name = our $AUTOLOAD;
+ $name =~ s/.*://; # strip fully-qualified portion
+
+ if (@_) {
+ return $self->{$name} = shift;
+ } else {
+ return $self->{$name};
+ }
+ }
+
+ package Bar::Autoloaded;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo::Autoloaded->new },
+ handles => { 'foo_bar' => 'bar' }
+ );
+
+ package Baz::Autoloaded;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo::Autoloaded->new },
+ handles => ['bar']
+ );
+
+ package Goorch::Autoloaded;
+ use Mouse;
+
+ ::dies_ok {
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo::Autoloaded->new },
+ handles => qr/bar/
+ );
+ } '... you cannot delegate to AUTOLOADED class with regexp';
+}
+
+# check HASH based delegation w/ AUTOLOAD
+
+{
+ my $bar = Bar::Autoloaded->new;
+ isa_ok($bar, 'Bar::Autoloaded');
+
+ ok($bar->foo, '... we have something in bar->foo');
+ isa_ok($bar->foo, 'Foo::Autoloaded');
+
+ # change the value ...
+
+ $bar->foo->bar(30);
+
+ # and make sure the delegation picks it up
+
+ is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
+ is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
+
+ # change the value through the delegation ...
+
+ $bar->foo_bar(50);
+
+ # and make sure everyone sees it
+
+ is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
+ is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
+
+ # change the object we are delegating too
+
+ my $foo = Foo::Autoloaded->new;
+ isa_ok($foo, 'Foo::Autoloaded');
+
+ $foo->bar(25);
+
+ is($foo->bar, 25, '... got the right foo->bar');
+
+ lives_ok {
+ $bar->foo($foo);
+ } '... assigned the new Foo to Bar->foo';
+
+ is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+
+ is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
+ is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+}
+
+# check ARRAY based delegation w/ AUTOLOAD
+
+{
+ my $baz = Baz::Autoloaded->new;
+ isa_ok($baz, 'Baz::Autoloaded');
+
+ ok($baz->foo, '... we have something in baz->foo');
+ isa_ok($baz->foo, 'Foo::Autoloaded');
+
+ # change the value ...
+
+ $baz->foo->bar(30);
+
+ # and make sure the delegation picks it up
+
+ is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
+ is($baz->bar, 30, '... baz->foo_bar delegated correctly');
+
+ # change the value through the delegation ...
+
+ $baz->bar(50);
+
+ # and make sure everyone sees it
+
+ is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
+ is($baz->bar, 50, '... baz->foo_bar delegated correctly');
+
+ # change the object we are delegating too
+
+ my $foo = Foo::Autoloaded->new;
+ isa_ok($foo, 'Foo::Autoloaded');
+
+ $foo->bar(25);
+
+ is($foo->bar, 25, '... got the right foo->bar');
+
+ lives_ok {
+ $baz->foo($foo);
+ } '... assigned the new Foo to Baz->foo';
+
+ is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
+
+ is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
+ is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
+}
+
+# Check that removing attributes removes their handles methods also.
+{
+ {
+ package Quux;
+ use Mouse;
+ has foo => (
+ isa => 'Foo',
+ default => sub { Foo->new },
+ handles => { 'foo_bar' => 'bar' }
+ );
+ }
+ my $i = Quux->new;
+ ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
+ $i->meta->remove_attribute('foo');
+ ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
+}
+
+# Make sure that a useful error message is thrown when the delegation target is
+# not an object
+{
+ my $i = Bar->new(foo => undef);
+ throws_ok { $i->foo_bar } qr/is not defined/,
+ 'useful error from unblessed reference';
+
+ my $j = Bar->new(foo => []);
+ throws_ok { $j->foo_bar } qr/is not an object \(got 'ARRAY/,
+ 'useful error from unblessed reference';
+
+ my $k = Bar->new(foo => "Foo");
+ lives_ok { $k->foo_baz } "but not for class name";
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 23;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'foo', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo' => (
+ reader => 'get_lazy_foo',
+ lazy => 1,
+ default => 10,
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo_w_type' => (
+ reader => 'get_lazy_foo_w_type',
+ isa => 'Int',
+ lazy => 1,
+ default => 20,
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo_w_type', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo_builder' => (
+ reader => 'get_lazy_foo_builder',
+ builder => 'get_foo_builder',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo_builder', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo_builder_w_type' => (
+ reader => 'get_lazy_foo_builder_w_type',
+ isa => 'Int',
+ builder => 'get_foo_builder_w_type',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo_builder_w_type', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ sub get_foo_builder { 100 }
+ sub get_foo_builder_w_type { 1000 }
+}
+
+{
+ my $foo = Foo->new(foo => 10);
+ isa_ok($foo, 'Foo');
+
+ is($foo->get_foo, 20, 'initial value set to 2x given value');
+ is($foo->get_lazy_foo, 20, 'initial lazy value set to 2x given value');
+ is($foo->get_lazy_foo_w_type, 40, 'initial lazy value with type set to 2x given value');
+ is($foo->get_lazy_foo_builder, 200, 'initial lazy value with builder set to 2x given value');
+ is($foo->get_lazy_foo_builder_w_type, 2000, 'initial lazy value with builder and type set to 2x given value');
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'foo', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ my $bar = Bar->new(foo => 10);
+ isa_ok($bar, 'Bar');
+
+ is($bar->get_foo, 20, 'initial value set to 2x given value');
+}
+
+{
+ package Fail::Bar;
+ use Mouse;
+
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ isa => 'Int',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'foo', '... got the right name');
+
+ $callback->("Hello $value World");
+ },
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+dies_ok {
+ Fail::Bar->new(foo => 10)
+} '... this fails, because initializer returns a bad type';
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 17;
+use Test::Exception;
+
+
+
+=pod
+
+ is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
+ is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
+ is => rw, accessor => _foo # turns into (accessor => _foo)
+ is => ro, accessor => _foo # error, accesor is rw
+
+=cut
+
+sub make_class {
+ my ($is, $attr, $class) = @_;
+
+ eval "package $class; use Mouse; has 'foo' => ( is => '$is', $attr => '_foo' );";
+
+ return $@ ? die $@ : $class;
+}
+
+my $obj;
+my $class;
+
+$class = make_class('rw', 'writer', 'Test::Class::WriterRW');
+ok($class, "Can define attr with rw + writer");
+
+$obj = $class->new();
+
+can_ok($obj, qw/foo _foo/);
+lives_ok {$obj->_foo(1)} "$class->_foo is writer";
+is($obj->foo(), 1, "$class->foo is reader");
+dies_ok {$obj->foo(2)} "$class->foo is not writer"; # this should fail
+ok(!defined $obj->_foo(), "$class->_foo is not reader");
+
+$class = make_class('ro', 'writer', 'Test::Class::WriterRO');
+ok($class, "Can define attr with ro + writer");
+
+$obj = $class->new();
+
+can_ok($obj, qw/foo _foo/);
+lives_ok {$obj->_foo(1)} "$class->_foo is writer";
+is($obj->foo(), 1, "$class->foo is reader");
+dies_ok {$obj->foo(1)} "$class->foo is not writer";
+isnt($obj->_foo(), 1, "$class->_foo is not reader");
+
+$class = make_class('rw', 'accessor', 'Test::Class::AccessorRW');
+ok($class, "Can define attr with rw + accessor");
+
+$obj = $class->new();
+
+can_ok($obj, qw/_foo/);
+lives_ok {$obj->_foo(1)} "$class->_foo is writer";
+is($obj->_foo(), 1, "$class->foo is reader");
+
+dies_ok { make_class('ro', 'accessor', "Test::Class::AccessorRO"); } "Cant define attr with ro + accessor";
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+
+
+{
+ package Bar::Meta::Attribute;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+
+ has 'my_legal_option' => (
+ isa => 'CodeRef',
+ is => 'rw',
+ );
+
+ around legal_options_for_inheritance => sub {
+ return (shift->(@_), qw/my_legal_option/);
+ };
+
+ package Bar;
+ use Mouse;
+
+ has 'bar' => (
+ metaclass => 'Bar::Meta::Attribute',
+ my_legal_option => sub { 'Bar' },
+ is => 'bare',
+ );
+
+ package Bar::B;
+ use Mouse;
+
+ extends 'Bar';
+
+ has '+bar' => (
+ my_legal_option => sub { 'Bar::B' }
+ );
+}
+
+my $bar_attr = Bar::B->meta->get_attribute('bar');
+my ($legal_option) = grep {
+ $_ eq 'my_legal_option'
+} $bar_attr->legal_options_for_inheritance;
+is($legal_option, 'my_legal_option',
+ '... added my_legal_option as legal option for inheritance' );
+is($bar_attr->my_legal_option->(), 'Bar::B', '... overloaded my_legal_option');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 8;
+use Test::Exception;
+
+my $exception_regex = qr/You must provide a name for the attribute/;
+{
+ package My::Role;
+ use Mouse::Role;
+
+ ::throws_ok {
+ has;
+ } $exception_regex, 'has; fails';
+
+ ::throws_ok {
+ has undef;
+ } $exception_regex, 'has undef; fails';
+
+ ::lives_ok {
+ has "" => (
+ is => 'bare',
+ );
+ } 'has ""; works now';
+
+ ::lives_ok {
+ has 0 => (
+ is => 'bare',
+ );
+ } 'has 0; works now';
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ ::throws_ok {
+ has;
+ } $exception_regex, 'has; fails';
+
+ ::throws_ok {
+ has undef;
+ } $exception_regex, 'has undef; fails';
+
+ ::lives_ok {
+ has "" => (
+ is => 'bare',
+ );
+ } 'has ""; works now';
+
+ ::lives_ok {
+ has 0 => (
+ is => 'bare',
+ );
+ } 'has 0; works now';
+}
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ eval "use Test::Output;";
+ plan skip_all => "Test::Output is required for this test" if $@;
+ plan tests => 5;
+}
+
+{
+ package Foo;
+ use Mouse;
+
+ sub get_a { }
+ sub set_b { }
+ sub has_c { }
+ sub clear_d { }
+ sub e { }
+}
+
+my $foo_meta = Foo->meta;
+stderr_like(sub { $foo_meta->add_attribute(a => (reader => 'get_a')) },
+ qr/^You are overwriting a locally defined method \(get_a\) with an accessor/, 'reader overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(b => (writer => 'set_b')) },
+ qr/^You are overwriting a locally defined method \(set_b\) with an accessor/, 'writer overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(c => (predicate => 'has_c')) },
+ qr/^You are overwriting a locally defined method \(has_c\) with an accessor/, 'predicate overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(d => (clearer => 'clear_d')) },
+ qr/^You are overwriting a locally defined method \(clear_d\) with an accessor/, 'clearer overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(e => (is => 'rw')) },
+ qr/^You are overwriting a locally defined method \(e\) with an accessor/, 'accessor overriding gives proper warning');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+{
+ package SomeAwesomeDB;
+
+ sub new_row { }
+ sub read { }
+ sub write { }
+}
+
+{
+ package MouseX::SomeAwesomeDBFields;
+
+ # implementation of methods not called in the example deliberately
+ # omitted
+
+ use Mouse::Role;
+
+ sub inline_create_instance {
+ my ( $self, $classvar ) = @_;
+
+ "bless SomeAwesomeDB::new_row(), $classvar";
+ }
+
+ sub inline_get_slot_value {
+ my ( $self, $invar, $slot ) = @_;
+
+ "SomeAwesomeDB::read($invar, \"$slot\")";
+ }
+
+ sub inline_set_slot_value {
+ my ( $self, $invar, $slot, $valexp ) = @_;
+
+ "SomeAwesomeDB::write($invar, \"$slot\", $valexp)";
+ }
+
+ sub inline_is_slot_initialized {
+ my ( $self, $invar, $slot ) = @_;
+
+ "1";
+ }
+
+ sub inline_initialize_slot {
+ my ( $self, $invar, $slot ) = @_;
+
+ "";
+ }
+
+ sub inline_slot_access {
+ die "inline_slot_access should not have been used";
+ }
+}
+
+{
+ package Toy;
+
+ use Mouse;
+ use Mouse::Util::MetaRole;
+
+ use Test::More tests => 3;
+ use Test::Exception;
+
+ Mouse::Util::MetaRole::apply_metaclass_roles(
+ for_class => __PACKAGE__,
+ instance_metaclass_roles => ['MouseX::SomeAwesomeDBFields']
+ );
+
+ lives_ok {
+ has lazy_attr => (
+ is => 'ro',
+ isa => 'Bool',
+ lazy => 1,
+ default => sub {0},
+ );
+ }
+ "Adding lazy accessor does not use inline_slot_access";
+
+ lives_ok {
+ has rw_attr => (
+ is => 'rw',
+ );
+ }
+ "Adding read-write accessor does not use inline_slot_access";
+
+ lives_ok { __PACKAGE__->meta->make_immutable; }
+ "Inling constructor does not use inline_slot_access";
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Test::Exception;
+
+{
+ package Bar;
+ use Mouse;
+
+ sub baz { 'Bar::baz' }
+ sub gorch { 'Bar::gorch' }
+
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Bar',
+ lazy => 1,
+ default => sub { Bar->new },
+ handles => [qw[ baz gorch ]]
+ );
+
+ package Foo::Extended;
+ use Mouse;
+
+ extends 'Foo';
+
+ has 'test' => (
+ is => 'rw',
+ isa => 'Bool',
+ default => sub { 0 },
+ );
+
+ around 'bar' => sub {
+ my $next = shift;
+ my $self = shift;
+
+ $self->test(1);
+ $self->$next();
+ };
+}
+
+my $foo = Foo::Extended->new;
+isa_ok($foo, 'Foo::Extended');
+isa_ok($foo, 'Foo');
+
+ok(!$foo->test, '... the test value has not been changed');
+
+is($foo->baz, 'Bar::baz', '... got the right delegated method');
+
+ok($foo->test, '... the test value has now been changed');
+
+
+
+
+
+
+
+
+++ /dev/null
-#!/usr/bin/env perl
-use strict;
-use warnings;
-use Test::More tests => 11;
-
-do {
- package Class;
- use Mouse;
-
- has name => (
- is => 'rw',
- isa => 'Str',
- init_arg => 'key',
- default => 'default',
- );
-};
-
-my $object = Class->new;
-is($object->name, 'default', 'accessor uses attribute name');
-is($object->{key}, undef, 'nothing in object->{init_arg}!');
-is($object->{name}, 'default', 'value is in object->{name}');
-
-my $object2 = Class->new(name => 'name', key => 'key');
-is($object2->name, 'key', 'attribute value is from name');
-is($object2->{key}, undef, 'no value for the init_arg');
-is($object2->{name}, 'key', 'value is in key from name');
-
-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');
-
-do {
- package Foo;
- use Mouse;
-
- has name => (
- is => 'rw',
- init_arg => undef,
- default => 'default',
- );
-};
-
-my $foo = Foo->new(name => 'joe');
-is($foo->name, 'default', 'init_arg => undef ignores attribute name in the constructor');
-
-Foo->meta->make_immutable;
-
-my $bar = Foo->new(name => 'joe');
-is($bar->name, 'default', 'init_arg => undef ignores attribute name in the inlined constructor');
use Test::More tests => 26;
use Test::Exception;
+use lib 't/lib';
+use Test::Mouse; # Mouse::Meta::Module->version
use Mouse::Meta::Role;
{
use Test::More tests => 40;
use Test::Exception;
+use lib 't/lib';
+use Test::Mouse; # Mouse::Meta::Module->version
+
=pod
NOTE:
use Test::More tests => 32;
use Test::Exception;
+use lib 't/lib';
+use Test::Mouse;
+
=pod
Check for repeated inheritance causing
ok(Role::Derived3->meta->has_override_method_modifier('foo'), '... have the method foo as expected');
ok(Role::Derived4->meta->has_override_method_modifier('foo'), '... have the method foo as expected');
ok(My::Test::Class2->meta->has_method('foo'), '... have the method foo as expected');
+{
+local $TODO = 'Not a Mouse::Meta::Method::Overriden';
isa_ok(My::Test::Class2->meta->get_method('foo'), 'Mouse::Meta::Method::Overridden');
+}
ok(My::Test::Class2::Base->meta->has_method('foo'), '... have the method foo as expected');
+{
+local $TODO = 'Not a Class::MOP::Method';
isa_ok(My::Test::Class2::Base->meta->get_method('foo'), 'Class::MOP::Method');
-
+}
is(My::Test::Class2::Base->foo, 'My::Test::Class2::Base', '... got the right value from method');
is(My::Test::Class2->foo, 'My::Test::Class2::Base -> Role::Base::foo', '... got the right value from method');
ok(Role::Derived5->meta->has_around_method_modifiers('foo'), '... have the method foo as expected');
ok(Role::Derived6->meta->has_around_method_modifiers('foo'), '... have the method foo as expected');
ok(My::Test::Class3->meta->has_method('foo'), '... have the method foo as expected');
+{
+local $TODO = 'Not a Class::MOP::Method::Wrapped';
isa_ok(My::Test::Class3->meta->get_method('foo'), 'Class::MOP::Method::Wrapped');
+}
ok(My::Test::Class3::Base->meta->has_method('foo'), '... have the method foo as expected');
+{
+local $TODO = 'Not a Class::MOP::Method';
isa_ok(My::Test::Class3::Base->meta->get_method('foo'), 'Class::MOP::Method');
-
+}
is(My::Test::Class3::Base->foo, 'My::Test::Class3::Base', '... got the right value from method');
is(My::Test::Class3->foo, 'Role::Base::foo(My::Test::Class3::Base)', '... got the right value from method');
}
ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar);
+{
+local $TODO = 'auto requires resolution is not supported';
ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required');
ok(!My::OtherRole->meta->requires_method('role_bar'), '... and the &role_bar method is not required');
+}
{
package My::AliasingRole;
package My::Foo::Class::Broken;
use Mouse;
- ::throws_ok {
+ ::dies_ok {
with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
'Baz::Role';
- } qr/Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo_foo' must be implemented or excluded by 'My::Foo::Class::Broken'/,
- '... composed our roles correctly';
+ } '... composed our roles correctly';
}
{
{
package My::Foo::Role::Other;
+ use Test::More; # for $TODO
use Mouse::Role;
+ local $TODO = 'not supported';
+
::lives_ok {
with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
}
ok(!My::Foo::Role::Other->meta->has_method('foo_foo'), "we dont have a foo_foo method");
+{
+local $TODO = 'auto requires resolution is not supported';
ok(My::Foo::Role::Other->meta->requires_method('foo_foo'), '... and the &foo method is required');
-
+}
{
package My::Foo::AliasOnly;
use Mouse;
is($foo->bar, 'BAR', '... got the expect value');
ok($foo->can('baz'), '... we have baz method now');
- is($foo->baz, 'FOO-BAZ', '... got the expect value');
+ {
+ local $TODO = 'rebless_params is not implemented';
+ is($foo->baz, 'FOO-BAZ', '... got the expect value');
+ }
}
# with extra params ...
Bar->meta->apply($foo, (rebless_params => { bar => 'FOO-BAR', baz => 'FOO-BAZ' }))
} '... this works';
- is($foo->bar, 'FOO-BAR', '... got the expect value');
+ {
+ local $TODO = 'rebless params is not implemented';
+ is($foo->bar, 'FOO-BAR', '... got the expect value');
+ }
ok($foo->can('baz'), '... we have baz method now');
- is($foo->baz, 'FOO-BAZ', '... got the expect value');
+ {
+ local $TODO = 'rebless params is not implemented';
+ is($foo->baz, 'FOO-BAZ', '... got the expect value');
+ }
}
use warnings;
use Test::More tests => 17;
+use lib 't/lib';
use Test::Mouse;
{
ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required');
ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required');
-use Data::Dumper; print Dumper(My::OtherRole->meta->{required_methods});
+
{
package Foo::Role;
use Mouse::Role;
use Test::More tests => 14;
use Test::Exception;
-use Mouse::Meta::Role::Application::RoleSummation;
+#use Mouse::Meta::Role::Application::RoleSummation;
use Mouse::Meta::Role::Composite;
{
use Test::More tests => 12;
use Test::Exception;
-use Mouse::Meta::Role::Application::RoleSummation;
+#use Mouse::Meta::Role::Application::RoleSummation;
use Mouse::Meta::Role::Composite;
{
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN {
+ eval "use IO::String; use IO::File;";
+ plan skip_all => "IO::String and IO::File are required for this test" if $@;
+ plan tests => 28;
+}
+
+
+
+{
+ package Email::Mouse;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ use IO::String;
+
+ our $VERSION = '0.01';
+
+ # create subtype for IO::String
+
+ subtype 'IO::String'
+ => as 'Object'
+ => where { $_->isa('IO::String') };
+
+ coerce 'IO::String'
+ => from 'Str'
+ => via { IO::String->new($_) },
+ => from 'ScalarRef',
+ => via { IO::String->new($_) };
+
+ # create subtype for IO::File
+
+ subtype 'IO::File'
+ => as 'Object'
+ => where { $_->isa('IO::File') };
+
+ coerce 'IO::File'
+ => from 'FileHandle'
+ => via { bless $_, 'IO::File' };
+
+ # create the alias
+
+ my $st = subtype 'IO::StringOrFile' => as 'IO::String | IO::File';
+ #::diag $st->dump;
+
+ # attributes
+
+ has 'raw_body' => (
+ is => 'rw',
+ isa => 'IO::StringOrFile',
+ coerce => 1,
+ default => sub { IO::String->new() },
+ );
+
+ sub as_string {
+ my ($self) = @_;
+ my $fh = $self->raw_body();
+
+ return do { local $/; <$fh> };
+ }
+}
+
+{
+ my $email = Email::Mouse->new;
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, undef, '... got correct empty string');
+}
+
+{
+ my $email = Email::Mouse->new(raw_body => '... this is my body ...');
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, '... this is my body ...', '... got correct string');
+
+ lives_ok {
+ $email->raw_body('... this is the next body ...');
+ } '... this will coerce correctly';
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, '... this is the next body ...', '... got correct string');
+}
+
+{
+ my $str = '... this is my body (ref) ...';
+
+ my $email = Email::Mouse->new(raw_body => \$str);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, $str, '... got correct string');
+
+ my $str2 = '... this is the next body (ref) ...';
+
+ lives_ok {
+ $email->raw_body(\$str2);
+ } '... this will coerce correctly';
+
+ isa_ok($email->raw_body, 'IO::String');
+
+ is($email->as_string, $str2, '... got correct string');
+}
+
+{
+ my $io_str = IO::String->new('... this is my body (IO::String) ...');
+
+ my $email = Email::Mouse->new(raw_body => $io_str);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::String');
+ is($email->raw_body, $io_str, '... and it is the one we expected');
+
+ is($email->as_string, '... this is my body (IO::String) ...', '... got correct string');
+
+ my $io_str2 = IO::String->new('... this is the next body (IO::String) ...');
+
+ lives_ok {
+ $email->raw_body($io_str2);
+ } '... this will coerce correctly';
+
+ isa_ok($email->raw_body, 'IO::String');
+ is($email->raw_body, $io_str2, '... and it is the one we expected');
+
+ is($email->as_string, '... this is the next body (IO::String) ...', '... got correct string');
+}
+
+{
+ my $fh;
+
+ open($fh, '<', $0) || die "Could not open $0";
+
+ my $email = Email::Mouse->new(raw_body => $fh);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::File');
+
+ close($fh);
+}
+
+{
+ my $fh = IO::File->new($0);
+
+ my $email = Email::Mouse->new(raw_body => $fh);
+ isa_ok($email, 'Email::Mouse');
+
+ isa_ok($email->raw_body, 'IO::File');
+ is($email->raw_body, $fh, '... and it is the one we expected');
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use Scalar::Util ();
+
+use lib 't/lib';
+use Mouse::Util::TypeConstraints;
+use Test::Mouse; # for export_type_constraints_as_functions()
+
+enum Letter => 'a'..'z', 'A'..'Z';
+enum Language => 'Perl 5', 'Perl 6', 'PASM', 'PIR'; # any others? ;)
+enum Metacharacter => '*', '+', '?', '.', '|', '(', ')', '[', ']', '\\';
+
+my @valid_letters = ('a'..'z', 'A'..'Z');
+
+my @invalid_letters = qw/ab abc abcd/;
+push @invalid_letters, qw/0 4 9 ~ @ $ %/;
+push @invalid_letters, qw/l33t st3v4n 3num/;
+
+my @valid_languages = ('Perl 5', 'Perl 6', 'PASM', 'PIR');
+my @invalid_languages = ('perl 5', 'Python', 'Ruby', 'Perl 666', 'PASM++');
+# note that "perl 5" is invalid because case now matters
+
+my @valid_metacharacters = (qw/* + ? . | ( ) [ ] /, '\\');
+my @invalid_metacharacters = qw/< > & % $ @ ! ~ `/;
+push @invalid_metacharacters, qw/.* fish(sticks)? atreides/;
+push @invalid_metacharacters, '^1?$|^(11+?)\1+$';
+
+Mouse::Util::TypeConstraints->export_type_constraints_as_functions();
+
+ok(Letter($_), "'$_' is a letter") for @valid_letters;
+ok(!Letter($_), "'$_' is not a letter") for @invalid_letters;
+
+ok(Language($_), "'$_' is a language") for @valid_languages;
+ok(!Language($_), "'$_' is not a language") for @invalid_languages;
+
+ok(Metacharacter($_), "'$_' is a metacharacter") for @valid_metacharacters;
+ok(!Metacharacter($_), "'$_' is not a metacharacter")
+ for @invalid_metacharacters;
+
+# check anon enums
+
+my $anon_enum = enum \@valid_languages;
+isa_ok($anon_enum, 'Mouse::Meta::TypeConstraint');
+
+#is($anon_enum->name, '__ANON__', '... got the right name');
+#is($anon_enum->parent->name, 'Str', '... got the right parent name');
+
+ok($anon_enum->check($_), "'$_' is a language") for @valid_languages;
+
+
+#ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" );
+#ok( $anon_enum->equals( $anon_enum ), "equals itself" );
+#ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" );
+
+#ok( !$anon_enum->is_subtype_of('Object'), 'enum not a subtype of Object');
+ok( !$anon_enum->is_a_type_of('Object'), 'enum not type of Object');
+
+#ok( !$anon_enum->is_subtype_of('ThisTypeDoesNotExist'), 'enum not a subtype of nonexistant type');
+ok( !$anon_enum->is_a_type_of('ThisTypeDoesNotExist'), 'enum not type of nonexistant type');
+
--- /dev/null
+#!/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
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+{
+ package SomeClass;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype 'DigitSix' => as 'Num'
+ => where { /^6$/ };
+ subtype 'TextSix' => as 'Str'
+ => where { /Six/i };
+
+ coerce 'TextSix'
+ => from 'DigitSix'
+ => via { confess("Cannot live without 6 ($_)") unless /^6$/; 'Six' };
+
+ has foo => (
+ is => 'ro',
+ isa => 'TextSix',
+ coerce => 1,
+ default => 6,
+ lazy => 1
+ );
+}
+
+is(SomeClass->new()->foo, 'Six');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+use Test::Exception;
+
+
+
+{
+ package My::Custom::Meta::Attr;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+}
+
+{
+ package My::Fancy::Role;
+ use Mouse::Role;
+
+ has 'bling_bling' => (
+ metaclass => 'My::Custom::Meta::Attr',
+ is => 'rw',
+ isa => 'Str',
+ );
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ with 'My::Fancy::Role';
+}
+
+my $c = My::Class->new;
+isa_ok($c, 'My::Class');
+
+ok($c->meta->has_attribute('bling_bling'), '... got the attribute');
+
+isa_ok($c->meta->get_attribute('bling_bling'), 'My::Custom::Meta::Attr');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+;
+
+lives_ok {
+ package MouseX::Attribute::Test;
+ use Mouse::Role;
+} 'creating custom attribute "metarole" is okay';
+
+lives_ok {
+ package Mouse::Meta::Attribute::Custom::Test;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+ with 'MouseX::Attribute::Test';
+} 'custom attribute metaclass extending role is okay';
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+=pod
+
+This is a test for a bug found by Purge on #moose:
+The code:
+
+ subtype Stuff
+ => as Object
+ => where { ... }
+
+will break if the Object:: namespace exists. So the
+solution is to quote 'Object', like so:
+
+ subtype Stuff
+ => as 'Object'
+ => where { ... }
+
+Mouse 0.03 did this, now it doesn't, so all should
+be well from now on.
+
+=cut
+
+{ package Object::Test; }
+
+package Foo;
+::use_ok('Mouse');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib';
+
+use Test::More tests => 2;
+
+
+
+use_ok('MyMouseA');
+use_ok('MyMouseB');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib';
+
+use Test::More tests => 1;
+
+use_ok('MyMouseObject');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+
+
+=pod
+
+This just makes sure that the Bar gets
+a metaclass initialized for it correctly.
+
+=cut
+
+{
+ package Foo;
+ use Mouse;
+
+ package Bar;
+ use strict;
+ use warnings;
+
+ use base 'Foo';
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+
+
+=pod
+
+This was a bug, but it is fixed now. This
+test makes sure it does not creep back in.
+
+=cut
+
+{
+ package Foo;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Int',
+ lazy => 1,
+ default => 10,
+ );
+ } '... this didnt die';
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+{
+ package Foo;
+ use Mouse;
+ has 'foo' => ( is => 'ro', reader => 'get_foo' );
+}
+
+{
+ my $foo = Foo->new(foo => 10);
+ my $reader = $foo->meta->get_attribute('foo')->reader;
+ is($reader, 'get_foo',
+ 'reader => "get_foo" has correct presedence');
+ can_ok($foo, 'get_foo');
+ is($foo->$reader, 10, "Reader works as expected");
+}
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ sub foo { 'Foo::foo(' . (inner() || '') . ')' };
+
+ package Bar;
+ use Mouse;
+
+ extends 'Foo';
+
+ package Baz;
+ use Mouse;
+
+ extends 'Foo';
+
+ my $foo_call_counter;
+ augment 'foo' => sub {
+ die "infinite loop on Baz::foo" if $foo_call_counter++ > 1;
+ return 'Baz::foo and ' . Bar->new->foo;
+ };
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Foo');
+
+=pod
+
+When a subclass which augments foo(), calls a subclass which does not augment
+foo(), there is a chance for some confusion. If Mouse does not realize that
+Bar does not augment foo(), because it is in the call flow of Baz which does,
+then we may have an infinite loop.
+
+=cut
+
+is($baz->foo,
+ 'Foo::foo(Baz::foo and Foo::foo())',
+ '... got the right value for 1 augmented subclass calling non-augmented subclass');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ our $foo_default_called = 0;
+
+ has foo => (
+ is => 'rw',
+ isa => 'Str',
+ default => sub { $foo_default_called++; 'foo' },
+ );
+
+ our $bar_default_called = 0;
+
+ has bar => (
+ is => 'rw',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { $bar_default_called++; 'bar' },
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+my $foo = Foo->new();
+
+is($Foo::foo_default_called, 1, "foo default was only called once during constructor");
+
+$foo->bar();
+
+is($Foo::bar_default_called, 1, "bar default was only called once when lazy attribute is accessed");
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use FindBin;
+
+use Test::More tests => 144;
+use Test::Exception;
+
+use Mouse::Util::TypeConstraints;
+
+subtype 'FilePath'
+ => as 'Str'
+ # This used to try to _really_ check for a valid Unix or Windows
+ # path, but the regex wasn't quite right, and all we care about
+ # for the tests is that it rejects '/'
+ => where { $_ ne '/' };
+{
+ package Baz;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
+
+ # Defining this causes the FIRST call to Baz->new w/o param to fail,
+ # if no call to ANY Mouse::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ }
+}
+
+{
+ package Qee;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
+
+ # Defining this causes the FIRST call to Qee->new w/o param to fail...
+ # if no call to ANY Mouse::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ }
+}
+
+{
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
+
+ # Having no DEMOLISH, everything works as expected...
+}
+
+check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error
+check_em ( 'Qee' ); # ok
+check_em ( 'Foo' ); # ok
+
+check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error
+check_em ( 'Baz' ); # ok
+check_em ( 'Foo' ); # ok
+
+check_em ( 'Foo' ); # ok
+check_em ( 'Baz' ); # ok !
+check_em ( 'Qee' ); # ok
+
+
+sub check_em {
+ my ( $pkg ) = @_;
+ my ( %param, $obj );
+
+ # Uncomment to see, that it is really any first call.
+ # Subsequents calls will not fail, aka giving the correct error.
+ {
+ local $@;
+ my $obj = eval { $pkg->new; };
+ ::like( $@, qr/is required/, "... $pkg plain" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new(); };
+ ::like( $@, qr/is required/, "... $pkg empty" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( notanattr => 1 ); };
+ ::like( $@, qr/is required/, "... $pkg undef" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( %param ); };
+ ::like( $@, qr/is required/, "... $pkg undef param" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => '/' ); };
+ ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); };
+ ::like( $@, qr/does not exist/, "... $pkg non existing path" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => $FindBin::Bin ); };
+ ::is( $@, '', "... $pkg no error" );
+ ::isa_ok( $obj, $pkg );
+ ::isa_ok( $obj, 'Mouse::Object' );
+ ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" );
+ }
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Test::Exception;
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'ro',
+ required => 1,
+ );
+
+ # Defining this causes the FIRST call to Baz->new w/o param to fail,
+ # if no call to ANY Mouse::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ # ... Mouse (kinda) eats exceptions in DESTROY/DEMOLISH";
+ }
+}
+
+{
+ my $obj = eval { Foo->new; };
+ like( $@, qr/is required/, "... Foo plain" );
+ is( $obj, undef, "... the object is undef" );
+}
+
+{
+ package Bar;
+
+ sub new { die "Bar died"; }
+
+ sub DESTROY {
+ die "Vanilla Perl eats exceptions in DESTROY too";
+ }
+}
+
+{
+ my $obj = eval { Bar->new; };
+ like( $@, qr/Bar died/, "... Bar plain" );
+ is( $obj, undef, "... the object is undef" );
+}
+
+{
+ package Baz;
+ use Mouse;
+
+ sub DEMOLISH {
+ $? = 0;
+ }
+}
+
+{
+ local $@ = 42;
+ local $? = 84;
+
+ {
+ Baz->new;
+ }
+
+ is( $@, 42, '$@ is still 42 after object is demolished without dying' );
+ is( $?, 84, '$? is still 84 after object is demolished without dying' );
+
+ local $@ = 0;
+
+ {
+ Baz->new;
+ }
+
+ is( $@, 0, '$@ is still 0 after object is demolished without dying' );
+
+ Baz->meta->make_immutable, redo
+ if Baz->meta->is_mutable
+}
+
+{
+ package Quux;
+ use Mouse;
+
+ sub DEMOLISH {
+ die "foo\n";
+ }
+}
+
+{
+ local $@ = 42;
+
+ eval { my $obj = Quux->new };
+
+ like( $@, qr/foo/, '$@ contains error from demolish when demolish dies' );
+
+ Quux->meta->make_immutable, redo
+ if Quux->meta->is_mutable
+}
+
--- /dev/null
+package Foo;
+use Mouse;
+
+## Problem:
+## lazy_build sets required => 1
+## required does not permit setting to undef
+
+## Possible solutions:
+#### remove required => 1
+#### check the attr to see if it accepts Undef (Maybe[], | Undef)
+#### or, make required accept undef and use a predicate test
+
+
+has 'foo' => ( isa => 'Int | Undef', is => 'rw', coerce => 1, lazy_build => 1 );
+has 'bar' => ( isa => 'Int | Undef', is => 'rw', coerce => 1 );
+
+sub _build_foo { undef }
+
+package main;
+use Test::More tests => 4;
+
+ok ( !defined(Foo->new->bar), 'NonLazyBuild: Undef default' );
+ok ( !defined(Foo->new->bar(undef)), 'NonLazyBuild: Undef explicit' );
+
+ok ( !defined(Foo->new->foo), 'LazyBuild: Undef default/lazy_build' );
+
+## This test fails at the time of creation.
+ok ( !defined(Foo->new->foo(undef)), 'LazyBuild: Undef explicit' );
+
+
+1;
};
is_deeply([splice @called], ['Child::DEMOLISHALL', 'Class::DEMOLISHALL', 'Child::DEMOLISH', 'Class::DEMOLISH']);
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+
+
+{
+ package My::Role;
+ use Mouse::Role;
+}
+{
+ package My::Class;
+ use Mouse;
+
+ ::throws_ok {
+ extends 'My::Role';
+ } qr/You cannot inherit from a Mouse Role \(My\:\:Role\)/,
+ '... this croaks correctly';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+use Test::Exception;
+
+
+
+# RT #37569
+
+{
+ package MyObject;
+ use Mouse;
+
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype 'MyArrayRef'
+ => as 'ArrayRef'
+ => where { defined $_->[0] }
+ => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy
+ ;
+
+ subtype 'MyObjectType'
+ => as 'Object'
+ => where { $_->isa('MyObject') }
+ => message {
+ if ( $_->isa('SomeObject') ) {
+ return 'More detailed error message';
+ }
+ elsif ( blessed $_ ) {
+ return 'Well it is an object';
+ }
+ else {
+ return 'Doh!';
+ }
+ }
+ ;
+
+ type 'NewType'
+ => where { $_->isa('MyObject') }
+ => message { blessed $_ ? 'blessed' : 'scalar' }
+ ;
+
+ has 'obj' => ( is => 'rw', isa => 'MyObjectType' );
+ has 'ar' => ( is => 'rw', isa => 'MyArrayRef' );
+ has 'nt' => ( is => 'rw', isa => 'NewType' );
+}
+
+my $foo = Foo->new;
+my $obj = MyObject->new;
+
+throws_ok {
+ $foo->ar( [] );
+}
+qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/,
+ '... got the right error message';
+
+throws_ok {
+ $foo->obj($foo); # Doh!
+}
+qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/,
+ '... got the right error message';
+
+throws_ok {
+ $foo->nt($foo); # scalar
+}
+qr/Attribute \(nt\) does not pass the type constraint because: blessed/,
+ '... got the right error message';
+
#!/usr/bin/env perl
-use Test::More qw(no_plan);
-
-# copied straight out of Moose t/100/019
+use Test::More tests => 10;
{
my $package = qq{
has id => (
isa => 'Str',
is => 'ro',
- default => 017600,
+ default => 017600,
);
no Mouse;
has id => (
isa => 'Str',
is => 'ro',
- default => 0xFF,
+ default => 0xFF,
);
no Mouse;
has id => (
isa => 'Str',
is => 'ro',
- default => '0xFF',
+ default => '0xFF',
);
no Mouse;
has id => (
isa => 'Str',
is => 'ro',
- default => '0 but true',
+ default => '0 but true',
);
no Mouse;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+{
+ package A;
+ use Mouse;
+
+ sub foo {
+ ::BAIL_OUT('A::foo called twice') if $main::seen{'A::foo'}++;
+ return 'a';
+ }
+
+ sub bar {
+ ::BAIL_OUT('A::bar called twice') if $main::seen{'A::bar'}++;
+ return 'a';
+ }
+
+ sub baz {
+ ::BAIL_OUT('A::baz called twice') if $main::seen{'A::baz'}++;
+ return 'a';
+ }
+}
+
+{
+ package B;
+ use Mouse;
+ extends qw(A);
+
+ sub foo {
+ ::BAIL_OUT('B::foo called twice') if $main::seen{'B::foo'}++;
+ return 'b' . super();
+ }
+
+ sub bar {
+ ::BAIL_OUT('B::bar called twice') if $main::seen{'B::bar'}++;
+ return 'b' . ( super() || '' );
+ }
+
+ override baz => sub {
+ ::BAIL_OUT('B::baz called twice') if $main::seen{'B::baz'}++;
+ return 'b' . super();
+ };
+}
+
+{
+ package C;
+ use Mouse;
+ extends qw(B);
+
+ sub foo { return 'c' . ( super() || '' ) }
+
+ override bar => sub {
+ ::BAIL_OUT('C::bar called twice') if $main::seen{'C::bar'}++;
+ return 'c' . super();
+ };
+
+ override baz => sub {
+ ::BAIL_OUT('C::baz called twice') if $main::seen{'C::baz'}++;
+ return 'c' . super();
+ };
+}
+
+is( C->new->foo, 'c' );
+is( C->new->bar, 'cb' );
+is( C->new->baz, 'cba' );
--- /dev/null
+## This test ensures that sub DEMOLISHALL fires even if there is no sub DEMOLISH
+## Currently fails because of a bad optimization in DESTROY
+## Feb 12, 2009 -- Evan Carroll me@evancarroll.com
+package Role::DemolishAll;
+use Mouse::Role;
+our $ok = 0;
+
+sub BUILD { $ok = 0 };
+after 'DEMOLISHALL' => sub { $Role::DemolishAll::ok++ };
+
+package DemolishAll::WithoutDemolish;
+use Mouse;
+with 'Role::DemolishAll';
+
+package DemolishAll::WithDemolish;
+use Mouse;
+with 'Role::DemolishAll';
+sub DEMOLISH {};
+
+
+package main;
+use Test::More tests => 2;
+
+my $m = DemolishAll::WithDemolish->new;
+undef $m;
+is ( $Role::DemolishAll::ok, 1, 'DemolishAll w/ explicit DEMOLISH sub' );
+
+$m = DemolishAll::WithoutDemolish->new;
+undef $m;
+is ( $Role::DemolishAll::ok, 1, 'DemolishAll wo/ explicit DEMOLISH sub' );
+
+1;
--- /dev/null
+package MyRole;
+
+use Mouse::Role;
+
+sub foo { return (caller(0))[3] }
+
+no Mouse::Role;
+
+package MyClass1; use Mouse; with 'MyRole'; no Mouse;
+package MyClass2; use Mouse; with 'MyRole'; no Mouse;
+
+package main;
+
+use Test::More tests => 4;
+
+{
+ local $TODO = 'Role composition does not clone methods yet';
+ is(MyClass1->foo, 'MyClass1::foo',
+ 'method from role has correct name in caller()');
+ is(MyClass2->foo, 'MyClass2::foo',
+ 'method from role has correct name in caller()');
+}
+
+isnt(MyClass1->foo, "MyClass2::foo", "role method is not confused with other class" );
+isnt(MyClass2->foo, "MyClass1::foo", "role method is not confused with other class" );
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More tests => 2;
+
+{
+
+ package FakeBar;
+ use Mouse::Role;
+
+ around isa => sub {
+ my ( $orig, $self, $v ) = @_;
+ return 1 if $v eq 'Bar';
+ return $orig->( $self, $v );
+ };
+
+ package Foo;
+ use Mouse;
+
+ use Test::More; # for $TODO
+
+ local $TODO = 'UNIVERSAL methods should be wrappable';
+
+ ::lives_ok { with 'FakeBar' } 'applied role';
+
+ my $foo = Foo->new;
+ ::isa_ok $foo, 'Bar';
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+use Mouse::Meta::Class;
+
+$SIG{__WARN__} = sub { die if shift =~ /recurs/ };
+
+TODO:
+{
+# local $TODO
+# = 'Loading Mouse::Meta::Class without loading Mouse.pm causes weird problems';
+
+ my $meta;
+ lives_ok {
+ $meta = Mouse::Meta::Class->create_anon_class(
+ superclasses => [ 'Mouse::Object', ],
+ );
+ }
+ 'Class is created successfully';
+}
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+{
+ package Foo;
+
+ use Mouse;
+
+ use overload '""' => sub {''};
+
+ sub bug { 'plenty' }
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+ok(Foo->new()->bug(), 'call constructor on object reference with overloading');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+{
+ package Foo;
+
+ sub new {
+ bless({}, 'Foo')
+ }
+
+ sub a { 'Foo::a' }
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ ::lives_ok {
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Foo',
+ lazy => 1,
+ default => sub { Foo->new() },
+ handles => qr/^a$/,
+ );
+ } '... can create the attribute with delegations';
+
+}
+
+my $bar;
+lives_ok {
+ $bar = Bar->new;
+} '... created the object ok';
+isa_ok($bar, 'Bar');
+
+is($bar->a, 'Foo::a', '... got the right delgated value');
+
+my @w;
+$SIG{__WARN__} = sub { push @w, "@_" };
+{
+ package Baz;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Foo',
+ lazy => 1,
+ default => sub { Foo->new() },
+ handles => qr/.*/,
+ );
+ } '... can create the attribute with delegations';
+
+}
+
+is(@w, 0, "no warnings");
+
+
+my $baz;
+lives_ok {
+ $baz = Baz->new;
+} '... created the object ok';
+isa_ok($baz, 'Baz');
+
+is($baz->a, 'Foo::a', '... got the right delgated value');
+
+
+
+
+
+@w = ();
+
+{
+ package Blart;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Foo',
+ lazy => 1,
+ default => sub { Foo->new() },
+ handles => [qw(a new)],
+ );
+ } '... can create the attribute with delegations';
+
+}
+
+{
+ local $TODO = "warning not yet implemented";
+
+ is(@w, 1, "one warning");
+ like($w[0], qr/not delegating.*new/i, "warned");
+}
+
+
+
+my $blart;
+lives_ok {
+ $blart = Blart->new;
+} '... created the object ok';
+isa_ok($blart, 'Blart');
+
+is($blart->a, 'Foo::a', '... got the right delgated value');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 36;
+use Test::Exception;
+
+
+
+BEGIN {
+ package MyRole;
+ use Mouse::Role;
+
+ requires 'foo';
+
+ package MyMetaclass;
+ use Mouse qw(extends with);
+ extends 'Mouse::Meta::Class';
+ with 'MyRole';
+
+ sub foo { 'i am foo' }
+}
+
+{
+ package MyClass;
+ use metaclass ('MyMetaclass');
+ use Mouse;
+}
+
+my $mc = MyMetaclass->initialize('MyClass');
+isa_ok($mc, 'MyMetaclass');
+
+ok($mc->meta->does_role('MyRole'), '... the metaclass does the role');
+
+is(MyClass->meta, $mc, '... these metas are the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+my $a = MyClass->new;
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_immutable;
+} '... make MyClass immutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_mutable;
+} '... make MyClass mutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyMetaclass->meta->make_immutable;
+} '... make MyClass immutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_immutable;
+} '... make MyClass immutable okay';
+
+is(MyClass->meta, $mc, '... these metas are still the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+{
+ package MyClass;
+ use Mouse;
+
+ sub DEMOLISH { }
+}
+
+my $object = MyClass->new;
+
+# Removing the metaclass simulates the case where the metaclass object
+# goes out of scope _before_ the object itself, which under normal
+# circumstances only happens during global destruction.
+Class::MOP::remove_metaclass_by_name('MyClass');
+
+# The bug happened when DEMOLISHALL called
+# Class::MOP::class_of($object) and did not get a metaclass object
+# back.
+lives_ok { $object->DESTROY }
+'can call DESTROY on an object without a metaclass object in the CMOP cache';
+
+
+MyClass->meta->make_immutable;
+Class::MOP::remove_metaclass_by_name('MyClass');
+
+# The bug didn't manifest for immutable objects, but this test should
+# help us prevent it happening in the future.
+lives_ok { $object->DESTROY }
+'can call DESTROY on an object without a metaclass object in the CMOP cache (immutable version)';
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 10;
+
+{
+ package Ball;
+ use Mouse;
+}
+
+{
+ package Arbitrary::Roll;
+ use Mouse::Role;
+}
+
+my $method_meta = Mouse::Meta::Class->create_anon_class(
+ superclasses => ['Mouse::Meta::Method'],
+ roles => ['Arbitrary::Roll'],
+);
+
+# For comparing identity without actually keeping $original_meta around
+my $original_meta = "$method_meta";
+
+my $method_class = $method_meta->name;
+
+my $method_object = $method_class->wrap(
+ sub {'ok'},
+ associated_metaclass => Ball->meta,
+ package_name => 'Ball',
+ name => 'bounce',
+);
+
+Ball->meta->add_method( bounce => $method_object );
+
+for ( 1, 2 ) {
+ is( Ball->bounce, 'ok', "method still exists on Ball" );
+ is( Ball->meta->get_method('bounce')->meta->name, $method_class,
+ "method's package still exists" );
+
+ is( Ball->meta->get_method('bounce'), $method_object,
+ 'original method object is preserved' );
+
+ is( Ball->meta->get_method('bounce')->meta . '', $original_meta,
+ "method's metaclass still exists" );
+ ok( Ball->meta->get_method('bounce')->meta->does_role('Arbitrary::Roll'),
+ "method still does Arbitrary::Roll" );
+
+ undef $method_meta;
+}
use Test::More tests => 15;
use Test::Exception;
+use lib 't/lib';
+use Test::Mouse; # Mouse::Meta::Module->version
use Mouse::Meta::Role;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+use Test::Exception;
+
+=pod
+
+This tests to make sure that the inlined constructor
+has all the type constraints in order, even in the
+cases when there is no type constraint available, such
+as with a Class::MOP::Attribute object.
+
+=cut
+
+{
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'Int' => from 'Str' => via { length $_ ? $_ : 69 };
+
+ has 'foo' => (is => 'rw', isa => 'Int');
+ has 'baz' => (is => 'rw', isa => 'Int');
+ has 'zot' => (is => 'rw', isa => 'Int', init_arg => undef);
+ has 'moo' => (is => 'rw', isa => 'Int', coerce => 1, default => '', required => 1);
+ has 'boo' => (is => 'rw', isa => 'Int', coerce => 1, builder => '_build_boo', required => 1);
+
+ sub _build_boo { '' }
+
+ Foo->meta->add_attribute(
+ Mouse::Meta::Attribute->new(
+ 'bar' => (
+ accessor => 'bar',
+ )
+ )
+ );
+}
+
+for (1..2) {
+ my $is_immutable = Foo->meta->is_immutable;
+ my $mutable_string = $is_immutable ? 'immutable' : 'mutable';
+ lives_ok {
+ my $f = Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4);
+ is($f->moo, 69, "Type coercion works as expected on default ($mutable_string)");
+ is($f->boo, 69, "Type coercion works as expected on builder ($mutable_string)");
+ } "... this passes the constuctor correctly ($mutable_string)";
+
+ lives_ok {
+ Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int");
+ } "... the constructor doesn't care about 'zot' ($mutable_string)";
+
+ dies_ok {
+ Foo->new(foo => "Hello World", bar => 100, baz => "Hello World");
+ } "... this fails the constuctor correctly ($mutable_string)";
+
+ Foo->meta->make_immutable(debug => 0) unless $is_immutable;
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'foo' => (is => 'rw', isa => 'Int');
+
+ sub DEMOLISH { }
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ extends qw(Foo);
+ has 'bar' => (is => 'rw', isa => 'Int');
+
+ sub DEMOLISH { }
+}
+
+lives_ok {
+ Bar->new();
+} 'Bar->new()';
+
+lives_ok {
+ Bar->meta->make_immutable;
+} 'Bar->meta->make_immutable';
+
+is( Bar->meta->get_method('DESTROY')->package_name, 'Bar',
+ 'Bar has a DESTROY method in the Bar class (not inherited)' );
+
+lives_ok {
+ Foo->meta->make_immutable;
+} 'Foo->meta->make_immutable';
+
+is( Foo->meta->get_method('DESTROY')->package_name, 'Foo',
+ 'Foo has a DESTROY method in the Bar class (not inherited)' );
use strict;
use warnings;
use Mouse ();
-use Test::More tests => 19;
+use Test::More tests => 23;
use Test::Exception;
# error handling
ok $anon_pkg2->can('meta'), 'cache => 1 makes it immortal';
+my $obj;
+{
+ my $anon = Mouse::Meta::Class->create_anon_class(superclasses => ['Mouse::Object']);
+ lives_ok{ $anon->make_immutable() } 'make anon class immutable';
+ $obj = $anon->name->new();
+}
+
+SKIP:{
+ skip 'Moose has a bug', 3 if 'Mouse' eq 'Moose';
+
+ isa_ok $obj, 'Mouse::Object';
+ can_ok $obj, 'meta';
+ lives_and{
+ isa_ok $obj->meta, 'Mouse::Meta::Class';
+ };
+}
eval {
Foo->new( bar => +{} );
};
-like($@, qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Str\|Baz\|Undef' failed with value HASH\(\w+\)/, 'type constraint and coercion failed')
+like($@, qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Baz\|Str\|Undef' failed with value HASH\(\w+\)/, 'type constraint and coercion failed')
or diag "\$@='$@'";
eval {
}
eval { Funk->new( foo => 'aaa' ) };
-like $@, qr/Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Type3\|KLASS\|Undef' failed with value aaa/;
+like $@, qr/Attribute \(foo\) does not pass the type constraint because: Validation failed for 'KLASS\|Type3\|Undef' failed with value aaa/;
my $k = Funk->new;
ok $k, 'got an object 4';
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+BEGIN{
+ package Foo;
+ use Mouse;
+
+ sub import{
+ shift;
+ Mouse->export_to_level(1, @_);
+ }
+ $INC{'Foo.pm'}++;
+}
+
+package A;
+use Test::More;
+
+use Foo qw(has);
+
+ok defined(&has), "export_to_level (DEPRECATED)";
+
+
+ok!defined(&Bar::has), "export (DEPRECATED)";
+Mouse->export('Bar', 'has');
+ok defined(&Bar::has), "export (DEPRECATED)";
--- /dev/null
+
+package Bar;
+use Mouse;
+use Mouse::Util::TypeConstraints;
+
+type Baz => where { 1 };
+
+subtype Bling => as Baz => where { 1 };
+
+1;
\ No newline at end of file
--- /dev/null
+
+package Foo;
+use Mouse;
+
+has 'bar' => (is => 'rw');
+
+1;
\ No newline at end of file
--- /dev/null
+package MyMouseA;
+
+use Mouse;
+
+has 'b' => (is => 'rw', isa => 'MyMouseB');
+
+1;
\ No newline at end of file
--- /dev/null
+package MyMouseB;
+
+use Mouse;
+
+1;
\ No newline at end of file
--- /dev/null
+package MyMouseObject;
+
+use strict;
+use warnings;
+use base 'Mouse::Object';
+
+1;
\ No newline at end of file
# Moose compatible methods/functions
-package Mouse::Util::TypeConstraints;
+package
+ Mouse::Meta::Module;
+
+sub version { no strict 'refs'; ${shift->name.'::VERSION'} }
+sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
+sub identifier {
+ my $self = shift;
+ return join '-' => (
+ $self->name,
+ ($self->version || ()),
+ ($self->authority || ()),
+ );
+}
+
+package
+ Mouse::Meta::Role;
+
+for my $modifier_type (qw/before after around/) {
+ my $modifier = "${modifier_type}_method_modifiers";
+ my $has_method_modifiers = sub{
+ my($self, $method_name) = @_;
+ my $m = $self->{$modifier}->{$method_name};
+ return $m && @{$m} != 0;
+ };
+
+ no strict 'refs';
+ *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
+}
+
+
+sub has_override_method_modifier {
+ my ($self, $method_name) = @_;
+ return exists $self->{override_method_modifiers}->{$method_name};
+}
+
+sub get_method_modifier_list {
+ my($self, $modifier_type) = @_;
+
+ return keys %{ $self->{$modifier_type . '_method_modifiers'} };
+}
+
+package
+ Mouse::Util::TypeConstraints;
use Mouse::Util::TypeConstraints ();
my $into = caller;
foreach my $type( list_all_type_constraints() ) {
- my $tc = find_type_constraint($type)->{_compiled_type_constraint};
+ my $tc = find_type_constraint($type)->_compiled_type_constraint;
my $as = $into . '::' . $type;
no strict 'refs';
return;
}
-package Mouse::Meta::Attribute;
+package
+ Mouse::Meta::Attribute;
sub applied_traits{ $_[0]->{traits} } # TEST ONLY
sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY
+sub has_documentation{ exists $_[0]->{documentation} } # TEST ONLY
+sub documentation{ $_[0]->{documentation} } # TEST ONLY
+
1;
__END__
projects / gitmo/Mouse.git / commitdiff