lib/MooseX/Object/Pluggable.pm

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