Inside-equiv sorting implemented

Table converted to indented text output (upon request)

diff --git a/kewensis-collect.pl b/kewensis-collect.pl
index 6190153..c6f399b 100755 (executable)
--- a/kewensis-collect.pl
+++ b/kewensis-collect.pl
@@ -5,7 +5,7 @@ use warnings;
 
 use vars qw/%DB %OWNS %PARENT %CURR $last_field $debugmatch $debugparse $key $owner $parent $ref $note_rest $printdupl $maxsize $fileno $fileid $filename/;
 
 
 use vars qw/%DB %OWNS %PARENT %CURR $last_field $debugmatch $debugparse $key $owner $parent $ref $note_rest $printdupl $maxsize $fileno $fileid $filename/;
 

-$maxsize=0x20000;
+$maxsize=0x40000;

 %DB=();
 %CURR=();
 $debugparse=0;
 %DB=();
 %CURR=();
 $debugparse=0;


@@ -46,18 +46,29 @@ sub htmlquote
        return $_;
 }
 
        return $_;
 }
 

-sub print_rec
+sub format_record

 {
 my( $preinsert,$postinsert,%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";
+       my($r)="<p><span class=\"name\">".$preinsert.&htmlquote(&rec_to_name(%rec)).$postinsert."</span>";
+       $r.="\n".htmlquote($rec{"Publ. Author"}) if (exists($rec{"Publ. Author"}));
+       $r.="<br />\n".htmlquote($rec{"Publication"}) if (exists($rec{"Publication"}));
+       $r.="<br />\n".htmlquote($rec{"Notes"}) if (exists($rec{"Notes"}));
+       $r.="</p>\n";
+       return($r);
+}
+
+sub extract_year
+{
+       ($_)=@_;
+       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 flush_CURR
 }
 
 sub flush_CURR


@@ -72,6 +83,8 @@ my( $key );
        else {
                print STDERR "ADDKEY: $key\n" if $debugparse;
                %{$DB{$key}}=%CURR;
        else {
                print STDERR "ADDKEY: $key\n" if $debugparse;
                %{$DB{$key}}=%CURR;

+#              my($year)=&extract_year($CURR{"Notes"});
+#              %{$DB{$key}}{"year"}=$year if (defined($year));

                }
        %CURR=();
        @{$OWNS{$key}}=();
                }
        %CURR=();
        @{$OWNS{$key}}=();


@@ -120,8 +133,8 @@ my( $reparent,$refkey );
        foreach $reparent (@{$OWNS{$parent}}) {
                $PARENT{$reparent}=$refkey;
                }
        foreach $reparent (@{$OWNS{$parent}}) {
                $PARENT{$reparent}=$refkey;
                }

-       @{$OWNS{$parent}}=() if (!defined $OWNS{$parent});
-       @{$OWNS{$refkey}}=() if (!defined $OWNS{$refkey});
+       @{$OWNS{$parent}}=() if (!exists $OWNS{$parent});
+       @{$OWNS{$refkey}}=() if (!exists $OWNS{$refkey});

        @{$OWNS{$refkey}}=(@{$OWNS{$refkey}},$parent,@{$OWNS{$parent}});
        delete $OWNS{$parent};
 
        @{$OWNS{$refkey}}=(@{$OWNS{$refkey}},$parent,@{$OWNS{$parent}});
        delete $OWNS{$parent};
 


@@ -147,20 +160,31 @@ MATCH: foreach $key (keys %DB) {
        }
 undef %PARENT;
 
        }
 undef %PARENT;
 

+#foreach $key (keys %DB) {
+#      $DB{$key}{"Publication"}=&extract_year($DB{$key}{"Publication"})." ::: ".$DB{$key}{"Publication"}
+#                      if (exists($DB{$key}{"Publication"}));
+#      }
+
+foreach $key (keys %OWNS) {
+       my(@keys)=@{$OWNS{$key}};
+       delete($OWNS{$key});
+       unshift(@keys,$key);
+       @keys=sort { &extract_year($DB{$b}{"Publication"}) <=> &extract_year($DB{$a}{"Publication"}); } @keys;
+       my($pkey)=shift(@keys);
+       @{$OWNS{$pkey}}=@keys;
+       }
+

 sub print_header
 {
 my($header)=@_;
 
        print OUT
 "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>
 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\">
+<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">
+<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\">

 <head><title>Kewensis $header</title>
 <style type=\"text/css\"><!--
 <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; }
+.name { font-weight: bold; }

 --></style>
 </head><body>
 \n";
 --></style>
 </head><body>
 \n";


@@ -192,11 +216,11 @@ my( $child );
                        { print STDERR " ($child)"; }
                print STDERR "\n";
                }
                        { print STDERR " ($child)"; }
                print STDERR "\n";
                }

-       &print_rec("<a name=\"".&htmlquote($owner)."\">","</a>",%{$DB{$owner}});
+       print OUT &format_record("<a id=\"".&htmlquote($owner)."\">","</a>",%{$DB{$owner}});

        if (@{$OWNS{$owner}}) {
                print OUT "<blockquote>\n";
        if (@{$OWNS{$owner}}) {
                print OUT "<blockquote>\n";

-               foreach $child (reverse @{$OWNS{$owner}})
-                       { &print_rec("","",%{$DB{$child}}); }
+               foreach $child (@{$OWNS{$owner}})
+                       { print OUT &format_record("","",%{$DB{$child}}); }

                print OUT "</blockquote>\n";
                }
        print OUT "\n";
                print OUT "</blockquote>\n";
                }
        print OUT "\n";


@@ -222,7 +246,7 @@ my( $child );
        print OUT "</a></p>";
        if (@{$OWNS{$owner}}) {
                print OUT "<ul>\n";
        print OUT "</a></p>";
        if (@{$OWNS{$owner}}) {
                print OUT "<ul>\n";

-               foreach $child (reverse @{$OWNS{$owner}}) {
+               foreach $child (@{$OWNS{$owner}}) {

                        print OUT "<li>";
                        &print_href($child);
                        print OUT "</li>\n";
                        print OUT "<li>";
                        &print_href($child);
                        print OUT "</li>\n";