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.0007';
   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 Notice regarding extensions.
  73
  74 Because I have been able to identify a real-world use case for the extension mechanism
  75 I have decided to deprecate it and remove it in the next major release.
  76
  77 =head1 Usage
  78
  79 For a simple example see the tests included in this distribution.
  80
  81 =head1 Attributes
  82
  83 =head2 _plugin_ns
  84
  85 String. The prefix to use for plugin names provided. MyApp::Plugin is sensible.
  86
  87 =head2 _plugin_ext
  88
  89 Boolean. Indicates whether we should attempt to load plugin extensions.
  90 Defaults to true;
  91
  92 =head2 _plugin_ext_ns
  93
  94 B<THIS FUNCTIONALITY HAS BEEN DEPRECATED AND WILL GO AWAY.> If you use
  95 this, please email me, but I am fairly sure that nobody uses this at
  96 all and it's just adding bloat and making things kind of ugly.
  97
  98 String. The namespace plugin extensions have. Defaults to 'ExtensionFor'.
  99
 100 This means that is _plugin_ns is "MyApp::Plugin" and _plugin_ext_ns is
 101 "ExtensionFor" loading plugin "Bar" would search for extensions in
 102 "MyApp::Plugin::Bar::ExtensionFor::*".
 103
 104 =head2 _plugin_app_ns
 105
 106 ArrayRef, Accessor automatically dereferences into array on a read call.
 107 By default will be filled with the class name and it's prescedents, it is used
 108 to determine which directories to look for plugins as well as which plugins
 109 take presedence upon namespace collitions. This allows you to subclass a pluggable
 110 class and still use it's plugins while using yours first if they are available.
 111
 112 =cut
 113
 114 =head2 _plugin_locator
 115
 116 An automatically built instance of L<Module::Pluggable::Object> used to locate
 117 available plugins.
 118
 119 =cut
 120
 121 #--------#---------#---------#---------#---------#---------#---------#---------#
 122
 123 has _plugin_ns      => (is => 'rw', required => 1, isa => 'Str',
 124                         default => 'Plugin');
 125 has _plugin_ext     => (is => 'rw', required => 1, isa => 'Bool',
 126                         default => 1);
 127 has _plugin_ext_ns  => (is => 'rw', required => 1, isa => 'Str',
 128                         default => 'ExtensionFor');
 129 has _plugin_loaded  => (is => 'rw', required => 1, isa => 'HashRef',
 130                         default => sub{ {} });
 131 has _plugin_app_ns  => (is => 'rw', required => 1, isa => 'ArrayRef', lazy => 1,
 132                         auto_deref => 1,
 133                         default => sub{ shift->_build_plugin_app_ns },
 134                         trigger => sub{ $_[0]->_clear_plugin_locator
 135                                          if $_[0]->_has_plugin_locator; },
 136                        );
 137 has _plugin_locator => (is => 'rw', required => 1, lazy => 1,
 138                         isa       => 'Module::Pluggable::Object',
 139                         clearer   => '_clear_plugin_locator',
 140                         predicate => '_has_plugin_locator',
 141                         default   => sub{ shift->_build_plugin_locator });
 142
 143 #--------#---------#---------#---------#---------#---------#---------#---------#
 144
 145 =head1 Public Methods
 146
 147 =head2 load_plugins @plugins
 148
 149 =head2 load_plugin $plugin
 150
 151 Load the apropriate role for C<$plugin> as well as any extensions it provides
 152 if extensions are enabled.
 153
 154 =cut
 155
 156 sub load_plugins {
 157     my ($self, @plugins) = @_;
 158     die("You must provide a plugin name") unless @plugins;
 159
 160     my $loaded = $self->_plugin_loaded;
 161
 162     my @load = grep { not exists $loaded->{$_} } @plugins;
 163
 164     my @roles = map { $self->_role_from_plugin($_) } @load;
 165
 166     if ( $self->_load_and_apply_role(@roles) ) {
 167         @{ $loaded }{@load} = @roles;
 168
 169         if ( $self->_plugin_ext ) {
 170             $self->load_plugin_ext($_) for @load;
 171         }
 172
 173         return 1;
 174     } else {
 175         return;
 176     }
 177 }
 178
 179
 180 sub load_plugin {
 181   my $self = shift;
 182   $self->load_plugins(@_);
 183 }
 184
 185
 186 =head2 load_plugin_ext
 187
 188 B<THIS FUNCTIONALITY HAS BEEN DEPRECATED AND WILL GO AWAY.> If you use
 189 this, please email me, but I am fairly sure that nobody uses this at
 190 all and it's just adding bloat and making things kind of ugly.
 191
 192 Will load any extensions for a particular plugin. This should be called
 193 automatically by C<load_plugin> so you don't need to worry about it.
 194 It basically attempts to load any extension that exists for a plugin
 195 that is already loaded. The only reason for using this is if you want to
 196 keep _plugin_ext as false and only load extensions manually, which I don't
 197 recommend.
 198
 199 =cut
 200
 201 sub load_plugin_ext{
 202     my ($self, $plugin) = @_;
 203     die("You must provide a plugin name") unless $plugin;
 204     my $role = $self->_plugin_loaded->{$plugin};
 205
 206     # $p for plugin, $r for role
 207     while( my($p,$r) = each %{ $self->_plugin_loaded }){
 208
 209         my $ext = join "::", $role, $self->_plugin_ext_ns, $p;
 210         if( $plugin =~ /^\+(.*)/ ){
 211             eval{ $self->_load_and_apply_role( $ext ) };
 212         } else{
 213             $self->_load_and_apply_role( $ext ) if
 214                 grep{ /^${ext}$/ } $self->_plugin_locator->plugins;
 215         }
 216
 217         #go back to prev loaded modules and load extensions for current module?
 218         #my $ext2 = join "::", $r, $self->_plugin_ext_ns, $plugin;
 219         #$self->_load_and_apply_role( $ext2 )
 220         #    if Class::Inspector->installed($ext2);
 221     }
 222 }
 223
 224 =head2 _original_class_name
 225
 226 Because of the way roles apply C<$self-E<gt>blessed> and C<ref $self> will
 227 no longer return what you expect. Instead use this class to get your original
 228 class name.
 229
 230 =cut
 231
 232 sub _original_class_name{
 233     my $self = shift;
 234     return (grep {$_ !~ /^Moose::/} $self->meta->class_precedence_list)[0];
 235 }
 236
 237
 238 =head1 Private Methods
 239
 240 There's nothing stopping you from using these, but if you are using them
 241 for anything thats not really complicated you are probably doing
 242 something wrong. Some of these may be inlined in the future if performance
 243 becomes an issue (which I doubt).
 244
 245 =head2 _role_from_plugin $plugin
 246
 247 Creates a role name from a plugin name. If the plugin name is prepended
 248 with a C<+> it will be treated as a full name returned as is. Otherwise
 249 a string consisting of C<$plugin>  prepended with the C<_plugin_ns>
 250 and the first valid value from C<_plugin_app_ns> will be returned. Example
 251
 252    #assuming appname MyApp and C<_plugin_ns> 'Plugin'
 253    $self->_role_from_plugin("MyPlugin"); # MyApp::Plugin::MyPlugin
 254
 255 =cut
 256
 257 sub _role_from_plugin{
 258     my ($self, $plugin) = @_;
 259
 260     return $1 if( $plugin =~ /^\+(.*)/ );
 261
 262     my $o = join '::', $self->_plugin_ns, $plugin;
 263     #Father, please forgive me for I have sinned.
 264     my @roles = grep{ /${o}$/ } $self->_plugin_locator->plugins;
 265
 266     croak("Unable to locate plugin '$plugin'") unless @roles;
 267     return $roles[0] if @roles == 1;
 268
 269     my $i = 0;
 270     my %presedence_list = map{ $i++; "${_}::${o}", $i } $self->_plugin_app_ns;
 271
 272     @roles = sort{ $presedence_list{$a} <=> $presedence_list{$b}} @roles;
 273
 274     return shift @roles;
 275 }
 276
 277 =head2 _load_and_apply_role @roles
 278
 279 Require C<$role> if it is not already loaded and apply it. This is
 280 the meat of this module.
 281
 282 =cut
 283
 284 sub _load_and_apply_role{
 285     my ($self, @roles) = @_;
 286     die("You must provide a role name") unless @roles;
 287
 288     foreach my $role ( @roles ) {
 289         eval { Class::MOP::load_class($role) };
 290         confess("Failed to load role: ${role} $@") if $@;
 291
 292         carp("Using 'override' is strongly discouraged and may not behave ".
 293             "as you expect it to. Please use 'around'")
 294         if scalar keys %{ $role->meta->get_override_method_modifiers_map };
 295     }
 296
 297     Moose::Util::apply_all_roles( $self, @roles );
 298
 299     return 1;
 300 }
 301
 302 =head2 _build_plugin_app_ns
 303
 304 Automatically builds the _plugin_app_ns attribute with the classes in the
 305 class presedence list that are not part of Moose.
 306
 307 =cut
 308
 309 sub _build_plugin_app_ns{
 310     my $self = shift;
 311     my @names = (grep {$_ !~ /^Moose::/} $self->meta->class_precedence_list);
 312     return \@names;
 313 }
 314
 315 =head2 _build_plugin_locator
 316
 317 Automatically creates a L<Module::Pluggable::Object> instance with the correct
 318 search_path.
 319
 320 =cut
 321
 322 sub _build_plugin_locator{
 323     my $self = shift;
 324
 325     my $locator = Module::Pluggable::Object->new
 326         ( search_path =>
 327           [ map { join '::', ($_, $self->_plugin_ns) } $self->_plugin_app_ns ]
 328         );
 329     return $locator;
 330 }
 331
 332 =head2 meta
 333
 334 Keep tests happy. See L<Moose>
 335
 336 =cut
 337
 338 1;
 339
 340 __END__;
 341
 342 =head1 SEE ALSO
 343
 344 L<Moose>, L<Moose::Role>, L<Class::Inspector>
 345
 346 =head1 AUTHOR
 347
 348 Guillermo Roditi, <groditi@cpan.org>
 349
 350 =head1 BUGS
 351
 352 Holler?
 353
 354 Please report any bugs or feature requests to
 355 C<bug-moosex-object-pluggable at rt.cpan.org>, or through the web interface at
 356 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MooseX-Object-Pluggable>.
 357 I will be notified, and then you'll automatically be notified of progress on
 358 your bug as I make changes.
 359
 360 =head1 SUPPORT
 361
 362 You can find documentation for this module with the perldoc command.
 363
 364     perldoc MooseX-Object-Pluggable
 365
 366 You can also look for information at:
 367
 368 =over 4
 369
 370 =item * AnnoCPAN: Annotated CPAN documentation
 371
 372 L<http://annocpan.org/dist/MooseX-Object-Pluggable>
 373
 374 =item * CPAN Ratings
 375
 376 L<http://cpanratings.perl.org/d/MooseX-Object-Pluggable>
 377
 378 =item * RT: CPAN's request tracker
 379
 380 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MooseX-Object-Pluggable>
 381
 382 =item * Search CPAN
 383
 384 L<http://search.cpan.org/dist/MooseX-Object-Pluggable>
 385
 386 =back
 387
 388 =head1 ACKNOWLEDGEMENTS
 389
 390 =over 4
 391
 392 =item #Moose - Huge number of questions
 393
 394 =item Matt S Trout <mst@shadowcatsystems.co.uk> - ideas / planning.
 395
 396 =item Stevan Little - EVERYTHING. Without him this would have never happened.
 397
 398 =back
 399
 400 =head1 COPYRIGHT
 401
 402 Copyright 2007 Guillermo Roditi.  All Rights Reserved.  This is
 403 free software; you may redistribute it and/or modify it under the same
 404 terms as Perl itself.
 405
 406 =cut