* Implement "override" and "super"
+ * MouseX::Types is now in its own dist
+
0.14 Sat Dec 20 16:53:05 2008
* POD fix
+++ /dev/null
-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 - Organise 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;
-
-=cut
+++ /dev/null
-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;
-
-
+++ /dev/null
-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;
+++ /dev/null
-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');
-}
-
+++ /dev/null
-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');
-
+++ /dev/null
-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';
projects / gitmo/Mouse.git / commitdiff