Perl simple webserver not handling multiple requests simultaneously - multithreading

I wrote a simple webserver which should continuously handle simultaneous requests. But, even after detaching the threads it doesn't handle simultaneous requests. Can someone help?
Webserver.pl
use HTTP::Daemon;
use threads;
my $webServer;
my $package_map = {"test" => "test"};
my $d = HTTP::Daemon->new(LocalAddr => $ARGV[0],
LocalPort => 80,
Listen => 20) || die;
print "Web Server started!\n";
print "Server Address: ", $d->sockhost(), "\n";
print "Server Port: ", $d->sockport(), "\n";
while (my $c = $d->accept) {
threads->create(\&process_req, $c)->detach();
}
sub process_req {
my $c = shift;
my $r = $c->get_request;
if ($r) {
if ($r->method eq "GET") {
my $path = $r->url->path();
my $service = $package_map->{$path};
if ($service) {
$response = $service->process_request($request);
}
}
}
$c->close;
undef($c);
}
test.pm
sub process_request
{
threads->create(\&testing)->detach();
my $response = HTTP::Response -> new (200);
$response -> header('Access-Control-Allow-Origin', '*');
$response -> content("Success");
return $response;
}
sub testing
{
my $command = 'echo "sleep 100" | ssh -o StrictHostKeyChecking=no -o ConnectTimeout=10 <dev_box>';
if (system($command) != 0) {
print "FAILED\n";
}
}

Here is code based on your example that works for me on Windows. Maybe you can show us how/where it fails for you:
#!perl
use strict;
use warnings;
use HTTP::Daemon;
use threads;
my $webServer;
#my $package_map = {"test" => "test"};
my $d = HTTP::Daemon->new(LocalAddr => $ARGV[0],
LocalPort => $ARGV[1] // 80,
Listen => 20) || die;
print "Web Server started!\n";
print "Server Address: ", $d->sockhost(), "\n";
print "Server Port: ", $d->sockport(), "\n";
while (my $c = $d->accept) {
warn "New connection";
threads->create(\&process_req, $c)->detach();
}
sub process_req {
my $c = shift;
while( my $r = $c->get_request ) {
if ($r) {
if ($r->method eq "GET") {
my $path = $r->url->path();
if (1) {
sleep 100;
$c->send_response( HTTP::Response->new(200, "OK", undef, "done\n") );
}
}
}
};
$c->close;
}

Related

Perl: multithreaded server with Coro and AnyEvent

I am a newbie in Perl, so in educational purposes I am developing multithreaded server using AnyEvent and Coro. The client sends to server list of directory paths and server responses with listing of these directories.
I am using tcp_server and AnyEvent::Handle for connections handling, and for each client I want server to check thread pool (which is actually pool of coros) for free coro to handle request. When handling request is finished, I want coro to wait for another client instead of finishing.
However, it seems like at the end of handle_request sub, coro is destroyed and not avaliable anymore.
#!/usr/bin/perl
use strict;
use v5.18;
use AnyEvent;
use AnyEvent::Socket qw(tcp_server);
use AnyEvent::Handle;
use Coro;
use Class::Struct;
print("Server is running...\n");
# dirs function
sub print_dirs {
my $dir_list = $_[0];
my #dirs = split(" ", $dir_list);
my $result = "";
for my $dir (#dirs) {
if (opendir my $dirent, $dir) {
my #files = readdir $dirent;
closedir $dirent;
$result = $result . "\nContents of $dir:\r\n" . join("\r\n", #files) . "\r\n";
} else {
$result = $result . "Failed to open $dir: $!\r\n";
}
}
return $result;
}
# thread struct
struct clt_thread => {
id => '$',
thread => '$',
is_busy => '$',
args => '$',
client => '$',
clt_key => '$'
};
my $threads_num = 16;
my $thread_id = 0;
my #pool = ();
# handling request
my $cv = AE::cv;
my %client = ();
sub handle_request {
my $thread_id = shift;
my $thread;
foreach my $thr (#pool) {
if ($thr->id == $thread_id) { $thread = $thr; }
}
my $self = $thread->client;
my $client_key = $thread->clt_key;
my $dir_list = $thread->args;
if ($thread->client != '') {
say "Directories read: " . $dir_list . "\n";
my #clients = keys %client;
for my $key (grep {$_ ne $client_key} #clients) {
my $response = print_dirs($dir_list);
$client{$key}->push_write("$response");
$self->push_shutdown;
delete $client{$client_key};
delete $client{$self};
}
}
$thread->is_busy(0);
Coro::cede();
}
# threads creation
for my $i (0..$threads_num) {
my $coro = new Coro(\&handle_request, $thread_id);
my $thread = clt_thread->new(id => $thread_id, thread => $coro, is_busy => 0, args => '', client => '', clt_key => '');
push #pool, $thread;
$thread_id = $thread_id+1;
}
# tcp server creation - main part
tcp_server '127.0.0.1', 8015, sub {
my ($fh, $host, $port) = #_;
my $client_key = "$host:$port";
my $hdl = AnyEvent::Handle->new(
fh => $fh,
poll => 'r',
on_read => sub {
my ($self) = #_;
foreach my $thr (#pool) {
if (!($thr->is_busy)) {
$thr->client($self);
$thr->args($self->rbuf);
$thr->clt_key($client_key);
$thr->is_busy(1);
$thr->thread->ready();
return;
}
}
},
on_error => sub {
say "Something went wrong: $!\n";
},
);
$client{$client_key} = $hdl;
$client{$hdl} = $hdl;
};
$cv->recv;
I have already tried using infinite loop inside handle_request, but this way everything stops working at all. Do you have any ideas how to fix that? I suppose using Coro::AnyEvent to integrate coroutines into event loop might be solution. Can it be helpful in my case?
Thans for your help.
The thread exits when handle_request exits, so you want to wrap the body of handle_request in an infinite loop.
You also want to use Coro::schedule; instead of Coro::cede; to wait for ->ready to be called again before continuing.
That first loop in handle_request can be reduced to my $thread = $pool[$thread_id];.
Untested fix:
sub handle_request {
my ($thread_id) = #_;
my $thread = $pool[$thread_id];
while (1) {
my $self = $thread->client;
my $client_key = $thread->clt_key;
my $dir_list = $thread->args;
...
$thread->is_busy(0);
Coro::schedule();
}
}
That said, the following is the approach I'd use:
use Coro;
use Coro::Channel;
use constant NUM_WORKERS => 16;
sub worker {
my ($job) = #_;
my $self = $job->client;
my $client_key = $job->clt_key;
my $dir_list = $job->args;
...
}
{
my $q = Coro::Channel->new();
my #threads =
map {
async {
while ( my $job = $q->get() ) {
eval { worker($job); 1 }
or warn $#;
}
}
}
1..NUM_WORKERS;
...
on_read => sub {
my ($self) = #_;
$q->put({
client => $self,
clt_key => $client_key,
args => $self->rbuf,
});
}
...
$cv->recv;
$q->shutdown;
$_->join for #threads;
}
This is the same approach I'd use with real threads (using Thread::Queue instead of Coro::Channel).

Segmentation fault on merging threads (Perl)

I had some working code that I've tried to multithread using the tutorial on dreamincode: http://www.dreamincode.net/forums/topic/255487-multithreading-in-perl/
The example code there seems to work fine, but I can't for the life of me work out why mine isn't. From putting in debug messages it seems to get all the way to the end of the subroutine with all of the threads, and then sit there for a while before hitting a segmentation fault and dumping the core. That being said I've also not managed to find the core dump files anywhere (Ubuntu 13.10).
If anyone has any suggested reading, or can see the error in the rather messy code below I'd be eternally grateful.
#!/usr/bin/env perl
use Email::Valid;
use LWP::Simple;
use XML::LibXML;
use Text::Trim;
use threads;
use DB_File;
use Getopt::Long;
my $sourcefile = "thislevel.csv";
my $startOffset = 0;
my $chunk = 10000;
my $num_threads = 8;
$result = GetOptions ("start=i" => \$startOffset, # numeric
"chunk=i" => \$chunk, # numeric
"file=s" => \$sourcefile, # string
"threads=i" => \$num_threads, #numeric
"verbose" => \$verbose); # flag
$tie = tie(#filedata, "DB_File", $sourcefile, O_RDWR, 0666, $DB_RECNO)
or die "Cannot open file $sourcefile: $!\n";
my $filenumlines = $tie->length;
if ($filenumlines>$startOffset + $chunk){
$numlines = $startOffset + $chunk;
} else {
$numlines = $filenumlines;
}
open (emails, '>>emails.csv');
open (errorfile, '>>errors.csv');
open (nxtlvl, '>>nextlevel.csv');
open (donefile, '>>donelines.csv');
my $line = '';
my $found = false;
my $linenum=0;
my #threads = initThreads();
foreach(#threads){
$_ = threads->create(\&do_search);
}
foreach(#threads){
$_->join();
}
close nxtlvl;
close emails;
close errorfile;
close donefile;
sub initThreads{
# An array to place our threads in
my #initThreads;
for(my $i = 1;$i<=$num_threads;$i++){
push(#initThreads,$i);
}
return #initThreads;
}
sub do_search{
my $id = threads->tid();
my $linenum=$startOffset-1+$id;
my $parser = XML::LibXML->new();
$parser->set_options({ recover => 2,
validation => 0,
suppress_errors => 1,
suppress_warnings => 1,
pedantic_parser => 0,
load_ext_dtd => 0, });
while ($linenum < $numlines) {
$found = false;
#full_line = split ',', $filedata[$linenum-1];
$line = trim(#full_line[1]);
$this_url = trim(#full_line[2]);
print "Thread $id Scanning $linenum of $filenumlines\: ";
printf "%.3f\%\n", 100 * $linenum / $filenumlines;
my $content = get trim($this_url);
if (!defined($content)) {
print errorfile "$this_url, no content\n";
}elsif (length($content)<100) {
print errorfile "$this_url, short\n";
}else {
my $doc = $parser->load_html(string => $content);
if(defined($doc)){
for my $anchor ( $doc->findnodes("//a[\#href]") )
{
$is_email = substr $anchor->getAttribute("href") ,7;
if(Email::Valid->address($is_email)) {
printf emails "%s, %s\n", $line, $is_email;
$found = true;
} else{
$link = $anchor->getAttribute("href");
if (substr lc(trim($link)),0,4 eq "http"){
printf nxtlvl "%s, %s\n", $line, $link;
} else {
printf nxtlvl "%s, %s/%s\n", $line, $line, $link;
}
}
}
}
if ($found=false){
my #lines = split '\n',$content;
foreach my $cline (#lines){
my #words = split ' ',$cline;
foreach my $word (#words) {
my #subwords = split '"',$word ;
foreach my $subword (#subwords) {
if(Email::Valid->address($subword)) {
printf emails "%s, %s\n", $line, $subword;
}
}
}
}
}
}
printf donefile "%s\n",$linenum;
$linenum = $linenum + $num_threads;
}
threads->exit();
}
In addition to sundry coding errors that mean my code should never ever be used as an example for other visitors, DB_File is not a thread-safe module.
Annoyingly, and perhaps misleadingly, it works absolutely as it should do right up until you close the threads that have been successfully accessing the file throughout your code.

Migrating threads to forks

There is forks::shared that should be drop in replacement for threads::shared, but how should I replace Thread::Queue?
I would like to convert following code to forks, if it is possible?
sub Qfac {
use threads;
use threads::shared;
use Thread::Queue;
my ($worker, $arrid, $arg) = #_;
$arrid ||= [];
$arg ||= {};
my %tr;
my %h :shared;
my %qe = map { $_ => Thread::Queue->new() } #$arrid;
for my $id (#$arrid) {
my $q = $qe{$id};
$tr{$id} = threads->create($arg, sub{
my $me = { id => $id };
while (my $item = $q->dequeue()) {
$me->{item} = $item;
eval { $worker->($me, \%h) };
$me->{err} = $# if $#;
my $temp = threads::shared::shared_clone($me);
{
lock (%h);
$h{$id} = $temp;
}
}
});
$tr{$id}->detach();
}
##
return sub {
my $act = shift;
if ($act eq "getshared") { return #_ ? #h{#_} : \%h }
elsif ($act eq "enqueue") { $_->enqueue(#_) for values %qe }
elsif ($act eq "getqe") { return \%qe }
elsif ($act eq "gettr") { return \%tr }
elsif ($act eq "getssize") { return threads->get_stack_size() }
elsif ($act eq "setssize") { return threads->set_stack_size(#_) }
else { die "unknown method" }
};
}
my $worker = sub {
my ($me) = #_;
my $id = $me->{id};
# $me->{foo} = "bar";
};
my $qf = Qfac($worker, [ 0 .. 10 ]);
# Send work to the thread
$qf->("enqueue", "do_something");
# ...
my $shared = $qf->("getshared");
use forks; (and its ::shared) is a drop-in replacement for use threads; (and its ::shared), and Thread::Queue uses thread::shared, so Thread::Queue will continue working just fine.
use if $ARGV[0], "forks";
use threads; # No effect under "use forks;"
use Thread::Queue;
my $q = Thread::Queue->new();
print "$$\n";
async {
print "$$\n";
print "$_\n" while $_ = $q->dequeue();
};
$q->enqueue($_) for 1..4;
$q->end();
$_->join() for threads->list();
$ perl x.pl 0
6047
6047
1
2
3
4
$ perl x.pl 1
6054
6056
1
2
3
4
(You'll need to add use forks::shared; with older versions for forks.)

Perl help: Can't call method "display" on an undefined value

Let start with the basic back ground. We recently brought our web hosting in house.
There are few old website still use Perl. I have no experience with Perl.
Let's Begin. We have a this sub website on our main domain.
Public link : http://www.gatewayrehab.org/eap/
When you goto website we get the following error message
"Software error:
Can't call method "display" on an undefined value at /var/www/www.gatewayrehab.org/app/webroot/eap/index.cgi line 47."
Looking at the EAP website/directory all files look in place with proper permission, again I have no experience with Perl/Cgi. Below is the index.cgi file :
#!/usr/bin/perl -w
### the main control file used in the system
BEGIN { unshift #INC, qw(./cgi-bin/include/); }
### send all fatal errors to the browser
use CGI::Carp qw(fatalsToBrowser);
use CGI qw(:standard);
use Error_Handler;
use File_Handler;
use Cookie_Handler;
require "./cgi-bin/setup.cgi";
do "./cgi-bin/include/common.cgi";
### initialize the file handling module
my $File = new File_Handler;
### initialize the cookie handling module
my $Cookie = new Cookie_Handler;
###parse
$ENV{'REQUEST_METHOD'} =~ tr/a-z/A-Z/;
if ($ENV{'REQUEST_METHOD'} eq "POST"){
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
} else {
$buffer = $ENV{'QUERY_STRING'};
}
#pairs = split(/&/, $buffer);
#&error_check;
foreach $pair (#pairs){
($name, $value) = split(/=/, $pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$name =~ tr/+/ /;
$name =~ s/\breq\_//ig;
$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$name =~ tr/A-Z/a-z/;
$name = trim($name);
$FORM{$name} = trim($value);
}
my %cookiedata = $Cookie -> get_cookies();
### read the summary database
my $summary_ref = $File -> read($login_summary)|| $Error -> display("$!". __LINE__);
my (#summary) = #$summary_ref;
### read the companies database
my $companies_ref = $File -> read($companies_db)|| $Error -> display("$!". __LINE__);
my (#companies) = #$companies_ref;
my %COMP = ();
foreach (#companies) {
$_ =~ s/\n|\r//g;
my ($c_num, $c_name) = split(/\t/, $_);
$COMP{$c_num} = $c_name;
}
if ( $cookiedata{'LOGIN'} != 1 ) {
my $found = 0;
my $company_number = $ENV{'REMOTE_USER'};
$company_number =~ s/s|e|w//g;
foreach (#summary) {
$_ =~ s/\n|\r//g;
my #field = split(/\t/, $_);
$field[0] = &trim($field[0]);
$field[2] = &trim($field[2]);
$field[3] = &trim($field[3]);
$field[4] = &trim($field[4]);
$field[5] = &trim($field[5]);
$field[6] = &trim($field[6]);
if ( $field[0] eq "$company_number" ) {
$found = 1;
my $firstletters = substr($ENV{'REMOTE_USER'}, 0, 2);
$firstletters = trim($firstletters);
if ( $firstletters ne "sw" && $firstletters ne "lf" ) {
$firstletters = substr($firstletters, 0, 1);
}
if ( lc($firstletters) eq "e" ) {
$field[3] = ($field[3] + 1);
} elsif ( lc($firstletters) eq "s" ) {
$field[2] = ($field[2] + 1);
} elsif ( lc($firstletters) eq "w" ) {
$field[4] = ($field[4] + 1);
} elsif ( lc($firstletters) eq "sw" ) {
$field[5] = ($field[2] + 1);
} elsif ( lc($firstletters) eq "lf" ) {
$field[6] = ($field[6] + 1);
} else {
$field[3] = ($field[3] + 1);
}
$_ = join("\t", #field);
}
}
if ( $found == 1 ) {
# write data back to file
# append to summary file
open(LOG, ">$login_summary") || $Error -> display("$!". __LINE__);
flock(LOG,2);
foreach (#summary) {
print LOG $_ ."\n";
}
flock(LOG,8);
close(LOG);
#$File -> file($login_summary);
#$File -> data(\#summary);
#$File -> write() || $Error -> display("$!". __LINE__);
} else {
$e = 0;
$s = 0;
$w = 0;
$sw = 0;
$lf = 0;
my $firstletters = substr($ENV{'REMOTE_USER'}, 0, 2);
$firstletters = trim($firstletters);
if ( $firstletters ne "sw" && $firstletters ne "lf" ) {
$firstletters = substr($firstletters, 0, 1);
}
if ( lc($firstletters) eq "e" ) {
$e = 1;
} elsif ( lc($firstletters) eq "s" ) {
$s = 1;
} elsif ( lc($firstletters) eq "w" ) {
$w = 1;
} elsif ( lc($firstletters) eq "sw" ) {
#$sw = 1;
$s = 1;
} elsif ( lc($firstletters) eq "lf" ) {
$lf = 1;
} else {
$e = 1;
}
# append to summary file
open(LOG, ">>$login_summary") || $Error -> display("$!". __LINE__);
flock(LOG,2);
print LOG $company_number ."\t". $COMP{$company_number} ."\t". $s ."\t". $e ."\t". $w . "\t". $sw ."\t". $lf ."\n";
flock(LOG,8);
close(LOG);
}
my (#login_logs) = ();
my $logline = "";
$login_logs[0] = $ENV{'REMOTE_USER'};
$login_logs[1] = $ENV{'REMOTE_ADDR'};
$login_logs[2] = time();
open(LOG, ">>$login_logs") || $Error -> display("$!". __LINE__);
flock(LOG,2);
print LOG $ENV{'REMOTE_USER'} ."\t". $ENV{'REMOTE_ADDR'} ."\t". time() ."\n";
flock(LOG,8);
close(LOG);
print "Set-Cookie: LOGIN=1";
print "; path=$cookiepath; domain=$cookiedomain;\n";
}
my $firstletters = substr($ENV{'REMOTE_USER'}, 0, 2);
$firstletters = trim($firstletters);
if ( $firstletters ne "sw" && $firstletters ne "lf") {
$firstletters = substr($firstletters, 0, 1);
}
if ( lc($firstletters) eq "e" ) {
print "Location: http://www.gatewayrehab.org/eap/new/employee/member.htm\n\n";
} elsif ( lc($firstletters) eq "s" ) {
print "Location: http://www.gatewayrehab.org/eap/supervisor/\n\n";
} elsif ( lc($firstletters) eq "w" ) {
print "Location: http://www.gatewayrehab.org/eap/new/worklife/member.htm\n\n";
} elsif ( lc($firstletters) eq "sw" ) {
print "Location: http://www.gatewayrehab.org/eap/supervisor-wl/\n\n";
exit;
} elsif ( lc($firstletters) eq "lf" ) {
print "Location: http://www.gatewayrehab.org/eap/legalandfinancial/\n\n";
exit;
} else {
print "Location: http://www.gatewayrehab.org/eap/new/employee/member.htm\n\n";
}
#output html
print "Content-type: text/html\n\n";
print "<h1>hello world!</h1>";
$e = `perl -ver`;
$r = `whereis perl5`;
$z = `whereis sendmail`;#
$w = `top`;#
$d = `w`;
print "<pre>perl version:<br>$e<hr>perl path:<br>$r<hr>sendmail path:<br>$z<hr>top:<br>$w<hr>w:<br>$d<hr>environment vars:<br>";##
while (($key, $val) = each %ENV) {
print "$key = $val\n";
}
$x= 'lowercase';
print "<hr>path tranlsated(NT)<br>$ENV{'PATH_TRANSLATED'}</pre>";
#$x = uc($x);
print "<br>$x";
exit;
Please let me know what I am missing. If you need to look at more "included" files let me know.
Also here is the link for our cgi config. http://www.gatewayrehab.org/eap/cgi-bin/cgi.cgi
Thank You.
The error comes from this line: my $summary_ref = $File -> read($login_summary)|| $Error -> display("$!". __LINE__);. It means $Error doesn't exist or its value is undef. And indeed, I don't see such a variable being declared or initialised. Maybe it's suppose to be exported by Error_Handler???
This error is happening when trying to report another error. You could try replacing (if only temporarily) $Error -> display("$!". __LINE__); with die($!) and checking your server's error log for the error message. That said, it's surely "No such file or directory" or "Permission denied", so maybe it's not worth the time to find out the exact message. (Upd: Actually, I think the message will be "redirected" to your browser, so that makes things easier.)
I'm guessing here, but it looks like it's trying to read the file named by $login_summary. I have no idea where this is set (if at all!), so you might want to find out its value, and maybe where it's getting set.
As ikegami pointed out, the error you are seeing indicates that $Error is not being initialized, and looking at the rest of the script, I would guess that what is needed (first of all) is to initialize it in the same manner as the $File and $Cookie variables. Add this line after line 20 in your script:
my $Error = new Error_Handler;
That might give you a nicer error message, but it will probably just tell you what you already discovered when you added your die($!); line: 'No such file or directory'.
Your script is also doing a file called ./cgi-bin/include/common.cgi. Check this file for your $login_summary variable, to know what file it's trying to access.
I have resolved the problem with a quick fix. I don't know why it work but it does for me.
Here what i did...After reading online i found that adding "-w" on the header of all .(dot)cgi files make it work.
I do hope there is a better method to add "-w" in one place then adding it on all .cgi files.
In short change #!/usr/bin/perl to #!/usr/bin/perl -w
Thanks all.

How can I rewrite this multiple OR condition so that it uses a Perl "for" loop?

I have a hard-coded if loops that looks like this:
my $tp = 0;
my $fp = 0;
if ( $myhash{$pred}
|| $myhash{$pred1}
|| $myhash{$pred2}
|| $myhash{$pred3}
|| $myhash{$pred4}
|| $myhash{$pred5}
|| $myhash{$pred6} )
{
$tp++;
}
else {
$fp++;
}
How can I do that in for loops?
I tried the following but it give different result in total of fp and tp:
my $tp=0;
my $fp=0;
my #allpreds = ($pred,$pred1,$pred2,$pred3,$pred4,$pred5);
foreach my $allpred ( #allpreds ) {
if ( $myhash{$allpred} ) {
$tp++;
}
}
if ( !myhash{$pred} ) {
$fp++;
}
my $tp=0;
my $fp=0;
my $count=0;
my #allpreds = ($pred,$pred1,$pred2,$pred3,$pred4,$pred5);
foreach my $allpred ( #allpreds ) {
if ( $myhash{$allpred} ) {
$count++;
}
}
if ($count>0) { $tp=1; } else { $fp=1; }
This is somewhat more compact than some answers, but fully equivalent.
my $tp = 0;
my $fp = 0;
foreach my $allpred ($pred, $pred1, $pred2, $pred3, $pred4, $pred5)
{
$tp++, last if ($myhash{$allpred});
}
$fp = !$tp;
It is not clear that the variable $fp earns its keep when !$tp is almost as simple to write.
Test code - change the settings on the RHS of the fat commas to change the behaviour of the test.
use strict;
use warnings;
my $pred = "";
my $pred1 = "1";
my $pred2 = "2 2";
my $pred3 = "3 3 3";
my $pred4 = "4 4 4 4";
my $pred5 = "5 5 5 5 5";
my %myhash = ( $pred1 => 0, $pred2 => 0, $pred3 => 0, $pred4 => 0, $pred5 => 1 );
my $tp = 0;
my $fp = 0;
foreach my $allpred ($pred, $pred1, $pred2, $pred3, $pred4, $pred5)
{
$tp++, last if ($myhash{$allpred});
}
$fp = !$tp;
printf "%d:%d\n", $tp, $fp;
grep will return a true value when any one or more of its inputs returns true for it's statement, basically allowing it to act like a chain of ||'ed statements, except that it won't short circuit.
my #allpreds = ($pred, $pred1, $pred2, $pred3, $pred4, $pred5, $pred6);
if (grep { $myhash{$_} } #allpreds) {
$tp++;
}
else {
$fp++;
}
Using grep this way can be a bit confusing so a more explicit way is to use List::MoreUtils any
use List::MoreUtils qw(any);
my #allpreds = ($pred, $pred1, $pred2, $pred3, $pred4, $pred5, $pred6);
if (any { $myhash{$_} } #allpreds) {
$tp++;
}
else {
$fp++;
}

Resources