File Coverage

blib/lib/Modern/PBP/Perl.pm

Criterion	Covered	Total	%
statement	73	101	72.2
branch	8	26	30.7
condition	1	3	33.3
subroutine	13	14	92.8
pod			n/a
total	95	144	65.9

# ##############################################################################
# # Script     : Modern::PBP::Perl                                             #
# # -------------------------------------------------------------------------- #
# # Copyright  : Free under 'GNU General Public License' or 'Artistic License' #
# # Authors    : JVBSOFT - Jürgen von Brietzke                   0.001 - 1.240 #
# # Version    : 1.240                                             23.Mai.2016 #
# # -------------------------------------------------------------------------- #
# # Function   : Loading pragmas and Modules for 'Perl Best Practices'.        #
# # -------------------------------------------------------------------------- #
# # Language   : PERL 5                                (V) 5.12.xx  -  5.24.xx #
# # Coding     : ISO 8859-15 / Latin-9                        UNIX-lineendings #
# # Standards  : Perl-Best-Practices                       severity 1 (brutal) #
# # -------------------------------------------------------------------------- #
# # Pragmas    : feature, mro, strict, version, warnings                       #
# # -------------------------------------------------------------------------- #
# # Module     : Carp                                   ActivePerl-CORE-Module #
# #              English                                                       #
# #              Exporter                                                      #
# #              IO::File                                                      #
# #              IO::Handle                                                    #
# #              ------------------------------------------------------------- #
# #              Perl::Version                          ActivePerl-REPO-Module #
# ##############################################################################

package Modern::PBP::Perl 1.240;

# ##############################################################################

use 5.012;

use feature ();
use mro     ();
use strict;
use version;
use warnings;

use Carp;
use English qw{-no_match_vars};
use Exporter;
use IO::File;
use IO::Handle;
use Perl::Version;

# ##############################################################################
# # Feature/Warnings-Table : Contains all the features available to Perl 5.24  #
# # -------------------------------------------------------------------------- #
# # 5.xx  <->  Feature is included in the feature tag ( ':5.xx' )              #
# # ++++  <->  Feature can be switched on in Perl version                      #
# # ----  <->  Feature is not implemented in the Perl version                  #
# ##############################################################################

                                                                      ## no tidy
# ------ Perl-Version ---- 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 -------------
our %FEATURES = (
   array_base      => [qw( 5.10 5.12 5.14 ++++ ++++ ++++ ++++ ++++ )],
   bitwise         => [qw( ---- ---- ---- ---- ---- ---- ++++ ++++ )],
   current_sub     => [qw( ---- ---- ---- 5.16 5.18 5.20 5.22 5.24 )],
   evalbytes       => [qw( ---- ---- ---- 5.16 5.18 5.20 5.22 5.24 )],
   fc              => [qw( ---- ---- ---- 5.16 5.18 5.20 5.22 5.24 )],
   lexical_subs    => [qw( ---- ---- ---- ---- ++++ ++++ ++++ ++++ )],
   postderef       => [qw( ---- ---- ---- ---- ---- ++++ ++++ ++++ )],
   postderef_qq    => [qw( ---- ---- ---- ---- ---- ++++ ++++ 5.24 )],
   refaliasing     => [qw( ---- ---- ---- ---- ---- ---- ++++ ++++ )],
   say             => [qw( 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 )],
   signatures      => [qw( ---- ---- ---- ---- ---- ++++ ++++ ++++ )],
   state           => [qw( 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 )],
   switch          => [qw( 5.10 5.12 5.14 5.16 5.18 5.20 5.22 5.24 )],
   unicode_eval    => [qw( ---- ---- ---- 5.16 5.18 5.20 5.22 5.24 )],
   unicode_strings => [qw( ---- 5.12 5.14 5.16 5.18 5.20 5.22 5.24 )],
);

our %WARNINGS = (
   autoderef       => [qw( ---- ---- ---- ---- ---- 5.20 5.22 ---- )],
   bitwise         => [qw( ---- ---- ---- ---- ---- ---- 5.22 5.24 )],
   const_attr      => [qw( ---- ---- ---- ---- ---- ---- 5.22 5.24 )],
   lexical_subs    => [qw( ---- ---- ---- ---- 5.18 5.20 5.22 5.24 )],
   lexical_topic   => [qw( ---- ---- ---- ---- 5.18 5.20 5.22 ---- )],
   postderef       => [qw( ---- ---- ---- ---- ---- 5.20 5.22 5.24 )],
   re_strict       => [qw( ---- ---- ---- ---- ---- ---- 5.22 5.24 )],
   refaliasing     => [qw( ---- ---- ---- ---- ---- ---- 5.22 5.24 )],
   regex_sets      => [qw( ---- ---- ---- ---- 5.18 5.20 5.22 5.24 )],
   signatures      => [qw( ---- ---- ---- ---- ---- 5.20 5.22 5.24 )],
   smartmatch      => [qw( ---- ---- ---- ---- 5.18 5.20 5.22 5.24 )],
);                                                                   ## 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[024])$/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;

} ## end of sub import
                                        ## use critic qw{RequireUseOfExceptions}

# ##############################################################################
# # Function  | Removes all experimental features a version of Perl.           #
# # ----------+--------------------------------------------------------------- #
# # Parameter | none                                                           #
# # ----------+--------------------------------------------------------------- #
# # Result    | none                                                           #
# ##############################################################################

sub unimport {                          ## no critic qw(ProhibitBuiltinHomonyms)

   warnings->unimport;
   strict->unimport;
   feature->unimport;

   return;

} ## end of sub unimport

# ##############################################################################
# #                                   E N D                                    #
# ##############################################################################
1;
__END__