Can anyone help me find an efficient implementation.

If the cost of a subroutine call is cheaper than scanning the list (which I suspect is the case), then you can assemble all the target patterns into one, perform a single match, and then dispatch to the sub that gives you what you want to substitute:

#! /usr/local/bin/perl -w

use strict;
use Regexp::Assemble;

my $ra;

my %dispatch = (
    'food'   => sub { 'pizza' },
    'water'  => sub { 'beer'  },
    'like'   => sub { 'enjoy' },
    '(\d+)F' => sub { int(($ra->mvar(1) - 32 ) * 5/9 ) . 'C' },
);

$ra = Regexp::Assemble->new( track => 1 )->add( keys %dispatch );

while( <DATA> ) {
    while( $ra->match($_) ) {
        my $m = $ra->matched;
        s/$m/&{$dispatch{$m}}/e;
    }
    print;
}

__DATA__
I'd like a glass of water with my food, it's 92F in here!
[download]

... produces...

I'd enjoy a glass of beer with my pizza, it's 33C in here!
[download]

Generating the dispatch table from a data file is left as an exercise to the reader (but a pretty fun one, I might say).

Thanks grinder.

I had already used module Regexp::Assemble for another quite similar script, and I had thought of using it with track=>1 for my replacement script. But I could not because my new script hanged whenever I created a Regexp::Assemble object with track=>1.

The exact line in my code where the script hanged:


my $Rpatt = Regexp::Assemble->new( chomp=>1, track=>1 )->add( keys(%PA
+TTS) );
[download]

Where %PATTS is a hash with elements of the form 'pattern->replacement'. Any idea why it hanged?

Any idea why it hanged?

Without seeing %PATTS, no idea. Maybe you have uncovered a bug! If you're interested in resolving the problem, I now have a mailing list for the module. If you care to join up we can maybe get to the bottom of the problem.

- another intruder with the mooring in the heart of the Perl

# assume REGEX is the pattern filehandle
# asseme INPUT is the your input filehandle
my %regex=();
while (<REGEX>) {
  chomp;
  my ($key,$value) = split (\t,$_);
  $value = "\"$value\"";
  $regex{$key}=$value;
}

while (<INPUT>) {
  s/$key/$regex{$key}/gee foreach my $key (keys %regex);
}
[download]

Thanx Hena. I will try what you suggest and see if it reduces processing time sufficiently.

As for your assumtions, a sample replacement patterns list (REGEX) could be:


\b([a-z])([a-z]*)ung\b    \u$1\l$2ung
Treecontrol    Tree Control
[Tt]abreiter    Reiterelement
[Tt]ile    Teilbild
[download]

And a sample input text (INPUT) for the replacements could be:


Die Segnung ist gestern erfolgt.
Die segnung ist gestern erfolgt.
Die Rechnung wird geschickt.
Die rechnung wird geschickt.
Die Treecontrol.
Die Tabreiter.
Die tabreiter.
Die Tile.
Die tile.
[download]

I wonder if this changes anything in what you suggest...

Well, all direct text translations might be handled faster... but unless there is a lot of them compared to others then it probably won't help (might actually be slower). The actual help would be better to be tested as this is pure speculation :).

Basicly make to hashes instead of one. Something like this.

while (<REGEX>) {
  chomp;
  my ($key,$value) = split (\t,$_);
  $value = "\"$value\"";
  if ($key=~s/^\w+$/) {
    $simple{$key}=$value;
  } else {
    $regex{$key}=$value;
  }
}

while (<INPUT>) {
  s/$key/$regex{$key}/gee foreach my $key (keys %regex);
  foreach (split (/\s+/,$_)) {
    if (exists($simple{$_})) {
      push (@line,$simple{$_});
    } else {
      push (@line,$_);
    }
  }
  print OUT "@line\n";
}
[download]

Note that in the given examples, you might write out the '[Tt]ile' pattern to Tile and tile rows. Which would move it from slower pattern group to faster. But as I said, I'm not sure how much this would help.

Expanding on Hena's idea I wonder if it would be even more efficient to use Tie::File to go through, writing replacements as you go (untested):


use Tie::File;

my $inputfile = "samplein.txt";
&replacer($inputfile);

sub replacer {
   tie my @currentfile, 'Tie::File', $inputfile or die "$!";
      my $inputline;
      foreach $inputline ( $currentfile[0] .. $#currentfile ) {
         foreach my $key (keys %regex) {
            $inputline =~ s/$key/$regex{$key}/gee;
         }
      }
   untie @currentfile;
}

## Totally untested
[download]


Seems like the write operation would be faster with Tie::File

#list of regex-strings
my @regex =
(
    's/(a+)/\U$1/g',
    's/([bz]+)/XX/g',
);

#is now a list of subroutines
@regex = map { eval "\$sub = sub { \$_=\$_[0]; $_; \$_ }" } @regex;
[download]

my @text = 
(
    "aaaabbzz",
    "bbbyyy",
);

for my $t ( @text )
{
    print "org $t\n";
    for my $re ( @regex )
    {
        $t = &$re($t);
    }
    print "new  $t\n";
}
[download]

No doubt - advantage for compiling the regular expressions only once. But I'd take it just a tiny bit further - instead of all the copying around of the line:

#list of regex-strings
my @regex =
(
    's/(a+)/\U$1/g',
    's/([bz]+)/XX/g',
);

#is now a list of subroutines
@regex = map { eval "sub { $_ }" } @regex;
[download]

Notes: got rid of the copying of the line in and out, we'll just work on the global $_; also got rid of the extraneous assignment to the global $sub variable. Now you use it like:

my @text = 
(
    "aaaabbzz",
    "bbbyyy",
);

for ( @text )
{
    print "org $_\n";
    for my $re ( @regex )
    {
        &$re();
        # or even just &$re
    }
    print "new  $_\n";
}
[download]

The advantage here is when you have many regex's (which the OP said they would) - less copying of data around. It's just a tiny bit more dangerous since so many functions modify $_, though.

# Preprocessing phase.
my @subs = map {my($r, $s) = split /\t/; [qr/$r/, $s]} @Patts;
# Real stuff.
open(my $in,  "<", "...") or die "...";
open(my $out, ">", "...") or die "...";
while (<$in>) {
    s/$_[0]/$_[1]/g for @subs; # No need for /ee, is there?
    print $out $_;
}
close $out or die "...";
[download]

This is a case where buying a block or two of additional memory may be the simplest - and most cost-effective - solution.

$INline =~ s/$Source/$Target/egoe
[download]

You´re missing that the /o-modifier is just a "promise" to perl, that the variable that contains the regex won´t change within the iteration/loop. In this cause using /o is just wrong, because only the first regex would be applied over and over. Regardless of the change of $Source or $Target.

qr//-ing the regex is something different. When you qr// a string and assign it to a variable you store the compiled regex in it. This is easily proven by ref()-ing that variable, it will return "Regexp". Of course you can store such a Regexp in whatever data-structure you want, not just plain scalars.

But that is of little use in this case, because there is no qs//-statment (qr// is just for matching, not for replacing).


holli, /regexed monk/

No, but I have tried precompiling $Source with qr// in my patterns list before I do the actual replacement. Isn't that more or less equivalent to using /o?