10 my(%DB,$debugmatch,$D,$key,$owner,$ref,$filename,$doimport,$import_xlate);
22 s/\(([0-9]{4}) publ. [0-9]{4}\)/($1)/g;
23 while (/\(([0-9]{4})(-[0-9]+)?\)/) {
24 return $1 if ($1>=1700 && $1<=2010);
35 print("-$file----------------$'--------------\n");
36 warn "Unable to match file \"".getcwd()."/$file\".";
43 if (!open(FI,$file)) {
44 warn("Unable to open file \"$file\" in dir \"".getcwd()."\": $!");
51 my($bigword)='[^<]*(?:<IT>)?[^<]*(?:<RO>)?[^<]*(?:<1000 m)?[^<]*';
54 my($any)='[\x00-\xFF]*';
55 my($ipniservletword)="<a href=\"\\./IpniServlet\\?id=($id)&query_type=by_id\">($word)</a>";
56 my($idquoted)=$id; $idquoted=~s%\W%\\$&%g;
57 my($ipniservletwordthree)=$ipniservletword; $ipniservletwordthree=~s%\($idquoted\)%((?:$idone){3})$&%os or die;
58 my($attrpat)="<p>nomenclatural synonym(\\(Main Record\\))?:$ipniservletword</p>|<p>basionym(\\(\\d+\\))?:$ipniservletword</p>|<p>basionym:($word)|<p>replaced synonym:$ipniservletword</p>|<p>replaced synonym:($word)|<p>Is a replaced synonym of:$ipniservletword</p>|<p>Is a basionym of:$ipniservletword</p>|<p>later publication of(\\(\\d+\\))?:$ipniservletword</p>|<p>Is a later publication of of:$ipniservletword</p>";
63 <title>IPNI Query Results</title>
65 <body bgcolor="#ffffff" text="#000000" link="#006666" vlink="#008080" alink="#008080">
66 <HR><b><i>Orchidaceae</i> ($word)</b> ($word) <br>
67 (?:<a href="\./PublicationServlet\?id=($id)&query_type=by_id"> ($word)</a> ($word)|($bigword(?:<br>\n$word)*))?(<p>($bigword)?</p><p>($word)?</p>(?:
68 remarks: .*)?(<HR><h4>Type</h4>)?(<table $any</table>)?(?:
69 <h4>Linked Records</h2>
70 ((?:$attrpat)*))?(<br>
72 <h4>Original Data</h2>
73 (?:basionym: ($word)<br>
74 )?(?:hybrid parentage: ($word)<br>
75 )?(?:replaced synonym: ($word)<br>
76 )?(?:distribution: ($word)<br>
77 )?(?:Notes: ($word))?)?)(?:<p><a href="\./query_ipni.html">Back to Search Page</a></p>
85 $rec{"Publ. Author"}=$2;
87 $publ.="$4 $5" if defined($4) && defined($5);
88 $publ.=$6 if defined $6;
89 $rec{"html"}=$7 if defined $7;
91 # catch-array destroyed here!
93 $rec{"Publication"}=$publ if $publ ne "";
94 ($rec{"id"}=$file)=~s#^($id)\.html$#$1#os or failed($file);
95 $rec{"html"}=~s#$ipniservletwordthree#<a href="$1/$1$2.html">$3</a>#osg if $import_xlate && exists $rec{"html"};
97 my $score=0; # -: upper, +: lower
98 while (defined($attrsbody) && $attrsbody=~s%^(?:$attrpat)%%os) {
99 # nomenclatural synonym: id=$2
101 # replaced synonym: id=$8
102 # Is a replaced synonym: id=$11
103 # Is a basionym: id=$13
104 # later publication: id=$16
105 # Is a later publication: id=$18
106 my(@refs)=($2,$5,$8,$11,$13,$16,$18);
108 push(@{$rec{"refs"}},$_) if defined ($_=shift @refs);
110 $score+=+10 if defined $5; # basionym: id=$5
111 $score+=-10 if defined $13; # Is a basionym: id=$13
112 $score+=- 4 if defined $16; # later publication: id=$16
113 $score+=+ 4 if defined $18; # Is a later publication: id=$18
115 $score+=+9 if $rec{"Publ. Author"}=~/^\s*\(/;
116 $rec{"score"}=$score;
121 $DB{$rec{"id"}}=\%rec;
131 warn("Unable to change to dir \"$dir\" from dir \"$old\": $!");
134 opendir(DIR,".") or die("Cannot open . in \"".getcwd()."\": $!");
135 foreach (sort readdir(DIR)) {
136 process_entry($_) if ($_!~/^\./);
139 chdir($old) or warn("Unable to retreat to dir \"$old\": $!");
146 process_dir ($entry) if -d $entry;
147 process_file($entry) if -f $entry;
151 { process_entry($_); }
153 for my $id (keys %DB) {
156 for $refid (@{$DB{$id}{"refs"}}) {
157 if (!exists $DB{$refid}) {
158 print "Undefined ref id \"$refid\" from id \"$id\"\n" if $D>=1;
161 next if $id eq $refid; # self-ref
162 # push(@refs,$DB{$refid});
165 $DB{$id}{"refs"}=\@refs;
168 print Data::Dumper->Dump([\%DB],["%DB"]) if $D>=2;
170 my %OWNS=map { $_=>$DB{$_}{"refs"}; } keys(%DB);
173 for my $id (keys %DB) {
174 $NAMES{$DB{$id}{"name"}}=[] if !exists $NAMES{$DB{$id}{"name"}};
175 push @{$NAMES{$DB{$id}{"name"}}},$id;
178 for my $id (keys %DB) {
179 next if !exists $OWNS{$id};
180 my @queue=($id,@{$OWNS{$id}});
182 while (my $refid=shift @queue) {
183 if (exists $NAMES{$DB{$refid}{"name"}}) {
184 push(@queue,@{$NAMES{$DB{$refid}{"name"}}});
185 delete $NAMES{$DB{$refid}{"name"}};
187 next if $refid eq $id;
188 next if !exists $OWNS{$refid};
189 push @queue,@{$OWNS{$refid}};
190 delete $OWNS{$refid};
191 print "processed connect id=$id <- refid=$refid\n" if $D>=1;
192 push @{$OWNS{$id}},$refid;
196 print Data::Dumper->Dump([\%OWNS],["%OWNS"]) if $D>=2;
198 foreach $key (keys %OWNS) {
199 my(@keys)=@{$OWNS{$key}};
202 # @keys=sort { $DB{$a}{"score"} <=> $DB{$b}{"score"}
203 # || extract_year($DB{$b}{"Publication"}) <=> extract_year($DB{$a}{"Publication"}); } @keys;
204 @keys=sort { $DB{$a}{"name"} cmp $DB{$b}{"name"}; } @keys;
205 my($pkey)=shift(@keys);
209 my($db_driver,$db_host,$db_user,$db_pwd,$DB_PWD,$db_name,$db);
215 #$DB_PWD=$ENV{"HOME"}."/priv/mysql.${db_user}.pwd";
218 $tb_tree="kewensis_tree";
220 $db=DBI->connect("DBI:$db_driver:database=$db_name;host=$db_host",$db_user,$db_pwd) or die "Database open fail: $!";
226 $db->do($cmd) or die("SQL command \"$cmd\" failed: $!");
229 eval { &db_do("drop table $tb_tree") };
231 &db_do("create table $tb_tree ("
232 ."id char(10) not null,"
233 ."family_id char(10) not null,"
234 ."family_order int not null,"
235 ."name varchar(100) not null,"
236 ."PublAuthor text null,"
237 ."Publication text null,"
241 &db_do("alter table $tb_tree add unique (id)");
242 &db_do("alter table $tb_tree add index (name)");
243 &db_do("alter table $tb_tree add unique (family_id,family_order)");
245 my $insert_tb_tree=$db->prepare("insert into $tb_tree (id,family_id,family_order,name,PublAuthor,Publication,html) values (?,?,?,?,?,?,?)")
246 or die "Prepare fail: $!";
248 foreach $owner (sort { $DB{$b}{"name"} cmp $DB{$a}{"name"}; } keys %OWNS) {
249 my @family=@{$OWNS{$owner}};
250 unshift(@family,$owner);
251 my $family_id=$DB{$owner}{"id"};
252 for my $family_order (0..$#family) {
253 my $id=$family[$family_order];
254 print "insert:$id,".$DB{$id}{"name"}."\n" if $D>=2;
255 $insert_tb_tree->execute($id,$family_id,$family_order,
256 $DB{$id}{"name"},$DB{$id}{"Publ. Author"},$DB{$id}{"Publication"},$DB{$id}{"html"}
257 ) or die "SQL insert failure: $!";