File Coverage

blib/lib/Perl/Modern/Perl.pm

Criterion	Covered	Total	%
statement	58	79	73.4
branch	9	26	34.6
condition			n/a
subroutine	10	11	90.9
pod			n/a
total	77	116	66.3

# ##############################################################################
# # Script     : Perl::Modern::Perl                                            #
# # -------------------------------------------------------------------------- #
# # Copyright  : Frei unter GNU General Public License  bzw.  Artistic License #
# # Authors    : JVBSOFT - Jürgen von Brietzke                   0.001 - 1.006 #
# # Version    : 1.006                                             20.Dez.2015 #
# # -------------------------------------------------------------------------- #
# # Function   : Lädt alle Features der aktuellen benutzten Perl-Version.      #
# # -------------------------------------------------------------------------- #
# # Language   : PERL 5                                (V) 5.12.xx  -  5.22.xx #
# # Coding     : ISO 8859-15 / Latin-9                         UNIX-Zeilenende #
# # Standards  : Perl-Best-Practices                       severity 1 (brutal) #
# # -------------------------------------------------------------------------- #
# # Pragmas    : feature, mro, strict, version, warnings                       #
# # -------------------------------------------------------------------------- #
# # Module     : Carp                                   ActivePerl-CORE-Module #
# #              English                                                       #
# #              ------------------------------------------------------------- #
# #              Perl::Version                          ActivePerl-REPO-Module #
# ##############################################################################

package Perl::Modern::Perl 1.006;

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

use 5.012;

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

use Carp;
use English qw{-no_match_vars};
use Perl::Version;

# ##############################################################################
# # Feature/Warnings-Table : Enthaelt alle verfuegbaren Features bis Perl 5.22 #
# # -------------------------------------------------------------------------- #
# # 5.xx  <->  Feature ist im Feature-Tag enthalten ( ':5.xx' )                #
# # ++++  <->  Feature ist in der Perl-Version zuschaltbar                     #
# # ----  <->  Feature ist in der Perl-Version nicht implementiert             #
# ##############################################################################

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

our %WARNINGS = (
# ----- Perl-Version ------ 5.10 5.12 5.14 5.16 5.18 5.20 5.22 -----------------
   autoderef       => [ qw( ---- ---- ---- ---- ---- 5.20 5.22 ) ],
   bitwise         => [ qw( ---- ---- ---- ---- ---- ---- 5.22 ) ],
   const_attr      => [ qw( ---- ---- ---- ---- ---- ---- 5.22 ) ],
   lexical_subs    => [ qw( ---- ---- ---- ---- 5.18 5.20 5.22 ) ],
   lexical_topic   => [ qw( ---- ---- ---- ---- 5.18 5.20 5.22 ) ],
   postderef       => [ qw( ---- ---- ---- ---- ---- 5.20 5.22 ) ],
   re_strict       => [ qw( ---- ---- ---- ---- ---- ---- 5.22 ) ],
   refaliasing     => [ qw( ---- ---- ---- ---- ---- ---- 5.22 ) ],
   regex_sets      => [ qw( ---- ---- ---- ---- 5.18 5.20 5.22 ) ],
   signatures      => [ qw( ---- ---- ---- ---- ---- 5.20 5.22 ) ],
   smartmatch      => [ qw( ---- ---- ---- ---- 5.18 5.20 5.22 ) ],
);

# ##############################################################################
# # Aufgabe   | Importiert die experimentellen Features einer Perl-Version.    #
# # ----------+ -------------------------------------------------------------- #
# # Aufruf    | use Perl::Features qw( [ 5.22 [ say [ -state ... ] ] ] );      #
# #           | -------------------------------------------------------------- #
# #           | Importiert alle Featurs von Perl 5.22 ausser 'say' und 'state. #
# # ----------+--------------------------------------------------------------- #
# # Rückgabe  | keine                                                          #
# ##############################################################################

sub import {

   my ( $class, $version, @delete_features_or_warnings ) = @ARG;

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

   # --- Aktuelle PERL-Version bestimmen und Feature-Tag bilden ----------------
   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";
   }

   # --- Versions-String pruefen und Feature-Tag bilden ------------------------
   if ( not $version ) {
      $version = $actual_perl_version;
   }
   if ( $version =~ /^5[.](?:1[13579]|2[13])$/ismx ) {
      confess "Developers version ($version) not supports\n";
   }
   if ( $version =~ /^5[.](1[02468]|2[02])$/ismx ) {
      $use_perl_version = "5.0$1";
      $version_idx      = $1 / 2 - 5;
      $version_tag      = ":$version";
   }
   else {
      confess "Version ($version) not supports\n";
   }

   # --- Testen ob die aktuelle PERL-Version groesser gleich 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";
   }

   # --- PERL-Version aktivieren und Features importieren ----------------------
   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' );

   # --- Zusatz-Features importieren -------------------------------------------
   foreach my $feature ( keys %FEATURES ) {
      if ( $FEATURES{$feature}->[$version_idx] eq '++++' ) {
         feature->import($feature);
      }
   }

   # --- Warnmeldung fuer importierte Features ausschalten ---------------------
   foreach my $warning ( keys %WARNINGS ) {
      if ( $WARNINGS{$warning}->[$version_idx] ne '----' ) {
         warnings->unimport( "experimental::$warning" );
      }
   }

   # --- Einzelne Features entfernen / einzelne Warnungen einschalten ----------
   my $flag;
   foreach my $delete ( @delete_features_or_warnings ) {
      $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";
      }
   }

   return;

}

# ##############################################################################
# # Aufgabe   | Entfernt alle experimentellen Features einer Perl-Version.     #
# # ----------+ -------------------------------------------------------------- #
# # Rückgabe  | keine                                                          #
# ##############################################################################

sub unimport {

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

   return;

}

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