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