lib/MooseX/AttributeHelpers/Base.pm

   1 package MooseX::AttributeHelpers::Base;
   2 use Moose;
   3 use Moose::Util::TypeConstraints;
   4 use MooseX::AttributeHelpers::MethodProvider;
   5 use MooseX::AttributeHelpers::Meta::Method::Provided;
   6
   7 our $VERSION   = '0.04';
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 extends 'Moose::Meta::Attribute';
  11
  12 # this is the method map you define ...
  13 has 'provides' => (
  14     is      => 'ro',
  15     isa     => 'HashRef',
  16     default => sub {{}}
  17 );
  18
  19 # extend the parents stuff to make sure
  20 # certain bits are now required ...
  21 has '+$!default'       => (required => 1);
  22 has '+type_constraint' => (required => 1);
  23
  24 ## Methods called prior to instantiation
  25
  26 # For overriding
  27 sub default_options {}
  28 sub auto_provide {0}
  29
  30 # Do not override both of these things.  You will be eaten.
  31 sub method_provider {}
  32 sub method_constructors {
  33     get_provider_methods($_[0]->method_provider, ':all')
  34 }
  35
  36 sub process_options_for_provides {
  37     my ($self, $options) = @_;
  38
  39     if (my $defaults = $self->default_options) {
  40         foreach my $key (keys %$defaults) {
  41             $options->{$key} = $defaults->{$key}
  42                 unless exists $options->{$key};
  43         }
  44     }
  45
  46     return unless $self->method_provider;
  47     my $type = get_provider_type($self->method_provider);
  48     $options->{isa} = $type unless exists $options->{isa};
  49     my $isa = $options->{isa};
  50
  51     unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) {
  52         $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint(
  53             $isa
  54         );
  55     }
  56
  57     confess "The type constraint for a $type ($options->{isa}) "
  58             . "must be a subtype of $type"
  59             unless $isa->is_a_type_of($type);
  60 }
  61
  62 before '_process_options' => sub {
  63     my ($self, $name, $options) = @_;
  64     $self->process_options_for_provides($options, $name);
  65 };
  66
  67 ## methods called after instantiation
  68
  69 # this confirms that provides has
  70 # all valid possibilities in it
  71 sub check_provides_values {
  72     my $self = shift;
  73
  74     my $method_constructors = $self->method_constructors;
  75
  76     foreach my $key (keys %{$self->provides}) {
  77         (exists $method_constructors->{$key})
  78             || confess "$key is an unsupported method type";
  79     }
  80
  81     my $provides = $self->provides;
  82     if (keys %$provides == 0 and $self->auto_provide) {
  83         my $attr_name = $self->name;
  84
  85         foreach my $method (keys %$method_constructors) {
  86           $provides->{$method} = "${method}_${attr_name}";
  87         }
  88     }
  89 }
  90
  91 after 'install_accessors' => sub {
  92     my $attr  = shift;
  93     my $class = $attr->associated_class;
  94
  95     # grab the reader and writer methods
  96     # as well, this will be useful for
  97     # our method provider constructors
  98     my $attr_reader = $attr->get_read_method_ref;
  99     my $attr_writer = $attr->get_write_method_ref;
 100
 101
 102     # before we install them, lets
 103     # make sure they are valid
 104     $attr->check_provides_values;
 105
 106     my $method_constructors = $attr->method_constructors;
 107
 108     foreach my $key (keys %{$attr->provides}) {
 109
 110         my $method_name = $attr->provides->{$key};
 111
 112         if ($class->has_method($method_name)) {
 113             confess "The method ($method_name) already exists in class (" . $class->name . ")";
 114         }
 115
 116         my $method = MooseX::AttributeHelpers::Meta::Method::Provided->wrap(
 117             $method_constructors->{$key}->(
 118                 $attr,
 119                 $attr_reader,
 120                 $attr_writer,
 121             )
 122         );
 123
 124         $attr->associate_method($method);
 125         $class->add_method($method_name => $method);
 126     }
 127 };
 128
 129 after 'remove_accessors' => sub {
 130     my $attr  = shift;
 131     my $class = $attr->associated_class;
 132     foreach my $key (keys %{$attr->provides}) {
 133         my $method_name = $attr->provides->{$key};
 134         my $method = $class->get_method($method_name);
 135         $class->remove_method($method_name)
 136             if blessed($method) &&
 137                $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided');
 138     }
 139 };
 140
 141 sub sugar {
 142     my ($class, %info) = @_;
 143     my $meta = $class->meta;
 144
 145     $meta->add_method('default_options', sub {$info{default_options}});
 146     $meta->add_method('auto_provide',    sub {$info{auto_provide} || 0});
 147
 148     my $provider = $info{method_provider};
 149     my $constructors = $info{method_constructors};
 150
 151     confess "Supply either method_provider or method_constructors"
 152         if ($provider && $constructors) || !($provider || $constructors);
 153
 154     if(my $provider = $info{method_provider}) {
 155         $meta->add_method('method_provider' => sub { $provider });
 156     }
 157     elsif (my $cons = $info{method_constructors}) {
 158         $meta->add_method('method_constructors' => sub { $cons });
 159     }
 160
 161     if (my $s = $info{shortcut}) {
 162         $meta->create("Moose::Meta::Attribute::Custom::$s",
 163             methods => {register_implementation => sub { $class }},
 164         );
 165     }
 166 }
 167
 168 no Moose;
 169 no Moose::Util::TypeConstraints;
 170
 171 1;
 172
 173 __END__
 174
 175 =pod
 176
 177 =head1 NAME
 178
 179 MooseX::AttributeHelpers::Base - Base class for attribute helpers
 180
 181 SYNOPSIS
 182
 183     package MooseX::AttributeHelpers::Counter;
 184     use Moose;
 185     use MooseX::AttributeHelpers::MethodProvider::Counter;
 186
 187     extends 'MooseX::AttributeHelpers::Base';
 188
 189     __PACKAGE__->sugar(
 190         default_options  => {
 191             is      => 'ro',
 192             default => 0,
 193         },
 194
 195         auto_provide     => 1,
 196         method_provider  => 'Counter',
 197         shortcut         => 'Counter',
 198     );
 199
 200     no Moose;
 201
 202     1;
 203
 204 =head1 DESCRIPTION
 205
 206 This class is what you inherit from when you want to make a new
 207 AttributeHelper metaclass.  Most of the work is done for you by the class
 208 method I<sugar> if you're doing something basic.
 209
 210 =head1 ATTRIBUTES
 211
 212 =over 4
 213
 214 =item B<provides>
 215
 216 This is the map of metaclass methods to methods that will be installed in your
 217 class, e.g. add => 'add_to_number'.
 218
 219 =back
 220
 221 =head1 EXTENDED ATTRIBUTES
 222
 223 =over 4
 224
 225 =item B<$!default>
 226
 227 C<$!default> is now required.
 228
 229 =item B<type_constraint>
 230
 231 C<type_constraint> is now required.
 232
 233 =back
 234
 235 =head1 METHODS
 236
 237 =over 4
 238
 239 =item B<method_provider>
 240
 241 The name of a method provider.  Usually one L<use|perlfunc/use>s a package
 242 that defines a method provider in the registry first, but you can just as well
 243 define one in your own code.  See L<MooseX::AttributeHelpers::MethodProvider>
 244 for details.
 245
 246 =item B<method_constructors>
 247
 248 You can optionally supply a hashref of names to subs instead of a class to be
 249 used as method constructors.  In that case, your methods won't be available
 250 for use by L<Composite|MooseX::AttributeHelpers::Composite>.
 251
 252 =item B<auto_provide>
 253
 254 If this method returns a true value, all available method constructors will be
 255 provided in the format $method_$attribute_name e.g. inc_counter.  This is
 256 intended to be overridden in subclasses.
 257
 258 =item B<default_options>
 259
 260 Returns a Maybe[Hashref] of attribution specifications to fill in if they are
 261 not overridden by the implementing attribute.  This is intended to be
 262 overridden in subclasses.
 263
 264 =item B<sugar>
 265
 266 A convenience method for subclassing declaratively.  See L<"SYNOPSIS"> for an
 267 example.  The shortcut option creates a package under
 268 Moose::Meta::Attribute::Custom to make it easier for users to find your
 269 metaclass, but you can do this manually if you desire.
 270
 271 =item B<check_provides_values>
 272
 273 =item B<install_accessors>
 274
 275 =item B<remove_accessors>
 276
 277 =item B<process_options_for_provides>
 278
 279 These are hooks you can use to change the behavior of the metaclass; read the
 280 source for inspiration.
 281
 282 =back
 283
 284 =head1 BUGS
 285
 286 All complex software has bugs lurking in it, and this module is no
 287 exception. If you find a bug please either email me, or add the bug
 288 to cpan-RT.
 289
 290 =head1 AUTHOR
 291
 292 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 293
 294 =head1 COPYRIGHT AND LICENSE
 295
 296 Copyright 2007-2008 by Infinity Interactive, Inc.
 297
 298 L<http://www.iinteractive.com>
 299
 300 This library is free software; you can redistribute it and/or modify
 301 it under the same terms as Perl itself.
 302
 303 =cut