lib/Moose/Exporter.pm

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