I'm wondering if Perl has a built-in way to check for the existence of a hash element with a key matching a particular regex. For example:
my %h = ( 'twelve' => 12, 'thirteen' => 13, 'fourteen' => 14 );
I'm wondering if there is any way to do this:
print "We have 12\n" if exists $h{twelve};
print "We have some teens\n" if exists $h{/.*teen$/};
The smart match operator does this (available since Perl v5.10).
$a $b Type of Match Implied Matching Code
====== ===== ===================== =============
...
Regex Hash hash key grep grep /$a/, keys %$b
...
Sample usage:
# print if any key in %h ends in "teen"
print "We have some teens\n" if /.*teen$/ ~~ %h;
In addition to the other answers here you can also do this with perl's grep:
print "We have some teens\n" if grep {/.*teen/} keys %h;
Yeah, it's called:
use List::Util qw<first>;
# Your regex does not compile perhaps you mean /teen$/
my $value = $hash{ ( first { m/teen/ } keys %hash ) || '' };
(Before smart match, that is. See mob's answer for smart match.)
You could also sort the keys:
my $value = $hash{ ( first { m/teen/ } sort keys %hash ) || '' };
I would freeze this into an "operation":
use Scalar::Util qw<reftype>;
sub values_for_keys_like (\[%$]$) {
my $ref = reftype( $_[0] ) eq 'HASH' ? $_[0] : $$_[0];
return unless my #keys = keys %$ref;
my $regex = shift;
# allow strings
$regex = qr/$regex/ unless my $typ = ref( $regex );
# allow regex or just plain ol' filter functions.
my $test = $typ eq 'CODE' ? $regex : sub { return unless m/$regex/; 1 };
if ( wantarray ) {
return unless my #k = grep { defined $test->( $_ ) } #keys;
return #$ref{ #k };
}
else {
return unless my $key = first { defined $test->( $_ ) } #keys;
return $ref->{ $key };
}
}
And you could use it like so:
my $key = values_for_keys_like( %hash => qr/teen/ );
Or
my $key = values_for_keys_like( $base->{level_two}{level_three} => qr/teen/ );
There's no built-in way, but there's Tie::Hash::Regex on CPAN.
Related
In this code, I'm checking if a certain key is present or not.
Here I am checking if key "Uri" present. I am getting output as "3".
use strict;
use warnings;
my %Names = (
Martha =>2,
Vivek =>9,
Jason =>6,
Socrates=>7,
Uri =>3,
Nitin =>1,
Plato =>0,
);
if (exists $Names{Uri} ) {
print "$Names{Uri}\n";
}
foreach my $name (sort {$Names{$a} cmp $Names{$b}} keys %Names)
{
print $name, $Names{$name}."\n";
}
Output
3
Plato 0
Nitin 1
Martha 2
Uri 3
Jason 6
Socrates 7
Vivek 9
But, I want the previous key value present before that key. For example:
If I search for key "Uri" Output should be "2"
If I search for key "Vivek" Output should be "7"
If I search for key "Plato" Output should be "0"
Does anyone know how to do it?
Create a sorted array of the hash values, then search through the array to get the value just lower than the value of your search key.
use strict;
use warnings;
my %Names = (
Martha =>2,
Vivek =>9,
Jason =>6,
Socrates=>7,
Uri =>3,
Nitin =>1,
Plato =>0,
);
my #vals = sort {$a <=> $b} values %Names;
get_prev('Uri');
get_prev('Vivek');
get_prev('Plato');
sub get_prev {
my $k = shift;
if (exists $Names{$k}) {
for (#vals) {
if ($Names{$k} == $vals[$_]) {
my $idx = ($_ == 0) ? 0 : $_ - 1;
print $vals[$idx], "\n";
last;
}
}
}
}
Prints:
2
7
0
If you want to print them all:
my $prev;
for my $name (
sort { $Names{$a} <=> $Names{$b} } # Note to use of <=> for numerical comparisons.
keys(%Names)
) {
say "$name $Names{$prev}" if $prev;
$prev = $name;
}
Similarly, to print just one
my $find = 'Uri';
my $prev;
for my $name (
sort { $Names{$a} <=> $Names{$b} }
keys(%Names)
) {
if ($name eq $find) {
say "$name $Names{$prev}" if $prev;
last;
}
$prev = $name;
}
The above hat would be an expensive way to perform multiple lookups.
For that, we'd build a mapping from names to the previous names.
my %prev_name_lkup;
my $prev;
for my $name (
sort { $Names{$a} <=> $Names{$b} }
keys(%Names)
) {
$prev_name_lkup{$name} = $prev if $prev;
$prev = $name;
}
This could also be done as follows:
my #sorted_names =
sort { $Names{$a} <=> $Names{$b} }
keys(%Names);
my %prev_name_lkup =
map { $sorted_names[$_-1] => $sorted_names[$_] }
1..$#sorted_names;
Either way, the lookups would look like this:
say "Uri $Names{$prev_name_lkup{Uri}}";
I am writing a code for calling a subroutine which has 4 argument(3 hashes and one file handler).i want to know how to access them in subroutine.My code is as below.
#print OUTFILE "Content of TPC file:.\n";
my $DATA_INFO = $ARGV[0];
my $OUT_DIR = $ARGV[1];
my $log= "$OUT_DIR/log1";
open(LOG1,">$log");
require "$DATA_INFO";
my $SCRIPT_DIR = $ENV{"SCRIPT_DIR"} ;
require "$SCRIPT_DIR/cmp_fault.pl";
require "$SCRIPT_DIR/pattern_mismatch.pl";
require "$SCRIPT_DIR/scan_count.pl";
print "\nComparing data:\n\n" ;
pattern_mismatch("\%data","\%VAR1","\%status",*LOG1);
cmp_fault("\%data","\%VAR1","\%status",*LOG1);
scan_count("\%data","\%status",*LOG1);
print "\n Comparison done:\n";
foreach $pattern (keys %status) {
print "pattern";
foreach $attr (keys %{$status{$pattern}}) {
print ",$attr";
}
print "\n";
last;
}
#Print Data
foreach $pattern (keys %status) {
print "$pattern";
foreach $attr (keys %{$status{$pattern}}) {
print ",$status{$pattern}{$attr}";
}
print "\n";
Sub routine cmp_fault is here:
sub cmp_fault {
use strict;
use warning;
$data_ref= $_[0];;
$VAR1_ref= $_[1];
$status_ref = $_[2];
$log1_ref=$_[3];
# print LOG1"For TPC : First find the pattern and then its fault type\n";
for $pat ( keys %$data_ref ) {
print "fgh:\n$pat,";
for $key (keys %{$data_ref{$pat}}) {
if($key=~/fault/){
print LOG1 "$key:$data_ref{$pat}{$key},\n";
}
}
}
# print LOG1 "\nFor XLS : First find the pattern and then its pattern type\n";
for $sheet (keys %$VAR1_ref){
if ("$sheet" eq "ATPG") {
for $row (1 .. $#{$VAR1_ref->{$sheet}}) {
$patname = $VAR1_ref->{'ATPG'}[$row]{'Pattern'} ;
next if ("$patname" eq "") ;
$faultXls = $VAR1_ref->{'ATPG'}[$row]{'FaultType'} ;
# print LOG1 " $patname==>$faultXls \n";
if (defined $data{$patname}{'fault'}) {
$faultTpc = $data{$patname}{'fault'} ;
# print LOG1 "\n $patname :XLS: $faultXls :TPC: $faultTpc\n";
if("$faultXls" eq "$faultTpc") {
print LOG1 "PASS: FaultType Matched $patname :XLS: $faultXls :TPC: $faultTpc\n\n\n";
print "PASS: FaultType Matched $patname :XLS: $faultXls :TPC: $faultTpc\n\n";
$status_ref->{$patname}{'FaultType'} = PASS;
}
else {
print LOG1 "FAIL: FaultType Doesn't Match\n\n";
$status_ref->{$patname}{'FaultType'} = Fail;
}
}
}
}
}
}
return 1;
When passing parameters into an array, you can only ever pass a single list of parameters.
For scalars, this isn't a problem. If all you're acting on is a single array, this also isn't a problem.
If you need to send scalars and an array or hash, then the easy way is to 'extract' the scalar parameters first, and then treat 'everything else' as the list.
use strict;
use warnings;
sub scalars_and_array {
my ( $first, $second, #rest ) = #_;
print "$first, $second, ", join( ":", #rest ), "\n";
}
scalars_and_array( "1", "2", "3", 4, 5, 6 );
But it should be noted that by doing so - you're passing values. You can do this with hashes too.
To pass data structure references, it's as you note - pass by reference, then dereference. It's useful to be aware though, that -> becomes useful, because it's accessing a hash and dereferencing it.
use strict;
use warnings;
use Data::Dumper;
sub pass_hash {
my ( $hashref ) = #_;
print $hashref,"\n";
print $hashref -> {"one"},"\n";
print $hashref -> {"fish"} -> {"haddock"};
}
my %test_hash = ( "one" => 2,
"three" => 4,
"fish" => { "haddock" => "plaice" }, );
pass_hash ( \%test_hash );
print "\n";
print Dumper \%test_hash;
The core of your problem here though, is that you haven't turned on strict and warnings which would tell you that:
for $pat ( keys %data_ref ) {
is wrong - there is no hash called data_ref there's only a scalar (which holds a hash reference) called $data_ref.
You need %$data_ref here.
And here:
for $key ( keys %{ $data{$pat} } ) {
You also have no $data - your code says $data_ref. (You might have %data in scope, but that's a really bad idea to mess around with within a sub).
There's a bunch of other errors - which would also be revealed by strict and warnings. That's a very basic debugging step, and you will generally get a much better response from Stack Overflow if you do this before asking for assistance. So please - do that, tidy up your code and remove errors/warnings. If you are still having problems after that, then by all means make a post outlining where and what problem you're having.
I'm using DBI to connect to Sybase to grab records in a hash_ref element. The DBI::Sybase driver has a nasty habit of returning records with trailing characters, specifically \x00 in my case. I'm trying to write a function to clean this up for all elements in the hashref, the code I have below does the trick, but I can't find a way to make it leaner, and I know there is away to do this better:
#!/usr/bin/perl
my $dbh = DBI->connect('dbi:Sybase:...');
my $sql = qq {SELECT * FROM table WHERE age > 18;};
my $qry = $dbh->selectall_hashref($sql, 'Name');
foreach my $val(values %$qry) {
$qry->{$val} =~ s/\x00//g;
}
foreach my $key(keys %$qry) {
$qry->{$key} =~ s/\x00//g;
foreach my $val1(keys %{$qry->{$key}}) {
$qry->{$key}->{$val1} =~ s/\x00//g;
}
foreach my $key1(keys %{$qry->{$key}}) {
$qry->{$key}->{$key1} =~ s/\x00//g;
}
While I think that a regex substitution is not exactly an ideal solution (seems like it should be fixed properly instead), here's a handy way to solve it with chomp.
use Data::Dumper;
my %a = (
foo => {
a => "foo\x00",
b => "foo\x00"
},
bar => {
c => "foo\x00",
d => "foo\x00"
},
baz => {
a => "foo\x00",
a => "foo\x00"
}
);
$Data::Dumper::Useqq=1;
print Dumper \%a;
{
local $/ = "\x00";
chomp %$_ for values %a;
}
print Dumper \%a;
chomp will remove a single trailing value equal to whatever the input record separator $/ is set to. When used on a hash, it will chomp the values.
As you will note, we do not need to use the values directly, as they are aliased. Note also the use of a block around the local $/ statement to restrict its scope.
For a more manageable solution, it's probably best to make a subroutine, called recursively. I used chomp again here, but you can just as easily skip that and use s/\x00//g. Or tr/\x00//d, which basically does the same thing. chomp is only safer in that it only removes characters from the end of the string, like s/\x00$// would.
strip_null(\%a);
print Dumper \%a;
sub strip_null {
local $/ = "\x00";
my $ref = shift;
for (values %$ref) {
if (ref eq 'HASH') {
strip_null($_); # recursive strip
} else {
chomp;
}
}
}
First your code:
foreach my $val(values %$qry) {
$qry->{$val} =~ s/\x00//g;
# here you are using a value as if it was a key
}
foreach my $key(keys %$qry) {
$qry->{$key} =~ s/\x00//g;
foreach my $val1(keys %{$qry->{$key}}) {
$qry->{$key}->{$val1} =~ s/\x00//g;
}
foreach my $key1(keys %{$qry->{$key}}) {
$qry->{$key}->{$key1} =~ s/\x00//g;
}
# and this does the same thing twice...
what you should do is:
foreach my $x (values %$qry) {
foreach my $y (ref $x eq 'HASH' ? values %$x : $x) {
$y =~ s/(?:\x00)+$//
}
}
which will clean up only ending nulls in the values of two levels of the hash.
the body of the loop could also be written as:
if (ref $x eq 'HASH') {
foreach my $y (values %$x) {
$y =~ s/(?:\x00)+$//
}
}
else {
$x =~ s/(?:\x00)+$//
}
But that forces you to write the substitution twice, and you shouldn't repeat yourself.
Or if you really want to reduce the code, using the implicit $_ variable works well:
for (values %$qry) {
s/(?:\x00)+$// for ref eq 'HASH' ? values %$_ : $_
}
I have a source list from which I am picking up random items and populating the destination list. The item that are in the list have a particular format. For example:
item1{'name'}
item1{'date'}
etc and many more fields.
while inserting into the destination list I check for unique names on items and insert it into that list. For this I have to traverse the entire destination list to check if an item with a given name exists and if not insert it.
I thought it would be nice if I make the destination list as hash instead of a list again so that I can look up for the item faster and efficiently. I am new to Perl and am not getting how to do this. Anybody, Please help me on how to insert an item, find for a particular item name, and delete an item in hash?
How can I make both the name and date as key and the entire item as value?
my %hash;
Insert an item $V with a key $K?
$hash{$K} = $V
Find for a particular name / key $K?
if (exists $hash{$K}) {
print "it is in there with value '$hash{$K}'\n";
} else {
print "it is NOT in there\n"
}
Delete a particular name / key?
delete $hash{$K}
Make name and date as key and entire item as value?
Easy Way: Just string everything together
set: $hash{ "$name:$date" } = "$name:$date:$field1:$field2"
get: my ($name2,$date2,$field1,$field2) = split ':', $hash{ "$name:$date" }
del: delete $hash{ "$name:$date" }
Harder Way: Store as a hash in the hash (google "perl object")
set:
my %temp;
$temp{"name"} = $name;
$temp{"date"} = $date;
$temp{"field1"} = $field1;
$temp{"field2"} = $field2
$hash{"$name:$date"} = \$temp;
get:
my $find = exists $hash{"$name:$date"} ? $hash{"$name:$date"} : undef;
if (defined find) { # i.e. it was found
printf "field 1 is %s\n", $find->{"field1"}
} else {
print "Not found\n";
}
delete:
delete $hash{"$name:$date"}
It is not easy to understand what you are asking because you do not describe the input and the desired outputs specifically.
My best guess is something along the lines of:
#!/usr/bin/perl
use strict; use warnings;
my #list = (
q(item1{'name'}),
q(item1{'date'}),
);
my %lookup;
for my $entry ( #list ) {
my ($name, $attrib) = $entry =~ /([^{]+){'([^']+)'}/;
$lookup{ $name }{ $attrib } = $entry;
}
for my $entry ( keys %lookup ) {
my %entry = %{ $lookup{$entry} };
print "#entry{keys %entry}\n"
}
use YAML;
print Dump \%lookup;
Output:
item1{'date'} item1{'name'}
---
item1:
date: "item1{'date'}"
name: "item1{'name'}"
If you know what items, you are going to need and what order you'll need them in
for keys, then re parsing the key is of questionable value. I prefer to store
them in levels.
$hash{ $h->{name} }{ $h->{date} } = $h;
# ... OR ...
$hash{ $h->{date} }{ $h->{name} } = $h;
foreach my $name ( sort keys %hash ) {
my $name_hash = $hash{$name};
foreach my $date ( keys %$name_hash ) {
print "\$hash{$name}{$date} => " . Dumper( $name_hash->{$date} ) . "\n";
}
}
For arbitrary levels, you may want a traversal function
sub traverse_hash (&#) {
my ( $block, $hash_ref, $path ) = #_;
$path = [] unless $path;
my ( #res, #results );
my $want = wantarray;
my $want_something = defined $want;
foreach my $key ( %$hash_ref ) {
my $l_path = [ #$path, $key ];
my $value = $hash_ref->{$key};
if ( ref( $value ) eq 'HASH' ) {
#res = traverse_hash( $block, $value, $l_path );
push #results, #res if $want_something && #res;
}
elsif ( $want_something ) {
#res = $block->( $l_path, $value );
push #results, #res if #res;
}
else {
$block->( $path, $value );
}
}
return unless $want_something;
return $want ? #results : { #results };
}
So this does the same thing as above:
traverse_hash {
my ( $key_path, $value ) = #_;
print( '$hash{' . join( '}{', #$key_path ) . '} => ' . ref Dumper( $value ));
();
} \%hash
;
Perl Solution
#!/usr/bin/perl -w
use strict;
use Data::Dumper;
sub main{
my %hash;
my #keys = qw(firstname lastname age); # hash's keys
# fname lname age
# --------|--------|-----
my #arr = ( [ 'foo1', 'bar1', '1' ],
[ 'foo2', 'bar2', '2' ],
[ 'foo3', 'bar3', '3' ]
);
# test if array set up correctly
print "\$arr[1][1] : $arr[1][1] \n"; # bar2
# loads the multidimensional array into the hash
for my $row (0..$#arr){
for my $col ( 0..$#{$arr[$row]} ){
my $itemnum = "item" . ($row+1); # using the item# format you used
$hash{$itemnum}->{$keys[$col]} = $arr[$row][$col];
}
}
# manually add a 4th item
$hash{item4} = {"firstname", "foo", "lastname", "bar", "age", "35"};
# How to Retrieve
# -----------------------
# single item pull
print "item1->firstname : $hash{item1}->{firstname} \n"; # foo1
print "item3->age : $hash{item3}->{age} \n"; # 3
# whole line 1
{ local $, = " ";
print "full line :" , %{$hash{item2}} , "\n"; # firstname foo2 lastname bar2 age 2
}
# whole line 2
foreach my $key (sort keys %{$hash{item2}}){
print "$key : $hash{item2}{$key} \n";
}
# Clearer description
#print "Hash:\n", Dumper %hash;
}
main();
This should be used in addition to the accepted answer. Your question was a little vague on the array to hash requirement, perhaps this is the model you are looking for?
I have a function to search an array of objects for a matching value using the eq operator, like so:
sub find {
my ( $self, %params ) = #_;
my #entries = #{ $self->{_entries} };
if ( $params{filename} ) {
#entries = grep { $_->filename eq $params{filename} } #entries;
}
if ( $params{date} ) {
#entries = grep { $_->date eq $params{date} } #entries;
}
if ( $params{title} ) {
#entries = grep { $_->title eq $params{title} } #entries;
}
....
I wanted to also be able to pass in a qr quoted variable to use in the comparison instead but the only way I can think of separating the comparisons is using an if/else block, like so:
if (lc ref($params{whatever}) eq 'regexp') {
#use =~
} else {
#use eq
}
Is there a shorter way of doing it? Because of reasons beyond my control I'm using Perl 5.8.8 so I can't use the smart match operator.
TIA
This is Perl, so of course there's a CPAN module: Match::Smart. It works very similarly to Perl 5.10's smart match operator, only you type smart_match($a, $b) rather than $a ~~ $b.
You may wish to compare with the perlsyn documentation for 5.10 smartmatching as Match::Smart handles quite a few more situations.
Otherwise, I don't see anything wrong with:
sub smart_match {
my ($target, $param) = #_;
if (ref $param eq 'Regexp') {
return ($target =~ qr/$param/);
}
else {
return ($target eq $param);
}
}
#entries = grep { smart_match($_->date, $params{date}) } #entries;
I don't know exactly what you want your end result to be, but you can do:
for my $field (qw(filename date title)) {
my $p = $param($field};
#entries = (ref($p) eq 'regexp')
? grep { $_->$field =~ /$p/ } #entries
: grep { $_->$field eq $p } #entries;
}
Alternatively, you can turn even your 'eq' comparisions into regular expressions, e.g.:
my $entry = "string to be equal to";
my $re = qr/^\Q$entry\E/;
and that simplifies the logic in the for loop.