use 5.010; # needs // (defined-or), \K regex extension use strict; use warnings; use Test::More 'no_plan'; use Test::NoWarnings; use Data::Dump qw(dd); # for debug my @Tests = ( 'replace ALL instances of search string (left-to-right)', [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', undef, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', 'unlimited replacements', ], [ 'ABABA', 'A', 'xx', undef, 'xxBxxBxx', 'unlimited replacements', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', 3, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', ], [ 'ABABA', 'A', 'xx', 3, 'xxBxxBxx', 'unlimited replacements', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', 4, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', ], [ 'ABABA', 'A', 'xx', 4, 'xxBxxBxx', 'unlimited replacements', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', 99, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', ], [ 'ABABA', 'A', 'xx', 99, 'xxBxxBxx', 'unlimited replacements', ], 'replace ALL instances of search string (right-to-left)', [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', -3, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', ], [ 'ABABA', 'A', 'xx', -3, 'xxBxxBxx', 'unlimited replacements', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', -4, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', ], [ 'ABABA', 'A', 'xx', -4, 'xxBxxBxx', 'unlimited replacements', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', -99, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', ], [ 'ABABA', 'A', 'xx', -99, 'xxBxxBxx', 'unlimited replacements', ], 'replace N instances of search string (left-to-right)', [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', 0, 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ], [ 'ABABA', 'A', 'xx', 0, 'ABABA', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', 1, 'ABC-@BC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ], [ 'ABABA', 'A', 'xx', 1, 'xxBABA', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', 2, 'ABC-@BC CBA-@CB CAB BAC CAB CAB CARAB CACBA AXCK', ], [ 'ABABA', 'A', 'xx', 2, 'xxBxxBA', ], 'replace N instances of search string (right-to-left)', [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', -1, 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA-@XCK', '1 right-most replacement', ], [ 'ABABA', 'A', 'xx', -1, 'ABABxx', '1 right-most replacement', ], [ 'ABC ABC CBA ACB CAB BAC CAB CAB CARAB CACBA AXCK', ' A', '-@', -2, 'ABC ABC CBA-@CB CAB BAC CAB CAB CARAB CACBA-@XCK', '2 right-most replacements', ], [ 'ABABA', 'A', 'xx', -2, 'ABxxBxx', '2 right-most replacements', ], ); # end @Tests VECTOR: for my $ar_vector (@Tests) { if (not ref $ar_vector) { note $ar_vector; next VECTOR; } my ($str, $srch, $repl, $n, $expect, $cmnt) = @$ar_vector; my $n_cmnt = $n // 'max'; my $comment = "'$srch' -> '$repl' $n_cmnt times"; $comment .= " ($cmnt)" if defined $cmnt; is Replace($str, $srch, $repl, $n), $expect, $comment; } # end for VECTOR done_testing; exit; # subroutines ################################################ sub Replace { # dd '===', \@_, '==='; # for debug my ($string, # string to search/replace $srch, # search string (no regex metacharacters) $repl, # optional: replacement string (default: '') $n, # optional: number of replacements (default: infinite) ) = @_; # handle degenerate cases. return '' unless defined $string; return $string unless defined $srch; # default replacement string: empty string. $repl //= ''; # replace left-to-right if n is not defined or >= 0. my $replace_left_to_right = ! defined($n) || $n >= 0; # make replacement count positive unless undefined/infinite. $n = defined $n ? abs($n) : -1; # escape all regex metacharacters in search substring. $srch = quotemeta $srch; # dd '===', [ $string, $srch, $repl, $n, ], '==='; # for debug # regex pattern matches if a search string is not present. my $rx_not_srch = qr{ (?! $srch) . }xms; my $rx_srch = $replace_left_to_right # replace search string n times from left. ? qr{ $rx_not_srch* \K $srch }xms # replace search string n times from right. : qr{ (?: $rx_not_srch* $srch)* $rx_not_srch* \K $srch }xms ; # dd '===', $rx_srch, $n, '==='; # for debug # n > 0: replace if replacement possible. 1 while $n-- && $string =~ s{ \G $rx_srch }{$repl}xms; return $string; }