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.0006';
   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 comile 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 applies is handles 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_plugin $plugin
 148
 149 Load the apropriate role for C<$plugin> as well as any extensions it provides
 150 if extensions are enabled.
 151
 152 =cut
 153
 154 sub load_plugin{
 155     my ($self, $plugin) = @_;
 156     die("You must provide a plugin name") unless $plugin;
 157
 158     my $loaded = $self->_plugin_loaded;
 159     return 1 if exists $loaded->{$plugin};
 160
 161     my $role = $self->_role_from_plugin($plugin);
 162
 163     $loaded->{$plugin} = $role      if $self->_load_and_apply_role($role);
 164     $self->load_plugin_ext($plugin) if $self->_plugin_ext;
 165
 166     return exists $loaded->{$plugin};
 167 }
 168
 169 =head2 load_plugins @plugins
 170
 171 Load all C<@plugins>.
 172
 173 =cut
 174
 175
 176 sub load_plugins {
 177   my $self = shift;
 178   $self->load_plugin($_) for @_;
 179 }
 180
 181
 182 =head2 load_plugin_ext
 183
 184 B<THIS FUNCTIONALITY HAS BEEN DEPRECATED AND WILL GO AWAY.> If you use
 185 this, please email me, but I am fairly sure that nobody uses this at
 186 all and it's just adding bloat and making things kind of ugly.
 187
 188 Will load any extensions for a particular plugin. This should be called
 189 automatically by C<load_plugin> so you don't need to worry about it.
 190 It basically attempts to load any extension that exists for a plugin
 191 that is already loaded. The only reason for using this is if you want to
 192 keep _plugin_ext as false and only load extensions manually, which I don't
 193 recommend.
 194
 195 =cut
 196
 197 sub load_plugin_ext{
 198     my ($self, $plugin) = @_;
 199     die("You must provide a plugin name") unless $plugin;
 200     my $role = $self->_plugin_loaded->{$plugin};
 201
 202     # $p for plugin, $r for role
 203     while( my($p,$r) = each %{ $self->_plugin_loaded }){
 204
 205         my $ext = join "::", $role, $self->_plugin_ext_ns, $p;
 206         if( $plugin =~ /^\+(.*)/ ){
 207             eval{ $self->_load_and_apply_role( $ext ) };
 208         } else{
 209             $self->_load_and_apply_role( $ext ) if
 210                 grep{ /^${ext}$/ } $self->_plugin_locator->plugins;
 211         }
 212
 213         #go back to prev loaded modules and load extensions for current module?
 214         #my $ext2 = join "::", $r, $self->_plugin_ext_ns, $plugin;
 215         #$self->_load_and_apply_role( $ext2 )
 216         #    if Class::Inspector->installed($ext2);
 217     }
 218 }
 219
 220 =head2 _original_class_name
 221
 222 Because of the way roles apply C<$self-E<gt>blessed> and C<ref $self> will
 223 no longer return what you expect. Instead use this class to get your original
 224 class name.
 225
 226 =cut
 227
 228 sub _original_class_name{
 229     my $self = shift;
 230     return (grep {$_ !~ /^Moose::/} $self->meta->class_precedence_list)[0];
 231 }
 232
 233
 234 =head1 Private Methods
 235
 236 There's nothing stopping you from using these, but if you are using them
 237 for anything thats not really complicated you are probably doing
 238 something wrong. Some of these may be inlined in the future if performance
 239 becomes an issue (which I doubt).
 240
 241 =head2 _role_from_plugin $plugin
 242
 243 Creates a role name from a plugin name. If the plugin name is prepended
 244 with a C<+> it will be treated as a full name returned as is. Otherwise
 245 a string consisting of C<$plugin>  prepended with the C<_plugin_ns>
 246 and the first valid value from C<_plugin_app_ns> will be returned. Example
 247
 248    #assuming appname MyApp and C<_plugin_ns> 'Plugin'
 249    $self->_role_from_plugin("MyPlugin"); # MyApp::Plugin::MyPlugin
 250
 251 =cut
 252
 253 sub _role_from_plugin{
 254     my ($self, $plugin) = @_;
 255
 256     return $1 if( $plugin =~ /^\+(.*)/ );
 257
 258     my $o = join '::', $self->_plugin_ns, $plugin;
 259     #Father, please forgive me for I have sinned.
 260     my @roles = grep{ /${o}$/ } $self->_plugin_locator->plugins;
 261
 262     die("Unable to locate plugin") unless @roles;
 263     return $roles[0] if @roles == 1;
 264
 265     my $i = 0;
 266     my %presedence_list = map{ $i++; "${_}::${o}", $i } $self->_plugin_app_ns;
 267
 268     @roles = sort{ $presedence_list{$a} <=> $presedence_list{$b}} @roles;
 269
 270     return shift @roles;
 271 }
 272
 273 =head2 _load_and_apply_role $role
 274
 275 Require C<$role> if it is not already loaded and apply it. This is
 276 the meat of this module.
 277
 278 =cut
 279
 280 sub _load_and_apply_role{
 281     my ($self, $role) = @_;
 282     die("You must provide a role name") unless $role;
 283
 284     #don't re-require...
 285     unless( Class::MOP::is_class_loaded($role) ){
 286         eval Class::MOP::load_class($role) || die("Failed to load role: $role");
 287     }
 288
 289     carp("Using 'override' is strongly discouraged and may not behave ".
 290          "as you expect it to. Please use 'around'")
 291         if scalar keys %{ $role->meta->get_override_method_modifiers_map };
 292     die("Failed to apply plugin: $role") unless $role->meta->apply( $self );
 293
 294     return 1;
 295 }
 296
 297 =head2 _build_plugin_app_ns
 298
 299 Automatically builds the _plugin_app_ns attribute with the classes in the
 300 class presedence list that are not part of Moose.
 301
 302 =cut
 303
 304 sub _build_plugin_app_ns{
 305     my $self = shift;
 306     my @names = (grep {$_ !~ /^Moose::/} $self->meta->class_precedence_list);
 307     return \@names;
 308 }
 309
 310 =head2 _build_plugin_locator
 311
 312 Automatically creates a L<Module::Pluggable::Object> instance with the correct
 313 search_path.
 314
 315 =cut
 316
 317 sub _build_plugin_locator{
 318     my $self = shift;
 319
 320     my $locator = Module::Pluggable::Object->new
 321         ( search_path =>
 322           [ map { join '::', ($_, $self->_plugin_ns) } $self->_plugin_app_ns ]
 323         );
 324     return $locator;
 325 }
 326
 327 =head2 meta
 328
 329 Keep tests happy. See L<Moose>
 330
 331 =cut
 332
 333 1;
 334
 335 __END__;
 336
 337 =head1 SEE ALSO
 338
 339 L<Moose>, L<Moose::Role>, L<Class::Inspector>
 340
 341 =head1 AUTHOR
 342
 343 Guillermo Roditi, <groditi@cpan.org>
 344
 345 =head1 BUGS
 346
 347 Holler?
 348
 349 Please report any bugs or feature requests to
 350 C<bug-moosex-object-pluggable at rt.cpan.org>, or through the web interface at
 351 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MooseX-Object-Pluggable>.
 352 I will be notified, and then you'll automatically be notified of progress on
 353 your bug as I make changes.
 354
 355 =head1 SUPPORT
 356
 357 You can find documentation for this module with the perldoc command.
 358
 359     perldoc MooseX-Object-Pluggable
 360
 361 You can also look for information at:
 362
 363 =over 4
 364
 365 =item * AnnoCPAN: Annotated CPAN documentation
 366
 367 L<http://annocpan.org/dist/MooseX-Object-Pluggable>
 368
 369 =item * CPAN Ratings
 370
 371 L<http://cpanratings.perl.org/d/MooseX-Object-Pluggable>
 372
 373 =item * RT: CPAN's request tracker
 374
 375 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MooseX-Object-Pluggable>
 376
 377 =item * Search CPAN
 378
 379 L<http://search.cpan.org/dist/MooseX-Object-Pluggable>
 380
 381 =back
 382
 383 =head1 ACKNOWLEDGEMENTS
 384
 385 =over 4
 386
 387 =item #Moose - Huge number of questions
 388
 389 =item Matt S Trout <mst@shadowcatsystems.co.uk> - ideas / planning.
 390
 391 =item Stevan Little - EVERYTHING. Without him this would have never happened.
 392
 393 =back
 394
 395 =head1 COPYRIGHT
 396
 397 Copyright 2007 Guillermo Roditi.  All Rights Reserved.  This is
 398 free software; you may redistribute it and/or modify it under the same
 399 terms as Perl itself.
 400
 401 =cut