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.
