Найти все возможные начальные позиции совпадения регулярного выражения в perl, включая перекрывающиеся совпадения?

Question

Есть ли способ найти все возможные начальные позиции для соответствия регулярному выражению в Perl?

Например, если ваше регулярное выражение было "aa", а текст был "aaaa", он бы возвратил 0, 1 и 2 вместо, скажем, 0 и 2.

Очевидно, что вы можете просто сделать что-то вроде возврата первого совпадения, а затем удалить все символы, включая этот начальный символ, включая этот, и выполнить другой поиск, но я надеюсь на что-то более эффективное.

Answer 1

Используйте lookahead:

$ perl -le 'print $-[0] while "aaaa" =~ /a(?=a)/g'

В общем, поместите все, кроме первого символа регулярного выражения внутри (?=...).

Answer 2

Я знаю, что вы запросили регулярное выражение, но на самом деле есть простая встроенная функция, которая делает нечто очень похожее, функция index (perldoc -f index).Исходя из этого, мы можем создать простое решение для вашего прямого вопроса, хотя, если вам действительно нужен более сложный поиск, чем ваш пример, это не сработает, поскольку он ищет только подстроки (после индекса, заданного третьим параметром).

#!/usr/bin/env perl

use strict;
use warnings;

my $str = 'aaaa';
my $substr = 'aa';

my $pos = -1;
while (1) {
  $pos = index($str, $substr, $pos + 1);
  last if $pos < 0;
  print $pos . "\n";
}

Answer 3

Обновление:

Я подумал об этом немного больше и придумал это решение, используя встроенный блок кода, который почти в три раза быстрее, чем решение grep:

use 5.010;
use warnings;
use strict;

{my @pos;
 my $push_pos = qr/(?{push @pos, $-[0]})/;

sub with_code {
    my ($re, $str) = @_;
    @pos = ();
    $str =~ /(?:$re)$push_pos(?!)/;
    @pos
}}

и для сравнения:

sub with_grep {  # old solution
    my ($re, $str) = @_;
    grep {pos($str) = $_; $str =~ /\G(?:$re)/} 0 .. length($str) - 1;
}

sub with_while { # per Michael Carman's solution, corrected
    my ($re, $str) = @_;
    my @pos;
    while ($str =~ /\G.*?($re)/) {
        push @pos, $-[1];
        pos $str = $-[1] + 1
    }
    @pos
}

sub with_look_ahead {  # a fragile "generic" version of Sean's solution
    my ($re, $str) = @_;
    my ($re_a, $re_b) = split //, $re, 2;
    my @pos;
    push @pos, $-[0] while $str =~ /$re_a(?=$re_b)/g;
    @pos
}

Бенчмаркинг и проверка работоспособности:

use Benchmark 'cmpthese';

my @arg = qw(aa aaaabbbbbbbaaabbbbbaaa);
my $expect = 7;

for my $sub qw(grep while code look_ahead) {
    no strict 'refs';
    my @got = &{"with_$sub"}(@arg);
    "@got" eq '0 1 2 11 12 19 20' or die "$sub: @got";
}

cmpthese -2 => {
    grep  => sub {with_grep      (@arg) == $expect or die},
    while => sub {with_while     (@arg) == $expect or die},
    code  => sub {with_code      (@arg) == $expect or die},
    ahead => sub {with_look_ahead(@arg) == $expect or die},
};

Какие отпечатки:

          Rate  grep while ahead  code
grep   49337/s    --  -20%  -43%  -65%
while  61293/s   24%    --  -29%  -56%
ahead  86340/s   75%   41%    --  -38%
code  139161/s  182%  127%   61%    --

Answer 4

Вы можете использовать глобальное соответствие с функцией pos():

my $s1 = "aaaa";
my $s2 = "aa";

while ($s1 =~ /aa/g) {
    print pos($s1) - length($s2), "\n";
}