view release on metacpan or  search on metacpan

lib/sanity.pm  view on Meta::CPAN

    push @pragmas, 'postderef_qq' if $main_pragma eq 'postderef';
    push @pragmas, 'smartmatch'   if $main_pragma eq 'switch';

    my @flags;
    foreach my $pragma (@pragmas) {
        push @flags, "-warnings/experimental::$pragma" if "warnings/experimental::$pragma" ~~ @FLAGS;
        push @flags, "feature/$pragma"                 if "feature/$pragma"                ~~ @FLAGS;
    }

    $ALIAS{"experimental/$main_pragma"} = \@flags;
}

# All FATAL warnings have both bits marked (at least in $^{WARNING_BITS}),
# so we'll mimic the same
foreach my $flag ( grep { qr(^warnings/) } @FLAGS ) {
   $ALIAS{"$flag/FATAL"} = [$flag, "MULTI:$flag/FATAL"];
}

# These modules are optional.  Everything else changes the nature
# of how Perl works, or would let you do something that would
# normally fatally error.
my @NON_INSTADIE = (qw(
   overloading
   autovivification
   indirect
   multidimensional
   bareword::filehandles
   criticism
));
# (autovivification probably shouldn't be here, since it actually
# prevents autoviv, but it's generally used as an author tool.)

my $author_load_warned;
sub import {
   my ($class, @args) = @_;

   # See if we need to encode a pragma hash
   my $print_hash  = find_and_remove(qr/^PRINT_PRAGMA_HASH$/, \@args);
   # ... or print flags
   my $print_flags = find_and_remove(qr/^PRINT_FLAGS$/, \@args);

   @args = ($class) unless (@args);
   unshift @args, $class if (all { /^-/ } @args);  # don't be all negative and such
   @args = filter_args(@args);

   if ($print_hash) {
      binmode STDOUT, ':utf8';
      print "use $class '".encode_pragmahash(\@args, '0')."';  # Overly long decimal version\n";
      print "use $class '".encode_pragmahash(\@args, '!')."';  # Safer ASCII version\n";
      print "use $class '".encode_pragmahash(\@args, '¡')."';  # Shorter UTF8 version\n";
      ### TODO: should try to resolve back to the closest alias ###
      exit;
   }
   if ($print_flags) {
      print join("\n", @args)."\n";
      exit;
   }

   # Look for every indicator that proves that the user is in the distro directory
   # and appears to be one of the coders
   my $author_mode = !!((caller)[1] =~ /^(?:x?t|b?lib)[\/\\]/ && (-d '.git' or -d '.svn'));
   $author_mode = 0 if (grep {
      $ENV{"PERL5_${_}_IS_RUNNING"} || $ENV{"PERL5_${_}_IS_RUNNING_IN_RECURSION"}
   } (qw/CPANM CPANP CPANPLUS CPAN/) );

   # Process order:
   #    v5.##.##
   #    utf8
   #    mro
   #    strict
   #    warnings
   #    feature
   #    ...anything else...
   #    namespace::clean
   #    namespace::functions (always last)
   # (If this needs to be changed, let me know and I can reorder it)

   # Perl version
   if ( my @perl_version = find_and_remove(qr/^BITMAP:perl\b/, \@args) ) {
      my $bitmap = args2bitmask(@perl_version) >> $FLAGS{'BITMAP:perl/0'};
      my $mj = ($bitmap >> 4) + 8;
      my $mn = $bitmap % 16 - 1;

      eval "use v5.$mj.$mn";
   }

   my @init = find_and_remove(qr/^(?:utf8|mro|strict|warnings|feature)\b/, \@args);
   my @end  = find_and_remove(qr/^namespace::(clean|functions)\b/, \@args);
   my @mod_list = uniq map { (/^(?:[A-Z]+\:(?!\:))?([\w\:]+)/)[0] } (@init, sort(@args), @end);
   unshift @args, @init;
   push    @args, @end;

   my @failed;
   foreach my $module (@mod_list) {
      my $success = load_pragma('import', find_and_remove(qr/^(?:[A-Z]+\:(?!\:))?$module\b/, \@args) );
      unless (defined $success) {
         require $module unless ($module ~~ @NON_INSTADIE);  # death by suicide (which prints the proper error msg)
         push @failed, $module;
      }
   }

   if (@failed and $author_mode and not $author_load_warned++) {
      my $failed = join ' ', @failed;
      warn <<EOE;
Detected current environment to be in "author mode" but couldn't load all
modules. Missing (author) modules were:

  $failed

You should install these modules via CPAN, but these modules are not
required by your users (unless you add them to your META file).
EOE
   }
}

# This is import with some subtractions and slight changes
sub unimport {
   my ($class, @args) = @_;

   @args = ($class) unless (@args);
   unshift @args, $class if (all { /^-/ } @args);  # don't be all negative and such