lib/MooseX/AttributeHelpers/Base.pm

   1
   2 package MooseX::AttributeHelpers::Base;
   3 use Moose;
   4
   5 our $VERSION   = '0.01';
   6 our $AUTHORITY = 'cpan:STEVAN';
   7
   8 extends 'Moose::Meta::Attribute';
   9
  10 has 'method_constructors' => (
  11     is      => 'ro',
  12     isa     => 'HashRef',
  13     default => sub { {} }
  14 );
  15
  16 has 'provides' => (
  17     is       => 'ro',
  18     isa      => 'HashRef',
  19     required => 1,
  20 );
  21
  22 # extend the parents stuff to make sure
  23 # certain bits are now required ...
  24 has '+$!default'       => (required => 1);
  25 has '+type_constraint' => (required => 1);
  26
  27 # this confirms that provides has
  28 # all valid possibilities in it
  29 sub _check_provides {
  30     my $self = shift;
  31     my $method_constructors = $self->method_constructors;
  32     foreach my $key (keys %{$self->provides}) {
  33         (exists $method_constructors->{$key})
  34             || confess "$key is an unsupported method type";
  35     }
  36 }
  37
  38 # this provides an opportunity to
  39 # manipulate the %options to handle
  40 # some of the provides features
  41 # correctly.
  42 sub _process_options_for_provides {
  43     my ($self, $options) = @_;
  44     # ...
  45 }
  46
  47 before '_process_options' => sub {
  48     my ($self, $name, $options) = @_;
  49     if (exists $options->{provides}) {
  50         $self->_process_options_for_provides($options);
  51     }
  52 };
  53
  54 after 'install_accessors' => sub {
  55     my $attr  = shift;
  56     my $class = $attr->associated_class;
  57
  58     # before we install them, lets
  59     # make sure they are valid
  60     $attr->_check_provides;
  61
  62     my $method_constructors = $attr->method_constructors;
  63
  64     foreach my $key (keys %{$attr->provides}) {
  65         $class->add_method(
  66             $attr->provides->{$key},
  67             $method_constructors->{$key}->($attr)
  68         );
  69     }
  70 };
  71
  72 no Moose;
  73
  74 1;
  75
  76 __END__
  77
  78 =pod
  79
  80 =head1 NAME
  81
  82 MooseX::AttributeHelpers::Base
  83
  84 =head1 SYNOPSIS
  85
  86 =head1 DESCRIPTION
  87
  88 =head1 METHODS
  89
  90 =head1 BUGS
  91
  92 All complex software has bugs lurking in it, and this module is no
  93 exception. If you find a bug please either email me, or add the bug
  94 to cpan-RT.
  95
  96 =head1 AUTHOR
  97
  98 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  99
 100 =head1 COPYRIGHT AND LICENSE
 101
 102 Copyright 2007 by Infinity Interactive, Inc.
 103
 104 L<http://www.iinteractive.com>
 105
 106 This library is free software; you can redistribute it and/or modify
 107 it under the same terms as Perl itself.
 108
 109 =cut