On Sat, 15 Dec 2001, Pierre Keller - BCU Lausanne wrote:
> Je crois qu'il existe plusieurs testeurs de liens qui
> travaillent à partir d'une page Web; mais à partir d'une
> base MySQL ?
J'utilise plutôt PostgreSQL: mais l'interfaçage depuis Perl doit être le
même ou presque.
1. Déclaration des champs pour faire un premier contrôle dans la base
de données
url TEXT CHECK ((url IS NULL)
OR (url LIKE 'http://%')),
(on pourrait ajouter un test qui soit plus strict selon les
RFCs, donnez-le moi si vous l'avez écrit :))
2. Faire le test proprement dit:
schaefer@defian:/tmp% wget 2> /dev/null -O /dev/null
'http://www.alphanet.ch/truc/abcd' && echo trouve
schaefer@defian:/tmp% wget 2> /dev/null -O /dev/null 'http://www.alphanet.ch/' && echo
trouve trouve
ou client HTTP Perl.
3. Parcourir une base de données
Il y a plusieurs méthodes, notamment des scripts Perl p.ex. Avec les
routines de base de données (que l'on peut trouver sur Contact DB,
http://www-internal.alphanet.ch/~schaefer/software.html). On peut aussi
directement utiliser l'interface Perl::DBI.
cela donne quelque chose comme: (avec bien sûr l'utilisation de faits
comme NOT NULL, etc, sinon le code devient plus compliqué)
#! /usr/bin/perl -w
use strict;
use contact;
use LWP::UserAgent;
use HTTP::Request::Common;
my $result = 0; # SUCCESS
my $error_reason = "unknown\n";
my $dbh = &open_database($database,
$server,
$user,
$password,
\$error_reason);
if (defined($dbh)) {
my @titles;
my @content;
if (&do_query($dbh,
"SELECT id, url FROM lien"
\@titles,
\@content,
undef,
undef,
\$error_reason)) {
my $hash_ref;
foreach $hash_ref (@content) {
if (!verify_url($hash_ref->{'url'}) {
print $hash_ref->{'id}', "\n";
}
}
}
else {
print STDERR "Query failed: ", $error_reason;
$result = 1;
}
if (!&close_database(\$dbh, \$error_reason)) {
print STDERR "Disconnect error: ", $error_reason;
$result = 1;
}
undef $dbh;
}
else {
print STDERR "Connect error: ", $error_reason;
$result = 1;
}
if ($result) {
print STDERR $0, ": something failed.\n";
exit $result;
}
# Devrait être amélioré pour distinguer les erreurs.
sub verify_url {
my ($url) = @_;
my $ua = LWP::UserAgent->new;
if (defined($ua)) {
my $request = HTTP::Request::Common::GET $url;
if (defined($request)) {
my $response = $ua->request($request);
if (defined($response)) {
if ($response->is_success()) {
return 1;
}
}
}
}
return 0; # fails (any error, not just not found!)
}
--
http://www-internal.alphanet.ch/linux-leman/ avant de poser
une question. Ouais, pour se désabonner aussi.
