#!/usr/bin/perl
# rechpatro version 0.3 14 avril 2000
# Ce programme est un utilitaire genealogique. Il regarde les patronymes
# qui figurent dans le fichier name.txt par defaut (ou dans le fichier
# donne en ligne de commande) chacun sur une ligne. Il lance une
# recherche sur ce patronyme sur les sites geneanet et familysearch (mormon)
# et enfin il ecrit un fichier resultat donnant les nouveautes par rapport
# a une recherche precedente.
#
# LIGNE DE COMMANDE :
# --moteur=geneanet ou -m geneanet pour une recherche sur geneanet
# --moteur=mormon ou -m mormon pour une recherche sur familysearch
# par defaut la recherche se fera sur les deux moteurs
# toute autre entree apres --moteur= ou -m ne lancera aucune recherche ;
# SUIVI eventuellement du nom du fichier source (name.txt par defaut).
#
# STRUCTURE DU FICHIER SOURCE :
# Chaque ligne doit commencer par le patronyme
# puis on indiquera au choix aucun ou plusieurs des criteres
# (au format reclame par geneanet : code geographique a 3 lettres pour
# pays, region et sousregion
# http://www.geneanet.com/codification/)
# dans n'importe quel ordre et en utilisant les balises ci-dessous suivies
# du separateur point-virgule (le dernier de la ligne peut etre omis) :
# DEBUT pour l'annee ou debutent les recherches
# FIN pour l'annee ou finissent les recherches
# LIEU pour le lieu ou chercher
# SUB pour la sous-region (departement)
# REG pour la region
# PAYS pour le pays (attention : je n'ai pris en compte que les pays
# France, Allemagne, Suisse et USA ; sinon ajouter les traductions
# pour les recherches avec familysearch)
# SOURCE pour indiquer la ou les sources a consulter, ou a ne pas consulter
# Remarque : la recherche par familysearch ne se fera que par pays,
# cmopte tenu de la faiblesse de leur moteur
# (recherche bicritere uniquement!)
#
# TODO :
# done * permettre une recherche multicritere en formattant le fichier
# name.txt genre : patro LIEU lieu; SOURCE source; ....
# et utiliser ces param dans les recherches web. S'kal propose xml :(
# * structurer pour que les moteurs apparaissent proprement: volontaire?
# done * facile : faire un fichier resultatjjmmaaaa au lieu de juste resultat
#
# BUGS CONNUS :
# done * j'ai eu sur recherche schmitt france mormon : deux dernieres lignes
# qui n'auraient jamais du y etre... !! NON en fait c'est bon :
# c'est du a la structure differente des infos "pages web"
#
use strict;
use Socket;
use FileHandle;
use File::Copy;
my($filesource, @listenoms, @tableau, @tableau_ancien, $fileresult);
my($jour, $mois, $annee);
my ($ligne, $entree, $moteur);
#my($fileancien, @lignesancien, $filenouveau, @lignesnouveau);
#my(@tronqueancien, @tronquenouveau);
($jour, $mois, $annee) = (localtime)[3..5];
$mois = $mois +1;
$annee = $annee +1900;
$fileresult = "resultat$jour$mois$annee";
open(RESULT, "> $fileresult");
# LIGNES UTILES AUX TESTS HORS CONNEXION
#$fileancien = './testpt'; # Name the file
#open(ANCIEN, $fileancien); # Open the file
#@lignesancien = <ANCIEN>; # Read it into an array
#close(ANCIEN); # Close the file
#
#$filenouveau = './testgd'; # Name the file
#open(NOUVEAU, $filenouveau); # Open the file
#@lignesnouveau = <NOUVEAU>; # Read it into an array
#close(NOUVEAU); # Close the file
#
#@tronqueancien = @{&tronque_mormon(\@lignesancien)};
#@tronquenouveau = @{&tronque_mormon(\@lignesnouveau)};
#@tronqueancien = @{&elimine_balise_html_mormon(\@tronqueancien)};
#@tronquenouveau = @{&elimine_balise_html_mormon(\@tronquenouveau)};
##&traitement_ancien_nouveau(\@tronqueancien,\@tronquenouveau,"nom");
##print @tronquenouveau;
##$patronyme="breyer";
##@tronquenouveau = @{&recherche_geneanet_simple($patronyme)};
##@tronquenouveau = @{&tronque_geneanet(\@tronquenouveau)};
##print @tronquenouveau;
#&traitement_ancien_nouveau(\@tronqueancien,\@tronquenouveau,"test");
#
$filesource = "name.txt"; # shift; # Nom du fichier source
$moteur = "";
if ($entree = shift) {
if($entree =~ /--moteur=(.*)\b/) {
$moteur = $1;
if ($entree = shift) {$filesource = $entree;}
}
elsif ($entree =~ /-m/) {
if ($entree = shift) {$moteur = $entree;}
if ($entree = shift) {$filesource = $entree;}
}
else {
$filesource = $entree;}}
open(NOMS, $filesource) or die "Absence de fichier de noms\n";# Open the file
@listenoms = <NOMS>; # Read it into an array
close(NOMS); # Close the file
if ($moteur eq "" or $moteur eq "geneanet")
{foreach $ligne (@listenoms)# a terme changer ces deux horribles boucles
#pas forcement possible, trop de specificites ds chaque moteur
{
my($name1,$name2);
my $sortie;
#transformer $ligne en tous les champs possibles
my($patronyme, $debut, $fin, $lieu, $sub, $reg, $pays, $source);
if ($ligne =~ /^(.*?)\s/) {$patronyme = $1;} else {
$ligne =~/^(.*?)$/; $patronyme = $1;}
if ($ligne =~ /DEBUT (.*?)(;|$)/) { $debut =$1;} else { $debut ="";}
if ($ligne =~ /FIN (.*?)(;|$)/) { $fin =$1;} else { $fin ="";}
if ($ligne =~ /LIEU (.*?)(;|$)/) { $lieu =$1;} else { $lieu ="";}
if ($ligne =~ /SUB (.*?)(;|$)/) { $sub =$1;} else { $sub ="";}
if ($ligne =~ /REG (.*?)(;|$)/) { $reg =$1;} else { $reg ="";}
if ($ligne =~ /PAYS (.*?)(;|$)/) { $pays =$1;} else { $pays ="";}
if ($ligne =~ /SOURCE (.*?)(;|$)/) { $source =$1;} else { $source ="";}
$source =~ tr/ /+/;
$name1="$patronyme" ."_geneanet_new";
$name2="$patronyme" ."_geneanet_old";
unless (-e "$name1")
{
# ecrire un fichier vide: utilite? oui: ne cree pas qd copie si inexistant
open(NEW, "> $name1");
close(NEW);
};
copy("$name1","$name2");
# ecrire tableau ancien
open(OLD,"$name2");
@tableau_ancien = <OLD>;
close(OLD);
# recherche sur le net : geneanet
# @tableau = @{&recherche_geneanet_simple($patronyme)};
@tableau = @{&recherche_geneanet($patronyme, $debut, $fin, $lieu, $sub, $reg, $pays, $source)};
@tableau = @{&tronque_geneanet(\@tableau)};
@tableau = @{&elimine_balise_html_geneanet(\@tableau)};
#comparer ancien et nouveau avec traitement
&traitement_ancien_nouveau(\@tableau_ancien,\@tableau,$patronyme,"geneanet");
#ecrire tableau dans le fichier $patro_geneanet_new
open(NEW, "> $name1");
$sortie = select(NEW);
print @tableau;
select($sortie);
close(NEW);
}}
if ($moteur eq "" or $moteur eq "mormon") {
foreach $ligne (@listenoms)
{
my($name1,$name2);
my $sortie;
my ($patronyme, $pays);
if ($ligne =~ /^(.*?)\s/) {$patronyme = $1;} else {
$ligne =~/^(.*?)$/; $patronyme = $1;}
if ($ligne =~ /PAYS (.*?)(;|$)/) { $pays =$1;} else { $pays ="";}
if ($pays =~ /fra/i) {$pays="Fran96";}
elsif ($pays =~ /deu/i) {$pays="ge99";}
elsif ($pays =~ /che/i) {$pays="Swit96";}
elsif ($pays =~ /usa/i) {$pays="US912";}
$name1="$patronyme" ."_mormon_new";
$name2="$patronyme" ."_mormon_old";
unless (-e "$name1")
{
# ecrire un fichier vide
open(NEW, "> $name1");
close(NEW);
};
copy("$name1","$name2");
# ecrire tableau ancien
open(OLD,"$name2");
@tableau_ancien = <OLD>;
close(OLD);
# recherche sur le net : mormon
@tableau = @{&recherche_mormon($patronyme, $pays)};
# @tableau = @{&recherche_mormon_simple($patronyme)};
@tableau = @{&tronque_mormon(\@tableau)};
@tableau = @{&elimine_balise_html_mormon(\@tableau)};
#comparer ancien et nouveau avec traitement
&traitement_ancien_nouveau(\@tableau_ancien,\@tableau,$patronyme,"mormon");
#ecrire tableau dans le fichier $patro_mormon_new
open(NEW, "> $name1");
$sortie = select(NEW);
print @tableau;
select($sortie);
close(NEW);
}
}
print "Les résultats de la recherche se trouvent dans le fichier $fileresult\n";
close(RESULT);
sub traitement_ancien_nouveau #(ancien,nouveau,patronyme,moteur)
{
my($patro, @tableau, $moteur);
my $sortie;
@tableau = @{&extrait_differences($_[0],$_[1])};
$patro = $_[2];
$moteur = $_[3];
if (@tableau == 0)
{
$sortie = select(RESULT);
print "Les informations du moteur $moteur concernant le patronyme $patro N'ont PAS changé\n";
select($sortie);
}
else
{
$sortie = select(RESULT);
print "Les changements concernant le patronyme " .
"$patro sur le moteur $moteur sont les suivants :\n";
print @tableau;
select($sortie);
}
}
sub compare_simple # teste juste si les fichiers sont egaux : plus utilisee
{
my ($tab1,$tab2)=@_;
my($i);
if (@$tab1 == @$tab2)
{
for ($i=0; $i <= $#$tab1 ; $i++)
{
if ($$tab1[$i] ne $$tab2[$i]) {return "0";}
}
return "1";
}
else
{
return "0";
}
}
sub extrait_differences #sort les lignes nouvelles (ancien, nouveau)
{
my ($tab1,$tab2) = @_;
my($objet);
my (%vu_dans_ancien, @que_dans_nouveau);
@vu_dans_ancien{@$tab1} = ();
foreach $objet (@$tab2) {
push (@que_dans_nouveau, $objet) unless exists $vu_dans_ancien{$objet};
}
return \@que_dans_nouveau;
}
sub tronque_geneanet #tronque le fichier html en lignes du tableau html
{
my ($tab)=@_;
my ($i , $i_debut , $i_fin);
my @nouveau_tableau;
$i_debut = -1;
for($i = 0; $i < @$tab ; $i++) {
if ($$tab[$i] =~ /<TABLE/){# $tab->[$i] = ....
$i_debut=$i;
last;
}
}
if ($i_debut != -1) {
for($i = $i_debut; $i < @$tab ; $i++) {
if ($$tab[$i] =~ /<\/TABLE>/ ){
$i_fin=$i;
last;
}
}
@nouveau_tableau= @$tab[$i_debut+1..$i_fin-1];
return \@nouveau_tableau;
}
else {
@nouveau_tableau=("");
return \@nouveau_tableau;
};
}
sub elimine_balise_html_geneanet#elimine les balises tr et td du tableau html (tableau)
{
my($tab)=@_;
my $ligne;
foreach $ligne (@$tab) {
$ligne =~ s/<TR>(.*)<\/TR>/$1/;
$ligne =~ s/<TD>(.*?)<\/TD>/$1 /g;
$ligne =~ s/<A HREF="(.*)">(.*)<\/A>/$2 http:\/\/www.geneanet.com$1/;
}
if (@$tab == 100) {
$ligne = "Cette liste contient 100 lignes, faire une recherche plus fine\n";
push (@$tab , $ligne);
}
return $tab;
}
sub tronque_mormon # tronque le fichier html en lignes du tableau html
{
my ($tab)=@_;
my ($i , $i_debut , $i_fin);
my @nouveau_tableau;
$i_debut = -1;
for($i = 0; $i < @$tab ; $i++) {
if ($$tab[$i] =~ /<td valign=top><strong>\d+\.<\/strong>/) {
$i_debut=$i;
last;
}
}
if ($i_debut != -1) {
for($i = $i_debut; $i < @$tab ; $i++) {
if ($$tab[$i] =~ /<\/table>/ ){
$i_fin=$i;
last;
}
}
@nouveau_tableau= @$tab[$i_debut..$i_fin-1];
return \@nouveau_tableau;
}
else {
@nouveau_tableau=("");
return \@nouveau_tableau;
};
}
sub elimine_balise_html_mormon # elimine les balises html (tableau)
{
my($tab)=@_;
my ($ligne, $ligne_intermediaire, @nouveau_tableau, $i);
for ( $i=0 ; $i < @$tab ; $i++) {
if ($$tab[$i] =~ /<td valign=top><strong>\d+\.<\/strong>/) {
chop ($$tab[$i]);
$ligne_intermediaire = $$tab[$i];
$i++;
while ($$tab[$i] !~ /<td valign=top align=left><\/td><\/tr>/) {
chop ($$tab[$i]);
$ligne_intermediaire = $ligne_intermediaire . $$tab[$i];
$i++;
}
if ($ligne_intermediaire =~ /Web Sites/) {
$ligne_intermediaire =~ s/^(.*?)<a href='(.*?)'>(.*?)<\/a>(.*?)<small>(.*?)<\/small><br>(.*?)<br>(.*?)$/$3 $5 $6 $2/;
}
else {
$ligne_intermediaire =~ s/^(.*?)<a href='(.*?)'>(.*?)<\/a>(.*?)<small>(.*?)<\/small><br>(.*?)<br>(.*?)$/$3 $5 $6 http:\/\/www.familysearch.com\/Search\/$2/;
}
$ligne_intermediaire = $ligne_intermediaire ."\n";
push(@nouveau_tableau, $ligne_intermediaire);
}
}
return \@nouveau_tableau;
}
sub recherche_page_web # recherche le source web (remote,repertoire,port)
{
my ($remote, $dir, $port, $iaddr, $paddr, $proto, $ligne);
my @tableau;
$remote = shift || 'localhost';
$dir = shift || "/";
$port = shift || 80;
if ($port =~ /\D/) {
$port = 80;
}
$iaddr = inet_aton ($remote) or die "Hôte absent : $remote";
$paddr = sockaddr_in ($port, $iaddr);
$proto = getprotobyname ('tcp');
socket (SOCK, PF_INET, SOCK_STREAM, $proto) or die "Socket : $!";
connect (SOCK, $paddr) or die "Connect : $!";
print SOCK "GET $dir HTTP/1.0\r\n\r\n";
flush SOCK;
@tableau = <SOCK>;
close (SOCK);
return \@tableau;
}
sub recherche_geneanet_simple # recherche sur geneanet (patro) plus utilisee
{
my ($patro, $remote, $dir, @tableau);
$patro = shift ;
$remote ="www.geneanet.com";
$dir = "/cgi-bin/search.pl?name=$patro&language=fr&limit=100";
print "Contacte www.geneanet.com pour recherche sur patronyme $patro.\n";
@tableau = @{&recherche_page_web($remote, $dir)};
return \@tableau;
}
sub recherche_geneanet # recherche multicritere geneanet (patro,etpatati)
{
my ($patro, $debut, $fin, $lieu, $sub, $reg, $pays, $source);
my ($remote, $dir, @tableau);
$patro = shift ;
$debut = shift;
$fin = shift;
$lieu = shift;
$sub = shift;
$reg = shift;
$pays = shift;
$source = shift;
$remote ="www.geneanet.com";
$dir = "/cgi-bin/search.pl?name=$patro&begin=$debut&end=$fin&place=$lieu&subregion=$sub®ion=$reg&country=$pays&sourcename=$source&language=fr&limit=100";
print "Contacte www.geneanet.com pour recherche sur patronyme $patro.\n";
@tableau = @{&recherche_page_web($remote, $dir)};
return \@tableau;
}
sub recherche_mormon_simple #recherche sur mormon (patro) plus utilisee
{
my ($patro, $remote, $dir, @tableau);
$patro = shift ;
$remote ="www.familysearch.com";
$dir = "/Search/ancestorsearchresults.asp?last_name=$patro";
print "Contacte www.familysearch.com pour recherche sur patronyme $patro.\n";
@tableau = @{&recherche_page_web($remote, $dir)};
return \@tableau;
}
sub recherche_mormon #recherche sur mormon (patro,pays)
{
my ($patro, $pays, $remote, $dir, @tableau);
$patro = shift ;
$pays = shift;
$remote ="www.familysearch.com";
$dir = "/Search/ancestorsearchresults.asp?last_name=$patro&juris1=$pays";
print "Contacte www.familysearch.com pour recherche sur patronyme $patro.\n";
@tableau = @{&recherche_page_web($remote, $dir)};
return \@tableau;
}