r27764 - in /branches/upstream/libmouse-perl/current: Changes lib/Mouse.pm lib/Mouse/Meta/Attribute.pm lib/Mouse/Tiny.pm lib/Mouse/Util.pm t/025-more-isa.t

bricas-guest at users.alioth.debian.org bricas-guest at users.alioth.debian.org
Fri Dec 5 12:40:36 UTC 2008


Author: bricas-guest
Date: Fri Dec  5 12:40:33 2008
New Revision: 27764

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=27764
Log:
[svn-upgrade] Integrating new upstream version, libmouse-perl (0.12)

Modified:
    branches/upstream/libmouse-perl/current/Changes
    branches/upstream/libmouse-perl/current/lib/Mouse.pm
    branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm
    branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm
    branches/upstream/libmouse-perl/current/lib/Mouse/Util.pm
    branches/upstream/libmouse-perl/current/t/025-more-isa.t

Modified: branches/upstream/libmouse-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/Changes?rev=27764&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/Changes (original)
+++ branches/upstream/libmouse-perl/current/Changes Fri Dec  5 12:40:33 2008
@@ -1,4 +1,13 @@
 Revision history for Mouse
+
+0.12 Thu Dec 4 19:23:10 2008
+    * Provide Test::Exception function unless it's version 0.27 - RT #41254
+
+    * Mouse::Util now provides dies_ok
+
+    * Make class-like types behave more like Moose; subclasses OK! (rjbs)
+
+    * Steal more tests from Moose
 
 0.11 Sun Nov 2 11:35:04 2008
     * Throw an error if accessor/predicate/clearer/handles code eval fails

Modified: branches/upstream/libmouse-perl/current/lib/Mouse.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse.pm?rev=27764&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse.pm Fri Dec  5 12:40:33 2008
@@ -4,7 +4,7 @@
 use warnings;
 use base 'Exporter';
 
-our $VERSION = '0.11';
+our $VERSION = '0.12';
 use 5.006;
 
 use Carp 'confess';
@@ -360,6 +360,11 @@
 bucket status). You must specify an appropriate type constraint to use
 auto_deref.
 
+=item lazy_build => 0|1
+
+Automatically define lazy => 1 as well as builder => "_build_$attr", clearer =>
+"clear_$attr', predicate => 'has_$attr' unless they are already defined.
+
 =back
 
 =head2 confess error -> BOOM

Modified: branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm?rev=27764&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse/Meta/Attribute.pm Fri Dec  5 12:40:33 2008
@@ -294,7 +294,7 @@
     my $checker = Mouse::TypeRegistry->optimized_constraints->{$type};
     return $checker if $checker;
 
-    return sub { blessed($_) && blessed($_) eq $type };
+    return sub { blessed($_) && $_->isa($type) };
 }
 
 sub verify_type_constraint {

Modified: branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm?rev=27764&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse/Tiny.pm Fri Dec  5 12:40:33 2008
@@ -7,6 +7,7 @@
 
 # tell Perl we already have all of the Mouse files loaded:
 $INC{'Mouse.pm'} = __FILE__;
+$INC{'ouse.pm'} = __FILE__;
 $INC{'Mouse/Object.pm'} = __FILE__;
 $INC{'Mouse/Role.pm'} = __FILE__;
 $INC{'Mouse/TypeRegistry.pm'} = __FILE__;
@@ -140,7 +141,7 @@
 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
         },
 #       VVVVV   CODE TAKEN FROM TEST::EXCEPTION   VVVVV
-        'Test::Exception' => do {
+        'Test::Exception 0.27' => do {
 
             my $Tester;
 
@@ -212,16 +213,18 @@
         test => [qw/throws_ok lives_ok/],
     );
 
-    for my $module_name (keys %dependencies) {
+    for my $module (keys %dependencies) {
+        my ($module_name, $version) = split ' ', $module;
+
         my $loaded = do {
             local $SIG{__DIE__} = 'DEFAULT';
-            eval "require $module_name; 1";
+            eval "use $module (); 1";
         };
 
         $loaded{$module_name} = $loaded;
 
-        for my $method_name (keys %{ $dependencies{ $module_name } }) {
-            my $producer = $dependencies{$module_name}{$method_name};
+        for my $method_name (keys %{ $dependencies{ $module } }) {
+            my $producer = $dependencies{$module}{$method_name};
             my $implementation;
 
             if (ref($producer) eq 'HASH') {
@@ -246,7 +249,7 @@
 use warnings;
 use base 'Exporter';
 
-our $VERSION = '0.09';
+our $VERSION = '0.12';
 use 5.006;
 
 use Carp 'confess';
@@ -438,94 +441,114 @@
     $_[0]->{_create_args}
 }
 
+sub inlined_name {
+    my $self = shift;
+    my $name = $self->name;
+    my $key   = "'" . $name . "'";
+    return $key;
+}
+
 sub generate_accessor {
     my $attribute = shift;
 
-    my $name       = $attribute->name;
-    my $key        = $name;
-    my $default    = $attribute->default;
-    my $type       = $attribute->type_constraint;
-    my $constraint = $attribute->find_type_constraint;
-    my $builder    = $attribute->builder;
-    my $trigger    = $attribute->trigger;
-
-    my $accessor = 'sub {
-        my $self = shift;';
-
+    my $name         = $attribute->name;
+    my $default      = $attribute->default;
+    my $type         = $attribute->type_constraint;
+    my $constraint   = $attribute->find_type_constraint;
+    my $builder      = $attribute->builder;
+    my $trigger      = $attribute->trigger;
+    my $is_weak      = $attribute->is_weak_ref;
+    my $should_deref = $attribute->should_auto_deref;
+
+    my $self  = '$_[0]';
+    my $key   = $attribute->inlined_name;
+
+    my $accessor = "sub {\n";
     if ($attribute->_is_metadata eq 'rw') {
-        $accessor .= 'if (@_) {
-            local $_ = $_[0];';
+        $accessor .= 'if (scalar(@_) >= 2) {' . "\n";
+
+        my $value = '$_[1]';
 
         if ($constraint) {
-            $accessor .= 'unless ($constraint->()) {
+            $accessor .= 'local $_ = '.$value.';
+                unless ($constraint->()) {
                     my $display = defined($_) ? overload::StrVal($_) : "undef";
                     Carp::confess("Attribute ($name) does not pass the type constraint because: Validation failed for \'$type\' failed with value $display");
-            }'
-        }
-
-        $accessor .= '$self->{$key} = $_;';
-
-        if ($attribute->is_weak_ref) {
-            $accessor .= 'weaken($self->{$key}) if ref($self->{$key});';
+            }' . "\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";
+
+        if ($is_weak) {
+            $accessor .= 'weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n";
         }
 
         if ($trigger) {
-            $accessor .= '$trigger->($self, $_, $attribute);';
-        }
-
-        $accessor .= '}';
+            $accessor .= '$trigger->('.$self.', '.$value.', $attribute);' . "\n";
+        }
+
+        $accessor .= "}\n";
     }
     else {
-        $accessor .= 'confess "Cannot assign a value to a read-only accessor" if @_;';
+        $accessor .= 'confess "Cannot assign a value to a read-only accessor" if scalar(@_) >= 2;' . "\n";
     }
 
     if ($attribute->is_lazy) {
-        $accessor .= '$self->{$key} = ';
+        $accessor .= $self.'->{'.$key.'} = ';
 
         $accessor .= $attribute->has_builder
-                   ? '$self->$builder'
-                     : ref($default) eq 'CODE'
-                     ? '$default->($self)'
-                     : '$default';
-
-        $accessor .= ' if !exists($self->{$key});';
-    }
-
-    if ($attribute->should_auto_deref) {
+                ? $self.'->$builder'
+                    : ref($default) eq 'CODE'
+                    ? '$default->('.$self.')'
+                    : '$default';
+        $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n";
+    }
+
+    if ($should_deref) {
         if ($attribute->type_constraint eq 'ArrayRef') {
             $accessor .= 'if (wantarray) {
-                return @{ $self->{$key} || [] };
+                return @{ '.$self.'->{'.$key.'} || [] };
             }';
         }
         else {
             $accessor .= 'if (wantarray) {
-                return %{ $self->{$key} || {} };
+                return %{ '.$self.'->{'.$key.'} || {} };
             }';
         }
     }
 
-    $accessor .= 'return $self->{$key};
+    $accessor .= 'return '.$self.'->{'.$key.'};
     }';
 
-    return eval $accessor;
+    my $sub = eval $accessor;
+    confess $@ if $@;
+    return $sub;
 }
 
 sub generate_predicate {
     my $attribute = shift;
-    my $key = $attribute->name;
-
-    my $predicate = 'sub { exists($_[0]->{$key}) }';
-
-    return eval $predicate;
+    my $key = $attribute->inlined_name;
+
+    my $predicate = 'sub { exists($_[0]->{'.$key.'}) }';
+
+    my $sub = eval $predicate;
+    confess $@ if $@;
+    return $sub;
 }
 
 sub generate_clearer {
     my $attribute = shift;
-    my $key = $attribute->name;
-
-    my $predicate = 'sub { delete($_[0]->{$key}) }';
-
-    return eval $predicate;
+    my $key = $attribute->inlined_name;
+
+    my $clearer = 'sub { delete($_[0]->{'.$key.'}) }';
+
+    my $sub = eval $clearer;
+    confess $@ if $@;
+    return $sub;
 }
 
 sub generate_handles {
@@ -544,6 +567,7 @@
         }';
 
         $method_map{$local_method} = eval $method;
+        confess $@ if $@;
     }
 
     return \%method_map;
@@ -1195,6 +1219,22 @@
     };
 }
 
+
+use strict;
+use warnings;
+
+BEGIN {
+    my $package;
+    sub import { 
+        $package = $_[1] || 'Class';
+        if ($package =~ /^\+/) {
+            $package =~ s/^\+//;
+            eval "require $package; 1" or die;
+        }
+    }
+    use Filter::Simple sub { s/^/package $package;\nuse Mouse;\n/; }
+}
+
 }; #eval
 } #unless
 

Modified: branches/upstream/libmouse-perl/current/lib/Mouse/Util.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/lib/Mouse/Util.pm?rev=27764&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/lib/Mouse/Util.pm (original)
+++ branches/upstream/libmouse-perl/current/lib/Mouse/Util.pm Fri Dec  5 12:40:33 2008
@@ -122,7 +122,7 @@
 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
         },
 #       VVVVV   CODE TAKEN FROM TEST::EXCEPTION   VVVVV
-        'Test::Exception' => do {
+        'Test::Exception 0.27' => do {
 
             my $Tester;
 
@@ -182,6 +182,16 @@
                     $@ = $exception;
                     return $ok;
                 },
+                'dies_ok' => sub (&;$) {
+                    my ( $coderef, $description ) = @_;
+                    my $exception = $try_as_caller->( $coderef );
+
+                    $Tester ||= Test::Builder->new;
+
+                    my $ok = $Tester->ok( $is_exception->( $exception ), $description );
+                    $@ = $exception;
+                    return $ok;
+                },
             },
         },
     );
@@ -191,19 +201,21 @@
     our @EXPORT_OK = map { keys %$_ } values %dependencies;
     our %EXPORT_TAGS = (
         all  => \@EXPORT_OK,
-        test => [qw/throws_ok lives_ok/],
+        test => [qw/throws_ok lives_ok dies_ok/],
     );
 
-    for my $module_name (keys %dependencies) {
+    for my $module (keys %dependencies) {
+        my ($module_name, $version) = split ' ', $module;
+
         my $loaded = do {
             local $SIG{__DIE__} = 'DEFAULT';
-            eval "require $module_name; 1";
+            eval "use $module (); 1";
         };
 
         $loaded{$module_name} = $loaded;
 
-        for my $method_name (keys %{ $dependencies{ $module_name } }) {
-            my $producer = $dependencies{$module_name}{$method_name};
+        for my $method_name (keys %{ $dependencies{ $module } }) {
+            my $producer = $dependencies{$module}{$method_name};
             my $implementation;
 
             if (ref($producer) eq 'HASH') {
@@ -256,6 +268,8 @@
 
 =head3 throws_ok
 
+=head3 dies_ok
+
 =head3 lives_ok
 
 =cut

Modified: branches/upstream/libmouse-perl/current/t/025-more-isa.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmouse-perl/current/t/025-more-isa.t?rev=27764&op=diff
==============================================================================
--- branches/upstream/libmouse-perl/current/t/025-more-isa.t (original)
+++ branches/upstream/libmouse-perl/current/t/025-more-isa.t Fri Dec  5 12:40:33 2008
@@ -1,7 +1,7 @@
 #!/usr/bin/env perl
 use strict;
 use warnings;
-use Test::More tests => 29;
+use Test::More tests => 30;
 use Mouse::Util ':test';
 
 do {
@@ -12,12 +12,22 @@
         is  => 'rw',
         isa => 'Test::Builder',
     );
+
+    package Test::Builder::Subclass;
+    our @ISA = qw(Test::Builder);
 };
 
 can_ok(Class => 'tb');
 
 lives_ok {
     Class->new(tb => Test::Builder->new);
+};
+
+lives_ok {
+    # Test::Builder was a bizarre choice, because it's a singleton.  Because of
+    # that calling new on T:B:S won't work.  Blessing directly -- rjbs,
+    # 2008-12-04
+    Class->new(tb => (bless {} => 'Test::Builder::Subclass'));
 };
 
 lives_ok {




More information about the Pkg-perl-cvs-commits mailing list