view release on metacpan or  search on metacpan

lib/Modern/PBP/Perl.pm  view on Meta::CPAN

   uniprop_wildcards => [qw( ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- 5.30 )],
   vlb               => [qw( ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- 5.30 )],
);                                                                   ## use tidy

# ##############################################################################
# # Function  | Imports all features of a given of the current version of Perl #
# #           | and the pragma 'strict' and 'warnings' and the modules English #
# #           | IO::File and IO::Handle.                                       #
# # ----------+------------+-------------------------------------------------- #
# # Parameter | Str        | Perl version and/or to remove features (optional) #
# # ----------+------------+-------------------------------------------------- #
# # Result    | none                                                           #
# ##############################################################################

sub import {

                                         ## no critic qw{RequireUseOfExceptions}
   my ( $class, @extra_parameters ) = @ARG;

   my ( $actual_perl_version, $use_perl_version, $version_tag, $version_idx );

   # --- Remove control for Perl version of parameters - if any ----------------
   my @version = grep {/^\d[.]\d\d/smx} @extra_parameters;
   @extra_parameters = grep { not /^\d[.]\d\d/smx } @extra_parameters;

   # --- Remove Control for 'English' of parameters - if any -------------------
   my $english_parameter = grep {/^(?:[+]?)match_vars$/smx} @extra_parameters;
   @extra_parameters = grep { not /^(?:[+]?)match_vars$/smx } @extra_parameters;

   # --- Determine current version of Perl -------------------------------------
   if ( $PERL_VERSION =~ /^v5[.](\d\d).+$/smx ) {
      $actual_perl_version = "5.$1";
      $use_perl_version    = "5.0$1";
   }
   else {
      confess "Version '$PERL_VERSION' not detected\n";
   }

   # --- Check the version string and form feature tag -------------------------
   my $version = $version[0] // $actual_perl_version;
   if ( $version =~ /^5[.](1[02468]|2[02468]|3[0])$/ismx ) {
      $use_perl_version = "5.0$1";
      $version_idx      = $1 / 2 - 5;
      $version_tag      = ":$version";
   }
   else {
      confess "Version ($version) not supports\n";
   }

   # --- Test - current version of Perl greater than or equal Feature version --
   my $perl_version    = Perl::Version->new($actual_perl_version);
   my $feature_version = Perl::Version->new($version);
   if ( $perl_version < $feature_version ) {
      confess "Features '$version' in '$actual_perl_version' not available\n";
   }

   # --- Activate Perl version and import features -----------------------------
   my $use = "use qw{$use_perl_version}";
   eval {$use} or confess "Can't execute '$use'\n";
   warnings->import;
   strict->import;
   version->import;
   feature->import($version_tag);
   mro::set_mro( scalar caller(), 'c3' );

   # --- Import additional features --------------------------------------------
   foreach my $feature ( keys %FEATURES ) {
      if ( $FEATURES{$feature}->[$version_idx] eq '++++' ) {
         feature->import($feature);
      }
   }

   # --- Off alerts for imported features --------------------------------------
   foreach my $warning ( keys %WARNINGS ) {
      if ( $WARNINGS{$warning}->[$version_idx] ne '----' ) {
         warnings->unimport("experimental::$warning");
      }
   }

   # --- Remove Individual Features / Turn certain warnings --------------------
   my $flag;
   foreach my $delete (@extra_parameters) {
      $flag = 0;
      $delete =~ s/^(?:[-+]?)(.+)/$1/smx;
      if ( exists $FEATURES{$delete} ) {
         $flag = 1;
         if ( $FEATURES{$delete}->[$version_idx] ne '----' ) {
            feature->unimport($delete);
         }
         else {
            confess "Feature '$delete' in version '$version' not available\n";
         }
      }
      if ( exists $WARNINGS{$delete} ) {
         $flag = 1;
         if ( $WARNINGS{$delete}->[$version_idx] ne '----' ) {
            warnings->import("experimental::$delete");
         }
      }
      if ( not $flag ) {
         confess "Unknown feature/warning for delete '$delete'\n";
      }
   }

   # --- Import 'English' variables --------------------------------------------
   local $Exporter::ExportLevel = 1;        ## no critic qw(ProhibitPackageVars)
   if ($english_parameter) {                                          ## no tidy
      *English::EXPORT = \@English::COMPLETE_EXPORT;
      my $match_vars = q{*English::MATCH     = *&;}
                     . q{*English::PREMATCH  = *`;}
                     . q{*English::POSTMATCH = *';}
                     . q{1;};                                        ## use tidy
      eval {$match_vars} or confess("Can't create English match variablen\n");
   }
   else {
      *English::EXPORT = \@English::MINIMAL_EXPORT;
   }
   Exporter::import('English');

   return;