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