[Moose-commits] r7555 - / MouseX-Types MouseX-Types/trunk
MouseX-Types/trunk/lib MouseX-Types/trunk/lib/MouseX
MouseX-Types/trunk/lib/MouseX/Types MouseX-Types/trunk/t
MouseX-Types/trunk/xt
yappo at code2.0beta.co.uk
yappo at code2.0beta.co.uk
Thu Feb 5 07:35:56 GMT 2009
Author: yappo
Date: 2009-02-04 23:35:55 -0800 (Wed, 04 Feb 2009)
New Revision: 7555
Added:
MouseX-Types/
MouseX-Types/branches/
MouseX-Types/tags/
MouseX-Types/trunk/
MouseX-Types/trunk/.shipit
MouseX-Types/trunk/Changes
MouseX-Types/trunk/MANIFEST
MouseX-Types/trunk/MANIFEST.SKIP
MouseX-Types/trunk/Makefile.PL
MouseX-Types/trunk/README
MouseX-Types/trunk/lib/
MouseX-Types/trunk/lib/MouseX/
MouseX-Types/trunk/lib/MouseX/Types.pm
MouseX-Types/trunk/lib/MouseX/Types/
MouseX-Types/trunk/lib/MouseX/Types/Mouse.pm
MouseX-Types/trunk/lib/MouseX/Types/TypeDecorator.pm
MouseX-Types/trunk/t/
MouseX-Types/trunk/t/001-make_immutable.t
MouseX-Types/trunk/t/002-base.t
MouseX-Types/trunk/t/003-isa-or.t
MouseX-Types/trunk/t/00_compile.t
MouseX-Types/trunk/xt/
MouseX-Types/trunk/xt/01_podspell.t
MouseX-Types/trunk/xt/02_perlcritic.t
MouseX-Types/trunk/xt/03_pod.t
MouseX-Types/trunk/xt/perlcriticrc
Log:
import MouseX::Types
Added: MouseX-Types/trunk/.shipit
===================================================================
--- MouseX-Types/trunk/.shipit (rev 0)
+++ MouseX-Types/trunk/.shipit 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,2 @@
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist, UploadCPAN
+svn.tagpattern = release-%v
Added: MouseX-Types/trunk/Changes
===================================================================
--- MouseX-Types/trunk/Changes (rev 0)
+++ MouseX-Types/trunk/Changes 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,4 @@
+Revision history for Perl extension MouseX::Types
+
+0.01 Thu Feb 5 13:50:49 2009
+ - original version
Added: MouseX-Types/trunk/MANIFEST
===================================================================
--- MouseX-Types/trunk/MANIFEST (rev 0)
+++ MouseX-Types/trunk/MANIFEST 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,29 @@
+Changes
+inc/Module/Install.pm
+inc/Module/Install/AuthorTests.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+inc/Scalar/Util.pm
+inc/Test/Exception.pm
+inc/Test/More.pm
+lib/MouseX/Types.pm
+lib/MouseX/Types/Mouse.pm
+lib/MouseX/Types/TypeDecorator.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/001-make_immutable.t
+t/002-base.t
+t/003-isa-or.t
+t/00_compile.t
+xt/01_podspell.t
+xt/02_perlcritic.t
+xt/03_pod.t
+xt/perlcriticrc
Added: MouseX-Types/trunk/MANIFEST.SKIP
===================================================================
--- MouseX-Types/trunk/MANIFEST.SKIP (rev 0)
+++ MouseX-Types/trunk/MANIFEST.SKIP 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,19 @@
+\bRCS\b
+\bCVS\b
+^MANIFEST\.
+^Makefile$
+~$
+^#
+\.old$
+^blib/
+^pm_to_blib
+^MakeMaker-\d
+\.gz$
+\.cvsignore
+^t/9\d_.*\.t
+^t/perlcritic
+^tools/
+\.svn/
+^[^/]+\.yaml$
+^[^/]+\.pl$
+^\.shipit$
Added: MouseX-Types/trunk/Makefile.PL
===================================================================
--- MouseX-Types/trunk/Makefile.PL (rev 0)
+++ MouseX-Types/trunk/Makefile.PL 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,15 @@
+use inc::Module::Install;
+name 'MouseX-Types';
+all_from 'lib/MouseX/Types.pm';
+
+requires 'Mouse' => 0.15;
+
+tests 't/*.t';
+author_tests 'xt';
+
+build_requires 'Test::More';
+build_requires 'Test::Exception';
+build_requires 'Scalar::Util';
+
+auto_include;
+WriteAll;
Added: MouseX-Types/trunk/README
===================================================================
--- MouseX-Types/trunk/README (rev 0)
+++ MouseX-Types/trunk/README 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,27 @@
+This is Perl module MouseX::Types.
+
+INSTALLATION
+
+MouseX::Types installation is straightforward. If your CPAN shell is set up,
+you should just be able to do
+
+ % cpan MouseX::Types
+
+Download it, unpack it, then build it as per the usual:
+
+ % perl Makefile.PL
+ % make && make test
+
+Then install it:
+
+ % make install
+
+DOCUMENTATION
+
+MouseX::Types documentation is available as in POD. So you can do:
+
+ % perldoc MouseX::Types
+
+to read the documentation online with your favorite pager.
+
+Kazuhiro Osawa
Added: MouseX-Types/trunk/lib/MouseX/Types/Mouse.pm
===================================================================
--- MouseX-Types/trunk/lib/MouseX/Types/Mouse.pm (rev 0)
+++ MouseX-Types/trunk/lib/MouseX/Types/Mouse.pm 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,15 @@
+package MouseX::Types::Mouse;
+use strict;
+use warnings;
+
+BEGIN { require Mouse::Util::TypeConstraints }
+use MouseX::Types;
+
+BEGIN {
+ my $builtin_type = +{ map { $_ => $_ } Mouse::Util::TypeConstraints->list_all_builtin_type_constraints };
+ sub type_storage { $builtin_type }
+}
+
+1;
+
+
Added: MouseX-Types/trunk/lib/MouseX/Types/TypeDecorator.pm
===================================================================
--- MouseX-Types/trunk/lib/MouseX/Types/TypeDecorator.pm (rev 0)
+++ MouseX-Types/trunk/lib/MouseX/Types/TypeDecorator.pm 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,41 @@
+package MouseX::Types::TypeDecorator;
+
+use strict;
+use warnings;
+
+use Scalar::Util 'blessed';
+
+use overload(
+ '""' => sub { ${ $_[0] } },
+ '|' => sub {
+
+ ## It's kind of ugly that we need to know about Union Types, but this
+ ## is needed for syntax compatibility. Maybe someday we'll all just do
+ ## Or[Str,Str,Int]
+
+ my @tc = grep {blessed $_} @_;
+ use Data::Dumper;
+ my $ret;
+ if (ref($_[0])) {
+ $ret = ${ $_[0] };
+ } else {
+ $ret = $_[0];
+ }
+ $ret .= '|';
+ if (ref($_[1])) {
+ $ret .= ${ $_[1] };
+ } else {
+ $ret .= $_[1];
+ }
+ $ret;
+ },
+ fallback => 1,
+
+);
+
+sub new {
+ my $type = $_[1];
+ bless \$type, $_[0];
+}
+
+1;
Added: MouseX-Types/trunk/lib/MouseX/Types.pm
===================================================================
--- MouseX-Types/trunk/lib/MouseX/Types.pm (rev 0)
+++ MouseX-Types/trunk/lib/MouseX/Types.pm 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,133 @@
+package MouseX::Types;
+use strict;
+use warnings;
+
+require Mouse::Util::TypeConstraints;
+use MouseX::Types::TypeDecorator;
+
+sub import {
+ my $class = shift;
+ my %args = @_;
+ my $caller = caller(0);
+
+ no strict 'refs';
+ *{"$caller\::import"} = sub { my $pkg = caller(0); _import($caller, $pkg, @_) };
+ push @{"$caller\::ISA"}, 'MouseX::Types::Base';
+
+ if (defined $args{'-declare'} && ref($args{'-declare'}) eq 'ARRAY') {
+ my $storage = $caller->type_storage($caller);
+ for my $name (@{ $args{'-declare'} }) {
+ my $obj = $storage->{$name} = "$caller\::$name";
+ *{"$caller\::$name"} = sub () { $obj };
+ }
+ }
+
+ return Mouse::Util::TypeConstraints->export_to_level(1, $class);
+}
+
+sub _import {
+ my($type_class, $pkg, @types) = @_;
+ no strict 'refs';
+ for my $name (@types) {
+ my $obj = $type_class->type_storage->{$name};
+ $obj = $type_class->type_storage->{$name} = MouseX::Types::TypeDecorator->new($obj)
+ unless ref($obj);
+ *{"$pkg\::$name"} = sub () { $obj };
+ }
+}
+
+{
+ package MouseX::Types::Base;
+ my %storage;
+ sub type_storage {
+ $storage{$_[0]} ||= +{}
+ }
+}
+
+1;
+
+=head1 NAME
+
+MouseX::Types - Organize your Mouse types in libraries
+
+=head1 SYNOPSIS
+
+=head2 Library Definition
+
+ package MyLibrary;
+
+ # predeclare our own types
+ use MouseX::Types
+ -declare => [qw(
+ PositiveInt NegativeInt
+ )];
+
+ # import builtin types
+ use MouseX::Types::Mouse 'Int';
+
+ # type definition.
+ subtype PositiveInt,
+ as Int,
+ where { $_ > 0 },
+ message { "Int is not larger than 0" };
+
+ subtype NegativeInt,
+ as Int,
+ where { $_ < 0 },
+ message { "Int is not smaller than 0" };
+
+ # type coercion
+ coerce PositiveInt,
+ from Int,
+ via { 1 };
+
+ 1;
+
+=head2 Usage
+
+ package Foo;
+ use Mouse;
+ use MyLibrary qw( PositiveInt NegativeInt );
+
+ # use the exported constants as type names
+ has 'bar',
+ isa => PositiveInt,
+ is => 'rw';
+ has 'baz',
+ isa => NegativeInt,
+ is => 'rw';
+
+ sub quux {
+ my ($self, $value);
+
+ # test the value
+ print "positive\n" if is_PositiveInt($value);
+ print "negative\n" if is_NegativeInt($value);
+
+ # coerce the value, NegativeInt doesn't have a coercion
+ # helper, since it didn't define any coercions.
+ $value = to_PositiveInt($value) or die "Cannot coerce";
+ }
+
+ 1;
+
+=head1 AUTHOR
+
+Kazuhiro Osawa E<lt>yappo <at> shibuya <döt> plE<gt>
+
+Shawn M Moore
+
+tokuhirom
+
+with plenty of code borrowed from L<MooseX::Types>
+
+=head1 REPOSITORY
+
+ svn co http://code2.0beta.co.uk/moose/svn/MouseX-Types/trunk MouseX-Types
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: MouseX-Types/trunk/t/001-make_immutable.t
===================================================================
--- MouseX-Types/trunk/t/001-make_immutable.t (rev 0)
+++ MouseX-Types/trunk/t/001-make_immutable.t 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,85 @@
+use strict;
+use warnings;
+use Test::More tests => 18;
+use Test::Exception;
+use Scalar::Util qw/isweak/;
+
+{
+ package Headers;
+ use Mouse;
+ has data => (
+ is => 'rw',
+ isa => 'Str',
+ );
+ no Mouse;
+}
+
+{
+ package Types;
+ use MouseX::Types -declare => [qw/Foo/];
+ use MouseX::Types::Mouse 'HashRef';
+ class_type Foo, { class => 'Headers' };
+ coerce Foo,
+ from HashRef,
+ via {
+ Headers->new($_);
+ };
+}
+
+
+&main; exit;
+
+sub construct {
+ my $class = shift;
+ eval <<"...";
+ package $class;
+ use Mouse;
+ BEGIN { Types->import('Foo') }
+ has bone => (
+ is => 'rw',
+ required => 1,
+ );
+ has foo => (
+ is => 'rw',
+ isa => Foo,
+ coerce => 1,
+ );
+ has weak_foo => (
+ is => 'rw',
+ weak_ref => 1,
+ );
+ has trigger_foo => (
+ is => 'rw',
+ trigger => sub { \$_[0]->bone('eat') },
+ );
+ sub BUILD { main::ok "calling BUILD in SoftDog" }
+ no Mouse;
+...
+ die $@ if $@;
+}
+
+sub test {
+ my $class = shift;
+ lives_ok { $class->new(bone => 'moo') } "$class new";
+ throws_ok { $class->new() } qr/\QAttribute (bone) is required/;
+ is($class->new(bone => 'moo', foo => { data => 3 })->foo->data, 3);
+
+ my $foo = Headers->new();
+ ok(Scalar::Util::isweak($class->new(bone => 'moo', weak_foo => $foo)->{weak_foo}));
+
+ {
+ my $o = $class->new(bone => 'moo');
+ $o->trigger_foo($foo);
+ is($o->bone, 'eat');
+ }
+}
+
+sub main {
+ construct('SoftDog');
+ test('SoftDog');
+
+ construct('HardDog');
+ HardDog->meta->make_immutable;
+ test('HardDog');
+}
+
Added: MouseX-Types/trunk/t/002-base.t
===================================================================
--- MouseX-Types/trunk/t/002-base.t (rev 0)
+++ MouseX-Types/trunk/t/002-base.t 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,118 @@
+use strict;
+use warnings;
+use Test::More tests => 16;
+
+{
+ package Types;
+ use MouseX::Types -declare => [qw/ Headers /];
+ use MouseX::Types::Mouse 'HashRef';
+
+ type Headers, where { defined $_ && eval { $_->isa('Headers1') } };
+ coerce Headers,
+ from HashRef, via {
+ Headers1->new(%{ $_ });
+ },
+ ;
+}
+
+{
+ package Types2;
+ use MouseX::Types -declare => [qw/ Headers /];
+ use MouseX::Types::Mouse 'HashRef';
+
+ type Headers, where { defined $_ && eval { $_->isa('Headers2') } };
+ coerce Headers,
+ from HashRef, via {
+ Headers2->new(%{ $_ });
+ },
+ ;
+}
+
+{
+ package Headers1;
+ use Mouse;
+ has 'foo' => ( is => 'rw' );
+}
+
+{
+ package Headers2;
+ use Mouse;
+ has 'foo' => ( is => 'rw' );
+}
+
+{
+ package Response;
+ use Mouse;
+ BEGIN { Types->import(qw/ Headers /) }
+
+ has headers => (
+ is => 'rw',
+ isa => Headers,
+ coerce => 1,
+ );
+}
+
+{
+ package Request;
+ use Mouse;
+ BEGIN { Types->import(qw/ Headers /) }
+
+ has headers => (
+ is => 'rw',
+ isa => Headers,
+ coerce => 1,
+ );
+}
+
+{
+ package Response2;
+ use Mouse;
+ BEGIN { Types2->import(qw/ Headers /) }
+
+ has headers => (
+ is => 'rw',
+ isa => Headers,
+ coerce => 1,
+ );
+}
+
+{
+ package Request2;
+ use Mouse;
+ BEGIN { Types2->import(qw/ Headers /) }
+
+ has headers => (
+ is => 'rw',
+ isa => Headers,
+ coerce => 1,
+ );
+}
+
+my $res = Response->new(headers => { foo => 'bar' });
+isa_ok($res->headers, 'Headers1');
+is($res->headers->foo, 'bar');
+$res->headers({foo => 'yay'});
+isa_ok($res->headers, 'Headers1');
+is($res->headers->foo, 'yay');
+
+my $req = Request->new(headers => { foo => 'bar' });
+isa_ok($res->headers, 'Headers1');
+is($req->headers->foo, 'bar');
+$req->headers({foo => 'yay'});
+isa_ok($res->headers, 'Headers1');
+is($req->headers->foo, 'yay');
+
+$res = Response2->new(headers => { foo => 'bar' });
+isa_ok($res->headers, 'Headers2');
+is($res->headers->foo, 'bar');
+$res->headers({foo => 'yay'});
+isa_ok($res->headers, 'Headers2');
+is($res->headers->foo, 'yay');
+
+$req = Request2->new(headers => { foo => 'bar' });
+isa_ok($res->headers, 'Headers2');
+is($req->headers->foo, 'bar');
+$req->headers({foo => 'yay'});
+isa_ok($res->headers, 'Headers2');
+is($req->headers->foo, 'yay');
+
Added: MouseX-Types/trunk/t/003-isa-or.t
===================================================================
--- MouseX-Types/trunk/t/003-isa-or.t (rev 0)
+++ MouseX-Types/trunk/t/003-isa-or.t 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,77 @@
+use strict;
+use warnings;
+use Test::More tests => 13;
+
+{
+ package Types;
+ use strict;
+ use warnings;
+ use MouseX::Types -declare => [qw/ Baz Type1 Type2 /];
+ use MouseX::Types::Mouse qw( ArrayRef );
+
+ type Baz, where { defined($_) && $_ eq 'Baz' };
+ coerce Baz, from ArrayRef, via { 'Baz' };
+
+ type Type1, where { defined($_) && $_ eq 'Name' };
+ coerce Type1, from 'Str', via { 'Names' };
+
+ type Type2, where { defined($_) && $_ eq 'Group' };
+ coerce Type2, from 'Str', via { 'Name' };
+
+}
+
+{
+ package Foo;
+ use Mouse;
+ use MouseX::Types::Mouse qw( Str Undef );
+ BEGIN { Types->import(qw( Baz Type1 )) }
+ has 'bar' => ( is => 'rw', isa => Str | Baz | Undef, coerce => 1 );
+}
+
+eval {
+ Foo->new( bar => +{} );
+};
+ok $@, 'not got an object';
+
+eval {
+ isa_ok(Foo->new( bar => undef ), 'Foo');
+};
+ok !$@, 'got an object 1';
+
+eval {
+ isa_ok(Foo->new( bar => 'foo' ), 'Foo');
+
+};
+ok !$@, 'got an object 2';
+
+
+my $f = Foo->new;
+eval {
+ $f->bar([]);
+};
+ok !$@;
+is $f->bar, 'Baz', 'bar is baz (coerce from ArrayRef)';
+
+eval {
+ $f->bar('hoge');
+};
+ok !$@;
+is $f->bar, 'hoge', 'bar is hoge';
+
+eval {
+ $f->bar(undef);
+};
+ok !$@;
+is $f->bar, undef, 'bar is undef';
+
+
+{
+ package Bar;
+ use Mouse;
+ BEGIN { Types->import(qw( Type1 Type2 )) }
+ has 'foo' => ( is => 'rw', isa => Type1 | Type2 , coerce => 1 );
+}
+
+my $foo = Bar->new( foo => 'aaa' );
+ok $foo, 'got an object 3';
+is $foo->foo, 'Name', 'foo is Name';
Added: MouseX-Types/trunk/t/00_compile.t
===================================================================
--- MouseX-Types/trunk/t/00_compile.t (rev 0)
+++ MouseX-Types/trunk/t/00_compile.t 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,4 @@
+use strict;
+use Test::More tests => 1;
+
+BEGIN { use_ok 'MouseX::Types' }
Added: MouseX-Types/trunk/xt/01_podspell.t
===================================================================
--- MouseX-Types/trunk/xt/01_podspell.t (rev 0)
+++ MouseX-Types/trunk/xt/01_podspell.t 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,12 @@
+use Test::More;
+eval q{ use Test::Spelling };
+plan skip_all => "Test::Spelling is not installed." if $@;
+add_stopwords(map { split /[\s\:\-]/ } <DATA>);
+$ENV{LANG} = 'C';
+all_pod_files_spelling_ok('lib');
+__DATA__
+Kazuhiro Osawa
+yappo <at> shibuya <döt> pl
+MouseX::Types
+Shawn M Moore
+tokuhirom
Added: MouseX-Types/trunk/xt/02_perlcritic.t
===================================================================
--- MouseX-Types/trunk/xt/02_perlcritic.t (rev 0)
+++ MouseX-Types/trunk/xt/02_perlcritic.t 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,8 @@
+use strict;
+use Test::More;
+eval {
+ require Test::Perl::Critic;
+ Test::Perl::Critic->import( -profile => 'xt/perlcriticrc');
+};
+plan skip_all => "Test::Perl::Critic is not installed." if $@;
+all_critic_ok('lib');
Added: MouseX-Types/trunk/xt/03_pod.t
===================================================================
--- MouseX-Types/trunk/xt/03_pod.t (rev 0)
+++ MouseX-Types/trunk/xt/03_pod.t 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,4 @@
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
Added: MouseX-Types/trunk/xt/perlcriticrc
===================================================================
--- MouseX-Types/trunk/xt/perlcriticrc (rev 0)
+++ MouseX-Types/trunk/xt/perlcriticrc 2009-02-05 07:35:55 UTC (rev 7555)
@@ -0,0 +1,2 @@
+[TestingAndDebugging::ProhibitNoStrict]
+allow=refs
More information about the Moose-commits
mailing list