Removed undocumented groups feature Moose::Exporter and updated tests accordingly.
[gitmo/Moose.git] / lib / Moose / Exporter.pm
1 package Moose::Exporter;
2
3 use strict;
4 use warnings;
5
6 our $VERSION   = '0.89_01';
7 $VERSION = eval $VERSION;
8 our $AUTHORITY = 'cpan:STEVAN';
9
10 use Class::MOP;
11 use List::MoreUtils qw( first_index uniq );
12 use Moose::Util::MetaRole;
13 use Sub::Exporter 0.980;
14 use Sub::Name qw(subname);
15
16 my %EXPORT_SPEC;
17
18 sub setup_import_methods {
19     my ( $class, %args ) = @_;
20
21     my $exporting_package = $args{exporting_package} ||= caller();
22
23     $class->build_import_methods(
24         %args,
25         install => [qw(import unimport init_meta)]
26     );
27 }
28
29 sub build_import_methods {
30     my ( $class, %args ) = @_;
31
32     my $exporting_package = $args{exporting_package} ||= caller();
33
34     $EXPORT_SPEC{$exporting_package} = \%args;
35
36     my @exports_from = $class->_follow_also( $exporting_package );
37
38     my $export_recorder = {};
39
40     my ( $exports, $is_removable )
41         = $class->_make_sub_exporter_params(
42         [ @exports_from, $exporting_package ], $export_recorder );
43
44     my $exporter = Sub::Exporter::build_exporter(
45         {
46             exports => $exports,
47             groups  => { default => [':all'] }
48         }
49     );
50
51     my %methods;
52     # $args{_export_to_main} exists for backwards compat, because
53     # Moose::Util::TypeConstraints did export to main (unlike Moose &
54     # Moose::Role).
55     $methods{import} = $class->_make_import_sub( $exporting_package,
56         $exporter, \@exports_from, $args{_export_to_main} );
57
58     $methods{unimport} = $class->_make_unimport_sub( $exporting_package,
59         $exports, $is_removable, $export_recorder );
60
61     $methods{init_meta} = $class->_make_init_meta( $exporting_package,
62         \%args );
63
64     my $package = Class::MOP::Package->initialize($exporting_package);
65     for my $to_install ( @{ $args{install} || [] } ) {
66         my $symbol = '&' . $to_install;
67         next
68             unless $methods{$to_install}
69                 && !$package->has_package_symbol($symbol);
70         $package->add_package_symbol( $symbol, $methods{$to_install} );
71     }
72
73     return ( $methods{import}, $methods{unimport}, $methods{init_meta} )
74 }
75
76 {
77     my $seen = {};
78
79     sub _follow_also {
80         my $class             = shift;
81         my $exporting_package = shift;
82
83         local %$seen = ( $exporting_package => 1 );
84
85         return uniq( _follow_also_real($exporting_package) );
86     }
87
88     sub _follow_also_real {
89         my $exporting_package = shift;
90
91         if (!exists $EXPORT_SPEC{$exporting_package}) {
92             my $loaded = Class::MOP::is_class_loaded($exporting_package);
93
94             die "Package in also ($exporting_package) does not seem to "
95               . "use Moose::Exporter"
96               . ($loaded ? "" : " (is it loaded?)");
97         }
98
99         my $also = $EXPORT_SPEC{$exporting_package}{also};
100
101         return unless defined $also;
102
103         my @also = ref $also ? @{$also} : $also;
104
105         for my $package (@also)
106         {
107             die "Circular reference in also parameter to Moose::Exporter between $exporting_package and $package"
108                 if $seen->{$package};
109
110             $seen->{$package} = 1;
111         }
112
113         return @also, map { _follow_also_real($_) } @also;
114     }
115 }
116
117 sub _make_sub_exporter_params {
118     my $class             = shift;
119     my $packages          = shift;
120     my $export_recorder   = shift;
121
122     my %exports;
123     my %is_removable;
124
125     for my $package ( @{$packages} ) {
126         my $args = $EXPORT_SPEC{$package}
127             or die "The $package package does not use Moose::Exporter\n";
128
129         for my $name ( @{ $args->{with_meta} } ) {
130             my $sub = do {
131                 no strict 'refs';
132                 \&{ $package . '::' . $name };
133             };
134
135             my $fq_name = $package . '::' . $name;
136
137             $exports{$name} = $class->_make_wrapped_sub_with_meta(
138                 $fq_name,
139                 $sub,
140                 $export_recorder,
141             );
142
143             $is_removable{$name} = 1;
144         }
145
146         for my $name ( @{ $args->{with_caller} } ) {
147             my $sub = do {
148                 no strict 'refs';
149                 \&{ $package . '::' . $name };
150             };
151
152             my $fq_name = $package . '::' . $name;
153
154             $exports{$name} = $class->_make_wrapped_sub(
155                 $fq_name,
156                 $sub,
157                 $export_recorder,
158             );
159
160             $is_removable{$name} = 1;
161         }
162
163         for my $name ( @{ $args->{as_is} } ) {
164             my $sub;
165
166             if ( ref $name ) {
167                 $sub  = $name;
168
169                 # Even though Moose re-exports things from Carp &
170                 # Scalar::Util, we don't want to remove those at
171                 # unimport time, because the importing package may
172                 # have imported them explicitly ala
173                 #
174                 # use Carp qw( confess );
175                 #
176                 # This is a hack. Since we can't know whether they
177                 # really want to keep these subs or not, we err on the
178                 # safe side and leave them in.
179                 my $coderef_pkg;
180                 ( $coderef_pkg, $name ) = Class::MOP::get_code_info($name);
181
182                 $is_removable{$name} = $coderef_pkg eq $package ? 1 : 0;
183             }
184             else {
185                 $sub = do {
186                     no strict 'refs';
187                     \&{ $package . '::' . $name };
188                 };
189
190                 $is_removable{$name} = 1;
191             }
192
193             $export_recorder->{$sub} = 1;
194
195             $exports{$name} = sub {$sub};
196         }
197     }
198
199     return ( \%exports, \%is_removable );
200 }
201
202 our $CALLER;
203
204 sub _make_wrapped_sub {
205     my $self            = shift;
206     my $fq_name         = shift;
207     my $sub             = shift;
208     my $export_recorder = shift;
209
210     # We need to set the package at import time, so that when
211     # package Foo imports has(), we capture "Foo" as the
212     # package. This lets other packages call Foo::has() and get
213     # the right package. This is done for backwards compatibility
214     # with existing production code, not because this is a good
215     # idea ;)
216     return sub {
217         my $caller = $CALLER;
218
219         my $wrapper = $self->_curry_wrapper($sub, $fq_name, $caller);
220
221         my $sub = subname($fq_name => $wrapper);
222
223         $export_recorder->{$sub} = 1;
224
225         return $sub;
226     };
227 }
228
229 sub _make_wrapped_sub_with_meta {
230     my $self            = shift;
231     my $fq_name         = shift;
232     my $sub             = shift;
233     my $export_recorder = shift;
234
235     return sub {
236         my $caller = $CALLER;
237
238         my $wrapper = $self->_late_curry_wrapper($sub, $fq_name,
239             sub { Class::MOP::class_of(shift) } => $caller);
240
241         my $sub = subname($fq_name => $wrapper);
242
243         $export_recorder->{$sub} = 1;
244
245         return $sub;
246     };
247 }
248
249 sub _make_wrapped_group {
250     my $class           = shift;
251     my $package         = shift; # package calling use Moose::Exporter
252     my $sub             = shift;
253     my $export_recorder = shift;
254     my $keywords        = shift;
255     my $is_removable    = shift;
256
257     return sub {
258         my $caller = $CALLER; # package calling use PackageUsingMooseExporter -group => {args}
259
260         # there are plenty of ways to deal with telling the code which
261         # package it lives in. the last arg (collector hashref) is
262         # otherwise unused, so we'll stick the original package in
263         # there and act like 'with_caller' by putting the calling
264         # package name as the first arg
265         $_[0] = $caller;
266         $_[3]{from} = $package;
267
268         my $named_code = $sub->(@_);
269         $named_code ||= { };
270
271         # send invalid return value error up to Sub::Exporter
272         unless (ref $named_code eq 'HASH') {
273             return $named_code;
274         }
275
276         for my $name (keys %$named_code) {
277             my $code = $named_code->{$name};
278
279             my $fq_name = $package . '::' . $name;
280             my $wrapper = $class->_curry_wrapper(
281                 $code,
282                 $fq_name,
283                 $caller
284             );
285
286             my $sub = subname( $fq_name => $wrapper );
287             $named_code->{$name} = $sub;
288
289             # mark each coderef as ours
290             $keywords->{$name} = 1;
291             $is_removable->{$name} = 1;
292             $export_recorder->{$sub} = 1;
293         }
294
295         return $named_code;
296     };
297 }
298
299 sub _curry_wrapper {
300     my $class   = shift;
301     my $sub     = shift;
302     my $fq_name = shift;
303     my @extra   = @_;
304
305     my $wrapper = sub { $sub->(@extra, @_) };
306     if (my $proto = prototype $sub) {
307         # XXX - Perl's prototype sucks. Use & to make set_prototype
308         # ignore the fact that we're passing "private variables"
309         &Scalar::Util::set_prototype($wrapper, $proto);
310     }
311     return $wrapper;
312 }
313
314 sub _late_curry_wrapper {
315     my $class   = shift;
316     my $sub     = shift;
317     my $fq_name = shift;
318     my $extra   = shift;
319     my @ex_args = @_;
320
321     my $wrapper = sub {
322         # resolve curried arguments at runtime via this closure
323         my @curry = ( $extra->( @ex_args ) );
324         return $sub->(@curry, @_);
325     };
326
327     if (my $proto = prototype $sub) {
328         # XXX - Perl's prototype sucks. Use & to make set_prototype
329         # ignore the fact that we're passing "private variables"
330         &Scalar::Util::set_prototype($wrapper, $proto);
331     }
332     return $wrapper;
333 }
334
335 sub _make_import_sub {
336     shift;
337     my $exporting_package = shift;
338     my $exporter          = shift;
339     my $exports_from      = shift;
340     my $export_to_main    = shift;
341
342     return sub {
343
344         # I think we could use Sub::Exporter's collector feature
345         # to do this, but that would be rather gross, since that
346         # feature isn't really designed to return a value to the
347         # caller of the exporter sub.
348         #
349         # Also, this makes sure we preserve backwards compat for
350         # _get_caller, so it always sees the arguments in the
351         # expected order.
352         my $traits;
353         ( $traits, @_ ) = _strip_traits(@_);
354
355         my $metaclass;
356         ( $metaclass, @_ ) = _strip_metaclass(@_);
357         $metaclass = Moose::Util::resolve_metaclass_alias(
358             'Class' => $metaclass
359         ) if defined $metaclass && length $metaclass;
360
361         # Normally we could look at $_[0], but in some weird cases
362         # (involving goto &Moose::import), $_[0] ends as something
363         # else (like Squirrel).
364         my $class = $exporting_package;
365
366         $CALLER = _get_caller(@_);
367
368         # this works because both pragmas set $^H (see perldoc
369         # perlvar) which affects the current compilation -
370         # i.e. the file who use'd us - which is why we don't need
371         # to do anything special to make it affect that file
372         # rather than this one (which is already compiled)
373
374         strict->import;
375         warnings->import;
376
377         # we should never export to main
378         if ( $CALLER eq 'main' && !$export_to_main ) {
379             warn
380                 qq{$class does not export its sugar to the 'main' package.\n};
381             return;
382         }
383
384         my $did_init_meta;
385         for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
386             # init_meta can apply a role, which when loaded uses
387             # Moose::Exporter, which in turn sets $CALLER, so we need
388             # to protect against that.
389             local $CALLER = $CALLER;
390             $c->init_meta( for_class => $CALLER, metaclass => $metaclass );
391             $did_init_meta = 1;
392         }
393
394         if ( $did_init_meta && @{$traits} ) {
395             # The traits will use Moose::Role, which in turn uses
396             # Moose::Exporter, which in turn sets $CALLER, so we need
397             # to protect against that.
398             local $CALLER = $CALLER;
399             _apply_meta_traits( $CALLER, $traits );
400         }
401         elsif ( @{$traits} ) {
402             require Moose;
403             Moose->throw_error(
404                 "Cannot provide traits when $class does not have an init_meta() method"
405             );
406         }
407
408         goto $exporter;
409     };
410 }
411
412
413 sub _strip_traits {
414     my $idx = first_index { $_ eq '-traits' } @_;
415
416     return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
417
418     my $traits = $_[ $idx + 1 ];
419
420     splice @_, $idx, 2;
421
422     $traits = [ $traits ] unless ref $traits;
423
424     return ( $traits, @_ );
425 }
426
427 sub _strip_metaclass {
428     my $idx = first_index { $_ eq '-metaclass' } @_;
429
430     return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
431
432     my $metaclass = $_[ $idx + 1 ];
433
434     splice @_, $idx, 2;
435
436     return ( $metaclass, @_ );
437 }
438
439 sub _apply_meta_traits {
440     my ( $class, $traits ) = @_;
441
442     return unless @{$traits};
443
444     my $meta = Class::MOP::class_of($class);
445
446     my $type = ( split /::/, ref $meta )[-1]
447         or Moose->throw_error(
448         'Cannot determine metaclass type for trait application . Meta isa '
449         . ref $meta );
450
451     my @resolved_traits
452         = map {
453             ref $_ ? $_ : Moose::Util::resolve_metatrait_alias( $type => $_ )
454         }
455         @$traits;
456
457     return unless @resolved_traits;
458
459     Moose::Util::MetaRole::apply_metaclass_roles(
460         for_class       => $class,
461         metaclass_roles => \@resolved_traits,
462     );
463 }
464
465 sub _get_caller {
466     # 1 extra level because it's called by import so there's a layer
467     # of indirection
468     my $offset = 1;
469
470     return
471           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
472         : ( ref $_[1] && defined $_[1]->{into_level} )
473         ? caller( $offset + $_[1]->{into_level} )
474         : caller($offset);
475 }
476
477 sub _make_unimport_sub {
478     shift;
479     my $exporting_package = shift;
480     my $exports           = shift;
481     my $is_removable      = shift;
482     my $export_recorder   = shift;
483
484     return sub {
485         my $caller = scalar caller();
486         Moose::Exporter->_remove_keywords(
487             $caller,
488             [ keys %{$exports} ],
489             $is_removable,
490             $export_recorder,
491         );
492     };
493 }
494
495 sub _remove_keywords {
496     shift;
497     my $package          = shift;
498     my $keywords         = shift;
499     my $is_removable     = shift;
500     my $recorded_exports = shift;
501
502     no strict 'refs';
503
504     foreach my $name ( @{ $keywords } ) {
505         next unless $is_removable->{$name};
506
507         if ( defined &{ $package . '::' . $name } ) {
508             my $sub = \&{ $package . '::' . $name };
509
510             # make sure it is from us
511             next unless $recorded_exports->{$sub};
512
513             # and if it is from us, then undef the slot
514             delete ${ $package . '::' }{$name};
515         }
516     }
517 }
518
519 sub _make_init_meta {
520     shift;
521     my $class = shift;
522     my $args  = shift;
523
524     my %metaclass_roles;
525     for my $role (
526         map {"${_}_roles"}
527         qw(metaclass
528         attribute_metaclass
529         method_metaclass
530         wrapped_method_metaclass
531         instance_metaclass
532         constructor_class
533         destructor_class
534         error_class
535         application_to_class_class
536         application_to_role_class
537         application_to_instance_class)
538         ) {
539         $metaclass_roles{$role} = $args->{$role} if exists $args->{$role};
540     }
541
542     my %base_class_roles;
543     %base_class_roles = ( roles => $args->{base_class_roles} )
544         if exists $args->{base_class_roles};
545
546     return unless %metaclass_roles || %base_class_roles;
547
548     return sub {
549         shift;
550         my %options = @_;
551
552         return unless Class::MOP::class_of( $options{for_class} );
553
554         Moose::Util::MetaRole::apply_metaclass_roles(
555             for_class => $options{for_class},
556             %metaclass_roles,
557         );
558
559         Moose::Util::MetaRole::apply_base_class_roles(
560             for_class => $options{for_class},
561             %base_class_roles,
562             )
563             if Class::MOP::class_of( $options{for_class} )
564                 ->isa('Moose::Meta::Class');
565
566         return Class::MOP::class_of( $options{for_class} );
567     };
568 }
569
570 sub import {
571     strict->import;
572     warnings->import;
573 }
574
575 1;
576
577 __END__
578
579 =head1 NAME
580
581 Moose::Exporter - make an import() and unimport() just like Moose.pm
582
583 =head1 SYNOPSIS
584
585   package MyApp::Moose;
586
587   use Moose ();
588   use Moose::Exporter;
589
590   Moose::Exporter->setup_import_methods(
591       with_meta => [ 'has_rw', 'sugar2' ],
592       as_is     => [ 'sugar3', \&Some::Random::thing ],
593       also      => 'Moose',
594   );
595
596   sub has_rw {
597       my ( $meta, $name, %options ) = @_;
598       $meta->add_attribute(
599           $name,
600           is => 'rw',
601           %options,
602       );
603   }
604
605   # then later ...
606   package MyApp::User;
607
608   use MyApp::Moose;
609
610   has 'name';
611   has_rw 'size';
612   thing;
613
614   no MyApp::Moose;
615
616 =head1 DESCRIPTION
617
618 This module encapsulates the exporting of sugar functions in a
619 C<Moose.pm>-like manner. It does this by building custom C<import>,
620 C<unimport>, and C<init_meta> methods for your module, based on a spec you
621 provide.
622
623 It also lets you "stack" Moose-alike modules so you can export Moose's sugar
624 as well as your own, along with sugar from any random C<MooseX> module, as
625 long as they all use C<Moose::Exporter>. This feature exists to let you bundle
626 a set of MooseX modules into a policy module that developers can use directly
627 instead of using Moose itself.
628
629 To simplify writing exporter modules, C<Moose::Exporter> also imports
630 C<strict> and C<warnings> into your exporter module, as well as into
631 modules that use it.
632
633 =head1 METHODS
634
635 This module provides two public methods:
636
637 =over 4
638
639 =item  B<< Moose::Exporter->setup_import_methods(...) >>
640
641 When you call this method, C<Moose::Exporter> builds custom C<import>,
642 C<unimport>, and C<init_meta> methods for your module. The C<import> method
643 will export the functions you specify, and can also re-export functions
644 exported by some other module (like C<Moose.pm>).
645
646 The C<unimport> method cleans the caller's namespace of all the exported
647 functions.
648
649 If you pass any parameters for L<Moose::Util::MetaRole>, this method will
650 generate an C<init_meta> for you as well (see below for details). This
651 C<init_meta> will call C<Moose::Util::MetaRole::apply_metaclass_roles> and
652 C<Moose::Util::MetaRole::apply_base_class_roles> as needed.
653
654 Note that if any of these methods already exist, they will not be
655 overridden, you will have to use C<build_import_methods> to get the
656 coderef that would be installed.
657
658 This method accepts the following parameters:
659
660 =over 8
661
662 =item * with_meta => [ ... ]
663
664 This list of function I<names only> will be wrapped and then exported. The
665 wrapper will pass the metaclass object for the caller as its first argument.
666
667 Many sugar functions will need to use this metaclass object to do something to
668 the calling package.
669
670 =item * as_is => [ ... ]
671
672 This list of function names or sub references will be exported as-is. You can
673 identify a subroutine by reference, which is handy to re-export some other
674 module's functions directly by reference (C<\&Some::Package::function>).
675
676 If you do export some other package's function, this function will never be
677 removed by the C<unimport> method. The reason for this is we cannot know if
678 the caller I<also> explicitly imported the sub themselves, and therefore wants
679 to keep it.
680
681 =item * also => $name or \@names
682
683 This is a list of modules which contain functions that the caller
684 wants to export. These modules must also use C<Moose::Exporter>. The
685 most common use case will be to export the functions from C<Moose.pm>.
686 Functions specified by C<with_meta> or C<as_is> take precedence over
687 functions exported by modules specified by C<also>, so that a module
688 can selectively override functions exported by another module.
689
690 C<Moose::Exporter> also makes sure all these functions get removed
691 when C<unimport> is called.
692
693 =back
694
695 Any of the C<*_roles> options for
696 C<Moose::Util::MetaRole::apply_metaclass_roles> and
697 C<Moose::Util::MetaRole::base_class_roles> are also acceptable.
698
699 =item B<< Moose::Exporter->build_import_methods(...) >>
700
701 Returns two or three code refs, one for C<import>, one for
702 C<unimport>, and optionally one for C<init_meta>, if the appropriate
703 options are passed in.
704
705 Accepts the additional C<install> option, which accepts an arrayref of method
706 names to install into your exporting package. The valid options are C<import>,
707 C<unimport>, and C<init_meta>. Calling C<setup_import_methods> is equivalent
708 to calling C<build_import_methods> with C<< install => [qw(import unimport
709 init_meta)] >> except that it doesn't also return the methods.
710
711 Used by C<setup_import_methods>.
712
713 =back
714
715 =head1 IMPORTING AND init_meta
716
717 If you want to set an alternative base object class or metaclass class, see
718 above for details on how this module can call L<Moose::Util::MetaRole> for
719 you.
720
721 If you want to do something that is not supported by this module, simply
722 define an C<init_meta> method in your class. The C<import> method that
723 C<Moose::Exporter> generates for you will call this method (if it exists). It
724 will always pass the caller to this method via the C<for_class> parameter.
725
726 Most of the time, your C<init_meta> method will probably just call C<<
727 Moose->init_meta >> to do the real work:
728
729   sub init_meta {
730       shift; # our class name
731       return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
732   }
733
734 Keep in mind that C<build_import_methods> will return an C<init_meta>
735 method for you, which you can also call from within your custom
736 C<init_meta>:
737
738   my ( $import, $unimport, $init_meta ) =
739       Moose::Exporter->build_import_methods( ... );
740
741   sub import {
742      my $class = shift;
743
744      ...
745
746      $class->$import(...);
747
748      ...
749   }
750
751   sub unimport { goto &$unimport }
752
753   sub init_meta {
754      my $class = shift;
755
756      ...
757
758      $class->$init_meta(...);
759
760      ...
761   }
762
763 =head1 METACLASS TRAITS
764
765 The C<import> method generated by C<Moose::Exporter> will allow the
766 user of your module to specify metaclass traits in a C<-traits>
767 parameter passed as part of the import:
768
769   use Moose -traits => 'My::Meta::Trait';
770
771   use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
772
773 These traits will be applied to the caller's metaclass
774 instance. Providing traits for an exporting class that does not create
775 a metaclass for the caller is an error.
776
777 =head1 AUTHOR
778
779 Dave Rolsky E<lt>autarch@urth.orgE<gt>
780
781 This is largely a reworking of code in Moose.pm originally written by
782 Stevan Little and others.
783
784 =head1 COPYRIGHT AND LICENSE
785
786 Copyright 2009 by Infinity Interactive, Inc.
787
788 L<http://www.iinteractive.com>
789
790 This library is free software; you can redistribute it and/or modify
791 it under the same terms as Perl itself.
792
793 =cut