lib/MooseX/Object/Pluggable.pm

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