adding in some basic policies and some tests

[gitmo/Moose-Policy.git] / lib / Moose / Policy.pm

diff --git a/lib/Moose/Policy.pm b/lib/Moose/Policy.pm
index ffe4b69..b609acc 100644 (file)
--- a/lib/Moose/Policy.pm
+++ b/lib/Moose/Policy.pm
@@ -1,4 +1,3 @@
-
 package Moose::Policy;
 
 use strict;
@@ -12,37 +11,144 @@ use Scalar::Util 'blessed';
 
 sub import {
     shift;
-    
+
     my $policy = shift || return;
-    
+
     unless (Moose::_is_class_already_loaded($policy)) {
-        ($policy->require)
-            || confess "Could not load policy module '$policy' because : " . $UNIVERSAL::require::ERROR;
+        ($policy->require) or confess "Could not load policy module " .
+            "'$policy' because : $UNIVERSAL::require::ERROR";
     }
-        
+
+    my $package = caller();
+    $package->can('meta') and
+        croak("'$package' already has a meta() method");
+
     my $metaclass = 'Moose::Meta::Class';
-    $metaclass = $policy->metaclass if $policy->can('metaclass');
-    
+    $metaclass = $policy->metaclass($package)
+        if $policy->can('metaclass');
+
     my %options;
-    
-    $options{':attribute_metaclass'} = $policy->attribute_metaclass 
-        if $policy->can('attribute_metaclass');
-    
-    my $package = caller();
-    
+
+    # build options out of policy's constants
+    $policy->can($_) and $options{":$_"} = $policy->$_($package)
+        for (qw(
+            attribute_metaclass
+            instance_metaclass
+            method_metaclass
+            ));
+
     # create a meta object so we can install &meta
     my $meta = $metaclass->initialize($package => %options);
     $meta->add_method('meta' => sub {
-        # we must re-initialize so that it 
-        # works as expected in subclasses, 
-        # since metaclass instances are 
-        # singletons, this is not really a 
-        # big deal anyway.
+        # we must re-initialize so that it works as expected in
+        # subclasses, since metaclass instances are singletons, this is
+        # not really a big deal anyway.
         $metaclass->initialize((blessed($_[0]) || $_[0]) => %options)
-    });    
+    });
 }
 
 1;
 
 __END__
 
+=pod
+
+=head1 NAME
+
+Moose::Policy - moose-mounted police
+
+=head1 SYNOPSIS
+
+  package Foo;
+
+  use Moose::Policy 'My::MooseBestPractice';
+  use Moose;
+
+  has 'bar' => (is => 'rw', default => 'Foo::bar');
+  has 'baz' => (is => 'ro', default => 'Foo::baz');
+
+=head1 DESCRIPTION
+
+This class allows you to specify your project-wide or company-wide Moose
+meta policy in one location.
+
+=head1 CAVEAT
+
+=over 4
+
+=item YOU MUST
+
+  use Moose::Policy 'My::Policy';
+
+=item BEFORE
+
+  use Moose;
+
+=back
+
+=head2 The Policy
+
+The argument to C<import()> is a package name.  This package is
+require()'d and queried for the following constants:
+
+=over
+
+=item metaclass 
+
+Defaults to C<'Moose::Meta::Class'>.
+
+=item attribute_metaclass
+
+=item instance_metaclass
+
+=item method_metaclass
+
+=back
+
+These values are then used to setup your $package->meta object.
+
+Your policy package could be simply a list of constants.
+
+  package My::Policy;
+  use constant attribute_metaclass => 'My::Moose::Meta::Attribute';
+
+But the methods are told what package is using the policy, so they could
+concievably give different answers.
+
+  package My::FancyPolicy;
+
+  sub attribute_metaclass {
+    my $self = shift;
+    my ($user_package) = @_;
+    return('Our::Attributes::Stricter')
+      if $user_package =~ m/^Private::Banking::Money/;
+    return('Our::Attributes');
+  }
+
+=head1 SEE ALSO
+
+L<Moose>, L<Moose::Meta::Class>
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no 
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Eric Wilhelm E<lt>...E<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+