From: short <>
Date: Sun, 7 Oct 2001 11:32:41 +0000 (+0000)
Subject: Table version, no inside-equiv sorting implemented yet
X-Git-Url: https://git.jankratochvil.net/?p=kewensis.git;a=commitdiff_plain;h=71cc8d6abe1ba07d13321c5a9491f0966babfe86
Table version, no inside-equiv sorting implemented yet
---
diff --git a/kewensis-collect.pl b/kewensis-collect.pl
index f71d434..6190153 100755
--- a/kewensis-collect.pl
+++ b/kewensis-collect.pl
@@ -1,7 +1,11 @@
-#! /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 vars qw/%DB %OWNS %PARENT %CURR $last_field $debugmatch $debugparse $key $owner $parent $ref $note_rest $printdupl $maxsize $fileno $fileid $filename/;
+
+$maxsize=0x20000;
%DB=();
%CURR=();
$debugparse=0;
@@ -20,7 +24,7 @@ my( $r )=@_;
sub rec_to_name
{
my( %rec )=@_;
-my( @list )=("Rank","Infrafam.","Genus","Species");
+my( @list )=("Genus","Species");
my( $item,$r );
$r="";
@@ -30,12 +34,39 @@ my( $item,$r );
return $r;
}
+sub htmlquote
+{
+($_)=@_;
+
+ s/&/&/g;
+ s//>/g;
+ s/\n/&nl;/g;
+ s/"/"/g;
+ return $_;
+}
+
+sub print_rec
+{
+my( $preinsert,$postinsert,%rec )=@_;
+
+ return if (!%rec);
+ print OUT "\n";
+ print OUT "| ".$preinsert.&rec_to_name(%rec).$postinsert." |
|---|
\n";
+ delete $rec{"Genus"};
+ delete $rec{"Species"};
+ foreach $key (sort keys %rec)
+ { print OUT "| ".&htmlquote($key).": | ".&htmlquote($rec{$key})." |
\n"; }
+ print OUT "
\n";
+}
+
sub flush_CURR
{
my( $key );
$key=&name_to_key(&rec_to_name(%CURR));
- return if (!defined $key);
+ return if (!$key);
+ delete $CURR{"Family"};
if (exists $DB{$key})
{ print STDERR "Key \"$key\" is duplicated!\n" if $printdupl; }
else {
@@ -43,8 +74,11 @@ my( $key );
%{$DB{$key}}=%CURR;
}
%CURR=();
+ @{$OWNS{$key}}=();
}
+%OWNS=();
+
while (<>) {
tr/\r\n//d;
if (/^ *\304\301\304/) {
@@ -67,7 +101,6 @@ while (<>) {
&flush_CURR();
undef %CURR;
-%OWNS=();
%PARENT=();
sub try_reparent
@@ -79,6 +112,10 @@ my( $reparent,$refkey );
return 0 if ($parent eq $refkey);
return 0 if !exists $DB{$refkey};
print STDERR "try_reparent: SUCCESS: key=\"$key\", refkey=\"$refkey\"\n" if $debugmatch;
+ if ($note_rest)
+ { $DB{$key}{"Notes"}=$note_rest; }
+ else
+ { delete $DB{$key}{"Notes"}; }
foreach $reparent (@{$OWNS{$parent}}) {
$PARENT{$reparent}=$refkey;
@@ -100,7 +137,8 @@ MATCH: foreach $key (keys %DB) {
$ref=~s/^=//;
$ref=~s/^O\. *//i;
$ref=~s/^Orchidaceae *//i;
- $ref=~s/\..*$//;
+ $ref=~s/\. *(.*)$//;
+ $note_rest=$1;
next MATCH if &try_reparent();
$ref=$DB{$key}{"Rank"}." $ref" if exists $DB{$key}{"Rank"};
next MATCH if &try_reparent();
@@ -109,17 +147,88 @@ MATCH: foreach $key (keys %DB) {
}
undef %PARENT;
-foreach $owner (keys %OWNS) {
+sub print_header
+{
+my($header)=@_;
+
+ print OUT
+"
+
+
+Kewensis $header
+
+
+\n";
+}
+
+$fileno=-1;
+
+sub OUT_flush
+{
+ print OUT "\n";
+ close(OUT);
+}
+
+my( $filename );
+foreach $owner (sort keys %OWNS) {
my( $child );
+ if ($fileno<0 || tell(OUT)>=$maxsize) {
+ &OUT_flush() if ($fileno>=0);
+ $fileid=sprintf("%04d",++$fileno);
+ $filename="kew-$fileid.html";
+ open(OUT,">$filename") or die "Cannot open \"$filename\": $!";
+ &print_header("chunk $fileid");
+ }
+
if ($debugmatch) {
print STDERR "($owner):";
foreach $child (@{$OWNS{$owner}})
{ print STDERR " ($child)"; }
print STDERR "\n";
}
- print "(".&rec_to_name(%{$DB{$owner}}).")";
- foreach $child (@{$OWNS{$owner}})
- { print " (".&rec_to_name(%{$DB{$child}}).")"; }
- print "\n";
+ &print_rec("","",%{$DB{$owner}});
+ if (@{$OWNS{$owner}}) {
+ print OUT "\n";
+ foreach $child (reverse @{$OWNS{$owner}})
+ { &print_rec("","",%{$DB{$child}}); }
+ print OUT "
\n";
+ }
+ print OUT "\n";
+ $DB{$owner}{"_filename"}=$filename;
+ }
+&OUT_flush();
+open(OUT,">kew-index.html") or die "Cannot open \"kew-index.html\": $!";
+&print_header("Index");
+
+sub print_href
+{
+my($owner)=@_;
+my(%rec)=%{$DB{$owner}};
+
+ print OUT &htmlquote(&rec_to_name(%rec));
+}
+
+foreach $owner (sort keys %OWNS) {
+my( $child );
+
+ print OUT "";
+ &print_href($owner);
+ print OUT "
";
+ if (@{$OWNS{$owner}}) {
+ print OUT "\n";
+ foreach $child (reverse @{$OWNS{$owner}}) {
+ print OUT "- ";
+ &print_href($child);
+ print OUT "
\n";
+ }
+ print OUT "
";
+ }
+ print OUT "\n";
}
+OUT_flush();