#!/usr/bin/perl -w



# isi2bib version 20030916.
# A script to generate BibTeX entries from Web of Science
# Author: Han-Kwang Nienhuys, 2003.
# Copy and modify at will, as long as this notice is kept.
# If you put the script online, I would appreciate it if you
# acknowledge me.


use CGI qw(-no_debug :standard);
use POSIX;

### config

$template = "online.html";
# $baseurl = "http://www.lagom.nl/latex/i2b/";
$logfile = "/home/hankwang/log/i2b-online.log";
$localaddr = "---";
### global vars

$warnings = "";
$numsuccess = 0;
$numfail = 0;

# global parameters
$authorline = "";
$isitext = "";
$abstract = "";
$longlabels = 0;

%WORDABBREVS = qw (ACADEMY Acad.
		   ADVANCES Adv.
		   ADVANCED Adv.
                   AGRICULTURAL Agr.
                   AMERICAN Am.
                   AMERICA Am.
		   ANNUAL Ann.
                   APPLIED Appl.
                   ATMOSPHERICAL Atmos.
		   BIOLOGY Biol.
		   BIOCHEMISTRY Biochem.
		   BIOPHYSICAL Biophys.
		   BIOPHYSICS Biophys.
                   CHEMICAL Chem.
                   CHEMISTRY Chem.
                   COMMUNICATIONS Comm.
		   ECONOMIC Econ.
		   ECONOMICS Econ.
                   GEOSCIENTIFICAL Geosci.
		   INORGANIC Inorg.
                   INTERNATIONAL Int.
                   JOURNAL J.
                   LETTERS Lett.
		   MATHEMATICAL Math.
                   METEOROLOGICAL Meteorol.
                   MOLECULAR Mol.
                   OPTICAL Opt.
                   PHYSICAL Phys.
                   PHYSICS Phys.
		   PROCEEDINGS Proc.
                   REVIEW Rev.
                   REVIEWS Rev.
                   SOCIETY Soc.
		   SPECTROSCOPY Spectr.
                   STRUCTURAL Struct.
                   STRUCTURE Struct.
		   SURFACE Surf.
		   SYNTHETIC Synth.
		   ZEITSCHRIFT Z.
                   XXX Sens.
                   XXX Sci.
                   );
                   
                   

sub hthead {
    print("Content-Type: text/html\n\n");
}

sub errorpage {
    print("<html><body><h1>Internal error</h1>\n".
	  "<big><strong>$_[0]</strong></big></body></html>\n");
    exit 0;
}

sub readtemplate {
    my $tplpath = $ENV{SCRIPT_FILENAME};
    $tplpath =~ s|^(.*/)[^/]+|$1|;
    $tplpath .= $template;
    my $res = open(FH, $tplpath);
    if ($res) {
	$html = join("", <FH>);
	close(FH);
    } else {
	errorpage("$tplpath: $!");
    }
    if (defined($baseurl) && $baseurl ne "") {
      my $base="\n<base href=\"$baseurl\">\n";
      $html =~ s|<head>|<head>$base|;
    }
}

sub giveform {
    readtemplate();
    print $html;
}


sub processform {
    readtemplate();
    my $bibtexrecs = getISI();
    my $warnings2 = "";
    my $resubmit = "";
    if ($numfail > 0) {
	$warnings .= "<br>There were problems in $numfail record(s).";
    }    
    if ($warnings ne "") {
	$warnings2 = "<strong>$warnings</strong><br>";
	$resubmit = $isitext;
    }
    my $results =
	("<h2>Results</h2>\n".
	 "<strong>Paste these into your bibTeX database</strong><br>\n".
	 "<form method=post><textarea name=foo cols=80 rows=10>\n".
	 $bibtexrecs .
	 "</textarea></form>".
	 $warnings2.
	 "<h2>New input</h2>\n");
    $html =~ s/<!--cgi:results-->/$results/;
    $html =~ s/foo=resubmit>/>$resubmit/;
    print $html;

    if ($ENV{"REMOTE_ADDR"} ne $localaddr) {
	if (open(LFH, ">>$logfile")) {
	    printf(LFH "#### %s %s (success: %d, fail: %d)\n",
		   "".localtime(), $ENV{REMOTE_ADDR},
		   $numsuccess, $numfail);
	    printf(LFH "U-A: $ENV{HTTP_USER_AGENT}\n");
	    print(LFH "$isitext\n==\n$authorline\n");
	    close(LFH);
	}
    }
    
}



# convert text to lowercase except first letter
sub Lowercase {
    my $txt = shift;
    my $a = substr($txt, 0, 1);
    $a =~ tr/a-z/A-Z/;
    my $b = (length($txt) >= 2) ? lc(substr($txt, 1)) : "";
    return "$a$b";
}

# make bibtex fields with label $0 and contents $1
sub bibtexfield {
    my $label = $_[0];
    my $contents = $_[1];
    my $output .= "  $label = {";
    if (!defined($contents)) {$contents = "";}
    my @cwords = split(" ", $contents);
    my $pos = 12;
    my $first = 1;
    foreach my $i (@cwords) {
	my $l = length($i);
	if ($pos+1+$l > 72) {
	    $output .= "\n     ";
	    $pos = 6;
	} else {
	    if ($first) {$first=0;} else {$output .= " ";}
	    $pos++;
	}
	$output .= "$i";
	$pos += $l;
    }
    $output .= "},\n";
    return $output;
}

# create label, either authorYY or author-jjj-vvv-ppp-yyyy
# first argument = first author
sub makelabel {
    my ($auth, $jour, $vol, $pages, $year) = @_;
    $auth =~ s/\s*^([^ ]*).*/$1/;
    $auth =~ tr/A-Z/a-z/;
    if ($longlabels) {
	$jour =~ s/^\s*(.*)\s*$/$1/; # remove trailing/leading space
	$jour = " $jour";
	$jour =~ s/\s+([^ ])[^ ]*/$1/g; # abbreviate
	$jour =~ tr/A-Z/a-z/;
	$jour =~ s/[^a-z0-9-]//g; # remove any strange chars.
	$pages =~ s/-{1,2}.*$//;
	my $label = "$auth-$jour-$vol-$pages-$year";
	$label =~ s/\s//g;
	return $label;
    } else {    
	my $authyear = $year;
	$authyear =~ s/..(..)/$1/;
	return "$auth$authyear";
    }
}



# uses $isitext
#   l1: lastname INITIALS, lastname INITIALS, ...
#   l2: Title (lowercase)
#   l3: TITLE TITLE TITLE vol: (issue) page-page {date} year
# and $authors;
sub getISI_cutpaste {
    $isitext =~ s/\r//g;
    my @lines = ("", "", "");
    my @rawlines = split("\n", $isitext);
    my $output = "";
    my $line;
    my $firstline =1 ;
    # get input
    foreach $line (@rawlines) {
        if ($line =~ /^$/) { next; }
        chomp($line);
	$line =~ s/\n*$//;
        $line =~ s/^\s*//;
        $line =~ s/\s*$//;
        if ($firstline) {
            $lines[0] = $line;
            $firstline = 0;
        } else {
            if ($line =~ /^ *[A-Z -]{1,} [A-Za-z0-9\(\) -]{1,}[ :] .*[0-9]{4}$/) {
                # looks like journal source
                $lines[2] = $line;
                last;
            } else {
                # looks like still title
                $lines[1] .= $line;
            }
        }
    }
    # parse line 1 (author)
    if ($authorline =~ /[^\s]/s) {
	$authorline =~ s/^\s*//s;
	$authorline =~ s/\s*$//s;
	$lines[0] = $authorline;
    } elsif ($lines[0] =~ /et\s+al/) {
	$warnings .=
	    ("<i>Et al.</i> in author list! Supply full author list\n");
    }
    my @authlist = split(", ", $lines[0]);
    my $auth1 = $authlist[0];
    for (my $i=0; $i<=$#authlist; ++$i) {
	if (!($authlist[$i] =~ /et al./)) {
	    my @nameparts = split(" ", $authlist[$i]);
	    # replace initials
	    my $initials = $nameparts[$#nameparts];
	    $initials =~ s/([A-Z])/$1. /g;
	    $initials =~ s/ $//;
	    pop(@nameparts);
	    my $lastname = Lowercase(join(" ", @nameparts));
	    $authlist[$i] = "$initials $lastname";
	}
    }

    # parse line 2 (title)
    if (!($lines[1] =~ /[a-z]/)) { # all-upcase title -> lowercase
	$lines[1] =~ tr/A-Z/a-z/;
    }
    my @twords = split(" ", $lines[1]);
    $twords[0] = Lowercase($twords[0]);
    for (my $i = 1; $i<$#twords; ++$i) {
	if ($twords[$i] =~ /[A-Z]/) {
	    $twords[$i] = "{$twords[$i]}";
	}
    }

    # parse line 3 (journal, volume, pages, year)
    # the general form is XXXXX XXXX {(XXX)}: PAGES DATE YEAR
    # PAGES can be nnn, nnn-nnn, art.no ...
    # {} = optional

    my $source = $lines[2];
    $source =~ s/ \([^\)].*\):/:/; # remove issue number (in parentheses)

    # extract jouranl, volume
    my $jourvol = $source; $jourvol =~ s/^(.*)\:.*/$1/;
    my $journal = $jourvol; $journal =~ s/^(.*) [0-9]*$/$1/;
    my $volume = $jourvol; $volume =~ s/^.* ([0-9]*)/$1/;
    
    # extract pages, year
    my $issppdate = $source; $issppdate =~ s/^.*\:(.*)/$1/;
    my $pages = $issppdate;
    $pages =~ s/\s+[0-9]{4}\s$//; # remove year
    if ($pages =~ /-/) {
    	# page range supplied
    	$pages =~ s/^.* ([0-9]{1,6}\-[0-9]{1,6}) .*$/$1/;
    } else {
    	# just one page: first number in the string
    	$pages =~ s/^[^0-9]*([0-9]{1,6})\s+.*$/$1/;
    }
    $pages =~ s/([0-9])-([0-9])/$1--$2/;
    my $year = $issppdate; $year =~ s/^.* ([0-9]{4}) *$/$1/;
    
    my @jourwords = split(" ", $journal);
    my @abbrevs = keys(%WORDABBREVS);
    
    for (my $i = 0; $i <= $#jourwords; ++$i) {
    	my $jw = $jourwords[$i];
    	for (my $j = 0; $j <= $#abbrevs; ++$j) {
    	    if ("$jw." =~ /^$abbrevs[$j]$/) {
    		$jw = "$abbrevs[$j]";
    		last;
    	    }
    	}
	if ($jw ne "IEEE") {
	    $jourwords[$i] = Lowercase($jw);
	}
    }
    $journal = join(" ", @jourwords);
    
    # construct label
    $output .= "\n\@Article{";
    $output .= makelabel($auth1, $journal, $volume, $pages, $year);
    $output .= ",\n";
    
    $output .= bibtexfield("author",  join(" and ", @authlist));
    $output .= bibtexfield("title",  join(" ", @twords));
    $output .= bibtexfield("journal", $journal);
    $output .= bibtexfield("volume", $volume);
    $output .= bibtexfield("pages", $pages);
    $output .= bibtexfield("year", $year);
    $output .= bibtexfield("entrydate", POSIX::strftime("%Y/%m/%d", gmtime));
    $output .= bibtexfield("abstract", $abstract);
    $output .= "}\n\n";
    if ($journal ne "" && $pages ne "" && $year ne "") {
	++$numsuccess;
    } else {
	++$numfail;
    }
    return $output;
}

# transform full name (e.g. JOURNAL OF PHYSICAL CHEMISTRY B) into
# abbreviation (J. Phys. Chem. B)
sub abbrev_journal {
    my @words = split(/ +/, $_[0]);
    my $short = "";
    foreach my $w (@words) {
	if (defined($WORDABBREVS{$w})) {
	    $w = $WORDABBREVS{$w};
	} else {
	    if ($w eq "OF" || $w eq "THE" || $w eq "AND") { next; }
	    $w = Lowercase($w) ;
	}
	$short .= " $w";
    }
    $short =~ s/^ //;
    return $short;
}

sub outputrecord_export() {
    my $output = "";
    # remove leading spaces
    foreach my $k (keys(%fields)) {
	$fields{$k} =~ s/^ //g;
    }
    my $output1 = "";
    # first author for label
    my $firstauth = lc((defined($aulist[0])) ? $aulist[0] : "xxx");
    $firstauth =~ s/[, ].*$//;    
    # author list: lowercase, "and" separator, periods after initials.
    for (my $i = 0; $i <= $#aulist; ++$i) {
	my ($lastname, $initials) = split(/, /, $aulist[$i], 2);
	if (!defined($lastname)) { $lastname = "Xxxx"; }
	if (!defined($initials)) { $initials = "W"; }
	$initials =~ s/([A-Z])/$1. /g;
	if ($lastname !~ /[a-z]/) {
	    $lastname = Lowercase($lastname);
	}
	$aulist[$i] = "$initials $lastname";
    }
    $output1 .= bibtexfield("author", join(" and ", @aulist));
    # title: escape single uppercase letters; downcase if entire title
    # in uppercase
    my $title = $fields{"TI"};
    if (!($title =~ /[a-z]/)) { # all-upcase title -> lowercase
	$title = Lowercase($title);
    }
    my @twords = split(" ", $title);
    for (my $i = 1; $i<$#twords; ++$i) {
	if ($twords[$i] =~ /[A-Z]/) {
	    $twords[$i] = "{$twords[$i]}";
	}
    }
    $output1 .= bibtexfield("title", join(" ", @twords));
    # journal
    my $journal = "";
    if ($fields{"JI"} ne "") {
	$journal = $fields{"JI"};
    } elsif ($fields{"J9"} ne "") {
	my @jwords = split(" ", $fields{"J9"});
	foreach my $jw (@jwords) {
	    $journal .=  Lowercase($jw) . ". ";
	}
    } elsif ($fields{"SO"} ne "") {
	$journal = abbrev_journal($fields{"SO"});
	   
    }
    $output1 .= bibtexfield("journal", $journal);
    # volume
    $output1 .= bibtexfield("volume", $fields{"VL"});
    # issue
    if ($fields{"IS"} ne "") {
	$output1 .= bibtexfield("number", $fields{"IS"});
    }
    # pages
    my $pages = "";
    if ($fields{"EP"} ne "") {
	$pages = $fields{"BP"} . "--" . $fields{"EP"};
    } elsif ($fields{"AR"} ne "") {
	$pages = $fields{"AR"};
    } else {
	$pages = $fields{"BP"};
    }
    

    
    $output1 .= bibtexfield("pages", $pages);
    # year
    $output1 .= bibtexfield("year", $fields{"PY"});
    $output1 .= bibtexfield("entrydate", POSIX::strftime("%Y/%m/%d", gmtime));
    if (defined($fields{"AB"})) {
	$output1 .= bibtexfield("abstract", $fields{"AB"});
    } else {
	$output1 .= bibtexfield("abstract", $fields{"AB"});
    }
    # label
		  
    # label: firstauthor + year
    my $authyear = (defined($fields{"PY"})) ? $fields{"PY"} : "yyyy";
    my $label = makelabel($firstauth, $journal, $fields{"VL"},
			  $pages, $fields{"PY"});

    $output .= "\@Article{$label,\n";
    $output .= $output1;
    $output .= "}\n\n";

    if ($journal ne "" && $fields{"VL"} ne "" && $fields{"PY"} ne "") {
	++$numsuccess;
    } else {
	++$numfail;
    }
    
    # cleanup
    foreach $k (keys(%fields)) {
	$fields{$k} = "";
	@aulist = ();
    } 

    return $output;
}


%fields = ("AU", "",
	   "TI", "",
	   "SO", "",	   
	   "BP", "",	   
	   "EP", "",
	   "JI", "",	   
	   "PY", "",	   
	   "VL", "",
	   "IS", "",
	   "J9", "",
	   "AR", "",
	   );
@aulist = ();


sub getISI_export {
  $isitext =~ s/\r//g;
  my @rawlines = split("\n", $isitext);
  $linecount = 0;
  my $output = "";
  my $curfield = "x";
  # remove leading spaces
  foreach $_ (@rawlines) {
      ++$linecount;
      if (/^\s*$/) {
	  next;
      }
      # valid field?
      if (!/^   / && !/^[A-Z][A-Z0-9] ?/) {
  	  $warnings .= "Format error (line $linecount: '$_')<br>\n";
	  ++$numfail;
	  return "";
      }
      # new field?
      if (/^[A-Z][A-Z0-9] ?/) {
  	  $curfield = substr($_, 0, 2);
	  $fields{$curfield} = "";
      }
      if ($curfield eq "ER") {
  	  $output .= outputrecord_export();
  	  next;
      }
      # add contents to current field
      if ($curfield eq "AU") {
  	  push(@aulist, substr($_, 3));
      } else {
  	  # default
	  if (length($_) > 3) {
	      $fields{$curfield} .= " " . substr($_, 3);
	  }
      }
  }
  return $output;
}

sub getISI {
    if ($isitext =~ /^AU /m && $isitext =~ /^TI /m) {
	return getISI_export();
    } else {
	return getISI_cutpaste();
    }
}


sub i2b_online() {
    hthead();
    $isitext = CGI::param("isitext");
    $authorline = CGI::param("authors");
    if (!defined($authorline)) { $authorline=""; }
    $abstract = CGI::param("abstract");
    if (!defined($abstract) || $abstract eq "") { $abstract="ABSTRACT"; }
    my $ll = CGI::param("longlabels");
    if (defined($ll) && $ll eq "1") {
	$longlabels =1;
    }	
    if (!defined($isitext)) {
  	giveform();
    } else {
  	processform();
    }
}  

sub i2b_commandline() {
    # commandline ?
    if (join(" ", @ARGV) =~ /-longlabels/) {
	$longlabels = 1;
    }
    # get first part of data from user
    print(STDERR
	  "Convert www ISI / Web of Science to BibTeX.\n".
	  "Paste data below (WoS export format (multiple)\n".
	  "or from search results (1 entry at a time)\n".
	  "End with 2 empty lines or EOF.\n");
    my $prevempty = 0;
    my $empty = 0;
    $isitext = "";
    while (<STDIN>) {
	$prevempty = $empty;
	$empty = (/^$/);
	$isitext .= $_;
	if ($empty && $prevempty) { last; }
    }
    # export format has strange end of line markers (CR/NL)
    $isitext =~ s/\r([^\n])/\n$1/g;
    $isitext =~ s/\r\n/\n/g;
    if ($isitext =~ /^AU /m && $isitext =~ /^TI /m) {
	# export format: proceed immediately
	$bibtexrecs = getISI_export();
    } else {
	# search results paste: get authors (et al) and abstract
	if ($isitext =~ /et al\./) {
	    print(STDERR "Enter full author list (no et al.) on one line:\n");
	    <STDIN>;
	    $authorline = $_;
	}
	print(STDERR "Abstract (empty line to finish)\n");
	$abstract = "";
	while (<STDIN>) {
	    if (/^$/) { last; }
	    $abstract .= $_;
	}
	# and go ahead!
	$bibtexrecs = getISI_cutpaste();
    }
    $warnings =~ s/<[^>]+>//; # remove HTML from warnings
    print $bibtexrecs;
    print(STDERR $warnings);        
}

#### main ####

# check: CGI script or interactive?
if (defined($ENV{'REQUEST_METHOD'})) {
    i2b_online();
} else {
    i2b_commandline();
}
    
