Related
I have to serialize and deserialize in Perl. I am aware that Data::Dumper and eval are not the best suited ones for this job but I am not allowed to modify this aspect in the legacy scripts which I am working on.
Below are two ways ( CODE 1 and CODE 2 ) to use eval.
In CODE 1, the hash is available as a string before being deserialized via eval.
In CODE 2, the hash is serialized using Dumper before being deserialized via eval.
In both the code samples, one of two attempted ways to deserialize works. Why does the other way to deserialize not work ?
CODE 1
my $r2 = "(
'w' => {
'k2' => 5,
'k1' => 'key',
'k3' => [
'a',
'b',
2,
'3'
]
},
'q' => 2
)";
my %z;
eval "\%z = $r2"; ####### Works.
print "\%z = [".Data::Dumper::Dumper (\%z)."] ";
my $answer = eval "$r2"; #### Does NOT work.
print "\n\nEvaled = [".Dumper($answer)."] ";
Output
%z = [$VAR1 = {
'w' => {
'k2' => 5,
'k1' => 'key',
'k3' => [
'a',
'b',
2,
'3'
]
},
'q' => 2
};
]
Evaled = [$VAR1 = 2;
]
But below code works in reverse manner :
CODE 2
my %a = ( "q" =>2, "w"=>{ "k1"=>"key", "k2"=>5, k3=>["a", "b", 2, "3",], }, ); **# Same hash as above example.**
$Data::Dumper::Terse=1;
$Data::Dumper::Purity = 1;
my $r2 = Dumper(\%a);
my %z;
eval '\%z = $r2';
print "\n\n\%z = [".Dumper(\%z)."] "; #### Does NOT work.
my $answer = eval $r2;
print "\n\nEvaled = [".Dumper($answer)."] "; ####### Works.
Output
%z = [$VAR1 = {};
]
Evaled = [$VAR1 = {
'w' => {
'k2' => 5,
'k1' => 'key',
'k3' => [
'a',
'b',
2,
'3'
]
},
'q' => 2
};
]
First of all, please don't put comments that result in syntax errors (**).
Notice that the string you provided in the first code block produces different data structure than the Dumper function. In the first block you are creating a hash, but you don't assign it to any variable. In case of the Dumper function, anonymous hash is created and it's reference is passed to the $VAR variable.
To make the first code work, you should replace ( with { to create anonymous hash and then assign it to a variable, for example:
my $r2 = "$VAR = {
'w' => {
'k2' => 5,
'k1' => 'key',
'k3' => [
'a',
'b',
2,
'3'
]
},
'q' => 2
}";
Don't use Data::Dumper to serialize data. Having said that...
This is a problem of scalar and list context. In the second eval, you have:
my $answer = ...;
Since you are assigning to a scalar, the right side is evaluated in scalar context. That means the eval is in scalar context. That value is:
(
'w' => {
'k2' => 5,
'k1' => 'key',
'k3' => [
'a',
'b',
2,
'3'
]
},
'q' => 2
)
That looks like a list, but it's really the comma operator in scalar context. That evaluates the left hand side, discards that result, and returns the righthand side. So, my $x = ( 'left', 'right' ) assigns right to $x. This is covered in What is the difference between a list and an array? in perlfaq4.
In your question, you see that $r gets the value 2. That's the rightmost value in the comma chain, so that's the value you get back in scalar context. Change that to another value (perhaps 'duck'), and that's the value that you'll get back:
my $r2 = "(
'w' => {
'k2' => 5,
},
'q' => 'duck'
)";
my $answer = eval "$r2";
use Data::Dumper;
print "Evaled =\n" . Dumper($answer);
It's not a number, which confuses people because they think it's some sort of count:
Evaled =
$VAR1 = 'duck';
Change that to assign in list context (that hash assignment is a list assignment) and you get the right answer:
my $r2 = "(
'w' => {
'k2' => 5,
},
'q' => 'duck'
)";
my #answer = eval "$r2";
use Data::Dumper;
print "Evaled =\n" . Dumper(\#answer);
Now it's the data structure you thought it should be:
Evaled =
$VAR1 = [
'w',
{
'k2' => 5
},
'q',
'duck'
];
I have searched for examples of returning even and odd elements of an array in Perl and came across some examples using map and grep.
#array = ('a', 'b', 'c', 'd', 'e', 'f', 'g');
#list = grep {$_ % 2} 0..$#array;
I have tried to return b, d, f from the given array but it's just returning numbers and not the actual value.
How can I get the actual values back?
Use an array slice with grep() to produce a list of indices.
my #array = qw(a b c d e f g);
my #list = #array[ grep { $_ % 2 } 0 .. $#array ];
I would like to write an simple perl script to generate all possible words for given phone number.
I started with definition of an array:
my #nums = (
['0'],
['1'],
['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'],
['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'],
['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'],
['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']
);
The final script should generate following output:
$ num2word 12
12
1a
1b
1c
$ num2word 213
213
21d
21e
21f
a13
a1d
a1e
a1f
b13
b1d
b1e
b1f
c13
c1d
c1e
c1f
I am looking for any module which can do most part of the job (something like List::Permutor which does not seem to qualify for this task).
Any hints?
Thanks!
Our very own #brian d foy has solved this problem with his Set::CrossProduct module.
use Set::CrossProduct;
my $iterator = Set::CrossProduct->new(
[ [ qw(8 t u v) ], [ qw(0) ], [ qw(7 p q r s) ] ] );
print "#$_\n" for $iterator->combinations;
Output:
8 0 7
8 0 p
8 0 q
8 0 r
8 0 s
t 0 7
t 0 p
t 0 q
t 0 r
t 0 s
u 0 7
u 0 p
u 0 q
u 0 r
u 0 s
v 0 7
v 0 p
v 0 q
v 0 r
v 0 s
This does what you ask.
use strict;
use warnings;
my #nums = (
[ qw/ 0 / ],
[ qw/ 1 / ],
[ qw /2 a b c / ],
[ qw /3 d e f / ],
[ qw /4 g h i / ],
[ qw /5 j k l / ],
[ qw /6 m n o / ],
[ qw /7 p q r s / ],
[ qw /8 t u v / ],
[ qw /9 w x y z / ],
);
list_matching('12');
list_matching('213');
sub list_matching {
my ($num) = #_;
my #num = $num =~ /\d/g;
my #map = (0) x #num;
do {
print join('', map { $nums[$num[$_]][$map[$_]] } 0 .. $#num), "\n";
my $i = $#map;
while ($i >= 0) {
last if ++$map[$i] < #{ $nums[$num[$i]] };
$map[$i--] = 0;
}
} while grep $_, #map;
}
output
12
1a
1b
1c
213
21d
21e
21f
a13
a1d
a1e
a1f
b13
b1d
b1e
b1f
c13
c1d
c1e
c1f
See the functions in Algorithm::Combinatorics.
Actually, does work, too early for me...
use autodie;
use strict;
use warnings;
my #nums = (
['0'],
['1'],
['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'],
['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'],
['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'],
['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']
);
my $input = shift || die "Need a number!\n";
die "Input not numeric!\n" unless $input =~ m/^\d+$/;
my #digits = split //, $input;
my #rows;
push #rows, $nums[$_] for #digits;
print_row(0,'');
exit;
sub print_row {
my $i = shift;
my $word = shift;
my $row = $rows[$i];
for my $j (0..$#{$row}) {
my $word2 = $word . $row->[$j];
if ($i < $#rows) {
print_row($i+1, $word2);
}
else {
print "$word2\n";
}
}
}
No modules required:
my #nums = (
['0'],
['1'],
['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'],
['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'],
['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'],
['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']
);
print "$_\n" while glob join '', map sprintf('{%s}', join ',', #{$nums[$_]}), split //, $ARGV[0]
use strict;
use warnings;
my #nums = (
['0'], ['1'], ['2', 'a', 'b', 'c'],
['3', 'd', 'e', 'f'], ['4', 'g', 'h', 'i'],
['5', 'j', 'k', 'l'], ['6', 'm', 'n', 'o'],
['7', 'p', 'q', 'r', 's'], ['8', 't', 'u', 'v'],
['9', 'w', 'x', 'y', 'z']);
num2word(12);
num2word(213);
sub num2word {
my ($i, $n, $t) = ($_[0]=~/(.)(.*)/, $_[1]);
for (#{$nums[$i]}) {
print "$t$_\n" and next if !length($n);
num2word($n, defined $t ? $t.$_ : $_);
}
}
A basic recursive solution:
#!/usr/bin/perl
use strict;
use warnings;
my $phone_number = $ARGV[0] or die "No phone number";
my #nums = (
['0'],
['1'],
[ '2', 'a', 'b', 'c' ],
[ '3', 'd', 'e', 'f' ],
[ '4', 'g', 'h', 'i' ],
[ '5', 'j', 'k', 'l' ],
[ '6', 'm', 'n', 'o' ],
[ '7', 'p', 'q', 'r', 's' ],
[ '8', 't', 'u', 'v' ],
[ '9', 'w', 'x', 'y', 'z' ]
);
my %letters = map { shift #{$_} => $_ } #nums;
my #permutations;
sub recurse {
my $str = shift;
my $done = shift || '';
unless ($str) {
push #permutations, $done;
return;
}
my $next = substr( $str, 0, 1 );
$str = substr( $str, 1 );
recurse( $str, $done . $next );
if ( my #chars = #{ $letters{$next} } ) {
recurse( $str, $done . $_ ) foreach #chars;
}
}
recurse($phone_number);
print "$_\n" foreach #permutations;
and:
perl num2word 12
12
1a
1b
1c
perl num2word 213
213
21d
21e
21f
a13
a1d
a1e
a1f
b13
b1d
b1e
b1f
c13
c1d
c1e
c1f
I'm new in perl and have a question concerning the use of hashes of arrays to retrieve specific columns. My code is the following:
my %hash = ( name1 => ['A', 'A', 'B', 'A', 'A', 'B'],
name2 => ['A', 'A', 'D', 'A', 'A', 'B'],
name3 => ['A', 'A', 'B', 'A', 'A', 'C'],
);
#the values of %hash are returned as arrays not as string (as I want)
foreach my $name (sort keys %hash ) {
print "$name: ";
print "$hash{$name}[2]\n";
}
for (my $i=0; $i<$length; $i++) {
my $diff = "no";
my $letter = '';
foreach $name (sort keys %hash) {
if (defined $hash{$name}[$i]) {
if ($hash{$name}[$i] =~ /[ABCD]/) {
$letter = $hash{$name}[$i];
}
elsif ($hash{$name}[$i] ne $letter) {
$diff = "yes";
}
}
if ( $diff eq "yes" ) {
foreach $name (sort keys %hash) {
if (defined $hash{$name}[$i]) { $newhash{$name} .= $hash{$name}[$i]; }
}
}
}
}
foreach $name (sort keys %newhash ) {
print "$name: $newhash{$name} \n";
}
I want the output of this program to be something like a new hash with only the variable columns:
my %newhash = ( name1 => 'BB',
name2 => 'DB',
name3 => 'BC',
);
but is only given this message:
Use of uninitialized value $letter in string ne at test_hash.pl line 31.
Does anyone have ideas about this?
Cheers
EDIT:
Many thanks for your help in this question.
I edited my post to confirm with the suggestions of frezik, Dan1111, Jean. You're right, now there are no warnings but I can not also get any output from the print statement and I don't have any clue about this...
#TLP: ok I just generate a random set of columns without any order purpose. What I really want is about how the letters vary, which means that if for the same array index (stored in the hash) the letters are the same, discard those, but if the letters are different between keys, I want to store that index column in a new hash.
Cheers.
I assume that by this, you want to match any of the letters A,B,C, or D:
if ($hash{$name}[$i] =~ /ABCD/)
However, as written, it matches the exact string "ABCD". You need a character class for what you want:
if ($hash{$name}[$i] =~ /[ABCD]/)
However, you have other logic problems as well, that can lead you to compare to $letter before it has been set. Setting it to empty (as Jean suggested) is a simple option that may help.
Another problem is here:
print "$name: #{ $newhash{$name} }\n";
%newhash is not a hash of arrays, so you need to remove the array dereference:
print "$name: $newhash{$name} \n";
You may be interested in this alternative solution
use strict;
use warnings;
my %hash = (
name1 => ['A', 'A', 'B', 'A', 'A', 'B'],
name2 => ['A', 'A', 'D', 'A', 'A', 'B'],
name3 => ['A', 'A', 'B', 'A', 'A', 'C'],
);
my #columns;
for my $list (values %hash) {
$columns[$_]{$list->[$_]}++ for 0 .. $#$list;
}
my %newhash = %hash;
for my $list (values %newhash) {
$list = join '', map $list->[$_], grep keys %{$columns[$_]} > 1, 0 .. $#$list;
}
use Data::Dump;
dd \%newhash;
output
{ name1 => "BB", name2 => "DB", name3 => "BC" }
I think it's a mistake to check the letters one by one. It seems easier to just collect all the letters and check them at once. The List::MoreUtils module's uniq function can then quickly determine if the letters vary, and they can be transposed into the resulting hash easily.
use strict;
use warnings;
use Data::Dumper;
use List::MoreUtils qw(uniq);
my %hash = ( name1 => ['A', 'A', 'B', 'A', 'A', 'B'],
name2 => ['A', 'A', 'D', 'A', 'A', 'B'],
name3 => ['A', 'A', 'B', 'A', 'A', 'C'],
);
my #keys = keys %hash;
my $len = $#{ $hash{$keys[0]} }; # max index
my %new;
for my $i (0 .. $len) {
my #col;
for my $key (#keys) {
push #col, $hash{$key}[$i];
}
if (uniq(#col) != 1) { # check for variation
for (0 .. $#col) {
$new{$keys[$_]} .= $col[$_];
}
}
}
print Dumper \%new;
Output:
$VAR1 = {
'name2' => 'DB',
'name1' => 'BB',
'name3' => 'BC'
};
Your scalar $letter is not defined. Add this to get rid of the warning.
my $letter='';
if ($hash{$name}[$i] =~ /ABCD/) {
The regex above would match a string like __ABCD__ or ABCD1234, but never a lone A or B. You probably wanted to match any one of those letters, and it's a good idea to anchor the regex, too:
if ($hash{$name}[$i] =~ /\A [ABCD] \z/x) {
(The /x option means that whitespace is ignored, which helps make regexes a bit easier to read.)
You would still get the warning in the example above when $i == 2 and the inner loop happens to hit the keys name1 or name3 first. Since the regex doesn't match T, $letter will remain uninitialized.
Great. Many thanks for all your help in this question.
I tried a code based on the suggestion of TLP and worked just fine. Because I'm relatively new in perl I thought this code was more easier for me to understand than the code of Borodin. What I did was:
#!/usr/bin/perl
use strict;
use warnings;
use List::MoreUtils qw(uniq);
my %hash = ( name1 => ['A', 'A', 'T', 'A', 'A', 'T', 'N', 'd', 'd', 'D', 'C', 'T', 'T', 'T'],
name2 => ['A', 'A', 'D', 'A', 'A', 'T', 'A', 'd', 'a', 'd', 'd', 'T', 'T', 'C'],
name3 => ['A', 'A', 'T', 'A', 'A', 'C', 'A', 'd', 'd', 'D', 'C', 'T', 'C', 'T'],
);
my #keys = keys %hash;
my $len = $#{ $hash{$keys[0]} }; # max index
my %new;
for (my $i=0; $i<$length; $i++) {
my #col;
for my $key (#keys) {
if ($hash{$key}[$i] =~ /[ABCDT]/) { #added a pattern match
push #col, $hash{$key}[$i];
}
}
if (uniq(#col) != 1) { # check for variation
for (0 .. $#col) {
$new{$keys[$_]} .= $col[$_];
}
}
}
foreach my $key (sort keys %new ) {
print "$key: $new{$key}\n";
}
However, when playing with the uniq function (if (uniq(#col) == 1)), I noticed that the output was a little buggy:
name1: AAAAADCT
name2: AAAAADCT
name3: AAAAT
It seems that is not preserving the initial order of keys => values. Does anyone has a hint about this?
Cheers.
I am trying to read values from an input file in Perl.
Input file looks like:
1-sampledata1 This is a sample test
and data for this continues
2-sampledata2 This is sample test 2
Data for this also is on second line
I want to read the above data so that data for 1-sampledata1 goes into #array1 and data for 2-sampledata2 goes in #array2 and so on.
I will have about 50 sections like this. like 50-sampledata50.
EDIT: The names wont always be X-sampledataX. I just did that for example. So names cant be in a loop. I think I'll have to type them manually
I so far have the following (which works). But I am looking for a more efficient way to do this..
foreach my $line(#body){
if ($line=~ /^1-sampledata1\s/){
$line=~ s/1-ENST0000//g;
$line=~ s/\s+//g;
push (#array1, $line);
#using splitarray because i want to store data as one character each
#for ex: i wana store 'This' as T H I S in different elements of array
#splitarray1= split ('',$line);
last if ($line=~ /2-sampledata2/);
}
}
foreach my $line(#body){
if ($line=~ /^2-sampledata2\s/){
$line=~ s/2-ENSBTAP0//g;
$line=~ s/\s+//g;
#splitarray2= split ('',$line);
last if ($line=~ /3-sampledata3/);
}
}
As you can see I have different arrays for each section and different for loops for each section. If I go with approach I have so far then I will end up with 50 for loops and 50 arrays.
Is there another better way to do this? In the end I do want to end up with 50 arrays but do not want to write 50 for loops. And since I will be looping through the 50 arrays later on in the program, maybe store them in an array? I am new to Perl so its kinda overwhelming ...
The first thing to notice is that you are trying to use variable names with integer suffixes: Don't. Use an array whenever you find your self wanting to do that. Second, you only need to read to go over the file contents once, not multiple times. Third, there is usually no good reason in Perl to treat a string as an array of characters.
Update: This version of the code uses existence of leading spaces to decide what to do. I am leaving the previous version up as well for reference.
#!/usr/bin/perl
use strict;
use warnings;
my #data;
while ( my $line = <DATA> ) {
chomp $line;
if ( $line =~ s/^ +/ / ) {
push #{ $data[-1] }, split //, $line;
}
else {
push #data, [ split //, $line ];
}
}
use Data::Dumper;
print Dumper \#data;
__DATA__
1-sampledata1 This is a sample test
and data for this continues
2-sampledata2 This is sample test 2
Data for this also is on second line
Previous version:
#!/usr/bin/perl
use strict;
use warnings;
my #data;
while ( my $line = <DATA> ) {
chomp $line;
$line =~ s/\s+/ /g;
if ( $line =~ /^[0-9]+-/ ) {
push #data, [ split //, $line ];
}
else {
push #{ $data[-1] }, split //, $line;
}
}
use Data::Dumper;
print Dumper \#data;
__DATA__
1-sampledata1 This is a sample test
and data for this continues
2-sampledata2 This is sample test 2
Data for this also is on second line
#! /usr/bin/env perl
use strict;
use warnings;
my %data;
{
my( $key, $rest );
while( my $line = <> ){
unless( ($rest) = $line =~ /^ \s+(.*)/x ){
($key, $rest) = $line =~ /^(.*?)\s+(.*)/;
}
push #{ $data{$key} }, $rest;
}
}
The code below is very similar to #Brad Gilbert's and #Sinan Unur's solutions:
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
my (%arrays, $label);
while (my $line = <DATA>)
{
($label, $line) = ($1, $2) if $line =~ /^(\S+)(.*)/; # new data block
$line =~ s/^\s+//; # strip whitespaces from the begining
# append data for corresponding label
push #{$arrays{$label}}, split('', $line) if defined $label;
}
print $arrays{'1-sampledata1'}[2], "\n"; # 'i'
print join '-', #{$arrays{'2-sampledata2'}}; # 'T-h-i-s- -i-s- -s-a-m-p-l
print Dumper \%arrays;
__DATA__
1-sampledata1 This is a sample test
and data for this continues
2-sampledata2 This is sample test 2
Data for this also is on second line
Output
i
T-h-i-s- -i-s- -s-a-m-p-l-e- -t-e-s-t- -2-D-a-t-a- -f-o-r- -t-h-i-s- -a-l-s-o- -i-s- -o-n- -s-e-c-o-n-d- -l-i-n-e-
$VAR1 = {
'2-sampledata2' => [
'T',
'h',
'i',
's',
' ',
'i',
's',
' ',
's',
'a',
'm',
'p',
'l',
'e',
' ',
't',
'e',
's',
't',
' ',
'2',
'D',
'a',
't',
'a',
' ',
'f',
'o',
'r',
' ',
't',
'h',
'i',
's',
' ',
'a',
'l',
's',
'o',
' ',
'i',
's',
' ',
'o',
'n',
' ',
's',
'e',
'c',
'o',
'n',
'd',
' ',
'l',
'i',
'n',
'e',
'
'
],
'1-sampledata1' => [
'T',
'h',
'i',
's',
' ',
'i',
's',
' ',
'a',
' ',
's',
'a',
'm',
'p',
'l',
'e',
' ',
't',
'e',
's',
't',
'a',
'n',
'd',
' ',
'd',
'a',
't',
'a',
' ',
'f',
'o',
'r',
' ',
't',
'h',
'i',
's',
' ',
'c',
'o',
'n',
't',
'i',
'n',
'u',
'e',
's',
'
'
]
};
You should, instead, use a hash map to arrays.
Use this regex pattern to get the index:
/^(\d+)-sampledata(\d+)/
And then, with my %arrays, do:
push($arrays{$index}), $line;
You can then access the arrays with $arrays{$index}.