lib/Moose/Exporter.pm

   1 package Moose::Exporter;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Class::MOP;
   7 use namespace::clean 0.08 ();
   8 use List::MoreUtils qw( uniq );
   9 use Sub::Exporter;
  10
  11
  12 my %EXPORT_SPEC;
  13
  14 sub build_import_methods {
  15     my $class = shift;
  16     my %args  = @_;
  17
  18     my $exporting_package = caller();
  19
  20     $EXPORT_SPEC{$exporting_package} = \%args;
  21
  22     my @exports_from = $class->_follow_also( $exporting_package );
  23
  24     my $exports
  25         = $class->_process_exports( $exporting_package, @exports_from );
  26
  27     my $exporter = Sub::Exporter::build_exporter(
  28         {
  29             exports => $exports,
  30             groups  => { default => [':all'] }
  31         }
  32     );
  33
  34     my $import = $class->_make_import_sub($exporter);
  35
  36     my $unimport = $class->_make_unimport_sub( [ keys %{$exports} ] );
  37
  38     no strict 'refs';
  39     *{ $exporting_package . '::import' }   = $import;
  40     *{ $exporting_package . '::unimport' } = $unimport;
  41 }
  42
  43 {
  44     my %seen;
  45
  46     sub _follow_also {
  47         my $class             = shift;
  48         my $exporting_package = shift;
  49
  50         %seen = ( $exporting_package => 1 );
  51
  52         return uniq( _follow_also_real($exporting_package) );
  53     }
  54
  55     sub _follow_also_real {
  56         my $exporting_package = shift;
  57
  58         die "Package in also ($exporting_package) does not seem to use MooseX::Exporter"
  59             unless exists $EXPORT_SPEC{$exporting_package};
  60
  61         my $also = $EXPORT_SPEC{$exporting_package}{also};
  62
  63         return unless defined $also;
  64
  65         my @also = ref $also ? @{$also} : $also;
  66
  67         for my $package (@also)
  68         {
  69             die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package"
  70                 if $seen{$package};
  71
  72             $seen{$package} = 1;
  73         }
  74
  75         return @also, map { _follow_also_real($_) } @also;
  76     }
  77 }
  78
  79 sub _process_exports {
  80     my $class    = shift;
  81     my @packages = @_;
  82
  83     my %exports;
  84
  85     for my $package (@packages) {
  86         my $args = $EXPORT_SPEC{$package}
  87             or die "The $package package does not use Moose::Exporter\n";
  88
  89         for my $name ( @{ $args->{with_caller} } ) {
  90             my $sub = do {
  91                 no strict 'refs';
  92                 \&{ $package . '::' . $name };
  93             };
  94
  95             $exports{$name} = $class->_make_wrapped_sub(
  96                 $package,
  97                 $name,
  98                 $sub
  99             );
 100         }
 101
 102         for my $name ( @{ $args->{as_is} } ) {
 103             my $sub;
 104
 105             if ( ref $name ) {
 106                 $sub  = $name;
 107                 $name = ( Class::MOP::get_code_info($name) )[1];
 108             }
 109             else {
 110                 $sub = do {
 111                     no strict 'refs';
 112                     \&{ $package . '::' . $name };
 113                 };
 114             }
 115
 116             $exports{$name} = sub {$sub};
 117         }
 118     }
 119
 120     return \%exports;
 121 }
 122
 123 {
 124     # This variable gets closed over in each export _generator_. Then
 125     # in the generator we grab the value and close over it _again_ in
 126     # the real export, so it gets captured each time the generator
 127     # runs.
 128     #
 129     # In the meantime, we arrange for the import method we generate to
 130     # set this variable to the caller each time it is called.
 131     #
 132     # This is all a bit confusing, but it works.
 133     my $CALLER;
 134
 135     sub _make_wrapped_sub {
 136         my $class             = shift;
 137         my $exporting_package = shift;
 138         my $name              = shift;
 139         my $sub               = shift;
 140
 141         # We need to set the package at import time, so that when
 142         # package Foo imports has(), we capture "Foo" as the
 143         # package. This lets other packages call Foo::has() and get
 144         # the right package. This is done for backwards compatibility
 145         # with existing production code, not because this is a good
 146         # idea ;)
 147         return sub {
 148             my $caller = $CALLER;
 149             Class::MOP::subname( $exporting_package . '::'
 150                     . $name => sub { $sub->( $caller, @_ ) } );
 151         };
 152     }
 153
 154     sub _make_import_sub {
 155         my $class          = shift;
 156         my $exporter       = shift;
 157
 158         return sub {
 159
 160             # It's important to leave @_ as-is for the benefit of
 161             # Sub::Exporter.
 162             my $class = $_[0];
 163
 164             $CALLER = Moose::Exporter::_get_caller(@_);
 165
 166             # this works because both pragmas set $^H (see perldoc
 167             # perlvar) which affects the current compilation -
 168             # i.e. the file who use'd us - which is why we don't need
 169             # to do anything special to make it affect that file
 170             # rather than this one (which is already compiled)
 171
 172             strict->import;
 173             warnings->import;
 174
 175             # we should never export to main
 176             if ( $CALLER eq 'main' ) {
 177                 warn
 178                     qq{$class does not export its sugar to the 'main' package.\n};
 179                 return;
 180             }
 181
 182             if ( $class->can('init_meta') ) {
 183                 $class->init_meta(
 184                     for_class => $CALLER,
 185                 );
 186             }
 187
 188             goto $exporter;
 189         };
 190     }
 191 }
 192
 193 sub _get_caller {
 194     # 1 extra level because it's called by import so there's a layer
 195     # of indirection
 196     my $offset = 1;
 197
 198     return
 199           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
 200         : ( ref $_[1] && defined $_[1]->{into_level} )
 201         ? caller( $offset + $_[1]->{into_level} )
 202         : caller($offset);
 203 }
 204
 205 sub _make_unimport_sub {
 206     my $class    = shift;
 207     my $exported = shift;
 208
 209     # [12:24]  <mst> yes. that's horrible. I know. but it should work.
 210     #
 211     # This will hopefully be replaced in the future once
 212     # namespace::clean has an API for it.
 213     return sub {
 214         @_ = ( 'namespace::clean', @{$exported} );
 215
 216         goto &namespace::clean::import;
 217     };
 218 }
 219
 220 1;
 221
 222 __END__
 223
 224 =head1 NAME
 225
 226 Moose::Exporter - make an import() and unimport() just like Moose.pm
 227
 228 =head1 SYNOPSIS
 229
 230   package MyApp::Moose;
 231
 232   use strict;
 233   use warnings;
 234
 235   use Moose ();
 236   use Moose::Exporter;
 237
 238   Moose::Exporter->build_export_methods(
 239       export         => [ 'sugar1', 'sugar2', \&Some::Random::thing ],
 240       init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ],
 241   );
 242
 243   # then later ...
 244   package MyApp::User;
 245
 246   use MyApp::Moose;
 247
 248   has 'name';
 249   sugar1 'do your thing';
 250   thing;
 251
 252   no MyApp::Moose;
 253
 254 =head1 DESCRIPTION
 255
 256 This module encapsulates the logic to export sugar functions like
 257 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
 258 methods for your module, based on a spec your provide.
 259
 260 It also lets your "stack" Moose-alike modules so you can export
 261 Moose's sugar as well as your own, along with sugar from any random
 262 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 263
 264 =head1 METHODS
 265
 266 This module provides exactly one public method:
 267
 268 =head2 Moose::Exporter->build_import_methods(...)
 269
 270 When you call this method, C<Moose::Exporter> build custom C<import>
 271 and C<unimport> methods for your module. The import method will export
 272 the functions you specify, and you can also tell it to export
 273 functions exported by some other module (like C<Moose.pm>).
 274
 275 The C<unimport> method cleans the callers namespace of all the
 276 exported functions.
 277
 278 This method accepts the following parameters:
 279
 280 =over 4
 281
 282 =item * with_caller => [ ... ]
 283
 284 This a list of function I<names only> to be exported wrapped and then
 285 exported. The wrapper will pass the name of the calling package as the
 286 first argument to the function. Many sugar functions need to know
 287 their caller so they can get the calling package's metaclass object.
 288
 289 =item * as_is => [ ... ]
 290
 291 This a list of function names or sub references to be exported
 292 as-is. You can identify a subroutine by reference, which is handy to
 293 re-export some other module's functions directly by reference
 294 (C<\&Some::Package::function>).
 295
 296 =item * init_meta_args
 297
 298 ...
 299
 300 =back
 301
 302 =head1 AUTHOR
 303
 304 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 305
 306 This is largely a reworking of code in Moose.pm originally written by
 307 Stevan Little and others.
 308
 309 =head1 COPYRIGHT AND LICENSE
 310
 311 Copyright 2008 by Infinity Interactive, Inc.
 312
 313 L<http://www.iinteractive.com>
 314
 315 This library is free software; you can redistribute it and/or modify
 316 it under the same terms as Perl itself.
 317
 318 =cut