How to change match modifier within a program in perl? [duplicate] - regex

Is there a way to use a variable as modifier in a substitution?
my $search = 'looking';
my $replace = '"find: $1 ="';
my $modifier = 'ee';
s/$search/$replace/$modifier;
I need to use an array of hashes to make bulk search-replace with different modifiers.

While the method using eval to compile a new substitution is probably the most straightforward, you can create a substitution that is more modular:
use warnings;
use strict;
sub subst {
my ($search, $replace, $mod) = #_;
if (my $eval = $mod =~ s/e//g) {
$replace = qq{'$replace'};
$replace = "eval($replace)" for 1 .. $eval;
} else {
$replace = qq{"$replace"};
}
sub {s/(?$mod)$search/$replace/ee}
}
my $sub = subst '(abc)', 'uc $1', 'ise';
local $_ = "my Abc string";
$sub->();
print "$_\n"; # prints "my ABC string"
This is only lightly tested, and it is left as an exercise for the reader to implement other flags like g

You could use eval, if you put on your safety goggles and your divide-by-zero suit.
E.g.:
use strict;
use warnings;
sub mk_re {
my ($search, $replace, $modifier) = #_;
$modifier ||= '';
die "Bad modifier $modifier" unless $modifier =~ /^[msixge]*$/;
my $sub = eval "sub { s/($search)/$replace/$modifier; }";
die "Error making regex for [$search][$replace][$modifier]: $#" unless $sub;
return $sub;
}
my $search = 'looking';
my $replace = '"find: $1 ="';
my $modifier = 'e';
# Sub can be stored in an array or hash
my $sub = mk_re($search, $replace, $modifier);
$_ = "abc-looking-def";
print "$_\n";
$sub->();
print "$_\n";

Hm, if I had to do it I would do like this:
use warnings;
use strict;
my #stuff = (
{
search => "this",
replace => "that",
modifier => "g",
},
{
search => "ono",
replace => "wendy",
modifier => "i",
}
);
$_ = "this ono boo this\n";
for my $h (#stuff) {
if ($h->{modifier} eq 'g') {
s/$h->{search}/$h->{replace}/g;
} elsif ($h->{modifier} eq 'i') {
s/$h->{search}/$h->{replace}/i;
}
# etc.
}
print;
There are only so many different modifiers you might want to use so I think this is easy enough.
You can use eval for this, but it's awfully messy.

Of course s/$search/$replace/ work as you expect. It is the dynamic modifiers that are not straightforward.
For the regular match modifiers of pimsx you can use Perl's Extended Patterns to modify the modifier flags on the fly as part of your pattern. These are of the form (?pimsx-imsx) to turn on / off those modifiers.
For the s// e and ee forms, you can use (?{ perl code}) documented in the same perlre section. For all of eval e or ee forms, consider the security of the resulting code!
There is no form to modify global to first match that I am aware of, so global vs first match would need to be separate statements.

Here's a combination of Kinopiko's answer and eval.
eval is used here to generate the lookup table in a controlled and maintainable fashion, and a lookup table is used to save all the if.. elsif.. elsif which are not too fun to look at.
(very lightly tested)
my #stuff = (
{
search => "this",
replace => "that",
modifier => "g",
},
{
search => "ono",
replace => "wendy",
modifier => "i",
}
);
$_ = "this ono boo this\n";
my #modifiers = qw{m s i x g e};
my $s_lookup = {};
foreach my $modifier (#modifiers) {
$s_lookup->{$modifier} = eval " sub { s/\$_[0]/\$_[1]/$modifier } ";
}
for my $h (#stuff) {
$s_lookup->{$h->{modifier}}->($h->{search},$h->{replace});
}
print;
To be fully useful this needs:
combinations of possible modifiers
sort function on the lookup table so 'msi' combination and 'mis' combination will go to the same key.

Related

multi replace in postgresql query using perl

I'm cleaning some text directly in my query, and rather than using nested replace functions, I found this bit of code that uses perl to perform multiple replacements at once: multi-replace with perl
CREATE FUNCTION pg_temp.multi_replace(string text, orig text[], repl text[])
RETURNS text
AS $BODY$
my ($string, $orig, $repl) = #_;
my %subs;
if (#$orig != #$repl) {
elog(ERROR, "array sizes mismatch");
}
if (ref #$orig[0] eq 'ARRAY' || ref #$repl[0] eq 'ARRAY') {
elog(ERROR, "array dimensions mismatch");
}
#subs{#$orig} = #$repl;
my $re = join "|",
sort { (length($b) <=> length($a)) } keys %subs;
$re = qr/($re)/;
$string =~ s/$re/$subs{$1}/g;
return $string;
$BODY$ language plperl strict immutable;
Example query:
select
name as original_name,
multi_replace(name, '{-,&,LLC$}', '{_,and,business}') as cleaned_name
from some_table
The function finds the pattern LLC at the end of the name string but removes it instead of replacing it with "business."
How can I make this work as intended?
When the strings in #$orig are to be matched literally, I'd actually use this:
my ($string, $orig, $repl) = #_;
# Argument checks here.
my %subs; #subs{ #$orig } = #$repl;
my $pat =
join "|",
map quotemeta,
sort { length($b) <=> length($a) }
#$orig;
return $string =~ s/$re/$subs{$&}/gr;
In particular, map quotemeta, was missing.
(By the way, the sort line isn't needed if you ensure that xy comes before x in #$orig when you want to replace both x(?!y) and xy.)
But you want the strings in #$orig to be treated as regex patterns. For that, you can use the following:
# IMPORTANT! Only provide strings from trusted sources in
# `#$orig` as it allows execution of arbitrary Perl code.
my ($string, $orig, $repl) = #_;
# Argument checks here.
my $re =
join "|",
map "(?:$orig->[$_])(?{ $_ })",
0..$#$orig;
{
use re qw( eval );
$re = qr/$re/;
}
return $string =~ s/$re/$repl->[$^R]/gr;
However, in your environment, I have doubts about the availability of use re qw( eval ); and (?{ }), so the above may be an unviable solution for you.
my ($string, $orig, $repl) = #_;
# Argument checks here.
my $re =
join "|",
map "(?<_$_>$orig->[$_])",
0..$#$orig;
$re = qr/$re/;
return
$string =~ s{$re}{
my ( $n ) =
map substr( $_, 1 ),
grep { $-{$_} && defined( $-{$_}[0] ) }
grep { /^_\d+\z/aa }
keys( %- );
$repl->[$n]
}egr;
While the regexp tests for LLC$ with the special meaning of the $, what gets captured into $1 is just the string LLC and so it doesn't find the look-up value to replace.
If the only thing you care about is $, then you could fix it by changing the map-building lines to:
#subs{map {my $t=$_; $t=~s/\$$//; $t} #$orig} = #$repl;
my $re = join "|",
sort { (length($b) <=> length($a)) } #$orig;
But it will be very hard to make it work more generally for every possible feature of regex.
The purpose of this plperl function in the linked blog post is to find/replace strings, not regular expressions. LLC being found with LLC$ as a search term does not happen in the original code, as the search terms go through quotemeta before being included into $re (as also sugggested in ikegami's answer)
The effect of removing the quotemeta transformation is that LLC at the end of a string is matched, but since as a key it's not found in $subs (because the key there isLLC$), then it's getting replaced by an empty string.
So how to make this work with regular expressions in the orig parameter?
The solution proposed by #ikegami does not seem usable from plperl, as it complains with this error: Unable to load re.pm into plperl.
I thought of an alternative implementation without the (?{ code }) feature: each match from the main alternation regexp can be rechecked against each regexp in orig, in a code block run with /ge. On the first match, the corresponding string in repl is selected as the replacement.
Code:
CREATE or replace FUNCTION pg_temp.multi_replace(string text, orig text[], repl text[])
RETURNS text AS
$BODY$
my ($string, $orig, $repl) = #_;
my %subs;
if (#$orig != #$repl) {
elog(ERROR, "array sizes mismatch");
}
if (ref #$orig[0] eq 'ARRAY' || ref #$repl[0] eq 'ARRAY') {
elog(ERROR, "array dimensions mismatch");
}
#subs{#$orig} = #$repl;
my $re = join "|", keys %subs;
$re = qr/($re)/;
# on each match, recheck the match individually against each regexp
# to find the corresponding replacement string
$string =~ s/$re/{ my $r; foreach (#$orig) { if ($1 =~ $_) {$r=$subs{$_}; last;} } $r;}/ge;
return $string;
$BODY$ language plperl strict immutable;
Test
=> select pg_temp.multi_replace(
'bar foo - bar & LLC',
'{^bar,-,&,LLC$}',
'{baz,_,and,business}'
);
multi_replace
----------------------------
baz foo _ bar and business

how can I take a dynamic variable in value of JSON?

I need use the find and replace through regular expression like following
use strict;
no strict 'refs';
use warnings;
use JSON;
use Encode qw( encode decode encode_utf8 decode_utf8);
my $data =
{
"find_replace" => [
{ "find" => "(.+?)&",
"replace"=> "$1"
}
]
};
my $find_replace_arr = $data->{'find_replace'};
my $string = "http://www.website.com/test.html&code=236523";
my $find = $find_replace_arr->[0]->{find};
my $replace = $find_replace_arr->[0]->{replace};
$string =~ s/$find/$replace/isge;
print $string;
exit();
in this code, I only want to "http://www.website.com/test.html" from the string.
I am not able to get replace (key)'s value dynamically, which is $1.
You can Run the above code.
This code throw the Error Use of uninitialized value $1 in string
Some things to consider. First, the regex ([^&]+) may not give the desired result, as it is really going to capture and replace with the same capture.. resulting in the same output string (confusing I bet).
Next, the replace string "$1"has to be quoted again and e modifier has to be doubled.
So try this:
my $data =
{
"find_replace" => [
{ "find" => "^(.+?)&.*",
"replace"=> '"$1"'
}
]
};
my $find_replace_arr = $data->{'find_replace'};
my $string = "http://www.website.com/test.html&code=236523";
my $find = $find_replace_arr->[0]->{find};
my $replace = $find_replace_arr->[0]->{replace};
$string =~ s/$find/$replace/isgee;
print $string;
exit();
Notice the new regex, ^(.+?)&.* will match the entire string, but the capture (...) will be the result to replace.

Dynamically capture regular expression match in Perl

I'm trying to dynamically catch regex matching in Perl. I've known that eval will help me do this but I may be doing something wrong.
Code:
use strict;
use warnings;
my %testHash = (
'(\d+)\/(\d+)\/(\d+)' => '$1$2$3'
);
my $str = '1/12/2016';
foreach my $pattern (keys (%testHash)) {
my $value = $testHash{$pattern};
my $result;
eval {
local $_ = $str;
/$pattern/;
print "\$1 - $1\n";
print "\$2 - $2\n";
print "\$3 - $3\n";
eval { print "$value\n"; }
}
}
Is it also possible to store captured regex patterns in an array?
I believe what you really want is a dynamic version of the following:
say $str =~ s/(\d+)\/(\d+)\/(\d+)/$1$2$3/gr;
String::Substitution provides what we need to achieve that.
use String::Substitution qw( gsub_copy );
for my $pattern (keys(%testHash)) {
my $replacement = $testHash{$pattern};
say gsub_copy($str, $pattern, $replacement);
}
Note that $replacement can also be a callback. This permits far more complicated substitutions. For example, if you wanted to convert 1/12/2016 into 2016-01-12, you could use the following:
'(\d+)/(\d+)/(\d+)' => sub { sprintf "%d-%02d-%02d", #_[3,1,2] },
To answer your actual question:
use String::Substitution qw( interpolate_match_vars last_match_vars );
for my $pattern (keys(%testHash)) {
my $template = $testHash{$pattern};
$str =~ $pattern # Or /$pattern/ if you prefer
or die("No match!\n");
say interpolate_match_vars($template, last_match_vars());
}
I am not completely sure what you want to do here, but I don't think your program does what you think it does.
You are useing eval with a BLOCK of code. That's like a try block. If it dies inside of that eval block, it will catch that error. It will not run your string like it was code. You need a string eval for that.
Instead of explaining that, here's an alternative.
This program uses sprintf and numbers the parameters. The %1$s syntax in the pattern says _take the first argument (1$) and format it as a string (%s). You don't need to localize or assign to $_ to do a match. The =~ operator does that on other variables for you. I also use qr{} to create a quoted regular expression (essentially a variable containing a precompiled pattern) that I can use directly. Because of the {} as delimiter, I don't need to escape the slashes.
use strict;
use warnings;
use feature 'say'; # like print ..., "\n"
my %testHash = (
qr{(\d+)/(\d+)/(\d+)} => '%1$s.%2$s.%3$s',
qr{(\d+)/(\d+)/(\d+) nomatch} => '%1$s.%2$s.%3$s',
qr{(\d+)/(\d+)/(\d\d\d\d)} => '%3$4d-%2$02d-%1$02d',
qr{\d} => '%s', # no capture group
);
my $str = '1/12/2016';
foreach my $pattern ( keys %testHash ) {
my #captures = ( $str =~ $pattern );
say "pattern: $pattern";
if ($#+ == 0) {
say " no capture groups";
next;
}
unless (#captures) {
say " no match";
next;
}
# debug-output
for my $i ( 1 .. $#- ) {
say sprintf " \$%d - %s", $i, $captures[ $i - 1 ];
}
say sprintf $testHash{$pattern}, #captures;
}
I included four examples:
The first pattern is the one you had. It uses %1$s and so on as explained above.
The second one does not match. We check the number of elements in #captured by looking at it in scalar context.
The third one shows that you can also reorder the result, or even use the sprintf formatting.
The last one has no capture group. We check by looking at the index of the last element ($# as the sigil for arrays that usually have an # sigil) in #+, which holds the offsets of the ends of the last successful submatches in the currently active dynamic scope. The first element is the end of the overall match, so if this only has one element, we don't have capture groups.
The output for me is this:
pattern: (?^:(\d+)/(\d+)/(\d\d\d\d))
$1 - 1
$2 - 12
$3 - 2016
2016-12-01
pattern: (?^:(\d+)/(\d+)/(\d+) nomatch)
no match
pattern: (?^:\d)
no capture groups
pattern: (?^:(\d+)/(\d+)/(\d+))
$1 - 1
$2 - 12
$3 - 2016
1.12.2016
Note that the order in the output is mixed up. That's because hashes are not ordered in Perl, and if you iterate over the keys in a hash without sort the order is random.
Apologies! I realized both my question and sample code were both vague. But after reading your suggestions I came of with the following code.
I haven't optimized this code yet and there is a limit to the replacement.
foreach my $key (keys %testHash) {
if ( $str =~ $key ) {
my #matchArr = ($str =~ $key); # Capture all matches
# Search and replace (limited from $1 to $9)
for ( my $i = 0; $i < #matchArr; $i++ ) {
my $num = $i+1;
$testHash{$key} =~ s/\$$num/$matchArr[$i]/;
}
$result = $testHash{$key};
last;
}
}
print "$result\n";
Evaluing the regexp in list context returns the matches. so in your example:
use Data::Dumper; # so we can see the result
foreach my $pattern (keys (%testHash)) {
my #a = ($str =~/$pattern/);
print Dumper(\#a);
}
would do the job.
HTH
Georg
Is it also possible to store captured regex patterns in an array?
Of course it is possible to store captured substrings in an array:
#!/usr/bin/env perl
use strict;
use warnings;
my #patterns = map qr{$_}, qw{
(\d+)/(\d+)/(\d+)
};
my $str = '1/12/2016';
foreach my $pattern ( #patterns ) {
my #captured = ($str =~ $pattern)
or next;
print "'$_'\n" for #captured;
}
Output:
'1'
'12'
'2016'
I do not quite understand what you are trying to do with combinations of local, eval EXPR and eval BLOCK in your code and the purpose of the following hash:
my %testHash = (
'(\d+)\/(\d+)\/(\d+)' => '$1$2$3'
);
If you are trying to codify that this pattern should result in three captures, you can do that like this:
my #tests = (
{
pattern => qr{(\d+)/(\d+)/(\d+)},
ncaptures => 3,
}
);
my $str = '1/12/2016';
foreach my $test ( #tests ) {
my #captured = ($str =~ $test->{pattern})
or next;
unless (#captured == $test->{ncaptures}) {
# handle failure
}
}
See this answer to find out how you can automate counting the number of capture groups in a pattern. Using the technique in that answer:
#!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
my #tests = map +{ pattern => qr{$_}, ncaptures => number_of_capturing_groups($_) }, qw(
(\d+)/(\d+)/(\d+)
);
my $str = '1/12/2016';
foreach my $test ( #tests ) {
my #captured = ($str =~ $test->{pattern});
ok #captured == $test->{ncaptures};
}
done_testing;
sub number_of_capturing_groups {
"" =~ /|$_[0]/;
return $#+;
}
Output:
ok 1
1..1

How can I match these function calls, and extract the nmae of the function and the first argument?

I am trying to parse an array of elements. Those who match a pattern like the following:
Jim("jjanson", Customer.SALES);
I want to create a hash table like Jim => "jjanson"
How can I do this?
I can not match the lines using:
if($line =~ /\s*[A-Za-z]*"(.*),Customer.*\s*/)
You're not matching either the '(' after the name, nor the ' ' after the comma, before "Customer.".
I can get 'jjanson"' using this expression:
/\s*[A-Za-z]\(*"(.*), Customer.*\s*/
But I assume you don't want jjanson", so we need to modify it like so. (I tend to include the negative character class when I'm looking for simply-delimited stuff. So, in this case I'll make the expression "[^"]*"
/\s*[A-Za-z]\(*"([^"]+)", Customer.*\s*/
Also, I try not to depend upon whitespace, presence or number, I'm going to replace the space with \s*. That you didn't notice that you skipped the whitespace is a good illustration of the need to say "ignore a bunch of whitespace".
/\s*[A-Za-z]\(*"([^"]+)",\s*Customer.*\s*/
Now it's only looking for the sequence ',' + 'Customer' in the significant characters. Functionally, the same, if more flexible.
But since you only do one capture, I can't see what you'd map to what. So I'll do my own mapping:
my %records;
while ( my $line = $source->()) { # simply feed for a source of lines.
my ( $first, $user, $tag )
= $line = m/\s*(\p{Alpha}+)\s*\(\s*"([^"]+)",\s*Customer\.(\S+?)\)\/
;
$records{ $user }
= { first => $first
, username => $user
, tag => $tag
};
}
This is much more than you would tend to need in a one-off, quick solution. But I like to store as much of my input as seems significant.
Note that Jim("jjanson", Customer.SALES); matches the syntax of a function call with two arguments. You can thus abuse string eval:
#!/usr/bin/env perl
use strict;
use warnings;
use YAML::XS;
my $info = extract_first_arg(q{ Jim("jjanson", Customer.SALES);} );
print Dump $info;
sub extract_first_arg {
my $call = shift;
my ($name) = ($call =~ m{ \A \s* (\w+) }x);
unless ($name) {
warn "Failed to find function name in '$call'";
return;
}
my $username = eval sprintf(q{
package My::DangerZone;
no strict;
local *{ %s } = sub { $_[0] };
%s
}, $name, $call);
return { $name => $username };
}
Output:
---
Jim: jjanson
Or, you can abuse autoloading:
our $AUTOLOAD;
print Dump eval 'no strict;' . q{ Jim("jjanson", Customer.SALES); };
sub AUTOLOAD {
my ($fn) = ($AUTOLOAD =~ /::(\w+)\z/);
return { $fn => $_[0] };
}
I would not necessarily recommend using these methods, especially on input that is not in your control, and in a situation where this script has access to sensitive facilities.
On the other hand, I have, in the right circumstances, utilized this kind of thing in transforming one given set of information into something that can be used elsewhere.
Try this:
$line = 'Jim("jjanson", Customer.SALES)';
my %hashStore = (); #Jim("jjanson"
if($line=~m/^\s*([^\(\)]*)\(\"([^\"]*)\"/g) { $hashStore{$1} = $2; }
use Data::Dumper;
print Dumper \%hashStore;
Output:
$VAR1 = {
'Jim' => 'jjanson'
};

Perl short form of regex capture

I would like to only get the first capture group into the same var. In fact, I am looking for a short form of:
$_ = $1 if m/$prefix($pattern)$suffix/;
Something like:
s/$prefix($pattern)$suffix/$1/a; ## Where a is the option I am looking for
Or even better:
k/$prefix($pattern)$suffix/; ## Where k is also an option I wish I can use...
This will avoid the need of matching all the text which leads to a more complicated line:
s/^.*$prefix($pattern)$suffix.*$/defined $1 ? $1 : ""/e;
Any clues?
This would be useful for this example:
push #array, {id => k/.*\s* = \s* '([^']+)'.*/};
instead of
/.*\s* = \s* '([^']+)'.*/;
my $id = '';
$id = $1 if $1;
push #array, {id => $id};
Edit:
I just found an interesting way, but if $1 is not defined I will get an error :(
$_ = (/$prefix($pattern)$suffix/)[0];
Use a Conditional operator
my $var = /$prefix($pattern)$suffix/ ? $1 : '';
You always want to make sure that you regex matches before using a capture group. By using a ternary you can either specify a default value or you can warn that a match wasn't found.
Alternatively, you can use the list form of capture groups inside an if statement, and let your else output the warning:
if (my ($var) = /$prefix($pattern)$suffix/) {
...;
} else {
warn "Unable to find a match";
}
You can use the /r switch to return the altered string instead of doing the substitution on the variable. There is no need to capture anything at all with that. Just get rid of the prefix and the suffix and add the result of that operation to your array.
use Data::Dump;
my #strings = qw( prefixcontent1suffix prefixcontent2suffix );
my #array = map { s/^prefix|suffix$//gr } #strings;
dd #array;
__END__
("content1", "content2")
If you want it to be configurable, how about this:
my $prefix = qr/.+\{\{/;
my $suffix = qr/\}\}.+/;
my #strings = ( '{fo}o-_#09{{content1}}bar42' );
my #array = map { s/^$prefix|$suffix$//gr } #strings;
dd #array;
__END__
"content1"
In list context, the m// operator returns the captures as a list. This means you can do this:
($_) = m/$prefix($pattern)$suffix/;
or this:
my ($key, $value) = $line =~ m/^([^=]+)=([^=]+)$/;