cleanup

diff --git a/Changes b/Changes
index 0ad2c39..afa1e0a 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,6 +1,10 @@
 Revision history for Perl extension Moose
 
 0.03
+    * Moose::Cookbook
+      - added the Moose::Cookbook with 5 recipes, 
+        describing all the stuff Moose can do.
+
     * Moose
       - fixed an issue with &extends super class loading
         it now captures errors and deals with inline 

diff --git a/lib/Moose.pm b/lib/Moose.pm
index 68d44dc..2b5297f 100644 (file)
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -60,45 +60,14 @@ sub import {
        
        # handle superclasses
        $meta->alias_method('extends' => subname 'Moose::extends' => sub { 
-           foreach my $super (@_) {
-               # see if this is already 
-               # loaded in the symbol table
-            next if _is_class_already_loaded($super);
-            # otherwise require it ...
-            ($super->require)
-                   || confess "Could not load superclass '$super' because : " . $UNIVERSAL::require::ERROR;
-           }
+        _load_all_superclasses(@_);
            $meta->superclasses(@_) 
        });     
        
        # handle attributes
        $meta->alias_method('has' => subname 'Moose::has' => sub { 
                my ($name, %options) = @_;
-               if (exists $options{is}) {
-                       if ($options{is} eq 'ro') {
-                               $options{reader} = $name;
-                       }
-                       elsif ($options{is} eq 'rw') {
-                               $options{accessor} = $name;                             
-                       }                       
-               }
-               if (exists $options{isa}) {
-                   # allow for anon-subtypes here ...
-                   if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
-                               $options{type_constraint} = $options{isa};
-                       }
-                       else {
-                           # otherwise assume it is a constraint
-                           my $constraint = find_type_constraint($options{isa});
-                           # if the constraing it not found ....
-                           unless (defined $constraint) {
-                               # assume it is a foreign class, and make 
-                               # an anon constraint for it 
-                               $constraint = subtype Object => where { $_->isa($options{isa}) };
-                           }                       
-                $options{type_constraint} = $constraint;
-                       }
-               }
+        _process_has_options($name, \%options);
                $meta->add_attribute($name, %options) 
        });
 
@@ -119,31 +88,13 @@ sub import {
        $meta->alias_method('super' => subname 'Moose::super' => sub {});
        $meta->alias_method('override' => subname 'Moose::override' => sub {
            my ($name, $method) = @_;
-           my $super = $meta->find_next_method_by_name($name);
-           (defined $super)
-               || confess "You cannot override '$name' because it has no super method";
-           $meta->add_method($name => sub {
-               my @args = @_;
-            no strict   'refs';
-            no warnings 'redefine';
-            local *{$meta->name . '::super'} = sub { $super->(@args) };
-               return $method->(@args);
-           });
+           $meta->add_method($name => _create_override_sub($meta, $name, $method));
        });             
        
        $meta->alias_method('inner' => subname 'Moose::inner' => sub {});
        $meta->alias_method('augment' => subname 'Moose::augment' => sub {
            my ($name, $method) = @_;
-           my $super = $meta->find_next_method_by_name($name);
-           (defined $super)
-               || confess "You cannot augment '$name' because it has no super method";
-           $meta->add_method($name => sub {
-               my @args = @_;
-            no strict   'refs';
-            no warnings 'redefine';
-            local *{$super->package_name . '::inner'} = sub { $method->(@args) };
-               return $super->(@args);
-           });
+           $meta->add_method($name => _create_augment_sub($meta, $name, $method));
        });     
 
        # make sure they inherit from Moose::Object
@@ -156,6 +107,48 @@ sub import {
        $meta->alias_method('blessed' => \&Scalar::Util::blessed);                              
 }
 
+## Utility functions
+
+sub _process_has_options {
+    my ($attr_name, $options) = @_;
+       if (exists $options->{is}) {
+               if ($options->{is} eq 'ro') {
+                       $options->{reader} = $attr_name;
+               }
+               elsif ($options->{is} eq 'rw') {
+                       $options->{accessor} = $attr_name;                              
+               }                       
+       }
+       if (exists $options->{isa}) {
+           # allow for anon-subtypes here ...
+           if (blessed($options->{isa}) && $options->{isa}->isa('Moose::Meta::TypeConstraint')) {
+                       $options->{type_constraint} = $options->{isa};
+               }
+               else {
+                   # otherwise assume it is a constraint
+                   my $constraint = find_type_constraint($options->{isa});
+                   # if the constraing it not found ....
+                   unless (defined $constraint) {
+                       # assume it is a foreign class, and make 
+                       # an anon constraint for it 
+                       $constraint = subtype Object => where { $_->isa($options->{isa}) };
+                   }                       
+            $options->{type_constraint} = $constraint;
+               }
+       }    
+}
+
+sub _load_all_superclasses {
+    foreach my $super (@_) {
+        # see if this is already 
+        # loaded in the symbol table
+        next if _is_class_already_loaded($super);
+        # otherwise require it ...
+        ($super->require)
+            || confess "Could not load superclass '$super' because : " . $UNIVERSAL::require::ERROR;
+    }    
+}
+
 sub _is_class_already_loaded {
        my $name = shift;
        no strict 'refs';
@@ -167,6 +160,34 @@ sub _is_class_already_loaded {
     return 0;
 }
 
+sub _create_override_sub {
+    my ($meta, $name, $method) = @_;
+    my $super = $meta->find_next_method_by_name($name);
+    (defined $super)
+        || confess "You cannot override '$name' because it has no super method";    
+    return sub {
+        my @args = @_;
+        no strict   'refs';
+        no warnings 'redefine';
+        local *{$meta->name . '::super'} = sub { $super->(@args) };
+        return $method->(@args);
+    };
+}
+
+sub _create_augment_sub {
+    my ($meta, $name, $method) = @_;    
+    my $super = $meta->find_next_method_by_name($name);
+    (defined $super)
+        || confess "You cannot augment '$name' because it has no super method";
+    return sub {
+        my @args = @_;
+        no strict   'refs';
+        no warnings 'redefine';
+        local *{$super->package_name . '::inner'} = sub { $method->(@args) };
+        return $super->(@args);
+    };    
+}
+
 1;
 
 __END__

diff --git a/lib/Moose/Cookbook/Recipe2.pod b/lib/Moose/Cookbook/Recipe2.pod
index 04c5613..1272275 100644 (file)
--- a/lib/Moose/Cookbook/Recipe2.pod
+++ b/lib/Moose/Cookbook/Recipe2.pod
@@ -39,7 +39,7 @@ Moose::Cookbook::Recipe2 - A simple Bank Account example
   before 'withdraw' => sub {
       my ($self, $amount) = @_;
       my $overdraft_amount = $amount - $self->balance();
-      if (self->overdraft_account && $overdraft_amount > 0) {
+      if ($self->overdraft_account && $overdraft_amount > 0) {
           $self->overdraft_account->withdraw($overdraft_amount);
           $self->deposit($overdraft_amount);
       }
@@ -107,7 +107,7 @@ modifier.
   before 'withdraw' => sub {
       my ($self, $amount) = @_;
       my $overdraft_amount = $amount - $self->balance();
-      if (self->overdraft_account && $overdraft_amount > 0) {
+      if ($self->overdraft_account && $overdraft_amount > 0) {
           $self->overdraft_account->withdraw($overdraft_amount);
           $self->deposit($overdraft_amount);
       }
@@ -130,7 +130,7 @@ pseudo-package. So the above method is equivalent to the one here.
   sub withdraw {
       my ($self, $amount) = @_;
       my $overdraft_amount = $amount - $self->balance();
-      if ($overdraft_amount > 0 && $self->overdraft_account) {
+      if ($self->overdraft_account && $overdraft_amount > 0) {
           $self->overdraft_account->withdraw($overdraft_amount);
           $self->deposit($overdraft_amount);
       }

diff --git a/t/002_basic.t b/t/002_basic.t
index 73a6756..5f81bfb 100644 (file)
--- a/t/002_basic.t
+++ b/t/002_basic.t
@@ -43,7 +43,7 @@ BEGIN {
        before 'withdraw' => sub {
                my ($self, $amount) = @_;
                my $overdraft_amount = $amount - $self->balance();
-               if (self->overdraft_account && $overdraft_amount > 0) {
+               if ($self->overdraft_account && $overdraft_amount > 0) {
                        $self->overdraft_account->withdraw($overdraft_amount);
                        $self->deposit($overdraft_amount);
                }

diff --git a/t/006_basic.t b/t/006_basic.t
index d02f46c..3cb0515 100644 (file)
--- a/t/006_basic.t
+++ b/t/006_basic.t
@@ -9,3 +9,88 @@ use Test::Exception;
 BEGIN {
     use_ok('Moose');           
 }
+
+=pod
+
+==> AtLeast.pm <==
+package BAST::Web::Model::Constraint::AtLeast;
+
+use strict;
+use warnings;
+use Moose;
+use BAST::Web::Model::Constraint;
+
+extends 'BAST::Web::Model::Constraint';
+
+has 'value' => (isa => 'Num', is => 'ro');
+
+sub validate {
+  my ($self, $field) = @_;
+  if ($self->validation_value($field) >= $self->value) {
+    return undef;
+  } else {
+    return $self->error_message;
+  }
+}
+
+sub error_message { 'must be at least '.shift->value; }
+
+1;
+
+==> NoMoreThan.pm <==
+package BAST::Web::Model::Constraint::NoMoreThan;
+
+use strict;
+use warnings;
+use Moose;
+use BAST::Web::Model::Constraint;
+
+extends 'BAST::Web::Model::Constraint';
+
+has 'value' => (isa => 'Num', is => 'ro');
+
+sub validate {
+  my ($self, $field) = @_;
+  if ($self->validation_value($field) <= $self->value) {
+    return undef;
+  } else {
+    return $self->error_message;
+  }
+}
+
+sub error_message { 'must be no more than '.shift->value; }
+
+1;
+
+==> OnLength.pm <==
+package BAST::Web::Model::Constraint::OnLength;
+
+use strict;
+use warnings;
+use Moose;
+
+has 'units' => (isa => 'Str', is => 'ro');
+
+override 'value' => sub {
+  return length(super());
+};
+
+override 'error_message' => sub {
+  my $self = shift;
+  return super().' '.$self->units;
+};
+
+1;
+
+package BAST::Web::Model::Constraint::LengthNoMoreThan;
+
+use strict;
+use warnings;
+use Moose;
+use BAST::Web::Model::Constraint::NoMoreThan;
+use BAST::Web::Model::Constraint::OnLength;
+
+extends 'BAST::Web::Model::Constraint::NoMoreThan';
+   with 'BAST::Web::Model::Constraint::OnLength';
+
+=cut
\ No newline at end of file