Table version, no inside-equiv sorting implemented yet

diff --git a/kewensis-collect.pl b/kewensis-collect.pl
index f71d434..6190153 100755 (executable)
--- 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;
 %DB=();
 %CURR=();
 $debugparse=0;


@@ -20,7 +24,7 @@ my( $r )=@_;
 sub rec_to_name
 {
 my( %rec )=@_;
 sub rec_to_name
 {
 my( %rec )=@_;

-my( @list )=("Rank","Infrafam.","Genus","Species");
+my( @list )=("Genus","Species");

 my( $item,$r );
 
        $r="";
 my( $item,$r );
 
        $r="";


@@ -30,12 +34,39 @@ my( $item,$r );
        return $r;
 }
 
        return $r;
 }
 

+sub htmlquote
+{
+($_)=@_;
+
+       s/&/&/g;
+       s/</&lt;/g;
+       s/>/&gt;/g;
+       s/\n/&nl;/g;
+       s/"/&quot;/g;
+       return $_;
+}
+
+sub print_rec
+{
+my( $preinsert,$postinsert,%rec )=@_;
+
+       return if (!%rec);
+       print OUT "<table border=\"1\" frame=\"border\" rules=\"none\"><col width=\"0*\" /><col width=\"1*\" />\n";
+       print OUT "<tr><th colspan=\"2\">".$preinsert.&rec_to_name(%rec).$postinsert."</th></tr>\n";
+       delete $rec{"Genus"};
+       delete $rec{"Species"};
+       foreach $key (sort keys %rec)
+               { print OUT "<tr><td class=\"left\">".&htmlquote($key).":</td><td>".&htmlquote($rec{$key})."</td></tr>\n"; }
+       print OUT "</table>\n";
+}
+

 sub flush_CURR
 {
 my( $key );
 
        $key=&name_to_key(&rec_to_name(%CURR));
 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 {
        if (exists $DB{$key})
                { print STDERR "Key \"$key\" is duplicated!\n" if $printdupl; }
        else {


@@ -43,8 +74,11 @@ my( $key );
                %{$DB{$key}}=%CURR;
                }
        %CURR=();
                %{$DB{$key}}=%CURR;
                }
        %CURR=();

+       @{$OWNS{$key}}=();

 }
 
 }
 

+%OWNS=();
+

 while (<>) {
        tr/\r\n//d;
        if (/^ *\304\301\304/) {
 while (<>) {
        tr/\r\n//d;
        if (/^ *\304\301\304/) {


@@ -67,7 +101,6 @@ while (<>) {
 &flush_CURR();
 undef %CURR;
 
 &flush_CURR();
 undef %CURR;
 

-%OWNS=();

 %PARENT=();
 
 sub try_reparent
 %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;
        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;
 
        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/^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();
        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;
 
        }
 undef %PARENT;
 

-foreach $owner (keys %OWNS) {
+sub print_header
+{
+my($header)=@_;
+
+       print OUT
+"<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
+<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
+<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">
+<head><title>Kewensis $header</title>
+<style type=\"text/css\"><!--
+table            { border: ridge; }
+blockquote table { border: groove; }
+td      { border: none; }
+td.left { white-space: nowrap; font-style: italic; }
+--></style>
+</head><body>
+\n";
+}
+
+$fileno=-1;
+
+sub OUT_flush
+{
+       print OUT "</body></html>\n";
+       close(OUT);
+}
+
+my( $filename );
+foreach $owner (sort keys %OWNS) {

 my( $child );
 
 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";
                }
        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("<a name=\"".&htmlquote($owner)."\">","</a>",%{$DB{$owner}});
+       if (@{$OWNS{$owner}}) {
+               print OUT "<blockquote>\n";
+               foreach $child (reverse @{$OWNS{$owner}})
+                       { &print_rec("","",%{$DB{$child}}); }
+               print OUT "</blockquote>\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 "<p><a href=\"".$DB{$owner}{"_filename"}."#$owner\">";
+       &print_href($owner);
+       print OUT "</a></p>";
+       if (@{$OWNS{$owner}}) {
+               print OUT "<ul>\n";
+               foreach $child (reverse @{$OWNS{$owner}}) {
+                       print OUT "<li>";
+                       &print_href($child);
+                       print OUT "</li>\n";
+                       }
+               print OUT "</ul>";
+               }
+       print OUT "\n";

        }
        }

+OUT_flush();