Related
I have a input like this.
a x1
a x1
a y1
b x1
b y1
b z1
c y1
c z1
Want a output like this
a = 3, x1= 2, y1= 1, z1= 0
b = 3, x1= 1, y1= 1, z1=1
c =2, x1=0, y1=1, z1=1
I want to make a perl program for this, but do not know .
Please help..
This is a pretty simple homework problem (which is why this has been downvoted a couple of times, no doubt), but it's a good way to show the power of hashes if you're struggling with that.
Let's break this down. You want to classify things by the first column (and count the number of occurrences), counting the associated data. Hashes are perfect for this.
Let's assume that the final hash will look something like this:
{
'a' => {
'*count' => 3,
'x1' => 2,
'y1' => 1,
},
. . .
}
(where '*count' is a string that should never appear in your data) and that your output will look like your specification.
Parsing the data is pretty simple.
my $hash = {};
my $count = '*count';
for( #lines ) {
chomp;
my ($x, $y) = split( /\s+/ );
$hash->{$x}->{$count}++;
$hash->{$x}->{$y}++;
}
Printing it out is just as simple:
for my $x ( sort keys %{$hash} ) {
my #output = ( sprintf( '%s = %d', $x, $hash->{$x}->{$count} ) );
for my $y ( qw{ x1 y1 z1 } ) {
push( #output, sprintf( '%s = %d', $y, $hash->{$x}->{$y} ) );
}
print join( ', ', #output ) . "\n";
}
Note that if, say, $hash->{'c'}->{'z1'} doesn't exist, the value returned will still be 0. You can do the additional checking with exists if you like, but it shouldn't be necessary.
I am having the below hash of hash,
my $hash = {1 => {'a'=>'a1','b'=>'b1', 'c'=>'c1', 'd'=>'d1'},
2 => {'a'=>'e1','b'=>'f1', 'c'=>'g1', 'd'=>'h1'},
3 => {'a'=>'i1','b'=>'j1','c'=>'k1', 'd'=>'l1'},
4 => {'a'=>'m1','b'=>'n1','c'=>'o1','d'=>'p1'}};
I want to display the above hash of hash in perl formatted manner. The hash of hash is dynamic in nature so we can have additional keys later on as well.
I am using the below code to generate the hash of hash into a proper format.
use strict;
my $hash = {1 => {'a'=>'a1','b'=>'b1', 'c'=>'c1', 'd'=>'d1'},
2 => {'a'=>'e1','b'=>'f1', 'c'=>'g1', 'd'=>'h1'},
3 => {'a'=>'i1','b'=>'j1','c'=>'k1', 'd'=>'l1'},
4 => {'a'=>'m1','b'=>'n1','c'=>'o1','d'=>'p1'}};
my #a = qw(1 2);
my #b = qw(3 4);
&displayreport($hash, \#a);
print "new display\n\n";
&displayreport($hash, \#b);
my($i,$j,$k,$l);
format STDOUT_TOP =
A B C D
-- -- -- --
.
format OUTPUT=
#<< #<< #<< #<<
$i,$j,$k,$l
.
sub displayreport{
my ($x, $y) = #_;
$~ = "STDOUT_TOP";
write;
foreach(#$y) {
$i = $hash->{$_}->{a};
$j = $hash->{$_}->{b};
$k = $hash->{$_}->{c};
$l = $hash->{$_}->{d};
$~ = "OUTPUT";
write();
}
}
The Output I got is,
A B C D
-- -- -- --
A B C D
-- -- -- --
a1 b1 c1 d1
e1 f1 g1 h1
new display
A B C D
-- -- -- --
i1 j1 k1 l1
m1 n1 o1 p1
where the header in the first case is repeated.
I need the output as,
A B C D
-- -- -- --
a1 b1 c1 d1
e1 f1 g1 h1
new display
A B C D
-- -- -- --
i1 j1 k1 l1
m1 n1 o1 p1
Where I am doing wrong. Kindly assist.
Rename STDOUT_TOP to STDOUT_TOPX and it works. But I have no idea why.
format's suffixed with _TOP have special meaning as Top of Form Processing
You can take advantage of this more explicitly by opening an output to a new filehandle, and using the $^ variable for setting a $FORMAT_TOP_NAME.
This is demonstrated by the following:
use strict;
use warnings;
my $hash = {
1 => { 'a' => 'a1', 'b' => 'b1', 'c' => 'c1', 'd' => 'd1' },
2 => { 'a' => 'e1', 'b' => 'f1', 'c' => 'g1', 'd' => 'h1' },
3 => { 'a' => 'i1', 'b' => 'j1', 'c' => 'k1', 'd' => 'l1' },
4 => { 'a' => 'm1', 'b' => 'n1', 'c' => 'o1', 'd' => 'p1' },
};
displayreport( $hash, [1,2] );
print "\nnew display\n";
displayreport( $hash, [3,4] );
format OUTPUT_TOP =
A B C D
-- -- -- --
.
my ( $i, $j, $k, $l );
format OUTPUT=
#<< #<< #<< #<<
$i,$j,$k,$l
.
sub displayreport {
my ( $hash, $keys ) = #_;
open my $fh, '>', \my $output or die "Can't open: $!";
my $ofh = select($fh);
$^ = "OUTPUT_TOP";
$~ = "OUTPUT";
foreach (#$keys) {
($i, $j, $k, $l) = #{$hash->{$_}}{qw(a b c d)};
write();
}
select($ofh);
close $fh;
print $output;
}
Outputs:
A B C D
-- -- -- --
a1 b1 c1 d1
e1 f1 g1 h1
new display
A B C D
-- -- -- --
i1 j1 k1 l1
m1 n1 o1 p1
Two Alternatives
First, if you really want to use formats, I suggest you use the more modern Perl6::Form.
Second, I would strongly recommend using the much simpler printf and sprintf for this type of basic formatting and skip formats all together:
displayreport( $hash, [1,2] );
print "\nnew display\n";
displayreport( $hash, [3,4] );
sub displayreport {
my ( $hash, $keys ) = #_;
my $fmt = " %3s %3s %3s %3s\n";
printf $fmt, qw(A B C D);
printf $fmt, qw(-- -- -- --);
foreach (#$keys) {
printf $fmt, #{$hash->{$_}}{qw(a b c d)};
}
}
Output is identical to the previous script.
I want to create a Perl function as follows:
$iError = _validate( "$cVariable", "c" );
$cVariable – the input that I want to validate against a pre-defined standard
"c" – the type of data that is expected
c = character
a = alphanumeric
i = integer
x = decimal number
d = date, two default formats are YY_MM_DD and YYYY_MM_DD
f = file/dir name
e = characters that are valid in an email address (email address must have \# instead of just #)
Return values:
Success = 0
Failed = -1
This is what I have so far but there's definitely some formatting errors that I can't catch since I am completely new to Perl, can anyone point out where I am going wrong?
$iError=_validate($cVariable, c)
if ($c == c) {
if ($cVariable =~ ^.+$) {
$iError=0
} else {
$iError=-1
} # end if
elsif ($c == a) {
if ($cVariable =~ ^([a-z])|([0-9])+$) {
%iError=0
}
else {$iError=-1} # end if
}
elsif ($c == i) {
if ($cVariable =~ ^[-+]?\d+$) {
$iError=0
}
else {$iError = -1} # end if
}
elsif ($c == x) {
if ($cVariable =~ ^[0-9]+[.][0-9]+$) {
$iError=0
}
else {$iError=-1} # end if
}
elsif ($c == d) {
if ($cVariable =~ ^\d{2}_{1}\d{2}_{1}\d{2}$) {
$iError=0
}
elsif ($cVariable =~ ^\d{4}_{1}\d{2}_{1}\d{2}$) {
$iError=0
}
else {$iError=-1} # end if
}
elsif($c == f) {
if ($cVariable =~ ^.+$) {
$iError=0
}
else {$iError=-1} # end if
}
else($c == e) {
if ($cVariable =~ ^\S{0,50}\\#\S{0,20}[.]\S{1,10}$) {
$iError=0
}
else {$iError=0} # end if
} # end outer if
return($iError);
One way to develop a solution, while learning Perl, would be to take the Test Driven Development [TDD] approach, in which you start out writing one or more tests and then develop the code to enable the tests to pass.
For the problem you state, you could start with a file of tests (call it 'validate.t' and put it in a directory named 't'):
#!/usr/bin/env perl -I.
use Test::More ;
BEGIN { require_ok( "ValidateStarter.pl" ) ; }
my $cVariable = 'abc' ;
my $iError = validate( $cVariable, 'c' ) ;
is( $iError, 0, "correctly validated a character string ($cVariable)" ) ;
$cVariable = 'def456' ;
$iError = validate( $cVariable, 'c' ) ;
is( $iError, -1, "correctly validated a non-character string ($cVariable)" ) ;
$cVariable = 'def456' ;
$iError = validate( $cVariable, 'a' ) ;
is( $iError, 0, "correctly validated an alphanumeric string ($cVariable)" ) ;
$cVariable = '123' ;
$iError = validate( $cVariable, 'a' ) ;
is( $iError, -1, "correctly validated a non-alphanumeric string ($cVariable)" ) ;
$cVariable = '1' ;
$iError = validate( $cVariable, 'i' ) ;
is( $iError, 0, "correctly validated an integer ($cVariable)" ) ;
$cVariable = 'z' ;
$iError = validate( $cVariable, 'i' ) ;
is( $iError, -1, "correctly validated a non-integer ($cVariable)" ) ;
$cVariable = '123.456' ;
$iError = validate( $cVariable, 'x' ) ;
is( $iError, 0, "correctly validated a decimal number ($cVariable)" ) ;
$cVariable = '-0.1234567' ;
$iError = validate( $cVariable, 'x' ) ;
is( $iError, 0, "correctly validated a decimal number ($cVariable)" ) ;
$cVariable = '1234567' ;
$iError = validate( $cVariable, 'x' ) ;
is( $iError, 0, "correctly validated a decimal number ($cVariable)" ) ;
$cVariable = '0xDEADBEEF' ;
$iError = validate( $cVariable, 'x' ) ;
is( $iError, -1, "correctly validated a non-decimal number ($cVariable)" ) ;
done_testing ;
Next, in the directory 'above' t/, create a file called ValidateStarter.pl:
#!/usr/bin/env perl
use strict ;
use warnings ;
use Regexp::Common qw( number ) ;
sub validate {
my ( $cVar, $c ) = #_ ;
if ( 'c' eq $c ) {
if ( $cVar =~ /^[[:alpha:]]+$/ ) {
return 0 ;
}
}
elsif ( 'a' eq $c ) {
if ( $cVar =~ /^[[:alpha:]][[:alnum:]]+$/ ) {
return 0 ;
}
}
elsif ( 'i' eq $c ) {
if ( $cVar =~ /^$RE{num}{int}$/ ) {
return 0 ;
}
}
elsif ( 'x' eq $c ) {
if ( $cVar =~ /^$RE{num}{decimal}$/ ) {
return 0 ;
}
}
elsif ( 'a' eq $c ) {
if ( $cVar =~ /^\A\p{Alnum}+\z$/ ) {
return 0 ;
}
}
return -1 ;
}
1 ;
Execute the tests by changing to the directory containing ValidateStarter.pl and the t/ directory and typing (Note: '$' would be your console prompt -- don't type it):
$ perl t/validate.t
If you can figure out how to make 'validate.t' an executable file (hint: use 'chmod' on Linux), then you could just type:
$ t/validate.t
On Linux, you'd see:
$ t/validate.t
ok 1 - require 'ValidateStarter.pl';
ok 2 - correctly validated a character string (abc)
ok 3 - correctly validated a non-character string (def456)
ok 4 - correctly validated an alphanumeric string (def456)
ok 5 - correctly validated a non-alphanumeric string (123)
ok 6 - correctly validated an integer (1)
ok 7 - correctly validated a non-integer (z)
ok 8 - correctly validated a decimal number (123.456)
ok 9 - correctly validated a decimal number (-0.1234567)
ok 10 - correctly validated a decimal number (1234567)
ok 11 - correctly validated a non-decimal number (0xDEADBEEF)
1..11
'ok' on a line of output means a test passed, while 'not ok' would mean it failed.
Starting with these lines of working code, I would suggest further steps along these lines:
Read Test::Tutorial for more on how to write tests in Perl.
Read Regexp::Common::number to see about using some good regular expression utilities.
Browse the online text of 'Modern Perl' by chromatic to read more about Perl itself.
Study and tinker with the example code until you understand how it works.
Add more test cases applying to the sample code.
Add a test case applying to another of the line items in your problem spec. and follow-up with the code to enable the test to pass.
Debug & add more test cases until you're done.
Judging by the very specific nature of your question, it seems likely that it's based on an assignment with a specific deadline, so you may believe you don't have time to write automated tests; but TDD is a good way to make progress incrementally as you learn what you need to know to develop the solution.
Keep in mind that you will know that whatever parts you're able to finish by the deadline are working as proven by the tests that you've written.
When you do RegEx ("=~"), you need to surround the expression with "/". So your first RegEx if statement should look like:
if ($cVariable =~ /^.+$/) {
Your code is broken and incomplete enough that I'm reluctant to wade through all the error messages just to get it to compile, as you would still have a flawed solution in the end.
Syntax, just about anyone can learn. But the more important problem is that each of the things you're trying to validate (with the exception of a character) are not as trivial as you might expect. Given the complexities involved in validating an email address, or a date, well-proven code as provided by trusted CPAN modules is the way to go. You really don't want to waste a lot of time fleshing out the details of a date validator, for example.
Here's how I might get started on it. The following code provides exactly the behavior you've described (with the exception of file/dir, since I don't know what you want there). But it does so in a way that is probably more correct than simple regex matching alone:
#!/usr/bin/env perl
use strict;
use warnings;
use Scalar::Util 'looks_like_number';
use Date::Calc 'check_date';
use Email::Valid;
use constant VALIDATORS => {
'c' => \&char, # Validate a single character.
'a' => \&alnum, # Validate string is alphanumeric only.
'i' => \&intgr, # Validate input is an integer.
'x' => \&dec, # Validate input is a number.
'd' => \&date, # Validate input is a date in YYYY_MM_DD or YY_MM_DD
'f' => \&fdn, # Who knows?! Something to do with file validation.
'e' => \&eml, # Validate input is a legal email address.
};
sub validate {
my( $input, $mode ) = #_;
die "No mode provided." unless defined $mode;
die "Invalid mode: $mode." unless exists VALIDATORS->{$mode};
return -1 if not defined $input;
return VALIDATORS->{$mode}->($input) ? 0 : -1;
}
sub char {
my $c = shift;
return 1 == length $c;
}
sub alnum {
my $an = shift;
return $an =~ /\A\p{Alnum}+\z/;
}
sub intgr {
my $n = shift;
return looks_like_number($n) && $n == int($n);
}
sub dec {
return looks_like_number(shift);
}
sub date {
my $date = shift;
my( $y, $m, $d );
if( ( $y, $m, $d ) = $date =~ m/\A(\d{2}|\d{4})_(\d{2})_(\d{2})\z/ ) {
return check_date( $y, $m, $d );
}
else {
return 0;
}
}
sub fdn {
# I have no idea what you want to do in validating a filename or directory.
# Is this a matter of "legal characters" for a given OS?
# Or is it a matter of "This file / path exists"?
}
sub eml { return Email::Valid->address(shift) }
# ___________________________
use Test::More;
{
local $#;
eval{ validate('a') };
like ( $#, qr/^No mode provided/, 'Die if no mode provided.' );
}
{
local $#;
eval{ validate('a','invalid') };
like( $#, qr/^Invalid mode/, 'Die on invalid mode.' );
}
# 0 = success, -1 = failure.
ok( 0 == validate( 'a','c' ), 'Char accepted.' );
ok( -1 == validate( 'ab', 'c' ), 'More than one char rejected.' );
ok( -1 == validate( '', 'c' ), 'Empty string rejected.' );
ok( -1 == validate( undef, 'c' ), 'undefined value rejected.' );
# 0 = success, non-zero = failure (-1).
ok( !validate( 'aA10', 'a' ), 'Alnum accepted.' );
ok( validate( '.$', 'a' ), 'Non-alnum rejected.' );
ok( validate( undef,'a' ), 'undefined value rejected for alnum.' );
ok( !validate( '10', 'i' ), 'Positive integer.' );
ok( !validate( -5, 'i' ), 'Negative integer.' );
ok( validate( -0.5, 'i' ), 'Reject non-integer.' );
ok( validate( 'a', 'i' ), 'Reject non-numeric as int.' );
ok( !validate( '10', 'x' ), 'Positive integer as decimal number.' );
ok( !validate( '10.5', 'x' ), 'Positive floating point as decimal number.' );
ok( validate( '17f', 'x' ), 'Decimal rejects hex string.' );
ok( validate( '12.3.5', 'x' ), 'Malformed decimal rejected.' );
ok( !validate( '1600_12_15', 'd' ), 'Four digit year date accepted.' );
ok( !validate( '14_06_05', 'd' ), 'Two digit year date accepted.' );
ok( validate( '15000_12_15', 'd' ), 'Y10k bug ;)' );
ok( validate( '2000_02_30', 'd' ), 'Impossible date rejected.' );
ok( !validate( 'someone#example.com', 'e' ), 'Good email address accepted.' );
ok( validate( 'a"b(c)d,e:f;g<h>i[j\k]l#example.com', 'e' ),
'Bad email rejected.' );
ok( validate( 'a#b#example.com', 'e' ), 'Bad email rejected.' );
done_testing();
I don't particularly care for the "0 == success, -1 == failure" mode, but it's not unheard of, and is simple to achieve.
There are modules on CPAN that would probably do a better job of validating integers and numbers, and you're welcome to search them out and drop them into place. My tests for those categories are quick and dirty, and should be effective in most cases.
For more detailed info on numeric validation, have a look at perlfaq4.
I didn't attempt to validate a filename or directory, as I'm not sure what you're after in that regard. The File::Util module could be useful in verifying that a filename is legal for a given operating system. As for paths, I'm not sure if you want to know if the characters are legal, or if the path exists. You'll have to work on that yourself.
None of this is the sort of thing that someone new to Perl should be taking on oneself when a deadline looms. There's a lot of learning involved in something that on the face looks quite simple.
I had written series of perl constructs using short form of if in perl as below,
( $psap[0] = sprintf( "%.4f", $psap[0] )
&& ( $psap[0] = "1:" . $psap[0] )
&& push( #all, $psap[0] ) )
if ( defined( $psap[0] ) );
( $psap[1] = sprintf( "%.4f", $psap[1] )
&& ( $psap[1] = "2:" . $psap[1] )
&& push( #all, $psap[1] ) )
if ( defined( $psap[1] ) );
I had faced some issues with this,
sprintf does not seems to be working ( Values are not rounded);
When I tried to print $psap[0] and $psap[1] value I was just getting 1 and 2 respectively and nothing else (#all contains the value of psap[0] as expected );
I agree that the code is not readable, I wanted some quick way to solve the issue that time. Later I wrote in full form of if which was working as expected.
Forget about the if... it's a red herring. Focus on this:
$psap[1] = sprintf( "%.4f", $psap[1] )
&& ( $psap[1] = "2:" . $psap[1] )
&& push( #all, $psap[1] )
That's essentially:
$psap[1] = X() && Y() && Z();
So you're setting $psap[1] to the result of a boolean && operation on three operands.
Either wrap your assignment in parentheses, like this:
( $psap[1] = sprintf("%.4f", $psap[1]) )
&& ( $psap[1] = "2:" . $psap[1] )
&& push( #all, $psap[1] )
Or use the low-precedence and operator:
$psap[1] = sprintf("%.4f", $psap[1])
and $psap[1] = "2:" . $psap[1]
and push(#all, $psap[1])
Your code is a dreadful misuse of the if statement modifier, which was never meant to control anything more than the simplest of statements.
I suggest you code it like this, which is far clearer
for my $i (0, 1) {
next unless defined $psap[$i];
$psap[$i] = sprintf '%d:%.4f', $i + 1, $psap[$i];
push #all, $psap[$i];
}
Logical operators should be avoided if you don't really want to depend on their result, and just want to sequentially execute your code, thus
$psap[1] = sprintf("%.4f", $psap[1]), $psap[1] ="2:$psap[1]", push(#all, $psap[1])
if defined $psap[1];
or shorter,
defined and $_ = sprintf("%.4f", $_), $_ ="2:$_", push(#all, $_)
for $psap[1];
or shorter,
defined and $_ = sprintf("2:%.4f", $_), push(#all, $_)
for $psap[1];
The assignment to $psap[0] is of lower precedence than the &&, so it is being assigned the value of
sprintf( "%.4f", $psap[0] ) && ( $psap[0] = "1:" . $psap[0] ) && push( #all, $psap[0] )
Just wrap it in some extra parentheses:
#!/usr/bin/env perl
use strict;
use warnings;
my #psap = ( 0.123456789 );
my #all;
( ( $psap[0] = sprintf( "1:%.4f", $psap[0] ) )
&& push( #all, $psap[0] )
)
if ( defined( $psap[0] ) );
print $psap[0], "\n";
I also took the liberty of putting the "1:" into the sprintf rather than building the string in two steps.
As shown in the operator precedence and associativity table, and is of a much lower precedence and could be used instead:
$psap[0] = sprintf( "1:%.4f", $psap[0] ) and push( #all, $psap[0] )
if ( defined( $psap[0] ) );
output:
1:0.1235
i am trying to scrape info from http://www.soccerbase.com/tournaments/tournament.sd?comp_id=1 from lines 1184 to 1325, basically the up coming games for the next 7 days. i have the code working for a single instance, but i can't figure out how to iterate the code so that it will scrape all the games info until it hits the end of the 7 day's worth of games. Is there some sort of loop i can create that will scrape until i hit a certain tag or something? Here is my code so far, thanks in advance!
my $page = WWW::Mechanize->new;
$page->get('http://www.soccerbase.com/tournaments/tournament.sd?comp_id=1');
my $stream = HTML::TokeParser->new(\$page->{content});
my #fixture;
my $tag = $stream->get_tag("td");
while($tag->[1]{class} ne "dateTime"){
$tag = $stream->get_tag("td");
}
if ($tag->[1]{class} eq "dateTime") {
push(#fixture, $stream->get_trimmed_text("/a"));
}
$stream->get_tag("a");
$stream->get_tag("a");
push(#fixture, $stream->get_trimmed_text("/a"));
$stream->get_tag("a");
push(#fixture, $stream->get_trimmed_text("/a"));
foreach $element (#fixture){
print $element, "\t";
}
print "\n";
Try Web::Query for parsing HTML, it is a much nicer to use than TokeParser. It works declarative instead of imperative and you select elements with CSS expressions.
If there is a score v, add the row to the result set, else discard the row.
use Web::Query 'wq';
my $football_matches = wq($mech->content)
->find('tr.match')
->map(sub {
my (undef, $e) = #_;
return 'v' eq $e->find('td.score')->text
? [
$e->attr('id'),
map { $e->find("td.$_")->text }
(qw(tournament dateTime homeTeam score awayTeam prices))
]
: ();
});
use Data::Dumper; print Dumper $football_matches;
$VAR1 = [
['tn7gc635476', '', ' Mo 12Mar 2012 ', 'Arsenal', 'v', 'Newcastle', ' '],
['tn7gc649937', '', ' Tu 13Mar 2012 ', 'Liverpool', 'v', 'Everton', ' '],
['tn7gc635681', '', ' Sa 17Mar 2012 ', 'Fulham', 'v', 'Swansea', ' '],
['tn7gc635661', '', ' Sa 17Mar 2012 ', 'Wigan', 'v', 'West Brom', ' '],
['tn7gc635749', '', ' Su 18Mar 2012 ', 'Wolves', 'v', 'Man Utd', ' '],
['tn7gc635556', '', ' Su 18Mar 2012 ', 'Newcastle', 'v', 'Norwich', ' ']
];