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( \@exports_from, [ 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     shift;
 206     my $sources  = shift;
 207     my $keywords = shift;
 208
 209     return sub {
 210         my $class  = shift;
 211         my $caller = scalar caller();
 212         Moose::Exporter->_remove_keywords(
 213             $caller,
 214             [ $class, @{$sources} ],
 215             $keywords
 216         );
 217     };
 218 }
 219
 220 sub _remove_keywords {
 221     shift;
 222     my $package  = shift;
 223     my $sources  = shift;
 224     my $keywords = shift;
 225
 226     my %sources = map { $_ => 1 } @{$sources};
 227
 228     no strict 'refs';
 229
 230     # loop through the keywords ...
 231     foreach my $name ( @{$keywords} ) {
 232
 233         # if we find one ...
 234         if ( defined &{ $package . '::' . $name } ) {
 235             my $keyword = \&{ $package . '::' . $name };
 236
 237             # make sure it is from us
 238             my ($pkg_name) = Class::MOP::get_code_info($keyword);
 239             next unless $sources{$pkg_name};
 240
 241             # and if it is from us, then undef the slot
 242             delete ${ $package . '::' }{$name};
 243         }
 244     }
 245 }
 246
 247 1;
 248
 249 __END__
 250
 251 =head1 NAME
 252
 253 Moose::Exporter - make an import() and unimport() just like Moose.pm
 254
 255 =head1 SYNOPSIS
 256
 257   package MyApp::Moose;
 258
 259   use strict;
 260   use warnings;
 261
 262   use Moose ();
 263   use Moose::Exporter;
 264
 265   Moose::Exporter->build_export_methods(
 266       export         => [ 'sugar1', 'sugar2', \&Some::Random::thing ],
 267       init_meta_args => { metaclass_class => 'MyApp::Meta::Class' ],
 268   );
 269
 270   # then later ...
 271   package MyApp::User;
 272
 273   use MyApp::Moose;
 274
 275   has 'name';
 276   sugar1 'do your thing';
 277   thing;
 278
 279   no MyApp::Moose;
 280
 281 =head1 DESCRIPTION
 282
 283 This module encapsulates the logic to export sugar functions like
 284 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
 285 methods for your module, based on a spec your provide.
 286
 287 It also lets your "stack" Moose-alike modules so you can export
 288 Moose's sugar as well as your own, along with sugar from any random
 289 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 290
 291 =head1 METHODS
 292
 293 This module provides exactly one public method:
 294
 295 =head2 Moose::Exporter->build_import_methods(...)
 296
 297 When you call this method, C<Moose::Exporter> build custom C<import>
 298 and C<unimport> methods for your module. The import method will export
 299 the functions you specify, and you can also tell it to export
 300 functions exported by some other module (like C<Moose.pm>).
 301
 302 The C<unimport> method cleans the callers namespace of all the
 303 exported functions.
 304
 305 This method accepts the following parameters:
 306
 307 =over 4
 308
 309 =item * with_caller => [ ... ]
 310
 311 This a list of function I<names only> to be exported wrapped and then
 312 exported. The wrapper will pass the name of the calling package as the
 313 first argument to the function. Many sugar functions need to know
 314 their caller so they can get the calling package's metaclass object.
 315
 316 =item * as_is => [ ... ]
 317
 318 This a list of function names or sub references to be exported
 319 as-is. You can identify a subroutine by reference, which is handy to
 320 re-export some other module's functions directly by reference
 321 (C<\&Some::Package::function>).
 322
 323 =item * init_meta_args
 324
 325 ...
 326
 327 =back
 328
 329 =head1 AUTHOR
 330
 331 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 332
 333 This is largely a reworking of code in Moose.pm originally written by
 334 Stevan Little and others.
 335
 336 =head1 COPYRIGHT AND LICENSE
 337
 338 Copyright 2008 by Infinity Interactive, Inc.
 339
 340 L<http://www.iinteractive.com>
 341
 342 This library is free software; you can redistribute it and/or modify
 343 it under the same terms as Perl itself.
 344
 345 =cut