#!/usr/bin/perl -w
use warnings;
use diagnostics;
use Switch;
open FH, "<$ARGV[0]" or die "$!";
sub commandType{
print "comm entered for $_";
switch($_){
case("add") {print "this is add\n"}
case("sub") {print "this is sub\n"}
case("neg") {print "this is neg\n"}
case("eq") {print "this is eq\n"}
case("gt") {print "this is gt\n"}
case("lt") {print "this is lt\n"}
case("and") {print "this is and\n"}
case("or") {print "this is or\n"}
case("not") {print "this is not\n"}
}
}
while(<FH>){
next if /^\s*\/\//;
next if /^\s*$/;
my $line = "$_";
$line =~ s/\s+$//;
print "$line\n";
commandType($line);
}
Here is my code which takes the input from the following file supplied to it through the command line:
// Pushes and adds two constants.
push constant 7
push constant 8
add
For each line of the file above the perl code will run the subroutine commandType to check if it is among the given cases inside the subroutine and prints if it is. But even though the add command is present in the file above the code still does not print it. I am getting the following output:
push constant 7
comm entered for push constant 7
push constant 8
comm entered for push constant 8
add
comm entered for add`
Why is case "add" not printing anything?
EXPLANATION
The problem is that $_ doesn't automatically refer to the first argument passed to a sub, currently you are reading the same $_ as the one in your while-loop.
The value of $_ when inside commandType is the line read, still having the potential new-line attached to it, and since "add\n" isn't equal to "add", your case isn't entered.
SOLUTION
It would be preferred to change the contents of sub commandType to the below:
sub commandType{
my $cmd = shift; # retrieve first argument
print "comm entered for $cmd";
switch($cmd) {
...
}
}
It isn't safe to use $_ as you would a normal variable. It has global scope and many built-in Perl operators act on it, so it is likely to be modified without any obvious reason.
In any case, the parameters passed to a subroutine are presented in #_, not in $_ and it is random chance that it seems to contain the right value in this case.
Rewrite your commandType subroutine like this and it should start behaving more sensibly
sub commandType {
my ($cmd) = #_;
print "comm entered for $cmd";
switch ($cmd) {
case 'add' { print "this is add\n" }
case 'sub' { print "this is sub\n" }
case 'neg' { print "this is neg\n" }
case 'eq' { print "this is eq\n" }
case 'gt' { print "this is gt\n" }
case 'lt' { print "this is lt\n" }
case 'and' { print "this is and\n" }
case 'or' { print "this is or\n" }
case 'not' { print "this is not\n" }
}
}
You must also always add use strict at the top of every program, especially if you are asking for help with it. It will quickly report trivial errors that you may otherwise spend valuable time tracking down.
The Switch module is also unsafe, and the built-in language construct given/when that has been available since version 10 has been marked as experimental because of a number of arcane shortcomings. You are much better off using a list of if statements as described in the "Basic BLOCKs" section of perlsyn.
Starting from Perl 5.10.1 (well, 5.10.0, but it didn't work right), you can say use feature "switch"; to enable an experimental switch feature. Under the "switch" feature, Perl gains the experimental keywords given , when , default , continue, and break.
#!/usr/bin/perl
use strict;
use warnings;
use feature "switch";
while(my $line=<DATA>){
given ($line) {
when (/push/) { print 'found push' }
when (/add/) { print 'found add' }
}
}
__DATA__
push constant 7
push constant 8
add
Demo
Also see: Perl 5.20 and the fate of smart matching and given-when?
Related
I'm a beginner and confused about what's happening inside this Perl subroutine.
I'm using only global variables to simplify things, but it's still not working.
I'm simply trying to print a file's read, write and executable attributes using the file test operators with IF statements.
Can anyone point out the problem for me?
Louie
sub getfileattributes {
if (-r $file) {
$attributes[0] = "readable";
} else { $attributes[0] = "not readable"; }
if (-w _) {
$attributes[1] = "writable";
} else { $attributes[1] = "not writable"; }
if (-x _) {
$attributes[2] = "executable";
} else { $attributes[2] = "not executable"; }
}
my #attributes;
my $file;
foreach $file (#ARGV) {
&getfileattributes;
printf "The file $file is %s, %s and %s\n", #attributes;
}
Using global variables is usually quite bad and points to a design error. In this case, the error seems to be that you don't know how to pass arguments to a sub.
Here is the pattern in Perl:
sub I_take_arguments {
# all my arguments are in #_ array
my ($firstarg, $secondarg, #rest) = #_;
say "1st argument: $firstarg";
say "2nd argument: " .($firstarg+1). " (incremented)";
say "The rest is: [#rest]";
}
Subs are invoked like
I_take_arguments(1, 2, "three", 4);
(Do not invoke them as &nameOfTheSub, this makes use of very special behaviour you don't usually want.)
This would print
1st argument: 1
2nd argument: 3
The rest is: [three 4]
Subroutines can return values, either with the return statement or as the value of the last statement that is executed. These subs are equivalent:
sub foo {return "return value"}
sub bar {"return value"}
I would write your getfileattributes as
sub getFileAttributes {
my ($name) = #_;
return
-r $name ? "readable" : "not readable",
-w $name ? "writable" : "not writable",
-x $name ? "executable" : "not executable";
}
What is happening here? I take an argument $name and then return a list of values. The return keyword could be omitted. The return takes a list of values and does not require parens, so I leave them out. The TEST ? TRUE-STATEMENT : FALSE-STATEMENT operator is known from other languages.
Then, in your loop, the sub would be invoked like
for my $filename (#ARGV) {
my ($r, $w, $x) = getFileAttributes($filename);
say "The file $filename is $r, $w and $x";
}
or
foreach my $file (#ARGV) {
my #attributes = getFileAttributes($file);
printf "The file $file is %s, %s and %s\n", #attributes;
}
Notes:
say is like print, but adds a newline at the end. To use it, you have to have a Perl > 5.10 and you should use 5.010 or whatever version or use feature qw(say).
always use strict; use warnings; unless you know better for sure.
Often, you can write programs without assigning to a variable twice (Single assignment form). This can make reasoning about control flow much easier. This is why global variables (but not global constants) are bad.
You are not actually using global varaibles. My scopes the variables them local to the main routine, so when you call the subroutine, $file and #attributes are scoped to the subroutine, not to the main routine.
Change my to our for $file and #attributes to make the variables global and available to the subroutine.
You can check this for yourself by using the -d argument for perl to run it in the debugger and check the values of the items.
This is driving me crazy, Perl is simply losing the value of a variable once I enter an if statement... and the weird this is, its only that variable, any other variable will not lose its value
open (MYFILE, "b");
my $haysack = "";
while (<MYFILE>)
{
$haysack = $haysack . "$_";
}
close (MYFILE);
open (MYFILE2, "ip_range");
my $needles = "";
while (<MYFILE2>)
{
$needles = $needles . "$_";
}
close (MYFILE2);
my $someOtherValue = "blabla";
while ($needles =~ m/(.*?)\n/g)
{
$needle = $1;
if ($haysack =~ m/$needle/ims)
{
print "FOUND : $needle\n";
print "$someOtherValue\n";
}
}
So the code succesfully enters the if statement, but once it does I get the following output:
FOUND:
blabla
can anyone help?
This really should be a comment, since it's not an answer, but comments don't allow code formatting, so:
Can you provide a complete, runnable, self-contained, minimal example which demonstrates the problem without extraneous moving parts, such as reading files? Something similar to the following:
#!/usr/bin/env perl
use strict;
use warnings;
my $haysack = "Foo
Bar
Baz
";
my $needles = "a
b
c
";
while ($needles =~ m/(.*?)\n/g) {
my $needle = $1;
if ($haysack =~ m/$needle/ims) {
print "FOUND : $needle\n";
}
}
...except that mine runs perfectly, producing the output
FOUND : a
FOUND : b
rather than failing. Note that, in the process of creating a minimal failing example, you are very likely to discover the solution to your problem...
As far as general troubleshooting advice, use strict and use warnings if you aren't already doing so. Check the value of $1 after doing the outer match to verify that $needle will be getting the value you expect it to.
My perl script needs to detect the extension of an existing file and print out the filename. The input that specifies the filename with a vague extension would be in this format:
foo.(txt|abc)
and the script would print "foo.txt" if it exists. If foo.txt does not exist and foo.abc exists, then it would print "foo.abc."
How can I do this detection and printing of the correct existing file in a neat and clean way?
Thanks!
Actually, you've almost got the regular expression right there: the only thing you need to do is escape the . with a backslash (since . means "any character except the newline character" in regular expressions), and it would also help to put a ?: inside of the parentheses (since you don't need to capture the file extension). Also, ^ and $ denote markers for the beginning and the end of the string (so we're matching the entire string, not just part of a string...that way we don't get a match for the file name "thisisnotfoo.txt")
Something like this should work:
use strict;
use warnings;
my $file1="foo.txt";
my $file2="foo.abc";
my $file3="some_other_file";
foreach ($file1,$file2,$file3)
{
if(/^foo\.(?:txt|abc)$/)
{
print "$_\n";
}
}
When the above code is run, the output is:
foo.txt
foo.abc
Take a look at perldoc perlretut for more stuff about regular expressions.
You may want to look at glob, but you'd have to use a different syntax. The equivalent would be:
foo.{txt,abc}
See File::Glob for more information. Also note that this will return a list of all of the matches, so you'll have to do your own rules if it should prefer one when multiple exist.
sub text_to_glob {
my ($s) = #_;
$s =~ s/([\\\[\]{}*?~\s])/\\$1/g;
return $s;
}
my $pat = 'foo.(txt|abc)';
my #possibilities;
if (my ($base, $alt) = $pat =~ /^(.*\.)\(([^()]*)\)\z/s) {
#possibilities = glob(
text_to_glob($base) .
'{' . join(',', split(/\|/, $alt)) . '}'
);
} else {
#possibilities = $pat;
}
for my $possibility (#possibilities) {
say "$possibility: ", -e $possibility ? "exists" : "doesn't exist";
}
glob, but also see File::Glob
-e
use strict;
use warnings;
FILE:
for (glob "file.{txt,abc}") {
if (-f $_) {
print $_, "\n";
last FILE;
}
}
EDIT:
I will try a better explication this time, this is the exact code from my script (sorry for all them coments, they are a result of your sugestions, and apear in the video below).
#use warnings;
#use Data::Dumper;
open(my $tmp_file, ">>", "/tmp/some_bad.log") or die "Can not open log file: $!\n";
#if( $id_client != "")
#allowed_locations = ();
#print $tmp_file "Before the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
if( $id_client )
{
# print $tmp_file "Start the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
# my $q = "select distinct id_location from locations inner join address using (id_db5_address) inner join zona_rural_detaliat using (id_city) where id_client=$id_client";
# my $st = &sql_special_transaction($sql_local_host, $sql_local_database, $sql_local_root, $sql_local_root_password, $q);
# print $tmp_file "Before the while loop: ref(st)='". ref($st) . "\n";
# while((my $id)=$st->fetchrow())
# {
# print $tmp_file "Row the while loop: ". Data::Dumper->Dump([$id]) . "";
# my $id = 12121212;
# push(#allowed_locations, $id);
# }
# print $tmp_file "After the while loop: ref(st)='". ref($st) . "\n";
# my($a) = 1;
#} else {
# my($a) = 0;
}
#print $tmp_file "After the if: ". Data::Dumper->Dump([\#allowed_locations, $id_client]) . "";
close($tmp_file) or die "Can not close file: $!\n";
#&html_error(#allowed_locations);
First off all, somebody said that I should try to run it in command line, the script works fine in command line (no warnings, It was uncommented then), but when triyng to load in via apache in the browser it fails, please see this video where I captured the script behavior, what I tried to show in the video:
I have opened 2 tabs the first doesn't define the variable $id_client, the second defines the variable $id_client that is read from GET: ?id_client=36124 => $id_client = 36124; , both of them include the library in the video "locallib.pl"
When running the script with all the
new code commented the page loads
when uncoment the line that defines
the #allowed_locations = (); the
script fails
leave this definition and uncoment
the if block, and the definition of
my $a; in the if block; Now the script works fine when $id_client is
defined, but fails when $id_client
is not defined
Uncoment the else block and the
definition of my $a; in the else
block. Now the script works fine
with or without $id_client
now comment all the my $a;
definisions and comment the else
block, the script fails
but if I'm using open() to open
a file before the IF, and
close() to close it after the if it does't fail even if the IF block
is empty and event if there is no
else block
I have replicated all the steps when running the script in the command line, and the script worked after each step.
I know it sounds like something that cannot be the behavior of the script, but please watch the video (2 minutes), maybe you will notice something that I'm doing wrong there.
Using perl version:
[root#db]# perl -v
This is perl, v5.8.6 built for i386-linux-thread-mult
Somebody asked if I don't have a test server, answer: NO, my company has a production server that has multiple purposes, not only the web interface, and I cannot risk to update the kernel or the perl version, and cannot risk instaling any debuger, as the company owners say: "If it works, leave it alone", and for them the solution with my ($a); is perfect beacause it works, I'm asking here just for me, to learn more about perl, and to understand what is going wrong and what can I do better next time.
Thank you.
P.S. hope this new approach will restore some of my -1 :)
EDIT:
I had success starting the error logging, and found this in the error log after each step that resulted in a failure I got this messages:
[Thu Jul 15 14:29:19 2010] [error] locallib.pl did not return a true value at /var/www/html/rdsdb4/cgi-bin/clients/quicksearch.cgi line 2.
[Thu Jul 15 14:29:19 2010] [error] Premature end of script headers: quicksearch.cgi
What I found is that this code is at the end of the main code in the locallib.pl after this there are sub definitions, and locallib.pl is a library not a program file, so it's last statement must returns true. , a simple 1; statement at the end of the library ensures that (I put it after sub definitions to ensure that noobody writes code in the main after the 1;) and the problem was fixed.
Don't know why in CLI it had no problem ...
Maybe I will get a lot of down votes now ( be gentle :) ) , but what can I do ...and I hope that some newbies will read this and learn something from my mistake.
Thank you all for your help.
You need to explicitly check for definedness.
If you want to enter the loop when $client is defined,
use if ( defined $client ).
If you want to enter the loop when $client is defined and a valid integer,
use if ( defined $client && $client =~ /^-?\d+$/ ).
I assume it's an integer from the context, if it can be a float, the regex needs to be enhanced - there's a standard Perl library containing pre-canned regexes, including ones to match floats. If you require a non-negative int, drop -? from regex's start.
If you want to enter the loop when $client is defined and a non-zero (and assuming it shouldn't ever be an empty string),
use if ( $client ).
If you want to enter the loop when $client is defined and a valid non-zero int,
use if ( $client && $client =~ /^-?\d+$/ ).
Your #ids is "undef" when if condition is false, which may break the code later on if it relies on #ids being an array. Since you didn't actually specify how the script breaks without an else, this is the most likely cause.
Please see if this version works (use whichever "if" condition from above you need, I picked the last one as it appears to match the closest witrh the original code's intent - only enter for non-zero integers):
UPDATED CODE WITH DEBUGGING
use Data::Dumper;
open(my $tmp_file, ">", "/tmp/some_bad.log") or die "Can not open log file: $!\n";
#ids = (); # Do this first so #ids is always an array, even for non-client!
print $tmp_file "Before the if: ". Data::Dumper->Dump([\#ids, $client]) . "\n";
if ( $client && $client =~ /^-?\d+$/ ) # First expression catches undef and zero
{
print $tmp_file "Start the if: ". Data::Dumper->Dump([\#ids, $client]) . "\n";
my $st = &sql_query("select id from table where client=$client");
print $tmp_file "Before the while loop: ref(st)='". ref($st) . "'\n";
while(my $row = $st->fetchrow())
{
print $tmp_file "Row the while loop: ". Data::Dumper->Dump([row]) . "'\n";
push(#ids, $row->[0]);
}
print $tmp_file "After the while loop: ref(st)='". ref($st) . "'\n";
# No need to undef since both variables are lexically in this block only
}
print $tmp_file "After the if\n";
close($tmp_file) or die "Can not close file: $!\n";
when checking against a string, == and != should be respectively 'eq' or 'ne'
if( $client != "" )
should be
if( $client ne "" )
Otherwise you don't get what you're expecting to get.
Always begin your script with :
use warnings;
use strict;
these will give you usefull informations.
Then you could write :
my #ids;
if (defined $client) {
#ids = (); # not necessary if you run this part only once
my $st = sql_query("select id from table where client=$client");
while( my ($id) = $st->fetchrow ) {
push #ids, $id;
}
} else {
warn '$client not defined';
}
if (#ids) { # Your query returned something
# do stuff with #ids
} else {
warn "client '$client' does not exist in database";
}
Note: this answer was deleted because I consider that this is not a real question. I am undeleting it to save other people repeating this.
Instead of
if( $client != "" )
try
if ($client)
Also, Perl debugging is easier if you
use warnings;
use strict;
What I found is that this code is at the end of the main code in the locallib.pl after this there are sub definitions, and locallib.pl is a library not a program file, so it's last statement must returns true, a simple 1; statement at the end of the library ensures that (put it after sub definitions to ensure that noobody writes code in the main after the 1;) and the problem was fixed.
The conclusion:
I have learned that every time you write a library or modify one, ensure that it's last statment returns true;
Oh my... Try this as an example instead...
# Move the logic into a subroutine
# Forward definition so perl knows func exists
sub getClientIds($);
# Call subroutine to find id's - defined later.
my #ids_from_database = &getClientIds("Joe Smith");
# If sub returned an empty list () then variable will be false.
# Otherwise, print each ID we found.
if (#ids_from_database) {
foreach my $i (#ids_from_database) {
print "Found ID $i \n";
}
} else {
print "Found nothing! \n";
}
# This is the end of the "main" code - now we define the logic.
# Here's the real work
sub getClientIds($) {
my $client = shift #_; # assign first parameter to var $client
my #ids = (); # what we will return
# ensure we weren't called with &getClientIds("") or something...
if (not $client) {
print "I really need you to give me a parameter...\n";
return #ids;
}
# I'm assuming the query is string based, so probably need to put it
# inside \"quotes\"
my $st = &sql_query("select id from table where client=\"$client\"");
# Did sql_query() fail?
if (not $st) {
print "Oops someone made a problem in the SQL...\n";
return #ids;
}
my #result;
# Returns a list, so putting it in a list and then pulling the first element
# in two steps instead of one.
while (#result = $st->fetchrow()) {
push #ids, $result[0];
}
# Always a good idea to clean up once you're done.
$st->finish();
return #ids;
}
To your specific questions:
If you want to test if $client is defined, you want "if ( eval { defined $client; } )", but that's almost certainly NOT what you're looking for! It's far easier to ensure $client has some definition early in the program (e.g. $client = "";). Also note Kaklon's answer about the difference between ne and !=
if (X) { stuff } else { } is not valid perl. You could do: if (X) { stuff } else { 1; } but that's kind of begging the question, because the real issue is the test of the variable, not an else clause.
Sorry, no clue on that - I think the problem's elsewhere.
I also echo Kinopiko in recommending you add "use strict;" at the start of your program. That means that any $variable #that %you use has to be pre-defined as "my $varable; my #that; my %you;" It may seem like more work, but it's less work than trying to deal with undefined versus defined variables in code. It's a good habit to get into.
Note that my variables only live within the squiggliez in which they are defined (there's implicit squiggliez around the whole file:
my $x = 1;
if ($x == 1)
{
my $x = 2;
print "$x \n"; # prints 2. This is NOT the same $x as was set to 1 above.
}
print "$x \n"; # prints 1, because the $x in the squiggliez is gone.
I want to pass a lexical file handle to a subroutine using a named argument, but the following does not compile:
#!/usr/bin/perl -w
use strict;
my $log_fh;
my $logname = "my.log";
sub primitive {
my ($fh, $m) = #_;
print $fh $m;
}
sub sophisticated {
my ($args) = #_;
print $args->{m};
print $args->{fh} $args->{m} ;
}
open $log_fh, ">", $logname;
print $log_fh "Today I learned ...\n";
primitive($log_fh,"... the old way works ...\n");
sophisticated({
fh=>$log_fh,
m=>"... and the new way requires an intervention by SO.",
});
close $log_fh;
The complaint is:
Scalar found where operator expected at ./lexical.file.handle.pl line 15, near
} $args"
(Missing operator before $args?)
$ perl --version
This is perl, v5.10.1
It works O.K. when I use the primitive technique of passing arguments, and the named-argument hash technique works for the message portion, just not for the file handle portion. Do I need a new version of print ?
When you've got a complex expression that returns a filehandle (like $args->{fh}) you'll need to disambiguate the syntax a bit by adding some extra curlies:
print { $args->{fh} } $args->{m};
This is due to the weird way the print operator is designed, with no comma between the filehandle and the list of stuff to print.
Alternatively, you could grab the filehandle out of your arguments hashref first, e.g.
my $fh = $args->{fh};
print $fh $args->{m};
friedo's answer covers your problem, but there's a stylistic issue I'd like to point out. You don't need to wrap everything in an anonymous hash to emulate named arguments. A hash initializer is just a list interpreted as key/value pairs. Passing such a list to a sub provides a cleaner syntax for the caller:
sub sophisticated {
my %arg = #_;
print $arg{m};
print {$arg{fh}} $arg{m};
}
sophisticated(fh => $log_fh, m => "Hello, world!\n");