kewensis-collect.pl

   1 #! /usr/bin/perl -w
   2
   3 use vars qw/%DB %OWNS %PARENT %CURR $last_field $debugmatch $debugparse $key $owner $parent $ref/;
   4
   5 %DB=();
   6 %CURR=();
   7 $debugparse=0;
   8 $printdupl=0;
   9 $debugmatch=0;
  10
  11 sub name_to_key
  12 {
  13 my( $r )=@_;
  14
  15         $r=~tr/A-Z/a-z/;
  16         $r=~tr/a-z0-9//cd;
  17         return $r;
  18 }
  19
  20 sub rec_to_name
  21 {
  22 my( %rec )=@_;
  23 my( @list )=("Rank","Infrafam.","Genus","Species");
  24 my( $item,$r );
  25
  26         $r="";
  27         while ($item=shift @list)
  28                 { $r.=" ".$rec{$item} if exists $rec{$item}; }
  29         $r=~s/^ //;
  30         return $r;
  31 }
  32
  33 sub flush_CURR
  34 {
  35 my( $key );
  36
  37         $key=&name_to_key(&rec_to_name(%CURR));
  38         return if (!defined $key);
  39         if (exists $DB{$key})
  40                 { print STDERR "Key \"$key\" is duplicated!\n" if $printdupl; }
  41         else {
  42                 print STDERR "ADDKEY: $key\n" if $debugparse;
  43                 %{$DB{$key}}=%CURR;
  44                 }
  45         %CURR=();
  46 }
  47
  48 while (<>) {
  49         tr/\r\n//d;
  50         if (/^ *\304\301\304/) {
  51                 &flush_CURR();
  52                 print STDERR "---\n" if $debugparse;
  53                 }
  54         elsif (/^([^³]*[^ ]) *³ *(.*)$/) {
  55                 print STDERR "FIELD: $1, VALUE: $2\n" if $debugparse;
  56                 $last_field=$1;
  57                 $CURR{$1}=$2;
  58                 }
  59         elsif (/^ *³ *(.*)$/) {
  60                 print STDERR "APPEND: $1\n" if $debugparse;
  61                 $CURR{$last_field}.=" ".$1;
  62                 }
  63         else {
  64                 print STDERR "DISCARD: $_\n" if $debugparse;
  65                 }
  66         }
  67 &flush_CURR();
  68 undef %CURR;
  69
  70 %OWNS=();
  71 %PARENT=();
  72
  73 sub try_reparent
  74 {
  75 my( $reparent,$refkey );
  76
  77         $refkey=&name_to_key($ref);
  78         return 0 if ($refkey eq "");
  79         return 0 if ($parent eq $refkey);
  80         return 0 if !exists $DB{$refkey};
  81         print STDERR "try_reparent: SUCCESS: key=\"$key\", refkey=\"$refkey\"\n" if $debugmatch;
  82
  83         foreach $reparent (@{$OWNS{$parent}}) {
  84                 $PARENT{$reparent}=$refkey;
  85                 }
  86         @{$OWNS{$parent}}=() if (!defined $OWNS{$parent});
  87         @{$OWNS{$refkey}}=() if (!defined $OWNS{$refkey});
  88         @{$OWNS{$refkey}}=(@{$OWNS{$refkey}},$parent,@{$OWNS{$parent}});
  89         delete $OWNS{$parent};
  90
  91         return 1;
  92 }
  93
  94 MATCH: foreach $key (keys %DB) {
  95         $parent=$PARENT{$key};
  96         $parent=$key if (!defined $parent);
  97         $ref=$DB{$key}{"Notes"};
  98         next MATCH if (!defined $ref);
  99         $ref=~tr/()//d;
 100         $ref=~s/^=//;
 101         $ref=~s/^O\. *//i;
 102         $ref=~s/^Orchidaceae *//i;
 103         $ref=~s/\..*$//;
 104         next MATCH if &try_reparent();
 105         $ref=$DB{$key}{"Rank"}." $ref" if exists $DB{$key}{"Rank"};
 106         next MATCH if &try_reparent();
 107         $ref=$DB{$key}{"Genus"}." $ref" if exists $DB{$key}{"Genus"};
 108         next MATCH if &try_reparent();
 109         }
 110 undef %PARENT;
 111
 112 foreach $owner (keys %OWNS) {
 113 my( $child );
 114
 115         if ($debugmatch) {
 116                 print STDERR "($owner):";
 117                 foreach $child (@{$OWNS{$owner}})
 118                         { print STDERR " ($child)"; }
 119                 print STDERR "\n";
 120                 }
 121         print "(".&rec_to_name(%{$DB{$owner}}).")";
 122         foreach $child (@{$OWNS{$owner}})
 123                 { print " (".&rec_to_name(%{$DB{$child}}).")"; }
 124         print "\n";
 125         }