lib/Moose/Exporter.pm

   1 package Moose::Exporter;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw( confess );
   7 use Class::MOP;
   8 use List::MoreUtils qw( first_index uniq );
   9 use Moose::Util::MetaRole;
  10 use Sub::Exporter;
  11
  12
  13 my %EXPORT_SPEC;
  14
  15 sub setup_import_methods {
  16     my ( $class, %args ) = @_;
  17
  18     my $exporting_package = $args{exporting_package} ||= caller();
  19
  20     my ( $import, $unimport ) = $class->build_import_methods(%args);
  21
  22     no strict 'refs';
  23     *{ $exporting_package . '::import' }   = $import;
  24     *{ $exporting_package . '::unimport' } = $unimport;
  25 }
  26
  27 sub build_import_methods {
  28     my ( $class, %args ) = @_;
  29
  30     my $exporting_package = $args{exporting_package} ||= caller();
  31
  32     $EXPORT_SPEC{$exporting_package} = \%args;
  33
  34     my @exports_from = $class->_follow_also( $exporting_package );
  35
  36     my $export_recorder = {};
  37
  38     my $exports = $class->_make_sub_exporter_params(
  39         [ $exporting_package, @exports_from ], $export_recorder );
  40
  41     my $exporter = Sub::Exporter::build_exporter(
  42         {
  43             exports => $exports,
  44             groups  => { default => [':all'] }
  45         }
  46     );
  47
  48     # $args{_export_to_main} exists for backwards compat, because
  49     # Moose::Util::TypeConstraints did export to main (unlike Moose &
  50     # Moose::Role).
  51     my $import = $class->_make_import_sub( $exporting_package, $exporter,
  52         \@exports_from, $args{_export_to_main} );
  53
  54     my $unimport = $class->_make_unimport_sub( $exporting_package, $exports,
  55         $export_recorder );
  56
  57     return ( $import, $unimport )
  58 }
  59
  60 {
  61     my $seen = {};
  62
  63     sub _follow_also {
  64         my $class             = shift;
  65         my $exporting_package = shift;
  66
  67         local %$seen = ( $exporting_package => 1 );
  68
  69         return uniq( _follow_also_real($exporting_package) );
  70     }
  71
  72     sub _follow_also_real {
  73         my $exporting_package = shift;
  74
  75         die "Package in also ($exporting_package) does not seem to use MooseX::Exporter"
  76             unless exists $EXPORT_SPEC{$exporting_package};
  77
  78         my $also = $EXPORT_SPEC{$exporting_package}{also};
  79
  80         return unless defined $also;
  81
  82         my @also = ref $also ? @{$also} : $also;
  83
  84         for my $package (@also)
  85         {
  86             die "Circular reference in also parameter to MooseX::Exporter between $exporting_package and $package"
  87                 if $seen->{$package};
  88
  89             $seen->{$package} = 1;
  90         }
  91
  92         return @also, map { _follow_also_real($_) } @also;
  93     }
  94 }
  95
  96 sub _make_sub_exporter_params {
  97     my $class             = shift;
  98     my $packages          = shift;
  99     my $export_recorder   = shift;
 100
 101     my %exports;
 102
 103     for my $package ( @{$packages} ) {
 104         my $args = $EXPORT_SPEC{$package}
 105             or die "The $package package does not use Moose::Exporter\n";
 106
 107         for my $name ( @{ $args->{with_caller} } ) {
 108             my $sub = do {
 109                 no strict 'refs';
 110                 \&{ $package . '::' . $name };
 111             };
 112
 113             my $fq_name = $package . '::' . $name;
 114
 115             $exports{$name} = $class->_make_wrapped_sub(
 116                 $fq_name,
 117                 $sub,
 118                 $export_recorder,
 119             );
 120         }
 121
 122         for my $name ( @{ $args->{as_is} } ) {
 123             my $sub;
 124
 125             if ( ref $name ) {
 126                 $sub  = $name;
 127                 $name = ( Class::MOP::get_code_info($name) )[1];
 128             }
 129             else {
 130                 $sub = do {
 131                     no strict 'refs';
 132                     \&{ $package . '::' . $name };
 133                 };
 134             }
 135
 136             $export_recorder->{$sub} = 1;
 137
 138             $exports{$name} = sub {$sub};
 139         }
 140     }
 141
 142     return \%exports;
 143 }
 144
 145 {
 146     # This variable gets closed over in each export _generator_. Then
 147     # in the generator we grab the value and close over it _again_ in
 148     # the real export, so it gets captured each time the generator
 149     # runs.
 150     #
 151     # In the meantime, we arrange for the import method we generate to
 152     # set this variable to the caller each time it is called.
 153     #
 154     # This is all a bit confusing, but it works.
 155     my $CALLER;
 156
 157     sub _make_wrapped_sub {
 158         shift;
 159         my $fq_name         = shift;
 160         my $sub             = shift;
 161         my $export_recorder = shift;
 162
 163
 164         # We need to set the package at import time, so that when
 165         # package Foo imports has(), we capture "Foo" as the
 166         # package. This lets other packages call Foo::has() and get
 167         # the right package. This is done for backwards compatibility
 168         # with existing production code, not because this is a good
 169         # idea ;)
 170         return sub {
 171             my $caller = $CALLER;
 172
 173             my $sub = Class::MOP::subname( $fq_name => sub { $sub->( $caller, @_ ) } );
 174
 175             $export_recorder->{$sub} = 1;
 176
 177             return $sub;
 178         };
 179     }
 180
 181     sub _make_import_sub {
 182         shift;
 183         my $exporting_package = shift;
 184         my $exporter          = shift;
 185         my $exports_from      = shift;
 186         my $export_to_main    = shift;
 187
 188         return sub {
 189             # I think we could use Sub::Exporter's collector feature
 190             # to do this, but that would be rather gross, since that
 191             # feature isn't really designed to return a value to the
 192             # caller of the exporter sub.
 193             #
 194             # Also, this makes sure we preserve backwards compat for
 195             # _get_caller, so it always sees the arguments in the
 196             # expected order.
 197             my $traits;
 198             ($traits, @_) = Moose::Exporter::_strip_traits(@_);
 199
 200             # Normally we could look at $_[0], but in some weird cases
 201             # (involving goto &Moose::import), $_[0] ends as something
 202             # else (like Squirrel).
 203             my $class = $exporting_package;
 204
 205             $CALLER = Moose::Exporter::_get_caller(@_);
 206
 207             # this works because both pragmas set $^H (see perldoc
 208             # perlvar) which affects the current compilation -
 209             # i.e. the file who use'd us - which is why we don't need
 210             # to do anything special to make it affect that file
 211             # rather than this one (which is already compiled)
 212
 213             strict->import;
 214             warnings->import;
 215
 216             # we should never export to main
 217             if ( $CALLER eq 'main' && ! $export_to_main ) {
 218                 warn
 219                     qq{$class does not export its sugar to the 'main' package.\n};
 220                 return;
 221             }
 222
 223             my $did_init_meta;
 224             for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
 225
 226                 $c->init_meta( for_class => $CALLER );
 227                 $did_init_meta = 1;
 228             }
 229
 230             if ( $did_init_meta && @{$traits} ) {
 231                 _apply_meta_traits( $CALLER, $traits );
 232             }
 233             elsif ( @{$traits} ) {
 234                 confess
 235                     "Cannot provide traits when $class does not have an init_meta() method";
 236             }
 237
 238             goto $exporter;
 239         };
 240     }
 241 }
 242
 243 sub _strip_traits {
 244     my $idx = first_index { $_ eq '-traits' } @_;
 245
 246     return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
 247
 248     my $traits = $_[ $idx + 1 ];
 249
 250     splice @_, $idx, 2;
 251
 252     $traits = [ $traits ] unless ref $traits;
 253
 254     return ( $traits, @_ );
 255 }
 256
 257 sub _apply_meta_traits {
 258     my ( $class, $traits ) = @_;
 259
 260     return unless @{$traits};
 261
 262     my $meta = $class->meta();
 263
 264     my $type = ( split /::/, ref $meta )[-1]
 265         or confess
 266         'Cannot determine metaclass type for trait application . Meta isa '
 267         . ref $meta;
 268
 269     my @resolved_traits
 270         = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
 271         @$traits;
 272
 273     return unless @resolved_traits;
 274
 275     Moose::Util::MetaRole::apply_metaclass_roles(
 276         for_class       => $class,
 277         metaclass_roles => \@resolved_traits,
 278     );
 279 }
 280
 281 sub _get_caller {
 282     # 1 extra level because it's called by import so there's a layer
 283     # of indirection
 284     my $offset = 1;
 285
 286     return
 287           ( ref $_[1] && defined $_[1]->{into} ) ? $_[1]->{into}
 288         : ( ref $_[1] && defined $_[1]->{into_level} )
 289         ? caller( $offset + $_[1]->{into_level} )
 290         : caller($offset);
 291 }
 292
 293 sub _make_unimport_sub {
 294     shift;
 295     my $exporting_package = shift;
 296     my $exports           = shift;
 297     my $export_recorder   = shift;
 298
 299     return sub {
 300         my $caller = scalar caller();
 301         Moose::Exporter->_remove_keywords(
 302             $caller,
 303             [ keys %{$exports} ],
 304             $export_recorder,
 305         );
 306     };
 307 }
 308
 309 sub _remove_keywords {
 310     shift;
 311     my $package          = shift;
 312     my $keywords         = shift;
 313     my $recorded_exports = shift;
 314
 315     no strict 'refs';
 316
 317     foreach my $name ( @{ $keywords } ) {
 318
 319         if ( defined &{ $package . '::' . $name } ) {
 320             my $sub = \&{ $package . '::' . $name };
 321
 322             # make sure it is from us
 323             next unless $recorded_exports->{$sub};
 324
 325             # and if it is from us, then undef the slot
 326             delete ${ $package . '::' }{$name};
 327         }
 328     }
 329 }
 330
 331 1;
 332
 333 __END__
 334
 335 =head1 NAME
 336
 337 Moose::Exporter - make an import() and unimport() just like Moose.pm
 338
 339 =head1 SYNOPSIS
 340
 341   package MyApp::Moose;
 342
 343   use strict;
 344   use warnings;
 345
 346   use Moose ();
 347   use Moose::Exporter;
 348
 349   Moose::Exporter->setup_import_methods(
 350       with_caller => [ 'sugar1', 'sugar2' ],
 351       as_is       => [ 'sugar3', \&Some::Random::thing ],
 352       also        => 'Moose',
 353   );
 354
 355   # then later ...
 356   package MyApp::User;
 357
 358   use MyApp::Moose;
 359
 360   has 'name';
 361   sugar1 'do your thing';
 362   thing;
 363
 364   no MyApp::Moose;
 365
 366 =head1 DESCRIPTION
 367
 368 This module encapsulates the logic to export sugar functions like
 369 C<Moose.pm>. It does this by building custom C<import> and C<unimport>
 370 methods for your module, based on a spec your provide.
 371
 372 It also lets your "stack" Moose-alike modules so you can export
 373 Moose's sugar as well as your own, along with sugar from any random
 374 C<MooseX> module, as long as they all use C<Moose::Exporter>.
 375
 376 =head1 METHODS
 377
 378 This module provides two public methods:
 379
 380 =head2 Moose::Exporter->setup_import_methods(...)
 381
 382 When you call this method, C<Moose::Exporter> build custom C<import>
 383 and C<unimport> methods for your module. The import method will export
 384 the functions you specify, and you can also tell it to export
 385 functions exported by some other module (like C<Moose.pm>).
 386
 387 The C<unimport> method cleans the callers namespace of all the
 388 exported functions.
 389
 390 This method accepts the following parameters:
 391
 392 =over 4
 393
 394 =item * with_caller => [ ... ]
 395
 396 This a list of function I<names only> to be exported wrapped and then
 397 exported. The wrapper will pass the name of the calling package as the
 398 first argument to the function. Many sugar functions need to know
 399 their caller so they can get the calling package's metaclass object.
 400
 401 =item * as_is => [ ... ]
 402
 403 This a list of function names or sub references to be exported
 404 as-is. You can identify a subroutine by reference, which is handy to
 405 re-export some other module's functions directly by reference
 406 (C<\&Some::Package::function>).
 407
 408 =item * also => $name or \@names
 409
 410 This is a list of modules which contain functions that the caller
 411 wants to export. These modules must also use C<Moose::Exporter>. The
 412 most common use case will be to export the functions from C<Moose.pm>.
 413
 414 C<Moose::Exporter> also makes sure all these functions get removed
 415 when C<unimport> is called.
 416
 417 =back
 418
 419 =head2 Moose::Exporter->build_import_methods(...)
 420
 421 Returns two code refs, one for import and one for unimport.
 422
 423 Used by C<setup_import_methods>.
 424
 425 =head1 IMPORTING AND init_meta
 426
 427 If you want to set an alternative base object class or metaclass
 428 class, simply define an C<init_meta> method in your class. The
 429 C<import> method that C<Moose::Exporter> generates for you will call
 430 this method (if it exists). It will always pass the caller to this
 431 method via the C<for_class> parameter.
 432
 433 Most of the time, your C<init_meta> method will probably just call C<<
 434 Moose->init_meta >> to do the real work:
 435
 436   sub init_meta {
 437       shift; # our class name
 438       return Moose->init_meta( @_, metaclass => 'My::Metaclass' );
 439   }
 440
 441 =head1 METACLASS TRAITS
 442
 443 The C<import> method generated by C<Moose::Exporter> will allow the
 444 user of your module to specify metaclass traits in a C<-traits>
 445 parameter passed as part of the import:
 446
 447   use Moose -traits => 'My::Meta::Trait';
 448
 449   use Moose -traits => [ 'My::Meta::Trait', 'My::Other::Trait' ];
 450
 451 These traits will be applied to the caller's metaclass
 452 instance. Providing traits for an exporting class that does not create
 453 a metaclass for the caller is an error.
 454
 455 =head1 AUTHOR
 456
 457 Dave Rolsky E<lt>autarch@urth.orgE<gt>
 458
 459 This is largely a reworking of code in Moose.pm originally written by
 460 Stevan Little and others.
 461
 462 =head1 COPYRIGHT AND LICENSE
 463
 464 Copyright 2008 by Infinity Interactive, Inc.
 465
 466 L<http://www.iinteractive.com>
 467
 468 This library is free software; you can redistribute it and/or modify
 469 it under the same terms as Perl itself.
 470
 471 =cut