lib/MooseX/Object/Pluggable.pm

   1 package MooseX::Object::Pluggable;
   2
   3 use Carp;
   4 use Moose::Role;
   5 use Class::MOP;
   6 use Module::Pluggable::Object;
   7
   8 our $VERSION = '0.0009';
   9
  10 =head1 NAME
  11
  12     MooseX::Object::Pluggable - Make your classes pluggable
  13
  14 =head1 SYNOPSIS
  15
  16     package MyApp;
  17     use Moose;
  18
  19     with 'MooseX::Object::Pluggable';
  20
  21     ...
  22
  23     package MyApp::Plugin::Pretty;
  24     use Moose::Role;
  25
  26     sub pretty{ print "I am pretty" }
  27
  28     1;
  29
  30     #
  31     use MyApp;
  32     my $app = MyApp->new;
  33     $app->load_plugin('Pretty');
  34     $app->pretty;
  35
  36 =head1 DESCRIPTION
  37
  38 This module is meant to be loaded as a role from Moose-based classes
  39 it will add five methods and four attributes to assist you with the loading
  40 and handling of plugins and extensions for plugins. I understand that this may
  41 pollute your namespace, however I took great care in using the least ambiguous
  42 names possible.
  43
  44 =head1 How plugins Work
  45
  46 Plugins and extensions are just Roles by a fancy name. They are loaded at runtime
  47 on demand and are instance, not class based. This means that if you have more than
  48 one instance of a class they can all have different plugins loaded. This is a feature.
  49
  50 Plugin methods are allowed to C<around>, C<before>, C<after>
  51 their consuming classes, so it is important to watch for load order as plugins can
  52 and will overload each other. You may also add attributes through has.
  53
  54 Please note that when you load at runtime you lose the ability to wrap C<BUILD>
  55 and roles using C<has> will not go through compile time checks like C<required>
  56 and <default>.
  57
  58 Even though C<override> will work , I STRONGLY discourage it's use
  59 and a warning will be thrown if you try to use it.
  60 This is closely linked to the way multiple roles being applied is handled and is not
  61 likely to change. C<override> bevavior is closely linked to inheritance and thus will
  62 likely not work as you expect it in multiple inheritance situations. Point being,
  63 save yourself the headache.
  64
  65 =head1 How plugins are loaded
  66
  67 When roles are applied at runtime an anonymous class will wrap your class and
  68 C<$self-E<gt>blessed> and C<ref $self> will no longer return the name of your object,
  69 they will instead return the name of the anonymous class created at runtime.
  70 See C<_original_class_name>.
  71
  72 =head1 Usage
  73
  74 For a simple example see the tests included in this distribution.
  75
  76 =head1 Attributes
  77
  78 =head2 _plugin_ns
  79
  80 String. The prefix to use for plugin names provided. MyApp::Plugin is sensible.
  81
  82 =head2 _plugin_app_ns
  83
  84 ArrayRef, Accessor automatically dereferences into array on a read call.
  85 By default will be filled with the class name and it's prescedents, it is used
  86 to determine which directories to look for plugins as well as which plugins
  87 take presedence upon namespace collitions. This allows you to subclass a pluggable
  88 class and still use it's plugins while using yours first if they are available.
  89
  90 =cut
  91
  92 =head2 _plugin_locator
  93
  94 An automatically built instance of L<Module::Pluggable::Object> used to locate
  95 available plugins.
  96
  97 =cut
  98
  99 #--------#---------#---------#---------#---------#---------#---------#---------#
 100
 101 has _plugin_ns =>
 102   (
 103    is => 'rw',
 104    required => 1,
 105    isa => 'Str',
 106    default => sub{ 'Plugin' },
 107   );
 108
 109 has _plugin_loaded =>
 110   (
 111    is => 'rw',
 112    required => 1,
 113    isa => 'HashRef',
 114    default => sub{ {} }
 115   );
 116
 117 has _plugin_app_ns =>
 118   (
 119    is => 'rw',
 120    required => 1,
 121    isa => 'ArrayRef',
 122    lazy => 1,
 123    auto_deref => 1,
 124    builder => '_build_plugin_app_ns',
 125    trigger => sub{ $_[0]->_clear_plugin_locator if $_[0]->_has_plugin_locator; },
 126   );
 127
 128 has _plugin_locator =>
 129   (
 130    is => 'rw',
 131    required => 1,
 132    lazy => 1,
 133    isa => 'Module::Pluggable::Object',
 134    clearer => '_clear_plugin_locator',
 135    predicate => '_has_plugin_locator',
 136    builder => '_build_plugin_locator'
 137   );
 138
 139 #--------#---------#---------#---------#---------#---------#---------#---------#
 140
 141 =head1 Public Methods
 142
 143 =head2 load_plugins @plugins
 144
 145 =head2 load_plugin $plugin
 146
 147 Load the apropriate role for C<$plugin>.
 148
 149 =cut
 150
 151 sub load_plugins {
 152     my ($self, @plugins) = @_;
 153     die("You must provide a plugin name") unless @plugins;
 154
 155     my $loaded = $self->_plugin_loaded;
 156     my @load = grep { not exists $loaded->{$_} } @plugins;
 157     my @roles = map { $self->_role_from_plugin($_) } @load;
 158
 159     if ( $self->_load_and_apply_role(@roles) ) {
 160         @{ $loaded }{@load} = @roles;
 161         return 1;
 162     } else {
 163         return;
 164     }
 165 }
 166
 167
 168 sub load_plugin {
 169   my $self = shift;
 170   $self->load_plugins(@_);
 171 }
 172
 173 =head2 _original_class_name
 174
 175 Because of the way roles apply C<$self-E<gt>blessed> and C<ref $self> will
 176 no longer return what you expect. Instead use this class to get your original
 177 class name.
 178
 179 =cut
 180
 181 sub _original_class_name{
 182     my $self = shift;
 183     return (grep {$_ !~ /^Moose::/} $self->meta->class_precedence_list)[0];
 184 }
 185
 186
 187 =head1 Private Methods
 188
 189 There's nothing stopping you from using these, but if you are using them
 190 for anything thats not really complicated you are probably doing
 191 something wrong.
 192
 193 =head2 _role_from_plugin $plugin
 194
 195 Creates a role name from a plugin name. If the plugin name is prepended
 196 with a C<+> it will be treated as a full name returned as is. Otherwise
 197 a string consisting of C<$plugin>  prepended with the C<_plugin_ns>
 198 and the first valid value from C<_plugin_app_ns> will be returned. Example
 199
 200    #assuming appname MyApp and C<_plugin_ns> 'Plugin'
 201    $self->_role_from_plugin("MyPlugin"); # MyApp::Plugin::MyPlugin
 202
 203 =cut
 204
 205 sub _role_from_plugin{
 206     my ($self, $plugin) = @_;
 207
 208     return $1 if( $plugin =~ /^\+(.*)/ );
 209
 210     my $o = join '::', $self->_plugin_ns, $plugin;
 211     #Father, please forgive me for I have sinned.
 212     my @roles = grep{ /${o}$/ } $self->_plugin_locator->plugins;
 213
 214     croak("Unable to locate plugin '$plugin'") unless @roles;
 215     return $roles[0] if @roles == 1;
 216
 217     my $i = 0;
 218     my %presedence_list = map{ $i++; "${_}::${o}", $i } $self->_plugin_app_ns;
 219
 220     @roles = sort{ $presedence_list{$a} <=> $presedence_list{$b}} @roles;
 221
 222     return shift @roles;
 223 }
 224
 225 =head2 _load_and_apply_role @roles
 226
 227 Require C<$role> if it is not already loaded and apply it. This is
 228 the meat of this module.
 229
 230 =cut
 231
 232 sub _load_and_apply_role{
 233     my ($self, @roles) = @_;
 234     die("You must provide a role name") unless @roles;
 235
 236     foreach my $role ( @roles ) {
 237         eval { Class::MOP::load_class($role) };
 238         confess("Failed to load role: ${role} $@") if $@;
 239
 240         carp("Using 'override' is strongly discouraged and may not behave ".
 241             "as you expect it to. Please use 'around'")
 242         if scalar keys %{ $role->meta->get_override_method_modifiers_map };
 243     }
 244
 245     Moose::Util::apply_all_roles( $self, @roles );
 246
 247     return 1;
 248 }
 249
 250 =head2 _build_plugin_app_ns
 251
 252 Automatically builds the _plugin_app_ns attribute with the classes in the
 253 class presedence list that are not part of Moose.
 254
 255 =cut
 256
 257 sub _build_plugin_app_ns{
 258     my $self = shift;
 259     my @names = (grep {$_ !~ /^Moose::/} $self->meta->class_precedence_list);
 260     return \@names;
 261 }
 262
 263 =head2 _build_plugin_locator
 264
 265 Automatically creates a L<Module::Pluggable::Object> instance with the correct
 266 search_path.
 267
 268 =cut
 269
 270 sub _build_plugin_locator{
 271     my $self = shift;
 272
 273     my $locator = Module::Pluggable::Object->new
 274         ( search_path =>
 275           [ map { join '::', ($_, $self->_plugin_ns) } $self->_plugin_app_ns ]
 276         );
 277     return $locator;
 278 }
 279
 280 =head2 meta
 281
 282 Keep tests happy. See L<Moose>
 283
 284 =cut
 285
 286 1;
 287
 288 __END__;
 289
 290 =head1 SEE ALSO
 291
 292 L<Moose>, L<Moose::Role>, L<Class::Inspector>
 293
 294 =head1 AUTHOR
 295
 296 Guillermo Roditi, <groditi@cpan.org>
 297
 298 =head1 BUGS
 299
 300 Holler?
 301
 302 Please report any bugs or feature requests to
 303 C<bug-moosex-object-pluggable at rt.cpan.org>, or through the web interface at
 304 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MooseX-Object-Pluggable>.
 305 I will be notified, and then you'll automatically be notified of progress on
 306 your bug as I make changes.
 307
 308 =head1 SUPPORT
 309
 310 You can find documentation for this module with the perldoc command.
 311
 312     perldoc MooseX-Object-Pluggable
 313
 314 You can also look for information at:
 315
 316 =over 4
 317
 318 =item * AnnoCPAN: Annotated CPAN documentation
 319
 320 L<http://annocpan.org/dist/MooseX-Object-Pluggable>
 321
 322 =item * CPAN Ratings
 323
 324 L<http://cpanratings.perl.org/d/MooseX-Object-Pluggable>
 325
 326 =item * RT: CPAN's request tracker
 327
 328 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MooseX-Object-Pluggable>
 329
 330 =item * Search CPAN
 331
 332 L<http://search.cpan.org/dist/MooseX-Object-Pluggable>
 333
 334 =back
 335
 336 =head1 ACKNOWLEDGEMENTS
 337
 338 =over 4
 339
 340 =item #Moose - Huge number of questions
 341
 342 =item Matt S Trout <mst@shadowcatsystems.co.uk> - ideas / planning.
 343
 344 =item Stevan Little - EVERYTHING. Without him this would have never happened.
 345
 346 =back
 347
 348 =head1 COPYRIGHT
 349
 350 Copyright 2007 Guillermo Roditi.  All Rights Reserved.  This is
 351 free software; you may redistribute it and/or modify it under the same
 352 terms as Perl itself.
 353
 354 =cut