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