view release on metacpan or  search on metacpan

lib/App/PTP/Commands.pm  view on Meta::CPAN

  } else {
    die "FATAL: Invalid command received for perl operation ($cmd).\n";
  }

  for my $i (0 .. $#$content) {
    if (not defined $content->[$i]) {
      undef $markers->[$i];
    } elsif (not defined $markers->[$i]) {
      # We don't want undef here, as we will filter on it.
      # Note that the $m and @m variables shared with the environment try to
      # prevent the user from setting undef in them. But we don't trust that
      # Too much.
      $markers->[$i] = '';
    }
  }
  @$content = grep { defined } @$content;
  @$markers = grep { defined } @$markers;
}

sub do_execute {
  my ($content, $markers, $modes, $options, $cmd, $code) = @_;
  $code = prepare_code($code, $modes) if $cmd ne 'M';
  $code = "use $code;" if $cmd eq 'M';
  eval_in_safe_env($code, $options);
  if ($@) {
    chomp($@);
    my $scmd = '-'.($cmd =~ s/^(..)/-$1/r);  # --execute or -M.
    die "FATAL: Perl code failed in ${scmd}: ${@}\n";
  }
}

sub do_load {
  my ($content, $markers, $modes, $options, $file) = @_;
  # do can open relative paths, but in that case it looks them up in the @INC
  # directory, which we want to avoid.
  # We don't use abs_path here to not die (just yet) if the file does not exist.
  my $abs_path = rel2abs($file);
  print "Loading file: '$abs_path'\n" if $options->{debug_mode};
  if (not defined eval_in_safe_env("do '${abs_path}';", $options)) {
    if ($@) {
      die "FATAL: Perl code failed in --load: ${@}\n";
    } elsif ($!) {
      die "FATAL: Cannot load file '$file' for --load: $!\n";
    }
  }
}

# Notes: we are not applying the --sq, --dq, and --ds mode to the code passed
# in the --comparator mode, as that is not a command.
sub do_sort {
  my ($content, $markers, $modes, $options) = @_;
  if (ref($modes->{comparator}) eq 'CODE') {
    # This branch is no longer used.
    @$content = sort { $modes->{comparator}() } @$content;
  } elsif (ref($modes->{comparator}) eq 'SCALAR') {
    if (${$modes->{comparator}} eq 'default') {
      @$content = sort @$content;
    } elsif (${$modes->{comparator}} eq 'numeric') {
      no warnings 'numeric';  ## no critic (ProhibitNoWarnings)
      @$content = sort { $a <=> $b } @$content;
    } elsif (${$modes->{comparator}} eq 'locale') {
      use locale;
      @$content = sort { $a cmp $b } @$content;
    } elsif (${$modes->{comparator}} eq 'semver') {
      my (%parsed, %warned);
      for my $line (@$content) {
        next if exists $parsed{$line};
        my $version = App::PTP::Util::Semver::parse($line);
        $parsed{$line} = $version;
        for my $warning (@{$version->{warnings}}) {
          print "WARNING: ${warning}\n" unless $warned{$warning}++;
        }
      }
      @$content =
          sort { App::PTP::Util::Semver::compare_parsed($parsed{$a}, $parsed{$b}) } @$content;
    } else {
      die sprintf "INTERNAL ERROR: Invalid comparator (%s)\n", ${$modes->{comparator}};
    }
  } else {
    die sprintf "INTERNAL ERROR: Invalid comparator type (%s)\n", Dumper($modes->{comparator})
        if ref $modes->{comparator};
    my $cmp = $modes->{comparator};
    my $sort = get_code_in_safe_env("sort { $cmp } \@_", $options, 'custom comparator');
    @$content = $sort->(@$content);
  }
  @$markers = (0) x scalar(@$content);
}

sub do_list_op {
  my ($content, $markers, $modes, $options, $sub, $apply_on_markers) = @_;
  if ($apply_on_markers eq 'none') {
    @$content = &$sub(@$content);
    @$markers = (0) x scalar(@$content);
  } elsif ($apply_on_markers eq 'same') {
    @$content = &$sub(@$content);
    @$markers = &$sub(@$markers);
  } elsif ($apply_on_markers eq 'together') {
    &$sub($content, $markers);
  } else {
    die
        "INTERNAL ERROR: Invalid value for \$apply_on_markers passed to do_list_op: $apply_on_markers\n";
  }
}

Readonly::Scalar my $DEFAULT_TAIL_LEN => 10;

sub do_tail {
  my ($content, $markers, $modes, $options, $len) = @_;
  $len = $DEFAULT_TAIL_LEN unless $len;
  splice @$content, 0, -$len;
  splice @$markers, 0, -$len;
}

sub do_head {
  my ($content, $markers, $modes, $options, $len) = @_;
  $len = $DEFAULT_TAIL_LEN unless $len;
  $len = -@$content if $len < -@$content;
  splice @$content, $len;
  splice @$markers, $len;
}

sub do_delete_marked {