Simple hash search by value - perl

I have a simple hash, and would like to return the $key based on $value criteria. That is, for line 14, what code would I need to return the $key where the $value is "yellow"?
1 #!/usr/bin/perl
2
3 # This program creates a hash then
4 # prints out what is in the hash
5
6 %fruit = (
7 'apple' => ['red','green'],
8 'kiwi' => 'green',
9 'banana' => 'yellow',
10 );
11
12 print "The apple is #{$fruit{apple}}.\n";
13 print "The kiwi is $fruit{kiwi}.\n";
14 print "What is yellow? ";

grep is the right tool for this job:
my #all_matches = grep { $fruit{$_} eq 'yellow' } keys %fruit;
print("$_ ") foreach #matching_keys;
my ($any_match) = grep { $fruit{$_} eq 'yellow' } keys %fruit;

I'm not so sure that's easy to do efficiently with a one-way hash. The whole point of a hash is to convert the key into a value (or position of the value if you're looking under the covers). You can do an exhaustive search over all the values, collecting the keys as you go but that's not as efficient as a hash lookup.
In order to go the other way efficiently, you might want to consider a two-way hash, something like:
%fruit = (
'apple' => ['red','green'],
'kiwi' => 'green',
'banana' => 'yellow',
);
%antifruit = (
'red' => 'apple',
'green' => ['apple','kiwi'],
'yellow' => 'banana',
);
print "The apple is #{$fruit{'apple'}}.\n";
print "The kiwi is $fruit{'kiwi'}.\n";
print "A yellow thing is $antifruit{'yellow'}.\n";

sub find_key {
my ( $h, $value ) = #_;
while ( my ( $k, $v ) = each %$h ) {
return $k if $v eq $value;
}
return;
}
So you could call it like so:
find_key( \%fruit, 'yellow' );

Since some of your values are arrays, you need to check for that.
Calling:
my #fruit = getfruit(\%fruit, $colour);
The subroutine:
sub getfruit {
my ($fruit, $col) = #_;
my #result;
for my $key (keys %$fruit) {
if (ref $fruit->{$key} eq 'ARRAY') {
for (#{$fruit->{$key}}) {
push #result, $key if /^$col$/i;
}
} else {
push #result, $key if $fruit->{$key} =~ /^$col$/i;
}
}
return #result;
}
Using a regex instead of eq is optional, just be mindful of keeping the same case, since Yellow and yellow are considered different keys.

I note your example has references to anonymous arrays, so I would just do a long winded foreach/if loop:
my %fruit = (
'apple' => ['red','green'],
'kiwi' => 'green',
'banana' => 'yellow',
);
print "The apple is #{$fruit{apple}}.\n";
print "The kiwi is $fruit{kiwi}.\n";
print "What is yellow? ";
my $ele;
my $search = 'yellow';
my #match = ();
foreach $ele (keys(%fruit)) {
if(ref($fruit{$ele}) eq 'ARRAY' and
grep { $_ eq $search } #{ $fruit{$ele} }) {
push(#match, $ele);
} elsif(!ref($fruit{$ele}) and $fruit{$ele} eq $search) {
push(#match, $ele);
}
}
print join(", ", #match) . "\n";

Related

Hash adding value without assignment [duplicate]

This question already has an answer here:
Hash in Perl adds key if it does not exist
(1 answer)
Closed 4 years ago.
I've got a script which contains 2 hashes and while printing out the contents I'm finding that the script is assigning a value to the 2nd hash without me doing it. I read through the 1st hash, then the 2nd, and then read through the entire 2nd hash after. It should only contain 1 entry in hash2, but it now contains 2 entries. How is the value James in hash2 getting assigned here?
my %hash1 = ();
my %hash2 = ();
$hash1{"James"}{"1 Main Street"}++;
$hash1{"John"}{"2 Elm Street"}++;
$hash2{"John"}{"3 Oak Street"}++;
foreach my $name (keys %hash1) {
print "Hash1 Name $name\n";
foreach my $address (keys %{$hash1{$name}}) {
print "Hash1 Address $address\n";
foreach my $address (keys %{$hash2{$name}}) {
print "Hash2 Address $address\n";
}
}
}
print "\n";
foreach my $name (keys %hash2) {
print "Hash2 Name $name\n";
foreach my $address (keys %{$hash2{$name}}) {
print "Hash2 Address $address\n";
}
}
output looks like this:
Hash1 Name James
Hash1 Address 1 Main Street
Hash1 Name John
Hash1 Address 2 Elm Street
Hash2 Address 3 Oak Street
Hash2 Name James
Hash2 Name John
Hash2 Address 3 Oak Street
The second value is being created when you are trying to read non-existan key from hash 2.
my %hash1 = ();
my %hash2 = ();
$hash1{"James"}{"1 Main Street"}++;
$hash1{"John"}{"2 Elm Street"}++;
$hash2{"John"}{"3 Oak Street"}++;
foreach my $name (keys %hash1) {
print "Hash1 Name $name\n";
foreach my $address (keys %{$hash1{$name}}) {
print "Hash1 Address $address\n";
next unless exists $hash2{$name}; # check if the key exists in second hash before trying to use the key in $hash2
foreach my $address (keys %{$hash2{$name}}) { #second value gets created here
print "Hash2 Address $address\n";
}
}
}
print "\n";
foreach my $name (keys %hash2) {
print "Hash2 Name $name\n";
foreach my $address (keys %{$hash2{$name}}) {
print "Hash2 Address $address\n";
}
}
When you used an undefined value as if it's a reference, Perl makes the reference sort that you wanted then tries to perform the operation. This is called "auto-vivification".
Here's a small demonstration. A variable starts out as undefined. You then treat it as an array reference (the dereference to get the 0th element):
use Data::Dumper;
my $empty;
print Dumper( $empty );
my $value = $empty->[0];
print Dumper( $empty );
Perl converts $empty to an array reference then tries to get the 0th element from that. You are left with an array reference where you formerly had undef:
$VAR1 = undef;
$VAR1 = [];
This is intended behavior.
Take it one step further. Put that undef inside an array and treat that element as if it's an array reference:
use Data::Dumper;
my #array = ( 1, undef, 'red' );
print Dumper( \#array );
my $value = $array[1]->[0];
print Dumper( \#array );
Now the second element is an empty array reference:
$VAR1 = [
1,
undef,
'red'
];
$VAR1 = [
1,
[],
'red'
];
Take it another step further. Don't store the undef value. Instead, access an array position past the last item in the array:
use Data::Dumper;
my #array = ( 1, 'red' );
print Dumper( \#array );
my $value = $array[2]->[0];
print Dumper( \#array );
Now you get an array reference element in your array. It's one element longer now:
$VAR1 = [
1,
'red'
];
$VAR1 = [
1,
'red',
[]
];
Had you gone further out (say, element 5), the interstitial elements up to the element you wanted would have been "filled in" with undef:
use Data::Dumper;
my #array = ( 1, 'red' );
print Dumper( \#array );
my $value = $array[5]->[0];
print Dumper( \#array );
$VAR1 = [
1,
'red'
];
$VAR1 = [
1,
'red',
undef,
undef,
undef,
[]
];
A hash works the same way, and that's what you are seeing. When you want to check if there is a second-level key under James, Perl needs to create the James key and give it an empty hash ref value to it can check that. That second-level key is not there, but the first-level key of 'James' sticks around:
use Data::Dumper;
my %hash = (
John => { Jay => '137' },
);
print Dumper( \%hash );
if( exists $hash{James}{Jay} ) {
print $hash{James}{Jay};
}
print Dumper( \%hash );
Now you see an extra key:
$VAR1 = {
'John' => {
'Jay' => '137'
}
};
$VAR1 = {
'James' => {},
'John' => {
'Jay' => '137'
}
};
In this case, you don't like this feature, but you can turn it off with the no autovivification pragma. It's a CPAN module that you need to install first:
no autovivification;
use Data::Dumper;
my %hash = (
John => { Jay => '137' },
);
print Dumper( \%hash );
if( exists $hash{James}{Jay} ) {
print $hash{James}{Jay};
}
print Dumper( \%hash );
You don't get the extra key:
$VAR1 = {
'John' => {
'Jay' => '137'
}
};
$VAR1 = {
'John' => {
'Jay' => '137'
}
};
You might also like to read How can I check if a key exists in a deep Perl hash?. I show a method that allows you to inspect a nested hash without creating intermediate levels.

printing out a multilevel hash perl 5

I have to make sense of this script , without making major changes and insulting the guy who made it. I can't change the hashes, even though it would be easy to load data into arrays and then split. The guy who wrote this (my boss) loves his multilevel hashes. I have to print out the %extend_hash multilevel hash - and I don't understand how to get to the last level. I need to print this out in to a CSV file that cane be read by salespeople.
It looks like it goes out like 6 levels.
I have to sort keys of a hash, of a hash, of a hash ...etc.
#!/scripts/perl/bin/perl
use strict;
use warnings;
use DBI;
my $dbUser = 'foo_01';
my $dbPass = 'foo_01';
my $dbSid = 'foo.WORLD';
my $dbh = DBI->connect("dbi:Oracle:$dbSid","$dbUser","$dbPass") or die( "Couldn't connect: $!" );
#sub read_extend
my %extend_hash = ();
my $query = "select level_id,e_risk_symbol,e_exch_dest,penny,specialist from etds_extend";
if(!$dbh) {
print "Error connecting to DataBase; $DBI::errstr\n";
}
my $cur_msg = $dbh->prepare($query) or die "\n\nCould not prepare statement: ".$dbh->errstr;
$cur_msg->execute();
while (my #row=$cur_msg->fetchrow_array) {
$extend_hash{$row[0]}{$row[1]}{$row[2]}{'penny'}=$row[3];
$extend_hash{$row[0]}{$row[1]}{$row[2]}{'specialist'}=$row[4];
}
for my $what_row0 (sort keys %extend_hash) {
for my $what_row1 (sort keys %{$extend_hash {$what_row0} }) {
for my $what_row2 (sort keys ..... I am lost.
I don't know how to print out the %extend_hash down to the lowest level
I am trying to make it comma delimited, able to be pumped into an email and read by salespeople.
6,ACI,ARCX,specialist,1
6,ACI,ARCX,penny,0
6,MCHP,ARCX,specialist,1,
6,MCHP,ARCX,penny,0
6,BC,AMXO,specialist,1
6,BC,AMXO,penny,0
6,WM,XISX,specialist,1
6,WM,XISX,penny,0
6,PK,AMXO,specialist,1
6,PK,AMXO,penny,0
6,SPLS,XISX,specialist,1
6,SPLS,XISX,penny,0
If I use Data::Dumper I get this which is great, but the sales/marketing guys will get confused. They will not be able to see ARCX penny0 in realtions to the group '6'. I don't think they are able to mentally walt through the data::dump
$VAR1 = {
'6' => {
'IACI' => {
'ARCX' => {
'specialist' => '1',
'penny' => '0'
}
},
'MCHP' => {
'ARCX' => {
'specialist' => '1',
'penny' => '0'
}
},
'BC' => {
'AMXO' => {
'specialist' => '1',
'penny' => '0'
}
},
'WM' => {
'XISX' => {
'specialist' => '1',
'penny' => '0'
}
},
'PKD' => {
'AMXO' => {
'specialist' => '1',
'penny' => '0'
}
},
'SPLS' => {
'XISX' => {
'specialist' => '1',
'penny' => '0'
}
}
}
};
update - amazing work I_alarmed_alien - this should be a good stackoverflow reference (my comments are disabled)
for my $level_1 (sort keys %extend_hash) {
for my $level_2 (sort keys %{$extend_hash{$level_1} }) {
for my $level_3 (sort keys %{$extend_hash{$level_1}{$level_2}}) {
for my $type (sort keys %{$extend_hash{$level_1}{$level_2}{$level_3}} ) {
print "$level_1, $level_2, $level_3 $type" . " $extend_hash{$level_1}{$level_2}{$level_3}{$type}" ."\n" ;
}
}
}
}
got it - I_alarmed_alien amazing work outputing a hash of a hash of a hash of a hash of a hash of a hash
6, XLNX, AMXO , specialist 1
6, XLP, AMXO , penny 0
6, XLP, AMXO , specialist 1
6, XLP, XISX , penny 0
6, XLP, XISX , specialist 1
6, XLV, AMXO , penny 0
6, XLV, AMXO , specialist 1
6, XLY, AMXO , penny 0
6, XLY, AMXO , specialist 1
6, YUM, AMXO , penny 0
6, YUM, AMXO , specialist 1
6, ZINC, XISX , penny 0
6, ZINC, XISX , specialist 1
6, ZMH, AMXO , penny 0
6, ZMH, AMXO , specialist 1
to traverse the whole structure and create the comma-separated table (quick and dirty, but working solution):
my $VAR1 = <insert the hash here>
sub printval
{
my ($val, $path) = #_;
if (ref($val) eq "HASH")
{
printval ($val->{$_}, ($path?"$path,":"")."$_") foreach (keys %{$val});
}
else
{
print "$path,$val\n";
}
}
printval($VAR1);
You're almost there with your code. Here is how to get to the bottom of the hash:
foreach my $l1 (keys %extend_hash) {
# '6'
foreach my $l2 (keys %{$extend_hash{$l1}}) {
# IACI, MCHP, BC, etc.
foreach my $l3 (keys %{$extend_hash{$l1}{$l2}}) {
# ARCX, AMXO, XISX, etc.
foreach my $k (keys %{$extend_hash{$l1}{$l2}{$l3}}) {
print "$l1, $l2, $l3, $k, " . $extend_hash{$l1}{$l2}{$l3}{$k} . "\n";
}
}
}
}
Note that the hash keys are not accessed in any particular order, so you may want to sort them -- e.g. foreach my $l1 (sort keys %extend_hash).
Hashes of hashes of hashes of hashes are fun! ;)
ETA: Here is a more generic function for recursing into arbitrarily deep hashes-of-hashes-of-hashes-of...
sub print_hash {
# href = reference to the hash we're examining (i.e. \%extend_hash)
# so_far = arrayref containing the hash keys we are accessing
my $href = shift;
my $so_far = shift;
foreach my $k (keys %$href) {
# put $k on to the array of keys
push #$so_far, $k;
# if $href->{$k} is a reference to another hash, call print_hash on that hash
if (ref($href->{$k}) eq 'HASH') {
print_hash($href->{$k}, $so_far);
} else {
# $href->{$k} is a scalar, so print out #$so_far (our list of hash keys)
# and the value in $href->{$k}
print join(", ", #$so_far, $href->{$k}) . "\n";
}
# we've finished looking at $href->{$k}, so remove $k from the array of keys
pop #$so_far;
}
}
print_hash($hash, []);
if you only want to print it, use Data::Dumper http://perldoc.perl.org/Data/Dumper.html
To check whether a certain variable is a hash reference, use:
if (ref($r) eq "HASH") {
print "r is a reference to a hash.\n";
}
use Data::Dumper;
print Dumper %extend_hash;

Perl Working On Two Hash References

I would like to compare the values of two hash references.
The data dumper of my first hash is this:
$VAR1 = {
'42-MG-BA' => [
{
'chromosome' => '19',
'position' => '35770059',
'genotype' => 'TC'
},
{
'chromosome' => '2',
'position' => '68019584',
'genotype' => 'G'
},
{
'chromosome' => '16',
'position' => '9561557',
'genotype' => 'G'
},
And the second hash is similar to this but with more hashes in the array. I would like to compare the genotype of my first and second hash if the position and the choromosome matches.
map {print "$_= $cave_snp_list->{$_}->[0]->{chromosome}\n"}sort keys %$cave_snp_list;
map {print "$_= $geno_seq_list->{$_}->[0]->{chromosome}\n"}sort keys %$geno_seq_list;
I could do that for the first array of the hashes.
Could you help me in how to work for all the arrays?
This is my actual code in full
#!/software/bin/perl
use strict;
use warnings;
use Getopt::Long;
use Benchmark;
use Config::Config qw(Sequenom.ini);
useDatabase::Conn;
use Data::Dumper;
GetOptions("sam=s" => \my $sample);
my $geno_seq_list = getseqgenotypes($sample);
my $cave_snp_list = getcavemansnpfile($sample);
#print Dumper($geno_seq_list);
print scalar %$geno_seq_list, "\n";
foreach my $sam (keys %{$geno_seq_list}) {
my $seq_used = $geno_seq_list->{$sam};
my $cave_used = $cave_snp_list->{$sam};
print scalar(#$geno_seq_list->{$_}) if sort keys %$geno_seq_list, "\n";
print scalar(#$cave_used), "\n";
#foreach my $seq2com (# {$seq_used } ){
# foreach my $cave2com( # {$cave_used} ){
# print $seq2com->{chromosome},":" ,$cave2com->{chromosome},"\n";
# }
#}
map { print "$_= $cave_snp_list->{$_}->[0]->{chromosome}\n" } sort keys %$cave_snp_list;
map { print "$_= $geno_seq_list->{$_}->[0]->{chromosome}\n" } sort keys %$geno_seq_list;
}
sub getseqgenotypes {
my $snpconn;
my $gen_list = {};
$snpconn = Database::Conn->new('live');
$snpconn->addConnection(DBI->connect('dbi:Oracle:pssd.world', 'sn', 'ss', { RaiseError => 1, AutoCommit => 0 }),
'pssd');
#my $conn2 =Database::Conn->new('live');
#$conn2->addConnection(DBI->connect('dbi:Oracle:COSI.world','nst_owner','nst_owner', {RaiseError =>1 , AutoCommit=>0}),'nst');
my $id_ind = $snpconn->execute('snp::Sequenom::getIdIndforExomeSample', $sample);
my $genotype = $snpconn->executeArrRef('snp::Sequenom::getGenotypeCallsPosition', $id_ind);
foreach my $geno (#{$genotype}) {
push #{ $gen_list->{ $geno->[1] } }, {
chromosome => $geno->[2],
position => $geno->[3],
genotype => $geno->[4],
};
}
return ($gen_list);
} #end of sub getseqgenotypes
sub getcavemansnpfile {
my $nstconn;
my $caveman_list = {};
$nstconn = Database::Conn->new('live');
$nstconn->addConnection(
DBI->connect('dbi:Oracle:CANP.world', 'nst_owner', 'NST_OWNER', { RaiseError => 1, AutoCommit => 0 }), 'nst');
my $id_sample = $nstconn->execute('nst::Caveman::getSampleid', $sample);
#print "IDSample: $id_sample\n";
my $file_location = $nstconn->execute('nst::Caveman::getCaveManSNPSFile', $id_sample);
open(SNPFILE, "<$file_location") || die "Error: Cannot open the file $file_location:$!\n";
while (<SNPFILE>) {
chomp;
next if /^>/;
my #data = split;
my ($nor_geno, $tumor_geno) = split /\//, $data[5];
# array of hash
push #{ $caveman_list->{$sample} }, {
chromosome => $data[0],
position => $data[1],
genotype => $nor_geno,
};
} #end of while loop
close(SNPFILE);
return ($caveman_list);
}
The problem that I see is that you're constructing a tree for generic storage of data, when what you want is a graph, specific to the task. While you are constructing the record, you could also be constructing the part that groups data together. Below is just one example.
my %genotype_for;
my $record
= { chromosome => $data[0]
, position => $data[1]
, genotype => $nor_geno
};
push #{ $gen_list->{ $geno->[1] } }, $record;
# $genotype_for{ position }{ chromosome }{ name of array } = genotype code
$genotype_for{ $data[1] }{ $data[0] }{ $sample } = $nor_geno;
...
return ( $caveman_list, \%genotype_for );
In the main line, you receive them like so:
my ( $cave_snp_list, $geno_lookup ) = getcavemansnpfile( $sample );
This approach at least allows you to locate similar position and chromosome values. If you're going to do much with this, I might suggest an OO approach.
Update
Assuming that you wouldn't have to store the label, we could change the lookup to
$genotype_for{ $data[1] }{ $data[0] } = $nor_geno;
And then the comparison could be written:
foreach my $pos ( keys %$small_lookup ) {
next unless _HASH( my $sh = $small_lookup->{ $pos } )
and _HASH( my $lh = $large_lookup->{ $pos } )
;
foreach my $chrom ( keys %$sh ) {
next unless my $sc = $sh->{ $chrom }
and my $lc = $lh->{ $chrom }
;
print "$sc:$sc";
}
}
However, if you had limited use for the larger list, you could construct the specific case
and pass that in as a filter when creating the longer list.
Thus, in whichever loop creates the longer list, you could just go
...
next unless $sample{ $position }{ $chromosome };
my $record
= { chromosome => $chromosome
, position => $position
, genotype => $genotype
};
...

array to hash in perl

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?

Recursively printing data structures in Perl

I am currently learning Perl. I have Perl hash that contains references to hashes and arrays. The hashes and arrays may in turn contain references to other hashes/arrays.
I wrote a subroutine to parse the hash recursively and print them with proper indentation. Though the routine works as expected, my instructor was not convinced about the readability and elegance of the below code.
I would really appreciate to get the views of Perl experts here on possible optimization of the below code.
Here is my complete code snippet..
# Array of Arrays
$ref_to_AoA = [
[ "fred", "barney" ],
[ "george", "jane", "elroy" ],
[ "homer", "marge", "bart" ],
];
#Array of Hashes
$ref_to_AoH = [
{
husband => "barney",
wife => "betty",
son => "bamm bamm",
},
{
husband => "george",
wife => "jane",
son => "elroy",
},
];
# Hash of Hashes
$ref_to_HoH = {
flintstones => {
husband => "fred",
pal => "barney",
},
jetsons => {
husband => "george",
wife => "jane",
"his boy" => "elroy", # Key quotes needed.
},
simpsons => {
husband => "homer",
wife => "marge",
kid => "bart",
},
};
# Hash which contains references to arrays and hashes
$finalHash = {
'arrayofArrays' => $ref_to_AoA,
'arrayofHash' => $ref_to_AoH,
'hashofHash' => $ref_to_HoH,
};
$string = str($finalHash);
print "$string\n";
#------------------------------------------------------------------
sub str {
my $hash = shift;
my ($space, $newline, $delimiter) = #_;
$space = "" unless (defined $space);
$newline = "\n\n\n" unless (defined $newline);
$delimiter = "\n--------------------------------------------" unless (defined $delimiter);
my $str = "";
for (sort keys %{$hash}) {
my $value = $hash->{$_};
$str .= "$newline$space$_ == $value$delimiter";
$str .= recurseErrors($value,$space);
}
$str;
}
#------------------------------------------------------------------
sub recurseErrors {
my $str;
my ($value,$space) = #_;
my $ref = ref $value;
if ($ref eq 'ARRAY') {
my $i = 0;
my $isEmpty = 1;
my #array = #$value;
$space .= "\t";
for my $a (#array) {
if (defined $a) {
$isEmpty = 0;
$str .= "\n$space$_\[$i\] :";
$str .= recurseErrors($a,$space);
}
$i++;
}
$str .= "= { }" if ($isEmpty);
} elsif ($ref eq 'HASH') {
$space .= "\t";
for my $k (sort keys %$value) {
if ( ( ref($value->{$k}) eq 'HASH') || (ref $value->{$k} eq 'ARRAY') ) {
my $val = $value->{$k};
$str .= "\n\n$space$k == ";
$str .= "$val";
}
else {
$str .= "\n$space$k == ";
}
$str .= recurseErrors($value->{$k},$space);
}
# we have reached a scalar (leaf)
} elsif ($ref eq '') {
$str .= "$value";
}
$str
}
#------------------------------------------------------------------
Output:
arrayofArrays == ARRAY(0x9d9baf8)
--------------------------------------------
arrayofArrays[0] :
arrayofArrays[0] :fred
arrayofArrays[1] :barney
arrayofArrays[1] :
arrayofArrays[0] :george
arrayofArrays[1] :jane
arrayofArrays[2] :elroy
arrayofArrays[2] :
arrayofArrays[0] :homer
arrayofArrays[1] :marge
arrayofArrays[2] :bart
arrayofHash == ARRAY(0x9d9bba8)
--------------------------------------------
arrayofHash[0] :
husband == barney
son == bamm bamm
wife == betty
arrayofHash[1] :
husband == george
son == elroy
wife == jane
hashofHash == HASH(0x9da45f8)
--------------------------------------------
flintstones == HASH(0x9d9bb48)
husband == fred
pal == barney
jetsons == HASH(0x9d9bbf8)
his boy == elroy
husband == george
wife == jane
simpsons == HASH(0x9d9bc48)
husband == homer
kid == bart
wife == marge
Always use use strict;
To be a good boy, use use warnings as well.
The names you use for subroutines should make it obvious what the subroutine does. "recurseErrors" kind of violates that principle. Yes, it does recurse. But what errors?
On the first line of each subroutine you should declare and initialize any parameters. recurseErrors first declares $str and then declares its parameters.
Don't mix shift and = #_ like you do in str()
You might consider breaking up what is now called recurseErrors into specialized routines for handling arrays and hashes.
There's no need to quote variables like you do on lines 99 and 109.
Apart from that I think your instructor had a bad day that day.
maybe Data::Dumper is what you want:
use Data::Dumper;
$str = Dumper($foo);
print($str);
If you are new to perl, I'd recommend running your code through perl-critic (there is also a script you can install from CPAN, normally I use it as a test so it gets run from the command line whenever I do "make test"). In addition to its output, you might want to break up your functions a bit more. recurseErrors has three cases that could be split into sub functions (or even put into a hash of ref-type to sub-function ref).
If this were a production job, I'd use Data::Dumper, but it sounds like this is homework, so your teacher might not be too pleased.
Here is one simple example why your code is not easily readable:
$delimiter = "\n--------------------------------------------" unless (defined $delimiter);
You could use the defined or operator:
$delimiter //= "\n" . '-' x 44;
If you are worried about earlier Perls:
defined $delimeter or $delimeter = "\n" . '-' x 44;
Conditionals going off the right margin are enough of a turn-off for me not to read the rest of the code.
My guess is that he doesn't like that you
expect a hash in the str function.
call the same function to print arrays as hashes, despite that there appears to be no common function between them.
allow various ways to call str, but it never figures into the final result.
allow configurable space to be passed in to the root function, but have a tab hardcoded in the recursive function.
omit undefined values that actually hold a place in the arrays
Those are issues that I can see, pretty quickly.
You could have separated out the code blocks that dealt with arrays, and hashes.
sub recurse{
...
recurse_A(#_) if $ref eq 'ARRAY';
recurse_H(#_) if $ref eq 'HASH';
...
}
sub recurse_A{ ... }
sub recurse_H{ ... }
I would recommend starting out your subroutines like this, unless you have a real good reason for doing otherwise.
sub example{
my( $one, $two, $three, $optional_four ) = #_;
( If you do it like this then Komodo, at least, will be able to figure out what the arguments are to your subroutine )
There is rarely any reason to put a variable into a string containing only the variable.
"$var" eq $var;
The only time I can think I would ever do that is when I am using an object that has an overloaded "" function, and I want to get the string, without also getting the object.
package My_Class;
use overload
'""' => 'Stringify',
;
sub new{
my( $class, $name ) = #_;
my $self = bless { name => $name }, $class;
return $self;
}
sub Stringify{
my( $self ) = #_;
return $self->{name};
}
my $object = My_Class->new;
my $string = "$object";
I've struggled with this same problem before, and found my way here. I almost used a solution posted here, but found a more suitable one (for me anyway). Read about Depth First Recursion here.
The sub in the above article works perfectly with a reference containing other Hashes, Arrays, or Scalars. It did not print Hash key names, though, so I slightly modified it:
#!/usr/bin/perl
#
# See:
#
# http://perldesignpatterns.com/?DepthFirstRecursion
#
use strict;
use warnings;
my %hash = (
'a' => {
'one' => 1111,
'two' => 222,
},
'b' => [ 'foo', 'bar' ],
'c' => 'test',
'd' => {
'states' => {
'virginia' => 'richmond',
'texas' => 'austin',
},
'planets' => [ 'venus','earth','mars' ],
'constellations' => ['orion','ursa major' ],
'galaxies' => {
'milky way' => 'barred spiral',
'm87' => 'elliptical',
},
},
);
&expand_references2(\%hash);
sub expand_references2 {
my $indenting = -1;
my $inner; $inner = sub {
my $ref = $_[0];
my $key = $_[1];
$indenting++;
if(ref $ref eq 'ARRAY'){
print ' ' x $indenting,'ARRAY:';
printf("%s\n",($key) ? $key : '');
$inner->($_) for #{$ref};
}elsif(ref $ref eq 'HASH'){
print ' ' x $indenting,'HASH:';
printf("%s\n",($key) ? $key : '');
for my $k(sort keys %{$ref}){
$inner->($ref->{$k},$k);
}
}else{
if($key){
print ' ' x $indenting,$key,' => ',$ref,"\n";
}else{
print ' ' x $indenting,$ref,"\n";
}
}
$indenting--;
};
$inner->($_) for #_;
}
#use strict ;
use warnings ;
# use module
use XML::Simple;
use Data::Dumper;
#debug print "START SCRIPT " ;
my $fileToParse = 'C:/Temp/CDIP/scripts/perl/nps_all_workflows.xml' ;
# create object
my $objXml= new XML::Simple;
# read XML file
my $data = $objXml->XMLin("$fileToParse");
# #debug print "\n FirstLevel is " . $objXml->{'POWERMART'} ;
my $level = 1 ;
#
printHashKeyValues ($data ) ;
sub printHashKeyValues
{
$level ++ ;
my $refHash = shift ;
my $parentKey = shift ;
my $parentValue = shift ;
while( my ($key, $value) = each %$refHash)
{
if ( defined ( $key ) )
{
if ( ref ($refHash->{"$key"}) eq 'HASH' )
{
my $newRefHash = $refHash->{"$key"} ;
#debug print " \n The key is a hash " ;
printHashKeyValues ($newRefHash , $key , $value) ;
}
if ( ref ($refHash->{"$key"}) eq 'ARRAY' )
{
#debug print " \n the key is an ARRAY " ;
printArrayValues ( $refHash->{"$key"} ) ;
}
} #eof if ( defined ( $key ))
if ( defined ( $value) )
{
if ( ref ($refHash->{"$value"}) eq 'HASH' )
{
my $newRefHash = $refHash->{"$value"} ;
#debug print " \n The value is a hash " ;
printHashKeyValues ($newRefHash , $key , $value) ;
}
if ( ref ($refHash->{"$value"}) eq 'ARRAY' )
{
#debug print " \n the value is an ARRAY " ;
printArrayValues ( $refHash->{"$value"} ) ;
}
} #eof if defined ( $value )
#debug print "\n key: $key, value: $value.\n";
} #eof while
} #eof sub
sub printArrayValues
{
my $arrRef = shift ;
my #array = #$arrRef;
my $parrentArrayElement = shift ;
#debug print "printArrayValues CALLED " ;
foreach my $arrayElement ( #array )
{
if (defined ( $arrayElement ) )
{
if ( ref ($arrayElement) eq 'HASH' )
{
#debug print " \n The \$arrayElement is a hash FROM THE ARRAY " ;
printHashKeyValues ($arrayElement ) ;
} #eof if
if ( ref ($arrayElement) eq 'ARRAY' )
{
#debug print " \n The \$arrayElement is a ARRAY FROM THE ARRAY " ;
printArrayValues ($arrayElement ) ;
} #eof if
#debug print "\n \$arrayElement is $arrayElement " ;
} #eof if ( defined ( $arrayElement ) )
} #eof foreach
} #eof sub
# #debug print output
##debug print Dumper($data);
1 ;