File Coverage

blib/lib/Perl/Version/Bumper.pm

Criterion	Covered	Total	%
statement	287	307	93.4
branch	135	180	75.0
condition	120	154	77.9
subroutine	42	43	97.6
pod	16	16	100.0
total	600	700	85.7

use v5.10;

package Perl::Version::Bumper;
$Perl::Version::Bumper::VERSION = '0.245';

use strict;
use warnings;
use version;

use Path::Tiny ();
use PPI::Document;
use PPI::Token::Operator;
use PPI::Token::Attribute;
use Carp qw( carp croak );

# CLASS METHODS

my $feature_version;

sub feature_version { $feature_version }

# reconstruct everything we know about every feature
# from the $DATA variable defined at the end of the file
my $FEATURE_DATA;

sub feature_data {
    my %feature;
    for ( grep !/\A(?:=|\z)/, split /\n/, $FEATURE_DATA ) {
        if (/\A *([1-9][0-9.]*)/) {    # header line
            $feature_version = version_fmt($1);
            next;
        }
        my $feature  = substr $_, 0, 33, '';    # %32s
        my $known    = substr $_, 0, 9,  '';    # %-8s
        my $enabled  = substr $_, 0, 9,  '';    # %-8s
        my $disabled = substr $_, 0, 9,  '';    # %-8s
        my $removed  = substr $_, 0, 9,  '';    # %-8s
        my @compat   = split ' ';               # %s
        y/ //d for $feature, $known, $enabled, $disabled;
        $feature{$feature}{known}     = $known;
        $feature{$feature}{enabled}   = $enabled  if $enabled;
        $feature{$feature}{disabled}  = $disabled if $disabled;
        $feature{$feature}{removed}   = $removed  if $removed;
        $feature{$feature}{compat}    = {@compat} if @compat;
        $feature{$feature}{unfeature} = 1         if $disabled;
    }
    return \%feature;
}

my %feature = %{ feature_data() };

# EXPORTABLE FUNCTIONS

use Exporter 'import';

our @EXPORT_OK = qw(
    version_fmt
    version_use
    stable_version
    stable_version_inc
    stable_version_dec
);

# return a normalized version of a plausible Perl version number (or die)
sub version_fmt {
    my $o = shift // $];
    $o = $] unless length $o;
    my $v = version::->parse($o)->numify;    # accept everything
    return $v < 5.010
      ? croak "Unsupported Perl version: $o"
      : sprintf "%.3f", $v;                  # Perl version bundle
}

# return a normalized version, suitable for "use VERSION"
sub version_use {
    my $o = shift // $];
    $o = $] unless length $o;
    my $v = version::->parse($o)->numify;    # accept everything
    return $v < 5.010
      ? croak "Unsupported Perl version: $o"
      : sprintf 'v5.%d', substr( $v, 2, 3 );    # Perl version bundle
}

# return the closest stable version number lower than the parameter
sub stable_version {
    my $v = version_fmt(shift);
    $v *= 1000;
    return sprintf "%.3f", ( int($v) - $v % 2 ) / 1000;
}

# increment the version number to the next stable version
sub stable_version_inc {
    my $v = stable_version(shift);    # closest previous stable
    return sprintf "%.3f", $v + 0.002;
}

# decrement the version number to the previous stable version
sub stable_version_dec {
    my $v = version_fmt(shift);    # format the version
    my $s = stable_version($v);    # get the closest previous stable
    return $v ne $s
      ? $s                         # dev -> previous stable
      : sprintf "%.3f", $s - 0.002 # previous stable
}

# CONSTRUCTOR

sub _feature_in_bundle {
    my $version_num = shift;
    return {
        known => {
            map +( $_ => $feature{$_}{known} ),
            grep exists $feature{$_}{known} && $version_num >= $feature{$_}{known},
            keys %feature
        },
        enabled => {
            map +( $_ => $feature{$_}{enabled} ),
            grep !exists $feature{$_}{disabled} || $version_num < $feature{$_}{disabled},
            grep  exists $feature{$_}{enabled}  && $version_num >= $feature{$_}{enabled},
            keys %feature
        },
        disabled => {
            map +( $_ => $feature{$_}{disabled} ),
            grep exists $feature{$_}{disabled} && $version_num >= $feature{$_}{disabled},
            keys %feature
        },
    };
}

sub new {

    # stolen from Moo::Object
    my $class = shift;
    my $args = scalar @_ == 1
      ? ref $_[0] eq 'HASH'
        ? { %{ $_[0] } }
        : Carp::croak("Single parameters to new() must be a HASH ref"
            . " data => ". $_[0])
      : @_ % 2
        ? Carp::croak("The new() method for $class expects a hash reference or a"
            . " key/value list. You passed an odd number of arguments")
        : {@_}
    ;

    # handle the version attribute
    my $version_arg = $args->{version} // stable_version($]);
    my $version_num = version_fmt( $version_arg );
    croak "Unsupported Perl version: $version_arg (greater than $feature_version)"
      if $version_num > $feature_version;
    croak "$args->{version} is not a stable Perl version"
      if $version_num ne stable_version($version_num);

    return bless {
        version           => version_use($version_num),
        version_num       => $version_num,
        feature_in_bundle => _feature_in_bundle($version_num),
    }, $class;
};

# ATTRIBUTES

sub version { shift->{version} }

sub version_num { shift->{version_num} }

# PRIVATE FUNCTIONS

sub __evaluate {
    map ref()
      ? $_->[0] eq 'CODE'
          ? sub { }    # leave anonymous subs as is
          : $_->[0] eq '[' ? [ __SUB__->( @$_[ 1 .. $#$_ ] ) ]    # ARRAY
        : $_->[0] eq '{' ? { __SUB__->( @$_[ 1 .. $#$_ ] ) }      # HASH
        : __SUB__->( @$_[ 1 .. $#$_ ] )    # LIST (flattened)
      : $_,                                # SCALAR
      @_;
}

# given a list of PPI tokens, construct a Perl data structure
sub _ppi_list_to_perl_list {

    # are there constants we ought to know about?
    my $constants = ref $_[-1] eq 'HASH' ? pop @_ : {};

    # make sure we have tokens (i.e. deconstruct Statement and Structure objects)
    my @tokens = grep $_->significant, map $_->tokens, @_;
    my @stack  = my $root = my $ptr = [];
    my $prev;
    while ( my $token = shift @tokens ) {
        if ( $token->isa('PPI::Token::Structure') ) {
            if ( $token =~ /\A[[{(]\z/ ) {    # opening
                $ptr = $token eq '{' && $prev && $prev eq 'sub'    # sub { ... }
                  ? do { pop @{ $stack[-1] }; ['CODE'] }    # drop 'sub' token
                  : ["$token"];
                push @{ $stack[-1] }, $ptr;
                push @stack,          $ptr;
            }
            elsif ( $token =~ /\A[]})]\z/ ) {                      # closing
                pop @stack;
                $ptr = $stack[-1];
            }
        }
        elsif ( $token eq ',' || $token eq '=>' ) { }              # skip
        elsif ( $token->isa('PPI::Token::Symbol') ) {              # variable

            # construct the expression back (and keep the object around)
            my $expr = PPI::Document->new( \join '', $token, @tokens );

            # PPI::Document -> PPI::Statement
            # -> PPI::Token::Symbol (ignored), PPI::Sructure::Subscript (maybe)
            my ( undef, $subscript ) = $expr->child(0)->children;
            if ( $subscript && $subscript->isa('PPI::Structure::Subscript') ) {
                shift @tokens for $subscript->tokens;    # drop subcript tokens
                push @$ptr, "$token$subscript";          # symbol + subscript
            }
            else {
                push @$ptr, "$token";                    # simple symbol
            }
        }
        elsif ($token->isa('PPI::Token::Word')                     # undef
            && $token eq 'undef'
            && ( $tokens[0] ? $tokens[0] ne '=>' : !!1 ) )
        {
            push @$ptr, undef;
        }
        elsif ($token->isa('PPI::Token::HereDoc') ) {              # heredoc
            push @$ptr, join '', $token->heredoc;
        }
        else {
            my $next_sibling = $token->snext_sibling;
            push @$ptr,

              # maybe a known constant?
                exists $constants->{$token} && ( $next_sibling ? $next_sibling ne '=>' : !!1 )
                                        ? $constants->{$token}

              # various types of strings
              : $token->can('literal')  ? $token->literal
              : $token->can('simplify') ? do {
                  my $clone = $token->clone;
                  $clone->simplify && $clone->can('literal')
                                        ? $clone->literal
                                        : "$clone";
                }
              : $token->can('string')   ? $token->string

              # stop at the first operator
              : $token->isa( 'PPI::Token::Operator' ) ? last

              # give up and just stringify
              :                         "$token";
        }
        $prev = $token;
    }
    return __evaluate(@$root);
}

sub _drop_statement {
    my ( $stmt, $keep_comments ) = @_;

    # remove non-significant elements before the statement
    while ( my $prev_sibling = $stmt->previous_sibling ) {
        last if $prev_sibling->significant;
        last if $prev_sibling =~ /\n\z/;
        $prev_sibling->remove;
    }

    # remove non-significant elements after the statement
    # if there was no significant element before it on the same line
    # (i.e. it was the only statement on the line)
    $stmt->document->index_locations;
    if (  !$stmt->sprevious_sibling
        || $stmt->sprevious_sibling->location->[0] ne $stmt->location->[0] )
    {
        # collect non-significant elements until next newline (included)
        my ( $next, @to_drop ) =  ( $stmt );
        while ( $next = $next->next_sibling ) {
            last if $next->significant;
            push @to_drop, $next;
            last if $next eq "\n";
        }

        # do not drop comments if asked to keep them
        @to_drop = grep !$_->isa('PPI::Token::Comment') && $_ ne "\n", @to_drop
          if $keep_comments && grep $_->isa('PPI::Token::Comment'), @to_drop;
        $_->remove for @to_drop;

        $stmt->document->flush_locations;
    }

    # and finally remove it
    $stmt->remove;
}

sub _drop_bare {
   my ( $type, $module, $doc ) = @_;
    my $use_module = $doc->find(
        sub {
            my ( $root, $elem ) = @_;
            return !!1
              if $elem->isa('PPI::Statement::Include')
              && $elem->module eq $module
              && $elem->type eq $type
              && !$elem->arguments;    # bare use module
            return;                    # only top-level
        }
    );
    if ( ref $use_module ) {
        _drop_statement($_) for @$use_module;
    }
    return;
}

sub _find_include {
   my ( $module, $doc, $type ) = @_;
    my $found = $doc->find(
        sub {
            my ( $root, $elem ) = @_;
            return !!1
              if $elem->isa('PPI::Statement::Include')
              && $elem->module eq $module;
            return !!0;
        }
    );
    croak "Bad condition for PPI::Node->find"
      unless defined $found;    # error
    return unless $found;       # nothing found
    return $type ? grep $_->type eq $type, @$found : @$found;
}

sub _version_stmts {
   my ($doc) = @_;
    my $version_stmts = $doc->find(
        sub {
            my ( $root, $elem ) = @_;
            return !!1 if $elem->isa('PPI::Statement::Include') && $elem->version;
            return !!0;
        }
    );
    croak "Bad condition for PPI::Node->find"
      unless defined $version_stmts;
    return $version_stmts ? @$version_stmts : ();
}

my %feature_shine = (
    when_enabled => {

        # the 'bitwise' feature may break bitwise operators,
        # so disable it when bitwise operators are detected
        bitwise => sub {
            my ($doc) = @_;

            # this only matters for code using bitwise ops
            return unless $doc->find(
                sub {
                    my ( $root, $elem ) = @_;
                    $elem->isa('PPI::Token::Operator')
                      && $elem =~ /\A[&|~^]=?\z/;
                }
            );

            # the `use VERSION` inserted earlier is always the first in the doc
            my $insert_point = ( _version_stmts($doc) )[0];
            my $indent = $insert_point->previous_sibling
              && $insert_point->previous_sibling->isa('PPI::Token::Whitespace')
              ? $insert_point->previous_sibling
              : '';
            my $no_feature_bitwise =
              PPI::Document->new( \"no feature 'bitwise';\n" );
            $insert_point->insert_after( $_->remove )
              for $no_feature_bitwise->elements;

            # also add an IMPORTANT comment to warn users
            $insert_point = $insert_point->snext_sibling;
            my $todo_comment = PPI::Document->new( \( << "TODO_COMMENT" ) );

$indent# IMPORTANT: Please double-check the use of bitwise operators
$indent# before removing the `no feature 'bitwise';` line below.
$indent# See manual pages 'feature' (section "The 'bitwise' feature")
$indent# and 'perlop' (section "Bitwise String Operators") for details.
TODO_COMMENT
            $insert_point->insert_before( $_->remove )
              for $todo_comment->elements;
            $insert_point->insert_before( $indent->clone ) if $indent;
        },

        # the 'signatures' feature needs prototypes to be updated.
        signatures => sub {
            my ($doc) = @_;

            # find all subs with prototypes
            my $prototypes = $doc->find('PPI::Token::Prototype');
            return unless $prototypes;

            # and turn them into prototype attributes
            for my $proto (@$prototypes) {
                $proto->insert_before( PPI::Token::Operator->new(':') );
                $proto->insert_before(
                    PPI::Token::Attribute->new("prototype$proto") );
                $proto->remove;
            }
        },

        # the 'fc' feature means CORE::fc is not required
        fc => sub {
            my ($doc) = @_;

            # find all occurences of 'CORE::fc'
            my $core_fc = $doc->find(
                sub {
                    my ( $root, $elem ) = @_;
                    return !!1
                      if $elem->isa('PPI::Token::Word') && $elem eq 'CORE::fc';
                    return !!0;
                }
            );
            return unless $core_fc;

            # and replace them by 'fc'
            $_->replace( PPI::Token::Word->new('fc') ) for @$core_fc;
        },
    },

    when_disabled => {

        # disabling the 'apostrophe_as_package_separator' feature
        # drops support for apostrophe in package names
        apostrophe_as_package_separator => sub {
            my ($doc) = @_;

            # find all names with an apostrophe
            my $apostrophes = $doc->find(
                sub {
                    my ( $root, $elem ) = @_;
                    $elem->isa('PPI::Token::Word') && $elem =~ /'/;
                }
            );
            return unless $apostrophes;

            # and replace it with double colons
            for my $word (@$apostrophes) {
                ( my $colon = "$word" ) =~ s/'/::/g;
                $word->replace( bless { content => $colon },
                    'PPI::Token::Word' );
            }
        },
    },

);

# PRIVATE "METHODS"

# handle the case of CPAN modules that serve as compatibility layer for some
# features on older Perls, or that existed before the feature was developed
sub _handle_compat_modules {
    my ( $self, $doc ) = @_;
    my $feature_in_bundle = $self->{feature_in_bundle};
    for my $feature ( grep exists $feature{$_}{compat}, keys %feature ) {
        for my $compat ( keys %{ $feature{$feature}{compat} } ) {
            for my $include_compat ( _find_include( $compat => $doc ) ) {

                # handle `no $compat;`
                if ( $include_compat->type eq 'no' ) {

                    # if the feature is known and not disabled
                    # and the compat module has an unimport() sub
                    if (   exists $feature_in_bundle->{known}{$feature}
                        && !exists $feature_in_bundle->{disabled}{$feature}
                        && $feature{$feature}{compat}{$compat} <= 0 )
                    {
                        my $no_feature = # feature enabled, and not disabled yet
                          PPI::Document->new( \"no feature '$feature';\n" );
                        $include_compat->insert_after( $_->remove )
                          for $no_feature->elements;
                    }

                    # some compat modules have no unimport() sub
                    # so we drop the useless `no $compat`
                    _drop_statement($include_compat)
                      if exists $feature_in_bundle->{known}{$feature}
                      || $feature{$feature}{compat}{$compat} > 0;
                }

                # handle `use $compat;`
                if ( $include_compat->type eq 'use' ) {
                    my $drop_stmt;    # should we drop the old statement?

                    # if the feature is known and not enabled or an unfeature
                    # and the compat module has an import() sub
                    if (   exists $feature_in_bundle->{known}{$feature}
                        && (  !exists $feature_in_bundle->{enabled}{$feature}
                            || exists $feature{$feature}{unfeature} )
                        && $feature{$feature}{compat}{$compat} >= 0 )
                    {
                        my $use_feature =
                          PPI::Document->new( \"use feature '$feature';\n" );
                        $include_compat->insert_after( $_->remove )
                          for $use_feature->elements;
                        $drop_stmt++;    # it's been replaced
                    }

                    # backward compatibility features, like 'indirect',
                    # can be enabled before being known
                    # (also handle the unlikely case where there's no import())
                    $drop_stmt++
                      if !exists $feature{$feature}{unfeature}
                      && ( exists $feature_in_bundle->{enabled}{$feature}
                        || $feature{$feature}{compat}{$compat} < 0 );

                    _drop_statement($include_compat) if $drop_stmt;
                }
            }
        }
    }
}

sub _cleanup_bundled_features {
    my ( $self, $doc, $old_num ) = @_;
    my $version_num       = $self->version_num;
    my $feature_in_bundle = $self->{feature_in_bundle};
    my ( %enabled_in_code, %disabled_in_code );

    # drop features enabled in this bundle
    # (also if they were enabled with `use experimental`)
    for my $module (qw( feature experimental )) {
        for my $use_line ( _find_include( $module => $doc, 'use' ) ) {
            my @old_args = _ppi_list_to_perl_list( $use_line->arguments );
            $enabled_in_code{$_}++ for @old_args;
            my @new_args =    # keep enabling features that
              grep !exists $feature_in_bundle->{enabled}{$_}    # are not enabled yet
                 || exists $feature{$_}{unfeature},             # or are unfeatures
              grep exists $feature{$_},                         # and actually exist
              @old_args;
            next if @new_args == @old_args;    # nothing to change
            if (@new_args) {    # replace old statement with a smaller one
                my $new_use_line = PPI::Document->new(
                    \"use $module @{[ join ', ', map qq{'$_'}, @new_args]};" );
                $use_line->insert_before( $_->remove )
                  for $new_use_line->elements;
                $use_line->remove;
            }
            else { _drop_statement($use_line); }
        }
    }

    # deal with compat modules
    $self->_handle_compat_modules($doc);

    # drop disabled features that are not part of the bundle
    # (also if they were disabled with `no experimental`)
    for my $module (qw( feature experimental )) {
        for my $no_feature ( _find_include( $module => $doc, 'no' ) ) {
            my @old_args = _ppi_list_to_perl_list( $no_feature->arguments );
            $disabled_in_code{$_}++ for @old_args;
            my @new_args =                # keep disabling features
              grep exists $feature{$_}    # that actually exist and are
              && !exists $feature_in_bundle->{disabled}{$_},    # not disabled yet
              @old_args;
            next if @new_args == @old_args;                     # nothing to change
            if (@new_args) {    # replace old statement with a smaller one
                my $new_no_feature = PPI::Document->new(
                    \"no $module @{[ join ', ', map qq{'$_'}, @new_args]};" );
                $no_feature->insert_before( $_->remove )
                  for $new_no_feature->elements;
                $no_feature->remove;
            }
            else { _drop_statement($no_feature); }
        }
    }

    # apply some feature shine when crossing the feature enablement boundary
    for my $feature ( sort keys %{ $feature_shine{when_enabled} }  ) {
        my $feature_enabled = $feature{$feature}{enabled};
        $feature_shine{when_enabled}{$feature}->($doc)
          if $old_num < $feature_enabled         # code from before the feature
          && $version_num >= $feature_enabled    # bumped to after the feature
          && !$enabled_in_code{$feature}         # not enabling the feature
          && !$disabled_in_code{$feature};       # and not disabling the feature
    }

    # apply some feature shine when crossing the feature disablement boundary
    for my $feature ( sort keys %{ $feature_shine{when_disabled} }  ) {
        my $feature_disabled = $feature{$feature}{disabled};
        $feature_shine{when_disabled}{$feature}->($doc)
          if $old_num < $feature_disabled        # code from before the feature
          && $version_num >= $feature_disabled   # bumped to after the feature
          && !$enabled_in_code{$feature}         # not enabling the feature
          && !$disabled_in_code{$feature};       # and not disabling the feature
    }

    # drop experimental warnings, if any
    for my $warn_line ( _find_include( warnings => $doc, 'no' ) ) {
        my @old_args = _ppi_list_to_perl_list( $warn_line->arguments );
        next unless grep /\Aexperimental::/, @old_args;
        my @new_args = grep {
            ( my $feature = $_ ) =~ s/\Aexperimental:://;
            !exists $feature_in_bundle->{enabled}{$feature};
          }
          grep /\Aexperimental::/, @old_args;
        my @keep_args = grep !/\Aexperimental::/, @old_args;
        next if @new_args == @old_args    # nothing to remove
          || @new_args + @keep_args == @old_args;
        if ( @new_args || @keep_args ) {    # replace old statement
            my $new_warn_line = PPI::Document->new(
                \"no warnings @{[ join ', ', map qq{'$_'}, @new_args, @keep_args]};"
            );
            $warn_line->insert_before( $_->remove )
              for $new_warn_line->elements;
            $warn_line->remove;
        }
        else { _drop_statement($warn_line); }
    }

    # strict is automatically enabled with 5.12
    _drop_bare( use => strict => $doc ) if $version_num >= 5.012;

    # warnings are automatically enabled with 5.36
    _drop_bare( use => warnings => $doc ) if $version_num >= 5.036;

    return;
}

sub _insert_version_stmt {
    my ( $self, $doc, $old_num ) = @_;
    $old_num //= 5.008;
    my $version_stmt =
      PPI::Document->new( \sprintf "use %s;\n", $self->version );
    my $insert_point = $doc->schild(0) // $doc->child(0);
    return unless defined $insert_point;    # empty document

    # record the indent before the next significant sibling
    # (unless it's a version statement: it will be removed,
    # and this version statement will replace it)
    my $indent;
    $indent = $insert_point->previous_sibling
      if $insert_point->previous_sibling
      && $insert_point->previous_sibling->isa('PPI::Token::Whitespace')
      && !($insert_point->isa('PPI::Statement::Include') && $insert_point->version );

    # put the use VERSION LINE at the top of the file
    if ( $insert_point->significant ) {
        $insert_point->insert_before( $_->remove ) for $version_stmt->elements;
        $insert_point->insert_before( $indent->clone ) if $indent;
    }
    else {
        $doc->add_element( $_->remove ) for $version_stmt->elements;
    }

    # cleanup features enabled or disabled by the new version
    _cleanup_bundled_features( $self, $doc, $old_num );
}

sub _try_compile_file {
    my ( $file, $env ) = @_;
    $env //= {};

    # redirect STDERR for quietness
    my $tmperr = Path::Tiny->tempfile;
    open( \*OLDERR, '>&', \*STDERR ) or die "Can't dup STDERR: $!";
    open( \*STDERR, '>',  $tmperr )  or die "Can't re-open STDERR: $!";

    # setup a local environment
    local %ENV = %ENV;
    $ENV{$_} = $env->{$_} for keys %$env;

    # try to compile the file
    my $status = system $^X, '-c', $file;
    my $exit = $status >> 8;

    # get STDERR back, and warn about errors while compiling
    open( \*STDERR, '>&', \*OLDERR ) or die "Can't restore STDERR: $!";
    warn $tmperr->slurp if $exit;

    return !$exit;    # 0 means success
}

# PUBLIC METHOS

sub bump_ppi {
    my ( $self, $doc ) = @_;
    $doc = $doc->clone;
    my $source = $doc->filename // 'input code';

    # found at least one version statement
    if ( my @version_stmts = _version_stmts($doc) ) {

        # bail out if there's more than one `use VERSION`
        if ( @version_stmts > 1 ) {
            carp "Found multiple use VERSION statements in $source:"
              . join ', ', map $_->version, @version_stmts;
        }

        # drop the existing version statement
        # and add the new one at the top
        else {
            my ($use_v) = _version_stmts($doc);    # there's only one
            my $old_num = version::->parse( $use_v->version )->numify;
            if ( $old_num <= $self->version_num ) {
                _insert_version_stmt( $self, $doc, $old_num );
                _drop_statement( $use_v, !!1 );
            }
        }
    }

    # no version statement found, add one
    else { _insert_version_stmt( $self, $doc ); }

    return $doc;
}

sub bump {
    my ( $self, $code, $filename ) = @_;
    my $doc = PPI::Document->new( \$code, filename => $filename );
    $filename //= 'input code';
    croak "Parsing of $filename failed" unless defined $doc;
    return $self->bump_ppi($doc)->serialize;
}

sub bump_file {
    my ( $self, $file ) = @_;
    my $code   = Path::Tiny->new($file)->slurp;
    my $bumped = $self->bump( $code, $file );
    if ( $bumped ne $code ) {
        $file->append( { truncate => 1 }, $bumped );
        return !!1;
    }
    return !!0;
}

# this one is private and returns an array ref with two values:
# the new PPI::Document, and the version it was actually bumped to
sub _bump_ppi_safely {
    my ( $self, $doc, $options ) = @_;
    my $version_limit = $options->{version_limit};
    $version_limit &&= stable_version($version_limit);
    $version_limit //= do {
        my @versions = map eval { version_fmt( $_->version ) },
          _version_stmts($doc);
        $versions[0] // 5.010;
    };

    # try compiling the file: if it fails, our safeguard won't work
    my $source = $doc->filename // 'input code';
    my $tmp    = Path::Tiny->tempfile;
    $tmp->spew( $doc->serialize );
    unless ( _try_compile_file( $tmp, $options->{env} ) ) {
        warn "Can't bump Perl version safely for $source: it does not compile\n";
        return [ $doc->clone, undef ];    # undef means "didn't compile"
    }

    # try bumping down version until it compiles
    my $bumped_doc;
    my $version = $self->version_num;
    while ( $version >= $version_limit or $version = !!0 ) {
        my $perv = $self->version_num eq $version
          ? $self    # no need to create a new object
          : Perl::Version::Bumper->new( version => $version );
        $bumped_doc = $perv->bump_ppi($doc);

        # try to compile the file
        $tmp = Path::Tiny->tempfile;
        $tmp->spew( $bumped_doc->serialize );
        last if _try_compile_file( $tmp, $options->{env} );

        # bump version down and repeat
        $version = stable_version_dec($version);
    }

    return $version ? [ $bumped_doc, $version ] : [ $doc->clone, $version ];
}

sub bump_ppi_safely {
    my ( $self, $doc, $options ) = @_;
    return $self->_bump_ppi_safely( $doc, $options )->[0];
}

sub bump_safely {
    my ( $self, $code, $options ) = @_;
    my $filename = $options->{filename} // 'input code';
    my $doc      = PPI::Document->new( \$code, filename => $filename );
    croak "Parsing of $filename failed" unless defined $doc;
    return $self->_bump_ppi_safely( $doc, $options )->[0]->serialize;
}

sub bump_file_safely {
    my ( $self, $file, $options ) = @_;
    my $doc = PPI::Document->new("$file");    # stringify any object
    croak "Parsing of $file failed" unless defined $doc;
    my ( $bumped_doc, $version ) =
      @{ $self->_bump_ppi_safely( $doc, $options ) };
    Path::Tiny->new($file)->append( { truncate => 1 }, $bumped_doc->serialize )
      if $version;
    return $version;
}

1;

=pod

=head1 NAME

Perl::Version::Bumper - Update C on any Perl code

=head1 SYNOPSIS

    use Perl::Version::Bumper;

    my $perv = Perl::Version::Bumper->new( version => 'v5.36' );

    # bump a PPI::Document
    my $bumped_ppi = $perv->bump_ppi($ppi_doc);

    # bump source code
    my $bumped_code = $perv->bump($code);

    # bump the source of a file
    $perv->bump_file($filename);

    # safe versions (check the result compiles)

    my $bumped_ppi  = $perv->bump_ppi_safely($ppi_doc);
    my $bumped_code = $perv->bump_safely($code);
    $perv->bump_file_safely( $filename, $version_limit );

=head1 DESCRIPTION

C can update Perl code to make it declare it uses
a more recent version of the Perl language by way of C.

It takes care of removing unnecessary loading of L and
L L, and adds the C line at the
top of the file (thus encouraging "line 1 semantics").

It also manages the removal of "compatibility" modules when the feature
they provide a compatibility layer with is fully supported in the target
Perl version.

If the code already declares a Perl version, it can only be bumped
to a higher version.

The module L a few helper functions. These are mostly used
by support tools for this distribution, and are not meant for general use.

=head1 CONSTRUCTOR

=head2 new

    my $perv = Perl::Version::Bumper->new( %attributes );
    my $perv = Perl::Version::Bumper->new( \%attributes );

Return a new C object.

=head1 ATTRIBUTES

=head2 version

The target version to bump to.

Defaults to the stable version less than or equal to the version of the
currenly running C.

The constructor accepts both forms of Perl versions, regular
(e.g. C) and floating-point (e.g. C<5.036>), and will
turn them into a string suitable for C.

To protect against simple mistakes (e.g. passing C<5.36> instead of
C), the constructor does some sanity checking, and checks that
the given version:

=over 4

=item *

is parsable as a Perl version number,

=item *

is greater than or equal to C,

=item *

is lower than the version of the Perl currently running,

=item *

is a stable Perl version.

=back

In case any of the above checks fail, the constructor will die.

The constructor will also silently drop any sub-version information
(so C will be turned into C).

=head1 CLASS METHODS

=head2 feature_version

Return the version (in numeric format) of the feature set recognized
by this module. It is not possible to bump code over that version.

The current value of C is: C<5.042>.

=head2 feature_data

Return a I of the internal data structure containing all the
information about features. That should only be needed for testing
and debugging.

=head1 METHODS

=head2 version_num

Return the L attribute as a number.

=head2 bump_ppi

    my $bumped_ppi_doc = $perv->bump_ppi($ppi_doc);

Take a L as input, and return a I L
with its declared version bumped to L.

=head2 bump

    my $bumped_code = $perv->bump($code);

Take a string containing Perl code as input, bump the declared Perl
version in the source code to L, and return the new source
code as a string.

=head2 bump_file

    $perv->bump_file($filename);

Bump the code of the file argument in-place.

Return a boolean indicating if the file content was modified or not.

=head1 SAFE METHODS

The L, L and L methods previously described
modify the source code they're given, but give I that the
updated code will even compile.

To address this issue, L, L and
L methods work as the regular methods, but will only
produce code that actually compiles.

If all attempts fail, the return value is identical to the input value.

=head2 Example of a safe bump

The following code uses L:

    my %h; $h{ 1, 2 } = 3;    # same as $foo{"1\x{1c}2"} = 3;

L will produce the following when trying to update it to C:

    use v5.40;
    my %h; $h{ 1, 2 } = 3;    # same as $foo{"1\x{1c}2"} = 3;

Which fails to compile with the following error:

    Multidimensional hash lookup is disabled

It's not possible to just bump this code up to C and expect it to
work, because it uses multidimensional array emulation, and the feature
that represents this (C) was disabled in C.
This code will in fact fail to compile with all version bundles greater
or equal to C.

A I to try to bump this code to C is to try with
C, detect it fails to compile, try again with C and
C, which also fail, until we hit C which compiles just
fine (because the C feature is still enabled in that
bundle). Leaving us with the following code:

    use v5.34;
    my %h; $h{ 1, 2 } = 3;    # same as $foo{"1\x{1c}2"} = 3;

The code needs to be updated to I use multidimensional array emulation
before it can I be bumped past version C.

=head2 Process of a safe bump

The process for a safe bump is to take some input, and try to compile it.
If the compilation fails, return immediately.

Otherwise, continue with the process: bump the content, and try to
compile the result. Return as soon as compilation succeeds.

If compilation fails, decrease the target Perl version number, bump
the content to that version, and try to compile the result again. Keep
decreasing the target version, all the way back to the currently
declared version in the document, or L, whichever is more
recent. Give up after the last compilation failure.

=head2 Options for a safe bump

All the methods below take one input argument (a L,
a string of code or a filename) and one optional hash reference
for options.

The possible options are:

=over 4

=item version_limit

The version at which to stop decreasing the target version.
Defaults to C.

=item env

A hash reference of key/value pairs for environment variables
to be set when trying to compile the bumped code.

=back

=head2 bump_ppi_safely

    my $bumped_ppi = $perv->bump_ppi_safely( $ppi_doc, \%options );

Safely bump the source code in the given L.

The return value is a new L containing the result of the
"safe bump" (its content might be the same as the original if there's
no safe way to bump the code).

=head2 bump_safely

    my $bumped_code = $perv->bump_safely( $code, \%options );
    my ( $bumped_code, $new_version ) = $perv->bump_safely($code);

Safely bump the source code given as a string.

The return value is a string containing the new source code.

=head2 bump_file_safely

    $perv->bump_file_safely( $filename, \%options );

Safely bump the code in the file argument in-place. The file will
not be modified if the code can't be bumped safely.

The return value is C if the original didn't compile, false
if all attempts to bump the file failed, and the actual (numerical)
version number the file was bumped to in case of success.

=head1 EXPORTS

The following I can be optionally exported. Be aware that they
are mostly meant for internal use of the module and helper scripts.

=head2 version_fmt

    my $v = version_fmt( $version );

Return the given version (in string, v-string or float format) as a number.

This function will die if the given version is not a plausible Perl
version number, i.e. is strictly lower than C<5.010>.

Note that all the following functions start by normalizing their
argument by calling L, meaning they will die in the same
circumstances.

=head2 version_use

    my $v = version_use( $version );

Return the given version (in string, v-string or float format) as
a string suitable for a C line.

=head2 stable_version

    my $s = stable_version( $version );

Return the closest stable version lower or equal to the given version,
as a number.

=head2 stable_version_inc

    my $n = stable_version_inc( $version );

Return the stable version following the given version, as a number.

=head2 stable_version_dec

    my $p = stable_version_dec( $version );

Return the stable version preceding the given version, as a number.

=head1 VERSION UPGRADE ALGORITHM

For a given version number, a feature has three attributes:

=over 4

=item known

the B I knows about the feature starting from that version.

If it's not known, passing it to C will I during
compilation with C (where
5.x.y is the version of the binary C program).

=item enabled

the feature is enabled starting with the corresponding I bundle
(i.e. C will implicitely enable it).

=item disabled

the feature is disabled starting from the corresponding I bundle
(i.e. C will implicitely disable it).

This is the case for so-called "unfeatures", i.e. constructs that were
deemed undesirable and removed from the language (e.g. C,
C, etc.).

=item removed

the feature was removed starting from the given version.

The only feature that was removed so far is C (in Perl v5.30).

=back

If there is more than one C line in the file, the algorithm
will bail out. Otherwise, the previous C line will be
removed, and a new one added at the top of the file (line 1).

The features that were enabled via C and are part of the
C feature bundle will be removed from the corresponding C
feature> or C lines. The disabling of the corresponding
C warnings will be removed.

"Unfeatures" are treated differently. Unfeatures are features that were
created to represent historical Perl behaviour, and are considered enabled
by default in all bundles until they are disabled at a later stage. If an
unfeature is enabled, it is considered to be for documentation purposes
(to indicate that the undesirable historical feature was used), and
therefore not removed, even if the specified C enables it.

The (un)features that were disabled via C and are disabled
as part of the C feature bundle will be removed from the
corresponding C or C lines.

If compatibility modules (CPAN modules that provide support for the
feature in older Perls) were loaded, they will removed if the feature
is enabled in the feature bundle for C, or replaced by the
corresponding C if the feature is known by the corresponding
C binary but not yet enabled by the feature bundle. (In the context
of compatibility modules for unfeatures, the same consideration for
documentation purposes apply.)

When a feature is enabled (or disabled) in the context of a feature
version bundle that's less than the version when the feature was known
by Perl, the line won't be removed.

For example this line:

    use feature 'signatures';

will die with any perl before perl5.20.0, because the binary does not
know about the feature itself.

When writing code like this:

    use v5.10;
    use feature 'signatures';

one is opting into a version of the Perl language that is not described
by any specific feature bundle. However, any perl that knows about the
C feature will know how to run it.

Bumping it to the feature bundle for v5.16, for example, is valid,
and will work with any B that knows about the C feature:

    use v5.16;
    use feature 'signatures';

And so on until v5.36, when the C feature was enabled by
the corresponding version bundle:

    use v5.36;

Finally, some features may imply extra edits:

=over 4

=item bitwise

When the C feature is enabled, the behaviour of the bitwise
operators (C<&>, C<|>, C<~> and C<^>) is modified. If the code makes use
of one of them, and the code is moved from a version I v5.28
to a version greater or equal to v5.28, the C feature will
be I, and a comment will be added, asking the maintainer to
review their use according to the C feature before removing it.

=item signatures

When signatures are implicitely enabled, any prototypes will be rewritten
with the prototype attribute syntax. For example:

    sub foo ($@) { ... }

will become:

    sub foo :prototype($@) { ... }

=item fc

Once C is implicitely enabled, All uses of C will be
replaced by a bare C.

=back

=head2 Feature/version data table

The following table is used to generate the feature data hash.

It is generated using the C script
shipped with the distribution.

The keys are:

=over 4

=item known

when perl first learnt about the feature

=item enabled

when the feature was first enabled (may be before it was known)

=item disabled

when the feature was first disabled

=item compat

replacement modules for features to be deprecated / added

=back

Different features have different lifecycles:

=over 4

=item *

New features (i.e. additional behaviour that didn't exist in Perl v5.8):

=over 4

=item *

are C in the Perl release that introduced them

=item *

are C either in the same version (e.g. C, C)
or after an "experimental" phase (e.g. C, C)

=item *

once enabled, they are not meant to be C in a later bundle.

=back

=item *

Unfeatures, or backwards compatibility features (features that existed
in older Perls,  but were later deemed undesirable, and scheduled for
being eventually disabled or removed):

=over 4

=item *

are C in the C<:default> bundle (they were part of the old
Perl 5 behaviour) before they are even C (a feature that
represents them was added to Perl).

=item *

are meant to be manually disabled (with C), until a
later feature bundle eventually disables them by default.

=back

=back

"compat" modules are CPAN modules meant to add support to the feature on
perls where it's not available yet. They exist both for new features and
backwards compatibility features. The number following the module name in
the data structure below is the sum of 1 (if the module has an C
method) and -1 (if the module has an C method).

=cut

BEGIN {
    $FEATURE_DATA = << '=cut';

=pod

                  5.042 features known    enabled  disabled removed  compat
                             say   5.010    5.010                    Perl6::Say 1 Say::Compat 1
                           state   5.010    5.010
                          switch   5.010    5.010    5.036
                 unicode_strings   5.012    5.012
                      array_base   5.016    5.010    5.016    5.030
                     current_sub   5.016    5.016
                       evalbytes   5.016    5.016
                              fc   5.016    5.016
                    unicode_eval   5.016    5.016
                    lexical_subs   5.018    5.026
                       postderef   5.020    5.024
                    postderef_qq   5.020    5.024
                      signatures   5.020    5.036
                         bitwise   5.022    5.028
                     refaliasing   5.022
                   declared_refs   5.026
                        indirect   5.032    5.010    5.036           indirect 0
                             isa   5.032    5.036
                multidimensional   5.034    5.010    5.036           multidimensional 0
            bareword_filehandles   5.034    5.010    5.038           bareword::filehandles 0
                             try   5.034    5.040                    Feature::Compat::Try 1 Syntax::Feature::Try 0 Syntax::Keyword::Try 0
                           defer   5.036                             Feature::Compat::Defer 1 Syntax::Keyword::Defer 0
         extra_paired_delimiters   5.036
                     module_true   5.038    5.038
                           class   5.038                             Feature::Compat::Class 1
 apostrophe_as_package_separator   5.042    5.010    5.042
                      smartmatch   5.042    5.010    5.042
                     keyword_all   5.042
                     keyword_any   5.042

=cut

}

=head1 ADDITIONAL INFORMATION ABOUT PERL FEATURES AND CONSTRUCTS

=head2 Official documentation

=over 4

=item L

Perl pragma to enable new features.

=item L

A listing of experimental features in Perl.

=item L

This pragma provides an easy and convenient way to enable or disable
experimental features.

=back

=head2 CPAN Modules

=over 4

=item L

For some new syntactic constructs, there is the L.
For the rest, there is L.::

=item L

Find a minimum required version of C for Perl code.

=item L

L is an alternative fast & lightweight
implementation of L.

=back

=head2 Other

=over 4

=item L

The most significant features introduced for recent versions of the Perl
scripting language.

=back

=head1 ACKNOWLEDGMENT

This software was originally developed at Booking.com. With approval
from Booking.com, this software was released as open source, for which
the authors would like to express their gratitude.

=head1 AUTHOR

Philippe Bruhat (BooK)

=head1 COPYRIGHT

Copyright 2024-2026 Philippe Bruhat (BooK), all rights reserved.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut