Related
I am new in Perl and trying to catch hold of the scripting language where I come across regular expression to validate a email address. I am sharing the perl script. I am not sure where I am making mistake in it. The \# part is omitted always following which the correct email id is also showing as invalid.
Here is the code :
#!/usrs/bin/perl/
$string = "XYZ#yahoo.com";
if ( $string =~ /([a-zA-Z]+)\#([a-zA-Z]+)\.(com|net|org)/)
{
print "TRUE";
print $string;
}
else
{
print "FALSE";
print $string;
}
Thanks for your help.
The regex for validating an email address is included in the source code for Email::Valid. I've copied it below:
$RFC822PAT = <<'EOF';
[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\
xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xf
f\n\015()]*)*\)[\040\t]*)*(?:(?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\x
ff]+(?![^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015
"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\
xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80
-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*
)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\
\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\
x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>#,;:".\\\[\]\000-\037\x8
0-\xff]+(?![^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n
\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x
80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
\t]*)*)*#[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([
^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\
\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>#,;:".\\\[\]\000-\037\
x80-\xff]+(?![^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-
\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()
]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\
x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\04
0\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\
n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\
015()]*)*\)[\040\t]*)*(?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?!
[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\
]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\
x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\01
5()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*|(?:[^(\040)<>#,;:".
\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]
)|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^
()<>#,;:".\\\[\]\x80-\xff\000-\010\012-\037]*(?:(?:\([^\\\x80-\xff\n\0
15()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][
^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)|"[^\\\x80-\xff\
n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^()<>#,;:".\\\[\]\
x80-\xff\000-\010\012-\037]*)*<[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?
:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-
\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:#[\040\t]*
(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015
()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()
]*)*\)[\040\t]*)*(?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\0
40)<>#,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\
[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\
xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*
)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80
-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x
80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t
]*)*(?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>#,;:".\\
\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])
*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x
80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80
-\xff\n\015()]*)*\)[\040\t]*)*)*(?:,[\040\t]*(?:\([^\\\x80-\xff\n\015(
)]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\
\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*#[\040\t
]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\0
15()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015
()]*)*\)[\040\t]*)*(?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(
\040)<>#,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|
\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80
-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()
]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x
80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
\t]*)*(?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>#,;:".
\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff
])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\
\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x
80-\xff\n\015()]*)*\)[\040\t]*)*)*)*:[\040\t]*(?:\([^\\\x80-\xff\n\015
()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\
\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)?(?:[^
(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>#,;:".\\\[\]\000-
\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\
n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|
\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))
[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff
\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\x
ff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(
?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>#,;:".\\\[\]\
000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\
xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\x
ff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)
*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*#[\040\t]*(?:\([^\\\x80-\x
ff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-
\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)
*(?:[^(\040)<>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>#,;:".\\\[\
]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\]
)[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-
\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\x
ff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(
?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80
-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<
>#,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>#,;:".\\\[\]\000-\037\x8
0-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:
\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]
*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)
*\)[\040\t]*)*)*>)
EOF
But your actual problem is this line:
$string = "XYZ#yahoo.com";
The #yahoo looks like an array variable to Perl, and and you don't have an array called #yahoo it gets replaced with an empty string. Try printing the value of $string to see what you get.
The solution is either to use single quotes (so the array variable isn't expanded):
$string = 'XYZ#yahoo.com';
Or to escape the # with a \:
$string = "XYZ\#yahoo.com";
Alway add use strict and use warnings to your Perl programs. They would have told you what the problem is.
#!/usr/bin/perl
use strict;
use warnings;
use Email::Valid;
my $email_address = 'a.n#example.com';
unless( Email::Valid->address($email_address) ) {
print "Sorry, that email address is not valid!";
}
Reference Site: http://learn.perl.org/examples/email_valid.html
For Regex Pattern try this:
my $pattern= '^([a-zA-Z][\w\_\.]{6,15})\#([a-zA-Z0-9.-]+)\.([a-zA-Z]{2,4})$';
Reference Site: https://www.experts-exchange.com/articles/8652/Email-validation-using-Regular-Expression-in-Perl.html
Change your if condition to
if ($string =~ /^[a-z0-9A-Z][A-Za-z0-9.]+[A-Za-z0-9]\#[A-Za-z0-9.-]+$/)
and change
$string = "XYZ#yahoo.com"; to
$string = 'XYZ#yahoo.com';
Refference : http://perlmaven.com/email-validation-using-regular-expression-in-perl
for details.
Try
if ($email =~ /^[a-z0-9]([a-z0-9.]+[a-z0-9])?\#[a-z0-9.-]+$/)
And some test code:
#!/usr/bin/perl
my $email = "john.doe\#acme.org";
if ($email =~ /^[a-z0-9]([a-z0-9.]+[a-z0-9])?\#[a-z0-9.-]+$/) {
print "Valid email\n";
} else {
print "Not valid email\n";
}
exit;
Output:
Valid email
I have been looking for a solution to my problem and Hashes seem to be the answer after reading several posts but I am unsure how to implement this for my requirement, can anyone suggest how or even a better option?
In my code the variable $host is being set from values in a database. I loop through these values changing the value of $host each time.
I want to discard some types of host names, and to determine which hosts to discard I read in a user-configurable file which holds the Perl regex for that exclude. i.e. the config file has a line
EXCLUDE=\d+DAT\d+,\d+INF\d+
I then want to build up the Perl regexp match (logical OR), i.e.
if ( $host =~ m/\d+DAT\d+/ || $host =~ m/\d+INF\d+/ ) {
# do something
}
At the moment my code is hard wired as in the above example, but how can I dynamically construct the Perl regex after reading in the config file?
I have read the config file into an array and will start from there. The code above needs to end up like this:
if ($exclude clause) {
# do something
}
This is how I set about achieving that reading from the array:
for ($i = 1; $i < #conf; $i++) {
$exclude_clause .= "$host =~/" . #conf[$i] . "/ || ";
}
$exclude_clause =~ s/ \|\| $//;
The problem is referencing $host within the $exclude_clause. My regex string is built OK apart from the $host.
I would suggest a different approach that doesn't require you to build up a big Regex string and then evaluate it. Instead, what about using the List::MoreUtils module's any function, which accepts a block of code, evaluates it for each member of a list, and returns true once the block returns true for at least one entry in the list. For example:
use List::MoreUtils qw{ any };
if ( any { $host =~ $_ } #conf ) {
# do something
}
In the code block passed to any, the temp variable $_ contains the current entry in the list. That way you can avoid constructing a Regex in the first place.
I think you should store the complete regex in the configuration file, but it can be be a set of comma separated alternatives if need be.
You would use the qr// construct to build the regex:
my $exc1 = "\d+DAT\d+"; # Read from configuration file
my $ecc2 = "\d+INF\d+";
my $rex1 = qr/$exc1/;
my $rex2 = qr/$exc2/;
...populate $host...
if ($host =~ $rex1 || $host =~ $rex2)
{
...exclude $host...
}
else
{
...include $host...
}
Alternatively, you can build a single regex:
my $exc1 = "\d+DAT\d+"; # Read from configuration file
my $ecc2 = "\d+INF\d+";
my $rex = qr/$exc1|$exc2/;
...populate $host...
if ($host =~ $rex)
{
...exclude $host...
}
else
{
...include $host...
}
The single regex can be built from as many alternative exclusionary regex fragments as you like. Of course, if the value in the file is:
EXCLUDE=\d+DAT\d+|\d+INF\d+
then your code simplifies once more, assuming the regex string is read into $exc:
my $exc = "\d+DAT\d+|\d+INF\d+"; # Read from file
my $rex = qr/$exc/;
...populate $host...
if ($host =~ $rex)
{
...exclude $host...
}
else
{
...include $host...
}
Part of the specification says "Some names are special, e.g. Hughie, Dewey, Louis, and Donald. Other names may be added over the lifetime of the project at arbitrary times. Whenever you input one of those names, play quack.wav."
I could write ...
while (<>) {
if ($_ =~ /Hughie|Dewey|Louis/) {
quack() ;
}
elsif ($_ =~ /Donald/ {
quack() ;
you_re_fired_apprentice() ; # Easter egg don't tell QA
}
}
... but though untaxing to implement, it looks WTF-y: Where's the binary search? What if there were a sudden stupendous increase in the number of duck names? It would not scale at all!
I could create empty files using those names in a temporary directory, and then use the "file exists" API, but that seems roundabout, and I would have to be sure they were deleted at the end.
Surely there is a better way?
You could write that, but you should write this:
my %ducks = map {$_ => 1} qw(Hughie Dewey Louis);
while (<>) {
if ($ducks{$_}) {
quack() ;
}
elsif ($_ eq 'Donald') {
quack() ;
you_re_fired_apprentice() ; # Easter egg don't tell QA
}
}
Creating the hash takes a little bit of time, but not more than O(n). Lookup with a hash is O(1) though, so it is much more efficient than sequential search (via grep or a regex with alternation) assuming you will be checking for more than one or two items.
By the way, the regex that you have will match the words anywhere in the search string. You need to add start and end anchors if you want an exact match.
Alternatively, you could use smart matching
my #ducks = qw(Hughie Dewey Louis);
my $name = 'Dewey';
say 'smart match' if $name ~~ #ducks;
This is what is used by switch statements, so you could write
given ($name) {
when (#ducks) {
quack();
}
when ('Donald') {
quack();
you_re_fired_apprentice(); # Easter egg don't tell QA
}
}
As mentioned, hashes are the way to go for this. This is sort of what OOP looked like before OOP.
use strict;
use warnings;
my %duck_action = (
Donald => sub {quack(); you_re_fired_apprentice()},
Hughie => sub {quack()},
Dewie => sub {quack()},
Louis => sub {quack()},
);
for my $duck (qw( Hughie Dewie Donald Louis Porkie )) {
print "$duck: ";
my $action = $duck_action{$duck} || &no_such_duck;
$action->();
}
sub quack {
print "Quack!\n";
}
sub you_re_fired_apprentice {
print "You're fired!\n";
}
sub no_such_duck {
print "No such duck!\n";
}
You can use a Perl Hash. See also How can I represent sets in Perl? and Representing Sets in Perl.
Using hashes to implement a set is not exactly pretty, but it should be fast.
To find a string in a list, you could also use any in List::MoreUtils
use List::MoreUtils qw(any);
my #ducks = qw(Hughie Dewey Louis);
my $name = 'Dewey';
say 'any' if any {$name eq $_} #ducks;
If you're tied to using an array rather than a hash, you can use perl's grep function to search the array for a string.
#specialnames = qw(Hughie Dewey Louis);
while (my $value = <>) {
if (grep {$value eq $_}, #specialnames) {
quack() ;
}
elsif ($_ =~ /Donald/ {
quack() ;
you_re_fired_apprentice() ; # Easter egg don't tell QA
}
}
This does scale a lot worse than a hash, and might even scale worse than copying the array into a hash and then doing hash lookups.
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.
This is the first time I have manipulated hashes and arrays in this way -- and it is working. Basically, for every key there are multiple values that I want to record and then print out in the form "key --> value --> value --> val..."
My code is as follows. I am surprised that it works, so concerned that it works "by mistake". Is this the correct way to accomplish this task, or is there a more efficient or appropriate method?
while ($source =~ m/(regex)/g) { #Get all key names from source
$listkey = $1; #Set current list key to the current regex result.
$list{$listkey} = ++$i unless $list{$listkey}; #Add the key to the hash unless it already exists.
$list{$listkey} = [] unless exists $list{$listkey}; #Add an array for the hash unless the hash already exists.
while ($loopcount==0) {
if ($ifcount==0) {
$listvalue=result_of_some_function_using_list_key; #Get the first list value by using the list key.
$ifcount++; #Increment so we only get the first list value once.
} else {
$listvalue=result_of_some_function_using_list_value; #Update the list value by using the last list value.
}
if ($listvalue) { #If the function returned a value...
push #{$list{$listkey}}, $listvalue; #...then add the value to the hash array for the key.
} else { #There are no more values and we need a new key.
$listkey=0; #Reset variable.
$listvalue=0; #Reset variable.
$loopcount++; #Increment loop counter to exit loop.
}
}
$ifcount=0; #Reset count variable so the next listvalue can be generated from the new key.
$loopcount=0; #Reset count variable so another loop can begin for a new key.
}
foreach $listkey (keys %list) { #For each key in the hash.
print "$listkey --> "; #Print the key.
#values = #{$list{$listkey}}; #Reference the arrays of the hash.
print join ' --> ', #values; #Print the values.
print "\n"; #Print new line.
}
The following code does the same as your code, without the unnecessary steps.
while ($source =~ m/(regex)/g) { # Get all key names from source
$listkey = $1; # Grab current regex result.
$listvalue = result_of_some_function_using_list_key;
while ($listvalue) {
push #{$list{$listkey}}, $listvalue;
$listvalue = result_of_some_function_using_list_value;
}
$listkey = 0; # Reset variable.
$domain = 0; # Reset variable.
}
However, as others have commented, global variables should be avoided in most cases. Instead, the list key and list value should be lexically scoped with my(), and the functions for generating list values should take one or more parameters (domain, list key and/or list value) as input.
The lines
$list{$listkey} = ++$i unless $list{$listkey};
$list{$listkey} = [] unless exists $list{$listkey};
in your original code aren't needed, it is sufficient with push #{ $list{$key} }, $value to initialize an entry.
The code above has many unnecessary steps. Perl is a very expressive language, and allows logic like this to be expressed very simply:
# uncomment for some sample data
# sub function {"#_" !~ /^\[{3}/ and "[#_]"}
# my $source = 'one two three';
my %list;
while ($source =~ m/(\S+)/g) {
my $key = $1;
my $value = function($key);
while ($value) {
push #{ $list{$key} }, $value;
$value = function($value)
}
}
for my $key (keys %list) {
print join(' --> ' => $key, #{$list{$key}}), "\n";
}
Nope! If this works, it's definitely "by mistake". But it's also obvious that this isn't your real code and that you added several more mistakes in "translating" it to an example, so it's hard to judge exactly what the intent was, but going from the skeleton of your program, it looks like it should be something like:
my %result;
while ($source =~ m/(regex)/g) {
my $key = $1;
my $value = mangle($key);
while ($value) {
push #{ $results{$key} }, $value;
$value = frob($value);
}
}
and no more. Your attempts to initialize the hash aren't doing what you think they are (and aren't necessary), your while loop as written isn't a good idea at all, and neither are all the global variables.