IPNI Query Results

X-Git-Url: https://git.jankratochvil.net/?p=kewensis.git;a=blobdiff_plain;f=kewensis-collect.pl;h=8fd1d541cdf6815b65c07b5a8b23847254926b80;hp=f71d434fd081e9eb486011795d39bdc8f2674913;hb=e332ad4bfdbfe8d2764271bdb52e15cb0d8c5c18;hpb=525245c5f9c7f716b224a04a62fd9b4a3b501bb8 diff --git a/kewensis-collect.pl b/kewensis-collect.pl index f71d434..8fd1d54 100755 --- a/kewensis-collect.pl +++ b/kewensis-collect.pl @@ -1,125 +1,240 @@ -#! /usr/bin/perl -w +#! /usr/bin/perl -use vars qw/%DB %OWNS %PARENT %CURR $last_field $debugmatch $debugparse $key $owner $parent $ref/; +use strict; +use warnings; + +use Cwd; +use Data::Dumper; +use DBI; + +my(%DB,%OWNS,$debugmatch,$D,$key,$owner,$ref,$filename,$doimport,$import_xlate); %DB=(); -%CURR=(); -$debugparse=0; -$printdupl=0; +$D=0; $debugmatch=0; +$doimport=1; +$import_xlate=1; -sub name_to_key +sub extract_year { -my( $r )=@_; - - $r=~tr/A-Z/a-z/; - $r=~tr/a-z0-9//cd; - return $r; + ($_)=@_; + if (defined($_)) { + s/$([0-9]{4}) publ. [0-9]{4}$/($1)/g; + while (/$([0-9]{4})(-[0-9]+)?$/) { + return $1 if ($1>=1700 && $1<=2010); + $_=$'; + } + } + return -1; } -sub rec_to_name +sub failed { -my( %rec )=@_; -my( @list )=("Rank","Infrafam.","Genus","Species"); -my( $item,$r ); - - $r=""; - while ($item=shift @list) - { $r.=" ".$rec{$item} if exists $rec{$item}; } - $r=~s/^ //; - return $r; +my($file)=@_; + + print("-$file----------------$'--------------\n"); + warn "Unable to match file \"".getcwd()."/$file\"."; } -sub flush_CURR +sub process_file { -my( $key ); - - $key=&name_to_key(&rec_to_name(%CURR)); - return if (!defined $key); - if (exists $DB{$key}) - { print STDERR "Key \"$key\" is duplicated!\n" if $printdupl; } - else { - print STDERR "ADDKEY: $key\n" if $debugparse; - %{$DB{$key}}=%CURR; - } - %CURR=(); -} +my($file)=@_; -while (<>) { - tr/\r\n//d; - if (/^ *\304\301\304/) { - &flush_CURR(); - print STDERR "---\n" if $debugparse; + if (!open(FI,$file)) { + warn("Unable to open file \"$file\" in dir \"".getcwd()."\": $!"); + return; } - elsif (/^([^³]*[^ ]) *³ *(.*)$/) { - print STDERR "FIELD: $1, VALUE: $2\n" if $debugparse; - $last_field=$1; - $CURR{$1}=$2; + undef $/; + my($fi)=; + close(FI); + my($word)='[^<]*'; + my($bigword)='[^<]*(?:)?[^<]*(?:)?[^<]*(?:<1000 m)?[^<]*'; + my($idone)='[-\d]'; + my($id)="$idone+"; + my($any)='[\x00-\xFF]*'; + my($ipniservletword)="($word)"; + my($idquoted)=$id; $idquoted=~s%\W%\\$&%g; + my($ipniservletwordthree)=$ipniservletword; $ipniservletwordthree=~s%$$idquoted$%((?:$idone){3})$&%os or die; + my($attrpat)="

nomenclatural synonym(\$Main Record\$)?:$ipniservletword

basionym(\$\\d+\$)?:$ipniservletword

basionym:($word)|

replaced synonym:$ipniservletword

replaced synonym:($word)|

Is a replaced synonym of:$ipniservletword

Is a basionym of:$ipniservletword

later publication of(\$\\d+\$)?:$ipniservletword

Is a later publication of of:$ipniservletword

"; + $|=1; + ""=~/^/; + if ($fi!~m%^ + +IPNI Query Results + + +

Orchidaceae ($word) ($word)
+((?: ($word) ($word)|$bigword(?:
\n$word)*)?

($bigword)?

($word)?

(?: +remarks: .*)?(

Type

)?()?(?: +

Linked Records

+((?:$attrpat)*))?(
+ +

Original Data

+(?:basionym: ($word)
+)?(?:hybrid parentage: ($word)
+)?(?:replaced synonym: ($word)
+)?(?:distribution: ($word)
+)?(?:Notes: ($word))?)?)(?:

Back to Search Page

+ +)$%os) { + failed($file); + return; } - elsif (/^ *³ *(.*)$/) { - print STDERR "APPEND: $1\n" if $debugparse; - $CURR{$last_field}.=" ".$1; + my(%rec); + $rec{"name"}=$1; + $rec{"Publ. Author"}=$2; + $rec{"Publication"}="$5 $6" if defined($5) && defined($6); + $rec{"html"}=$3 if defined $3; + my($attrsbody)=$11; + ($rec{"id"}=$file)=~s#^($id)\.html$#$1#os or failed($file); + $rec{"html"}=~s#$ipniservletwordthree#$3#osg if $import_xlate && exists $rec{"html"}; + my $score=0; # -: upper, +: lower + while (defined($attrsbody) && $attrsbody=~s%^(?:$attrpat)%%os) { + # nomenclatural synonym: id=$2 + # basionym: id=$5 + # replaced synonym: id=$8 + # Is a replaced synonym: id=$11 + # Is a basionym: id=$13 + # later publication: id=$16 + # Is a later publication: id=$18 + my(@refs)=($2,$5,$8,$11,$13,$16,$18); + $rec{"refs"}=[]; + while (@refs) { + push(@{$rec{"refs"}},$_) if defined ($_=shift @refs); + } + $score+=-10 if defined $5; # basionym: id=$5 + $score+=+10 if defined $13; # Is a basionym: id=$13 + $score+=+10 if defined $16; # later publication: id=$16 + $score+=-10 if defined $18; # Is a later publication: id=$18 } - else { - print STDERR "DISCARD: $_\n" if $debugparse; + $rec{"score"}=$score; + if ($attrsbody) { + failed($file); + return; } - } -&flush_CURR(); -undef %CURR; + $DB{$rec{"id"}}=\%rec; +} -%OWNS=(); -%PARENT=(); -sub try_reparent +sub process_dir { -my( $reparent,$refkey ); +my( $dir )=@_; +my( $old )=getcwd(); - $refkey=&name_to_key($ref); - return 0 if ($refkey eq ""); - return 0 if ($parent eq $refkey); - return 0 if !exists $DB{$refkey}; - print STDERR "try_reparent: SUCCESS: key=\"$key\", refkey=\"$refkey\"\n" if $debugmatch; - - foreach $reparent (@{$OWNS{$parent}}) { - $PARENT{$reparent}=$refkey; + if (!chdir($dir)) { + warn("Unable to change to dir \"$dir\" from dir \"$old\": $!"); + return; + } + opendir(DIR,".") or die("Cannot open . in \"".getcwd()."\": $!"); + foreach (sort readdir(DIR)) { + process_entry($_) if ($_!~/^\./); } - @{$OWNS{$parent}}=() if (!defined $OWNS{$parent}); - @{$OWNS{$refkey}}=() if (!defined $OWNS{$refkey}); - @{$OWNS{$refkey}}=(@{$OWNS{$refkey}},$parent,@{$OWNS{$parent}}); - delete $OWNS{$parent}; + closedir(DIR); + chdir($old) or warn("Unable to retreat to dir \"$old\": $!"); +} + +sub process_entry +{ +my( $entry )=@_; - return 1; + process_dir ($entry) if -d $entry; + process_file($entry) if -f $entry; } -MATCH: foreach $key (keys %DB) { - $parent=$PARENT{$key}; - $parent=$key if (!defined $parent); - $ref=$DB{$key}{"Notes"}; - next MATCH if (!defined $ref); - $ref=~tr/()//d; - $ref=~s/^=//; - $ref=~s/^O\. *//i; - $ref=~s/^Orchidaceae *//i; - $ref=~s/\..*$//; - next MATCH if &try_reparent(); - $ref=$DB{$key}{"Rank"}." $ref" if exists $DB{$key}{"Rank"}; - next MATCH if &try_reparent(); - $ref=$DB{$key}{"Genus"}." $ref" if exists $DB{$key}{"Genus"}; - next MATCH if &try_reparent(); +%OWNS=(); + +foreach (@ARGV) + { process_entry($_); } + +my($id); +for $id (keys %DB) { + my($refid); + my(@refs); + for $refid (@{$DB{$id}{"refs"}}) { + if (!exists $DB{$refid}) { + warn "Undefined ref id \"$refid\" from id \"$id\"" if $D; + next; + } + next if $id eq $refid; # self-ref +# push(@refs,$DB{$refid}); + push(@refs,$refid); + } + $DB{$id}{"refs"}=\@refs; + } + +print Data::Dumper->Dump([\%DB],["%DB"]) if $D; + +%OWNS=map { $_=>[] } keys(%DB); + +for $id (keys %OWNS) { + next if !exists $OWNS{$id}; + for my $refid (@{$DB{$id}{"refs"}}) { + next if !exists $OWNS{$refid}; + push(@{$OWNS{$id}},$refid,@{$OWNS{$refid}}); + delete $OWNS{$refid}; + print "connected: id=$id,refid=$refid\n" if $D; + } + } + +print Data::Dumper->Dump([\%OWNS],["%OWNS"]) if $D; + +foreach $key (keys %OWNS) { + my(@keys)=@{$OWNS{$key}}; + delete($OWNS{$key}); + unshift(@keys,$key); + @keys=sort { $DB{$a}{"score"} <=> $DB{$b}{"score"} + || extract_year($DB{$b}{"Publication"}) <=> extract_year($DB{$a}{"Publication"}); } @keys; + my($pkey)=shift(@keys); + $OWNS{$pkey}=\@keys; } -undef %PARENT; -foreach $owner (keys %OWNS) { -my( $child ); +my($db_driver,$db_host,$db_user,$db_pwd,$DB_PWD,$db_name,$db); +my($tb_tree); + +$db_driver="mysql"; +$db_host=""; +#$db_user="short"; +#$DB_PWD=$ENV{"HOME"}."/priv/mysql.${db_user}.pwd"; +$db_name="short"; +$tb_tree="kewensis_tree"; + +$db=DBI->connect("DBI:$db_driver:database=$db_name;host=$db_host",$db_user,$db_pwd) or die "Database open fail: $!"; + +sub db_do +{ +my( $cmd )=@_; + + $db->do($cmd) or die("SQL command \"$cmd\" failed: $!"); +} - if ($debugmatch) { - print STDERR "($owner):"; - foreach $child (@{$OWNS{$owner}}) - { print STDERR " ($child)"; } - print STDERR "\n"; +eval { &db_do("drop table $tb_tree") }; + +&db_do("create table $tb_tree (" + ."id char(10) not null," + ."family_id char(10) not null," + ."family_order int not null," + ."name varchar(100) not null," + ."Publication text null," + ."Notes text null," + ."html text null" + .")"); + +&db_do("alter table $tb_tree add unique (id)"); +&db_do("alter table $tb_tree add index (name)"); +&db_do("alter table $tb_tree add unique (family_id,family_order)"); + +my $insert_tb_tree=$db->prepare("insert into $tb_tree (id,family_id,family_order,name,Publication,Notes,html) values (?,?,?,?,?,?,?)") + or die "Prepare fail: $!"; + +foreach $owner (sort { $DB{$b}{"name"} cmp $DB{$a}{"name"}; } keys %OWNS) { + my @family=@{$OWNS{$owner}}; + unshift(@family,$owner); + my $family_id=$DB{$owner}{"id"}; + for my $family_order (0..$#family) { + my $id=$family[$family_order]; + print "insert:$id,".$DB{$id}{"name"}."\n" if $D; + $insert_tb_tree->execute($id,$family_id,$family_order, + $DB{$id}{"name"},$DB{$id}{"Publication"},$DB{$id}{"Notes"},$DB{$id}{"html"} + ) or die "SQL insert failure: $!"; } - print "(".&rec_to_name(%{$DB{$owner}}).")"; - foreach $child (@{$OWNS{$owner}}) - { print " (".&rec_to_name(%{$DB{$child}}).")"; } - print "\n"; }