Perl 在 url 中每次出现斜杠后从文件中插入一个字符串

Question

我有以下网址：

FILE1.txt

http://www.stackoveflow.com/dog/cat/rabbit/hamster/
192.168.192.168/lion/tiger/elephant/

FILE2.txt

HELLO
GOODBYE

我想要达到的输出：

http://www.stackoveflow.com/dogHELLO/cat/rabbit/hamster/
http://www.stackoveflow.com/dog/catHELLO/rabbit/hamster/
http://www.stackoveflow.com/dog/cat/rabbitHELLO/hamster/
http://www.stackoveflow.com/dog/cat/rabbit/hamsterHELLO/
http://www.stackoveflow.com/dog/cat/rabbit/hamster/HELLO

http://www.stackoveflow.com/dogGOODBYE/cat/rabbit/hamster/
http://www.stackoveflow.com/dog/catGOODBYE/rabbit/hamster/
http://www.stackoveflow.com/dog/cat/rabbitGOODBYE/hamster/
http://www.stackoveflow.com/dog/cat/rabbit/hamsterGOODBYE/
http://www.stackoveflow.com/dog/cat/rabbit/hamster/GOODBYE

192.168.192.168/lionHELLO/tiger/elephant/
192.168.192.168/lion/tigerHELLO/elephant/
192.168.192.168/lion/tiger/elephantHELLO/
192.168.192.168/lion/tiger/elephant/HELLO

192.168.192.168/lionGOODBYE/tiger/elephant/
192.168.192.168/lion/tigerGOODBYE/elephant/
192.168.192.168/lion/tiger/elephantGOODBYE/
192.168.192.168/lion/tiger/elephant/GOODBYE

如您所见，字符串 HELLO 和 GOODBYE 被插入到每个斜杠之后，如果斜杠之后已经有一个字符串，它将在之后附加 HELLO 和 GOODBYE（例如 http://www.stackoveflow.com/dogHELLO/cat/rabbit/hamster/等等）。

我的尝试

use strict;
use warnings;

my @f1 = do {
   open my $fh, '<', 'FILE1.txt';
   <$fh>;
};
chomp @f1;

my @f2 = do {
  open my $fh, '<', 'FILE2.txt';
  <$fh>;
};
chomp @f2;

for my $f1 (@f1) {
  my @fields = $f1 =~ m{[^/]+}g;
  for my $f2 (@f2) {
    for my $i (0 .. $#fields) {
      my @new = @fields;
      $new[$i] .= $f2;
      print qq{/$_/\n}, for join '/', @new;
    }
    print "\n\n";
  }
}
#courtesy of Borodin

但是此代码不适合在http:// 部分中带有斜杠的网址，因为它们在不应该的情况下被http:HELLO/ 替换。

如果没有字符串，它也不会在斜杠之后放置HELLO 或GOODBYE，例如http://www.stackoveflow.com/dog/cat/rabbit/hamster/<--SHOULD PUT HELLO AFTER THIS SLASH AS WELL BUT DOSN'T

似乎此代码删除了斜杠，然后重新插入了 FILE2.txt 中的字符串，而不是在正确的开始位置插入 HELLO 和 GOODBYE。

我的问题

是否有更好的方法来实现我需要的输出，或者我可以对现有代码做些什么来解决上述问题？

非常感谢您的帮助，非常感谢

Answer 1

这是散文中的算法：

Open File2.txt. Read in all lines, removing the newline. We call the array @words.

Open File2.txt. We call the file handle $fh.

As long as we can read a $line from $fh:

    Remove the newline, remove starting and ending slashes.
    Split the $line at every slash, call the array @animals.

    Loop through the @words, calling each element $word:

        Loop through the indices of the @animals, calling each index $i:

            Make a @copy of the @animals.
            Append the $word to the $i-th element of @copy.
            Join the @copy with slashes, surround it with slashes, and print with newline.

        Print an empty line.

Answer 2

这个程序会按照你的要求做。

use strict;
use warnings;
use autodie;

my @f1 = do {
  open my $fh, '<', 'FILE1.txt';
  <$fh>;
};
chomp @f1;

my @f2 = do {
  open my $fh, '<', 'FILE2.txt';
  <$fh>;
};
chomp @f2;

for my $f1 (@f1) {
  my @fields = $f1 =~ m{[^/]+}g;
  for my $f2 (@f2) {
    for my $i (0 .. $#fields) {
      my @new = @fields;
      $new[$i] .= $f2;
      print qq{/$_/\n}, for join '/', @new;
    }
    print "\n\n";
  }
}

输出

/dogHELLO/cat/rabbit/hamster/
/dog/catHELLO/rabbit/hamster/
/dog/cat/rabbitHELLO/hamster/
/dog/cat/rabbit/hamsterHELLO/


/dogGOODBYE/cat/rabbit/hamster/
/dog/catGOODBYE/rabbit/hamster/
/dog/cat/rabbitGOODBYE/hamster/
/dog/cat/rabbit/hamsterGOODBYE/


/lionHELLO/tiger/elephant/
/lion/tigerHELLO/elephant/
/lion/tiger/elephantHELLO/


/lionGOODBYE/tiger/elephant/
/lion/tigerGOODBYE/elephant/
/lion/tiger/elephantGOODBYE/

Answer 3

您可以使用正则表达式来完成所有操作，而不是在每个斜杠上分割线。

更新版本：

#!usr/bin/perl
use strict;
use warnings;

my @insert_words = qw/HELLO GOODBYE/;
my $word = 0;

while (<DATA>)
{
    chomp;
    foreach my $word (@insert_words)
    {
        my $repeat = 1;
        while ((my $match=$_) =~ s|(?<!/)(?:/(?!/)[^/]*){$repeat}[^/]*\K|$word|)
        {
            print "$match\n";
            $repeat++;
        }
        print "\n";
    }
}

__DATA__
/dog/cat/rabbit/hamster/
http://www.stackoverflow.com/dog/cat/rabbit/hamster/

关键是替换运算符：s|(?<!/)(?:/(?!/)[^/]*){$repeat}[^/]*\K|$word|。

(?<!/) 和 (?!/) 分别是负后瞻和前瞻。他们确保我们只匹配一个/，从而忽略http://。

(?:/(?!/)[^/]*){$repeat} 是一个必须匹配指定次数的捕获组，我们增加该次数直到不再匹配。

我不得不使用[^/]* 而不是[^/]+ 来满足您在字符串末尾匹配的要求。这就是为什么需要后视和前瞻的原因。

\K 的意思是“匹配到目前为止的所有内容，但不要将其包含在匹配本身中。”因此，我们不必担心在替换中包含匹配字符串的整个开头。

注意：r 选项是另一种在不修改原始字符串的情况下执行替换的方法。但是，它需要 Perl 5.16（感谢 Amon）。因此我将其从示例中删除。