File Coverage

blib/lib/String/Substitution.pm

Criterion	Covered	Total	%
statement	38	38	100.0
branch	10	10	100.0
condition	2	3	66.6
subroutine	14	14	100.0
pod	8	8	100.0
total	72	73	98.6

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of String-Substitution
#
# This software is copyright (c) 2010 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package String::Substitution;
# git description: v1.001-5-gd591202

our $AUTHORITY = 'cpan:RWSTAUNER';
# ABSTRACT: Simple runtime string substitution functions
$String::Substitution::VERSION = '1.002';
use Sub::Exporter 0.982;
{
  my $exports = {
    exports => [qw(interpolate_match_vars last_match_vars)],
    groups => {}
  };
  my @funcs = qw(sub gsub);
  foreach my $suffix ( qw(copy modify context) ){
    push(@{ $exports->{exports} }, map { "${_}_${suffix}" } @funcs);
    $exports->{groups}->{$suffix} = [
      map { ("${_}_${suffix}" => { -as => $_ }) } @funcs
    ];
  }
  Sub::Exporter::setup_exporter($exports);
}


sub gsub_copy {
  my ($string, $pattern, $replacement) = @_;
  $string =~ s/$pattern/
    _replacement_sub($replacement)->(last_match_vars());/ge;
  return $string;
}


sub gsub_modify {
  my ( undef, $pattern, $replacement ) = @_;
  return $_[0] =~ s/$pattern/
    _replacement_sub($replacement)->(last_match_vars());/ge;
}


sub gsub_context {
  return defined wantarray
    ? gsub_copy(@_)
    : gsub_modify(@_);
}


sub interpolate_match_vars {
  my ($replacement, @matched) = @_;
  my $string = $replacement;
  # Handling backslash-escapes and variable interpolations
  # in the same substitution (alternation) keeps track of the position
  # in the string so that we don't have to count backslashes.
  $string =~
    s/
      (?:
        \\(.)                  # grab escaped characters (including $)
      |
        (?:
          \$\{([1-9]\d*)\}   # match "${1}" (not unrelated '${0}')
        |
          \$  ([1-9]\d*)     # match  "$1"  (not unrelated '$0')
        )
      )
    /
      defined $1
        ? $1                   # if something was escaped drop the \\
        : $matched[$2 || $3];  # else use braced or unbraced number
                               # ($2 will never contain '0')
    /xge;
  return $string;
}


sub last_match_vars {
  no strict 'refs'; ## no critic
  return (
    # fake $& with a substr to avoid performance penalty (see perlvar)
    #(@_ ? substr($_[0], $-[0], $+[0] - $-[0]) : undef),
    undef,
    # $1, $2 ..
    map { defined($$_) ? $$_ : '' } ( 1 .. $#- )
  );
}

# Return a sub that will get matched vars array passed to it

sub _replacement_sub {
  my ($rep) = @_;
  # if $rep is not a sub, assume it's a string to be interpolated
  ref $rep
    ? $rep
    : sub { interpolate_match_vars($rep, @_); };
}


sub sub_copy {
  my ($string, $pattern, $replacement) = @_;
  $string =~ s/$pattern/
    _replacement_sub($replacement)->(last_match_vars());/e;
  return $string;
}


sub sub_modify {
  my ( undef, $pattern, $replacement ) = @_;
  return $_[0] =~ s/$pattern/
    _replacement_sub($replacement)->(last_match_vars());/e;
}


sub sub_context {
  return defined wantarray
    ? sub_copy(@_)
    : sub_modify(@_);
}

1;

__END__