view release on metacpan or  search on metacpan

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

# process($file_name, \@pipeline, \%options, \@content, $missing_final_sep)
# Applies all the stage of the pipeline on the given content (which is modified
# in place).
sub process {  ## no critic (RequireArgUnpacking)
               # We are unpacking the arguments but later we are taking a reference on $_[0]
  my ($file_name, $pipeline, $options, $content, $missing_final_separator) = @_;
  if ($options->{debug_mode}) {
    # For long files, we print only the first and last lines.
    my @debug_content = @$content;
    Readonly::Scalar my $NB_DEBUG_LINES => 4;
    Readonly::Scalar my $MAX_LINES_TO_PRINT => 10;
    my $omit_msg = sprintf '... (%d lines omitted)', (@$content - ($NB_DEBUG_LINES * 2));
    splice @debug_content, $NB_DEBUG_LINES, -$NB_DEBUG_LINES, $omit_msg
        if @$content > $MAX_LINES_TO_PRINT;
    if (ref($file_name)) {
      print "Processing $${file_name} with content: ".Dumper(\@debug_content);
    } else {
      print "Processing '${file_name}' with content: ".Dumper(\@debug_content);
    }
    print 'Has final separator: '.($missing_final_separator ? 'false' : 'true')."\n";
  }
  prepare_perl_env($file_name, $options);
  @markers = (0) x scalar(@$content);
  my $markers = \@markers;
  @content_stack = ();
  for my $stage (@$pipeline) {
    my ($command, $code, $modes, @args) = @$stage;
    $N_setter->set(scalar(@$content));
    $modes->{missing_final_separator} = $missing_final_separator;
    $modes->{file_name_ref} = \$_[0];  # this is an alias to the passed value.
    if ($options->{debug_mode}) {
      local $Data::Dumper::Indent = 0;
      printf "Executing command: %s(%s).\n", $command, join(', ', map { Dumper($_) } @args);
    }
    &$code($content, $markers, $modes, $options, @args);
  }
}

sub base_prepare_re {
  my ($re, $modes) = @_;
  if ($modes->{quote_regex}) {
    $re = quotemeta($re);
  }
  if (not $modes->{case_sensitive}) {
    $re = '(?i)'.$re;
  }
  return $re;
}

# prepare_re('re', \%options)
# Applies the modal option on the given regex.
# This function is not exported.
sub prepare_re {
  my ($re, $modes) = @_;
  $re = base_prepare_re($re, $modes);
  my $r;
  if ($modes->{regex_engine} ne 'perl') {
    # Some play to correctly escape whatever special characters might be in the
    # regex while preserving its semantics. This relies on the fact that the
    # 'Terse' option of Data::Dumper is set in the main program.
    # The regex-engine variable has been validated in the Args module.
    my $str_re = Dumper($re);
    my $engine = 're::engine::'.$modes->{regex_engine};
    # We could the safe to avoid this perlcritic warning but we are not actually
    # executing code here, so the safe is not needed (and we would need to find
    # variable names that are guaranteed not to collide with user code).
    $r = eval "use ${engine}; \$re = $str_re; qr/\$re/s";  ## no critic (ProhibitStringyEval)
    if ($@) {
      chomp($@);
      die "FATAL: Cannot use the specified regex engine: ${@}\n";
    }
  } else {
    $r = qr/$re/s;
  }
  return $r;
}

sub quote_for_re {
  my ($text, $modes) = @_;
  if ($modes->{quote_regex}) {
    return quotemeta($text);
  } else {
    # We quote just the '{' or '}' characters.
    return $text =~ s/(\{|\})/\\$1/gr;
  }
}

sub prepare_re2 {
  my ($re, $modes) = @_;
  $re = quote_for_re($re, $modes);
  if (not $modes->{case_sensitive}) {
    $re = '(?i)'.$re;
  }
  my $use_statement = '';
  if ($modes->{regex_engine} ne 'perl') {
    $use_statement = "use re::engine::$modes->{regex_engine};";
  }
  return ($use_statement, "{${re}}");
}

# This interpolate str in the Perl env (unless -Q is in effect).
sub maybe_interpolate {
  my ($str, $modes, $options, $command) = @_;
  if (not $modes->{quote_regex}) {
    $str = eval_in_safe_env("<<\"PTP_EOF_WORD\"\n${str}\nPTP_EOF_WORD\n", $options);
    die "FATAL: Cannot eval string for --${command}: ${@}\n" if $@;
    chomp($str);
  }
  return $str;
}

sub do_grep {
  my ($content, $markers, $modes, $options, $re) = @_;
  my ($use_stmt, $quoted_re) = prepare_re2($re, $modes);
  print "\$re = ${quoted_re}\n" if $options->{debug_mode};
  my $conjunction = $modes->{inverse_match} ? 'if' : 'unless';
  my $wrapped = get_code_in_safe_env("{; ${use_stmt} undef \$_ ${conjunction} m ${quoted_re} }",
    $options, '--grep');
  local $. = 0;
  map {
    $m_setter->set(\$markers->[$.]);