Related
Is it possible to map different keys to the same value in a hash but using only 1 "slot"?
E.g. if I have the following:
my %hash = (
person => A,
persons => A,
employee => C,
employees => C,
desk => X,
);
Can I make it somehow like:
my %hash = (
person|persons => A,
employee|employees => C,
desk => X,
);
Is it possible?
There isn't any built in syntax which is like that. But you can always do:
my %hash;
$hash{employee} = $hash{employees} = 'C';
Or even:
my %hash;
#hash{qw( employee employees )} = ('C') x 2; # or ('C', 'C'); or qw(C C);
There's no built-in syntax for that, but you could use a little helper function:
sub make_hash {
my #result;
while (my ($key, $value) = splice #_, 0, 2) {
push #result, $_, $value for split /\|/, $key;
}
return #result;
}
Then you could say:
my %hash = make_hash(
'person|persons' => 'A',
'employee|employees' => 'C',
desk => 'X',
);
There was a similar question and solutions posted over on perlmonks where (IMO) the best solution goes like this:
my %hash = map { my $item = pop #$_; map { $_, $item } #$_ }
[qw(HELP ?) => sub { ... }],
[qw(QUIT EXIT LEAVE) => sub { ... }],
...;
Your goal is unclear to me but, maybe an aproach
where you use an intermediate "alias" hash would work.
Then access values through %categories to reach a value in %hash
my %categories = (
person => people,
persons => people,
employee => worker,
employees => worker,
desk => furniture,
chair => furniture,
);
my %hash = (
people => A,
worker => C,
furniture => X,
);
Hi I have an perl hash of arbitrary depth. I want to substitute the a string in entire structure with something else.
What is the right approach to do it?
I did something like this
#convert the hash to string for manipulation
my $data = YAML::Dump(%hash);
# do manipulation
---
---
# time to get back the hash
%hash = YAML::Load($data);
Your idea seems very risky to me, since it can be hard to be sure that the substitution won't destroy something in the output of YAML::Dump that will prevent the result from being read back in again, or worse, something that will alter the structure of the hash as it is represented in the dump string. What if the manipulation you are trying to perform is to replace : with , or ’ with ', or something of that sort?
I would probably do something more like this:
use Scalar::Util 'reftype';
# replace $this with $that in key names and string values of $hash
# recursively apply replacement in hash and all its subhashes
sub hash_replace {
my ($hash, $this, $that) = #_;
for my $k (keys %$hash) {
# substitution in value
my $v = $hash->{$k};
if (ref $v && reftype($v) eq "HASH") {
hash_replace($v, $this, $that);
} elsif (! ref $v) {
$v =~ s/$this/$that/og;
}
my $new_hash = {};
for my $k (keys %$hash) {
# substitution in key
(my $new_key = $k) =~ s/$this/$that/og;
$new_hash->{$new_key} = $hash->{$k};
}
%$hash = %$new_hash; # replace old keys with new keys
}
The s/…/…/ replacement I used here may not be appropriate for your task; you should feel free to use something else. For example, instead of strings $this and $that you might pass two functions, $key_change and $val_change which are applied to keys and to values, respectively, returning the modified versions. See the ###### lines below:
use Scalar::Util 'reftype';
# replace $this with $that in key names and string values of $hash
# recursively apply replacement in hash and all its subhashes
sub hash_replace {
my ($hash, $key_change, $val_change) = #_;
for my $k (keys %$hash) {
# substitution in value
my $v = $hash->{$k};
if (ref $v && reftype($v) eq "HASH") {
hash_replace($v, $key_change, $val_change);
} elsif (! ref $v) {
$v = $val_change->($v); #######
}
}
my $new_hash = {};
for my $k (keys %$hash) {
# substitution in key
my $new_key = $key_change->($k); #######
$new_hash->{$new_key} = $hash->{$k};
}
%$hash = %$new_hash;
}
Here's one way to attack it, by recursing through the hash. In this code, you pass in a sub that does whatever you like to each value in the nested hash. This code only modifies the values, not the keys, and it ignores other reference types (ie. scalar refs, array refs) in the nested structure.
#!/usr/bin/perl -w
use Modern::Perl;
## Visit all nodes in a nested hash. Bare-bones.
sub visit_hash
{
my ($start, $sub) = #_;
my #q = ( $start );
while (#q) {
my $hash = pop #q;
foreach my $key ( keys %{$hash} ) {
my $ref = ref($hash->{$key});
if ( $ref eq "" ) { # not a reference
&$sub( $hash->{$key} );
next;
}
if ( $ref eq "HASH" ) { # reference to a nested hash
push #q, $hash->{$key};
next;
}
# ignore other reference types.
}
}
}
The following gives an example of how to use it, replacing e with E in a nested hash:
# Example of replacing a string in all values:
my %hash =
(
a => "fred",
b => "barney",
c => "wilma",
d => "betty",
nest1 =>
{
1 => "red",
2 => "orange",
3 => "green"
},
nest2 =>
{
x => "alpha",
y => "beta",
z => "gamma"
},
);
use YAML::XS;
print "Before:\n";
print Dump( \%hash );
# now replace 'e' with 'E' in all values.
visit_hash( \%hash, sub { $_[0] =~ s/e/E/g; } );
print "After:\n";
print Dump( \%hash );
For just the problem without a story, skip to after the line.
I was fooling around with splitting up a string of some letters and numbers, both of which could occur, into two fields in a hashref. They should only appear if the field exists at all. The string might look like this: /^\D*\d*$/, for example ZR17, R15, -19, 22.
I did not want to simply put this into two variables like this, because the actual hashref is a little longer, and I wanted to keep stuff grouped together.
my $asdf = "ZR17";
my ($x, $y) = $asdf =~ m/^(\D*)(\d*)$/;
my $foo = {
foo => $x,
bar => $y
};
If I wanted to not have the key foo in case of the string 17, I could say:
my $foo = {
( $x ? ( foo => $x ) : () ),
( $y ? ( bar => $y ) : () ),
};
I came up with putting it all in the hashref assignment like this:
my $asdf = "ZR17";
my $foo = {
( $asdf =~ m/(\d+)/ ? ( foo => $1 ) : () ),
( $asdf =~ m/(\D+)/ ? ( bar => $1 ) : () ),
};
print Dumper $foo;
This yields the following:
$VAR1 = {
'bar' => 'ZR',
'foo' => 'ZR'
};
Somehow it looks like there is only one $1 here, and it gets mixed up. If I coment out the second line, foo will be 17.
Can someone explain what is happening here? Where is the $1 getting lost/confused?
According to perldoc (http://perldoc.perl.org/perlre.html):
These special variables, like ... the numbered match variables ($1 , $2 , $3
, etc.) are dynamically scoped until the end of the enclosing block or until
the next successful match, whichever comes first.
Therefore, $1 has been overwritten to 17 after $asdf =~ m/(\d+)/ as it found a match but hasn't encountered the end of the enclosing block yet.
This however,
my $foo = {
( eval{$asdf =~ m/(\D+)/ ? ( bar => $1 ) : ()} ),
( eval{$asdf =~ m/(\d+)/ ? ( foo => $1 ) : ()} ),
};
will give the expected result as the scopes are separated.
Perl 5.10+ will allow you to use named captures, which is essentially what you want to do. Any capture group that doesn't match will be stored in %+ with "" as the value in your case:
use strict;
use warnings;
use Data::Dump 'dd';
my $asdf = "ZR17";
$asdf =~ m/^(?<alpha>\D*)(?<num>\d*)$/;
my $foo = { map { $+{$_} ? ( $_ => $+{$_} ) : () } keys %+ };
dd $foo; # { alpha => "ZR", num => 17 }
It looks like $1 for foo and bar is from last regex match,
my $asdf = "ZR17";
my $foo = {
( $asdf =~ m/(\D+)/ ? ( bar => $1 ) : () ),
( $asdf =~ m/(\d+)/ ? ( foo => $1 ) : () ),
};
print Dumper $foo;
output
$VAR1 = {
'bar' => '17',
'foo' => '17'
};
This however works as expected,
my $foo = {
( map { (bar => $_) } $asdf =~ m/(\D+)/ ),
( map { (foo => $_) } $asdf =~ m/(\d+)/ ),
};
output
$VAR1 = {
'bar' => 'ZR',
'foo' => '17'
};
I guess the ternary operator doesn't evaluate $1 when it returns ( bar => $1 ) and ( foo => $1 ). So in the intermediary step you get
$foo = { ( bar => $1 ), ( foo => $1 ) };
And since $1 is by now the captured substring of 2nd match operation, you get the same values for both $foo{bar} and $foo{foo}.
Another way to achieve what you want (i.e. the hash element doesn't exist if corresponding match is not found):
my %patt = {
foo => '(\d+)',
bar => '(\D+)',
};
my %foo = map { $_ => $1 if $asdf =~ /$patt{$_}/ } keys %patt;
You can extend %patt when you need to match more patterns.
I have many vendors in database, they all differ in some aspect of their data. I'd like to make data validation rule which is based on previous data.
Example:
A: XZ-4, XZ-23, XZ-217
B: 1276, 1899, 22711
C: 12-4, 12-75, 12
Goal: if user inputs string 'XZ-217' for vendor B, algorithm should compare previous data and say: this string is not similar to vendor B previous data.
Is there some good way/tools to achieve such comparison? Answer could be some generic algoritm or Perl module.
Edit:
The "similarity" is hard to define, i agree. But i'd like to catch to algorithm, which could analyze previous ca 100 samples and then compare the outcome of analyze with new data. Similarity may based on length, on use of characters/numbers, string creation patterns, similar beginning/end/middle, having some separators in.
I feel it is not easy task, but on other hand, i think it has very wide use. So i hoped, there is already some hints.
You may want to peruse:
http://en.wikipedia.org/wiki/String_metric and http://search.cpan.org/dist/Text-Levenshtein/Levenshtein.pm (for instance)
Joel and I came up with similar ideas. The code below differentiates 3 types of zones.
one or more non-word characters
alphanumeric cluster
a cluster of digits
It creates a profile of the string and a regex to match input. In addition, it also contains logic to expand existing profiles. At the end, in the task sub, it contains some pseudo logic which indicates how this might be integrated into a larger application.
use strict;
use warnings;
use List::Util qw<max min>;
sub compile_search_expr {
shift;
#_ = #{ shift() } if #_ == 1;
my $str
= join( '|'
, map { join( ''
, grep { defined; }
map {
$_ eq 'P' ? quotemeta;
: $_ eq 'W' ? "\\w{$_->[1],$_->[2]}"
: $_ eq 'D' ? "\\d{$_->[1],$_->[2]}"
: undef
;
} #$_
)
} #_ == 1 ? #{ shift } : #_
);
return qr/^(?:$str)$/;
}
sub merge_profiles {
shift;
my ( $profile_list, $new_profile ) = #_;
my $found = 0;
PROFILE:
for my $profile ( #$profile_list ) {
my $profile_length = #$profile;
# it's not the same profile.
next PROFILE unless $profile_length == #$new_profile;
my #merged;
for ( my $i = 0; $i < $profile_length; $i++ ) {
my $old = $profile->[$i];
my $new = $new_profile->[$i];
next PROFILE unless $old->[0] eq $new->[0];
push( #merged
, [ $old->[0]
, min( $old->[1], $new->[1] )
, max( $old->[2], $new->[2] )
]);
}
#$profile = #merged;
$found = 1;
last PROFILE;
}
push #$profile_list, $new_profile unless $found;
return;
}
sub compute_info_profile {
shift;
my #profile_chunks
= map {
/\W/ ? [ P => $_ ]
: /\D/ ? [ W => length, length ]
: [ D => length, length ]
}
grep { length; } split /(\W+)/, shift
;
}
# Psuedo-Perl
sub process_input_task {
my ( $application, $input ) = #_;
my $patterns = $application->get_patterns_for_current_customer;
my $regex = $application->compile_search_expr( $patterns );
if ( $input =~ /$regex/ ) {}
elsif ( $application->approve_divergeance( $input )) {
$application->merge_profiles( $patterns, compute_info_profile( $input ));
}
else {
$application->escalate(
Incident->new( issue => INVALID_FORMAT
, input => $input
, customer => $customer
));
}
return $application->process_approved_input( $input );
}
Here is my implementation and a loop over your test cases. Basically you give a list of good values to the function and it tries to build a regex for it.
output:
A: (?^:\w{2,2}(?:\-){1}\d{1,3})
B: (?^:\d{4,5})
C: (?^:\d{2,2}(?:\-)?\d{0,2})
code:
#!/usr/bin/env perl
use strict;
use warnings;
use List::MoreUtils qw'uniq each_arrayref';
my %examples = (
A => [qw/ XZ-4 XZ-23 XZ-217 /],
B => [qw/ 1276 1899 22711 /],
C => [qw/ 12-4 12-75 12 /],
);
foreach my $example (sort keys %examples) {
print "$example: ", gen_regex(#{ $examples{$example} }) || "Generate failed!", "\n";
}
sub gen_regex {
my #cases = #_;
my %exploded;
# ex. $case may be XZ-217
foreach my $case (#cases) {
my #parts =
grep { defined and length }
split( /(\d+|\w+)/, $case );
# #parts are ( XZ, -, 217 )
foreach (#parts) {
if (/\d/) {
# 217 becomes ['\d' => 3]
push #{ $exploded{$case} }, ['\d' => length];
} elsif (/\w/) {
#XZ becomes ['\w' => 2]
push #{ $exploded{$case} }, ['\w' => length];
} else {
# - becomes ['lit' => '-']
push #{ $exploded{$case} }, ['lit' => $_ ];
}
}
}
my $pattern = '';
# iterate over nth element (part) of each case
my $ea = each_arrayref(values %exploded);
while (my #parts = $ea->()) {
# remove undefined (i.e. optional) parts
my #def_parts = grep { defined } #parts;
# check that all (defined) parts are the same type
my #part_types = uniq map {$_->[0]} #def_parts;
if (#part_types > 1) {
warn "Parts not aligned\n";
return;
}
my $type = $part_types[0]; #same so make scalar
# were there optional parts?
my $required = (#parts == #def_parts);
# keep the values of each part
# these are either a repitition or lit strings
my #values = sort uniq map { $_->[1] } #def_parts;
# these are for non-literal quantifiers
my $min = $required ? $values[0] : 0;
my $max = $values[-1];
# write the specific pattern for each type
if ($type eq '\d') {
$pattern .= '\d' . "{$min,$max}";
} elsif ($type eq '\w') {
$pattern .= '\w' . "{$min,$max}";
} elsif ($type eq 'lit') {
# quote special characters, - becomes \-
my #uniq = map { quotemeta } uniq #values;
# join with alternations, surround by non-capture grouup, add quantifier
$pattern .= '(?:' . join('|', #uniq) . ')' . ($required ? '{1}' : '?');
}
}
# build the qr regex from pattern
my $regex = qr/$pattern/;
# test that all original patterns match (#fail should be empty)
my #fail = grep { $_ !~ $regex } #cases;
if (#fail) {
warn "Some cases fail for generated pattern $regex: (#fail)\n";
return '';
} else {
return $regex;
}
}
To simplify the work of finding the pattern, optional parts may come at the end, but no required parts may come after optional ones. This could probably be overcome but it might be hard.
If there was a Tie::StringApproxHash module, it would fit the bill here.
I think you're looking for something that combines the fuzzy-logic functionality of String::Approx and the hash interface of Tie::RegexpHash.
The former is more important; the latter would make light work of coding.
I am trying to search through a Load Balancer config and extract some data. The configuration file looks like this
pool {
name "POOL_name1"
ttl 30
monitor all "tcp"
preferred rr
partition "Common"
member 12.24.5.100:80
}
pool {
name "Pool-name2"
ttl 30
monitor all "https_ignore_dwn"
preferred rr
fallback rr
partition "Common"
member 69.241.25.121:8443
member 69.241.25.122:8443
}
I am trying to assign each pool config to it's own array, so I can loop through the array to find specific IP addresses and pool names. I tried the following regex, but its not working.
my #POOLDATA = <FILE>;
close FILE;
foreach (#POOLDATA) {
if (/^pool\s\{\s/ .. /^\}\s/) {
push (#POOLCONFIG, "$_");
}
}
Does anyone have a suggestion on how to separate each pool config into its own array? (or a better suggestion) Thank you in advance for your help
#!/usr/bin/env perl
use warnings; use strict;
my #pools;
my $keys = join('|', sort
'name',
'ttl',
'monitor all',
'preferred',
'partition',
'member'
);
my $pat = qr/^($keys)\s+([^\n]+)\n\z/;
while ( my $line = <DATA> ) {
if ($line =~ /^pool\s+{/ ) {
push #pools, {},
}
elsif (my ($key, $value) = ($line =~ $pat)) {
$value =~ s/^"([^"]+)"\z/$1/;
push #{ $pools[-1]->{$key} }, $value;
}
}
use Data::Dumper;
print Dumper \#pools;
__DATA__
pool {
name "POOL_name1"
ttl 30
monitor all "tcp"
preferred rr
partition "Common"
member 12.24.5.100:80
}
pool {
name "Pool-name2"
ttl 30
monitor all "https_ignore_dwn"
preferred rr
fallback rr
partition "Common"
member 69.241.25.121:8443
member 69.241.25.122:8443
}
Output:
$VAR1 = [
{
'monitor all' => [
'tcp'
],
'member' => [
'12.24.5.100:80'
],
'ttl' => [
'30'
],
'name' => [
'POOL_name1'
],
'preferred' => [
'rr'
],
'partition' => [
'Common'
]
},
{
'monitor all' => [
'https_ignore_dwn'
],
'member' => [
'69.241.25.121:8443',
'69.241.25.122:8443'
],
'ttl' => [
'30'
],
'name' => [
'Pool-name2'
],
'preferred' => [
'rr'
],
'partition' => [
'Common'
]
}
];
Edit:
Of course, you can check for a member element, and fill in a default one if it isn't found. In fact, with the basic structure in place, you should have been able to do that yourself.
One way to do it is to check for the end of a pool record:
while ( my $line = <DATA> ) {
if ($line =~ /^pool\s+{/ ) {
push #pools, {},
}
elsif (my ($key, $value) = ($line =~ $pat)) {
$value =~ s/^"([^"]+)"\z/$1/;
push #{ $pools[-1]->{$key} }, $value;
}
elsif ($line =~ /^\s*}/) {
my $last = $pools[-1];
if ($last and not $last->{member}) {
$last->{member} = [ qw(0.0.0.0) ];
}
}
}
As Sinan Unur recommended, you can store a reference to a hash in your array. That way, each element of your array is a hash.
By the way, Sinan's data structure is a bit more complex: You have an array of pools. Each pool is a hash with a key that's the value of the name of the pool element, and a reference to an array. This way, each element in the pool could have multiple values (like your IP addresses do).
My only comment is that I might use a hash for storing the pools, and key it by IP address. That is, assuming that an IP address is unique to a particular pool. That way, you can easily pull up a pool by the IP address without having to search. I would also keep a parallel structure by pool name for the same reason. (And, since each pool is a reference, storing the pool by both IP address and name wouldn't take up that much extra memory. And, updating one would update the other automatically).
If you're not familiar with Perl references, or how to create an array or hashes, or a hash of arrays, you can take a look at the following Perl tutorials:
perlretut - Mark's very short tutorial about references
perldsc - Perl Data Structures Cookbook
Once you get the hang of using multilayered Perl structures, you can quickly learn how to use object oriented design in your Perl scripts, and make maintaining these structures very easy to do.
Just another way to look at it. This one handles the multiple member fields, specially.
use strict;
use warnings;
use Data::Dumper;
use English qw<$RS>;
use List::MoreUtils qw<natatime>;
use Params::Util qw<_ARRAY _CODE>;
# Here, we rig the record separator to break on \n}\n
local $RS = "\n}\n";
# Here, we standardize a behavior with hash duplicate keys
my $TURN_DUPS_INTO_ARRAYS = sub {
my ( $hr, $k, $ov, $nv ) = #_;
if ( _ARRAY( $ov )) {
push #{ $ov }, $nv;
}
else {
$h->{ $k } = [ $ov, $nv ];
}
};
# Here is a generic hashing routine
# Most of the work is figuring out how the user wants to store values
# and deal with duplicates
sub hash {
my ( $code, $param_name, $store_op, $on_duplicate );
while ( my ( $peek ) = #_ ) {
if ( $code = _CODE( $peek )) {
last unless $param_name;
if ( $param_name eq 'on_dup' ) {
$on_duplicate = shift;
}
elsif ( $param_name eq 'store' ) {
$store_op = shift;
}
else {
last;
}
undef $code;
}
else {
my #c = $peek =~ /^-?(on_dup|store$)/;
last unless $param_name = $c[0];
shift;
}
}
$store_op ||= sub { $_[0]->{ $_[1] } = $_[3]; };
$on_duplicate ||= $code || $store_op;
my %h;
while ( #_ ) {
my $k = shift;
next unless defined( my $v = shift );
(( exists $h{ $k } and $on_duplicate ) ? $on_duplicate
: $store_op
)->( \%h, $k, $h{ $k }, $v )
;
}
return wantarray ? %h : \%h;
}
my %pools;
# So the loop is rather small
while ( <DATA> ) {
# remove pool { ... } brackets
s/\A\s*pool\s+\{\s*\n//smx;
s/\n\s*\}\n*//smx;
my $h
= hash( -on_duplicate => $TURN_DUPS_INTO_ARRAYS
, map { s/"$//; s/\s+$//; $_ }
map { split /\s+"|\s{2,}/msx, $_, 2 }
split /\n/m
);
$pools{ $h->{name} } = $h;
}
print Dumper( \%pools );
### %pools
__DATA__
pool {
name "POOL_name1"
ttl 30
monitor all "tcp"
preferred rr
partition "Common"
member 12.24.5.100:80
}
pool {
name "Pool-name2"
ttl 30
monitor all "https_ignore_dwn"
preferred rr
fallback rr
partition "Common"
member 69.241.25.121:8443
member 69.241.25.122:8443
}
Just a note about the hash function, I had noticed a high number of posts recently about hashes that handle duplicates. This is a general solution.