I'm optimizing my link checker .. here's the full sub.
Code:
BEGIN{ eval { require warnings; import warnings }; $^W = 1 }
use LWP::Parallel::UserAgent qw(:CALLBACK);
use constant FAIL_MESSAGE => <<MESSAGE;
<table width="95%" border="0" cellspacing="0" cellpadding="2">
<tr>
<td width="2%" align="middle"> </td>
<td width="6%" bgcolor="#EEEECC"align="right" valign="top">
<font face="Arial, Helvetica, sans-serif" size="2">%s</font> </td>
<td width="58%" bgcolor="#E9EBEF"> <font face="Arial, Helvetica, sans-serif" size="2">%s</font></td>
<td width="20%" bgcolor="#FFDDDD"> <font face="Arial, Helvetica, sans-serif" size="2">%s</font></td>
<td width="14%" bgcolor="#EEEECC" valign="top" align="center">
<a href="odb.cgi?action=edit_record&id=%s"><img src="/images/icons/edit.gif" width="15" height="15" alt="[ edit ]" border="0">
</a> <a href="odb.cgi?action=del_record&id=%s" onClick="return confirm('Delete record %s?')">
<img src="/images/icons/delete.gif" width="15" height="15" alt="[ delete ]" border="0">
</a> <a href="odb.cgi?action=toggle_live&id=%s"><img src="/images/icons/live%s.gif" border="0"></a>
</td>
</tr>
/table>
<BR>
MESSAGE
#$ref->{id}, $ref->{'name_en'}, "$res_code : $res_msg", $ref->{'id'},
#$ref->{'id'}, $ref->{'id'}, $ref->{'id'}, ($live ? "yes" : "no")
sub check_links_results {
print $query->header;
my $ua = LWP::Parallel::UserAgent->new;
$ua->nonblock(1) if $ua->can("nonblock");
$ua->agent("OpticDB LinkCheck/0.1");
$ua->remember_failures();
my $dbh = connect_to_db();
my $sth = $dbh->prepare(qq[SELECT url_en, id, name_end FROM $DB_MYSQL_NAME]);
$sth->execute();
my ($count, %info) = 0;
my $endcon = sub { return C_ENDCON };
local *LPW::Parallel::UserAgent::on_return = sub {
my ($self, $req, $res, $entry) = @_;
$self->discard_entry($req);
my $code = $res->code();
return if $code >= 100 && $code < 400; # success!
if( $req->method() eq "HEAD" and
$code != 404 and substr($code,0,1) != 5 ) {
$req->method("GET");
$self->register($req, $endcon);
return;
}
++$count;
my ($id, $name) = @{ $info{ $req->url } };
$tmpl_show_record .= sprintf FAIL_MESSAGE,
$id, $name, "$code " . $res->message(),
($id) x 4, ($data_status eq "Live" ? "yes" : "no");
}
while( my ($url, $id, $name) = $sth->fetchrow_array ) {
$info{$url} = [$id, $name];
my $req = HTTP::Request->new(HEAD => $url);
$req->header(Range => "bytes=0-0");
$ua->register($req, $endcon);
}
$dbh->disconnect;
$ua->wait;
$num_dead = $count;
if( !$count ) {
error_html("No dead links found!");
exit;
}
parse_template("$PATH_TEMPLATE/check_links_results.tmpl");
}