|<\/p>)\s*)';
my $SEMI_AND = "(?:$MERE_SEMI|$AND)";
my $COMMA_AND = "(?:$MERE_COMMA$AND|$AND|$MERE_COMMA)";
my $SPACE = '(?:\s|\ |\n|\r)';
my @NAME_PREFIXES_RE;
for (my $i=0; $i<=$#NAME_PREFIXES; $i++) {
$NAME_PREFIXES_RE[$i] = '(?:$|^|\W)' . $NAME_PREFIXES[$i] . '(?:$|^|\W)';
}
my $PREFIXES = "(?:" . join('|',@NAME_PREFIXES_RE) . ")";
#
# CODE STARTS HERE
#
sub setNameAbbreviations {
while (my $a = shift @_) {
my $b = shift;
$ABBREVIATIONS{$a} ||= {};
$ABBREVIATIONS{$a}->{$b} = 1;
$ABBREVIATIONS_LC{lc $a} ||= {};
$ABBREVIATIONS_LC{lc $a}->{lc $b} = 1;
}
}
sub getNameAbbreviations {
return \%ABBREVIATIONS;
}
our %commonSurnames;
our %commonMaleFirstnames;
our %commonFemaleFirstnames;
our $namesInitialized = 0;
# These three variables initialized below
my $COMMON_SURNAMES;
my $COMMON_MALE_FIRSTNAMES;
my $COMMON_FEMALE_FIRSTNAMES;
sub firstnamePrevalence {
my $name = uc shift;
prepareCommonNames() unless $namesInitialized;
return (($commonMaleFirstnames{$name} || 0) + ($commonFemaleFirstnames{$name} || 0))/2;
}
sub surnamePrevalence {
my $name = uc shift;
prepareCommonNames() unless $namesInitialized;
return $commonSurnames{$name} || 0;
}
sub isCommonFirstname {
my ($name, $percentLimit) = @_;
$percentLimit ||= 0;
return firstnamePrevalence($name) > $percentLimit;
}
sub isCommonSurname {
my ($name, $percentLimit) = @_;
$percentLimit ||= 0;
return surnamePrevalence($name) > $percentLimit;
}
sub isMisparsed {
my ($name) = @_;
$name = lc $name;
return 1 if $name !~ /\w.*,.*\w/;
for my $prefix ((@NAME_PREFIXES,'dr','dr.','prof','prof.','jr','jr.')) {
#warn "check prefix: $prefix";
return 1 if $name =~ /\b$prefix$/i;
}
return 1 if $name =~ /^\w\b/;
return 0;
}
sub isLikelyMisparsed {
my ($name) = @_;
my @parts = parseName2($name);
for my $p (@parts) {
next unless $p;
my @sub_parts = split(/\s+/,$p);
return 1 if $#sub_parts >= 2; # three or more subparts likely a mess
}
# also likely misparsed if firstname containg a likely lastname AND surname contains a likely firstname
my @firstname_parts = split(/\s+/, $parts[0]);
my @first_surname = grep { isCommonSurname($_) } @firstname_parts;
my @surname_parts = split(/\s/, $parts[2]);
my @surname_first = grep { isCommonFirstname($_) } @surname_parts;
return 1 if $#first_surname > -1 and $#surname_first > -1;
return isMisparsed($name);
}
my $fem_ending = qr/(ette|ne|a)$/i;
sub guessGender {
my ($name) = @_;
$name = uc $name;
prepareCommonNames() unless $namesInitialized;
# extract firstname part if necessary
if ($name =~ /[,\s]/) {
my @parts = parseName($name);
$name = $parts[0];
}
my $fscore = $commonFemaleFirstnames{$name};
my $mscore = $commonMaleFirstnames{$name};
return undef if !($fscore || $mscore);
return 'F' if $fscore and !$mscore;
return 'M' if $mscore and !$fscore;
#warn "M: $mscore vs F: $fscore";
my $threshold = 20;
# now the name exist in both. we make a decision if the percentage is very different
# now in both
return 'F' if $fscore / $mscore >= $threshold;
return 'M' if $mscore / $fscore >= $threshold;
# adjust threashold based on common female name endings
my $fem_end = ($name =~ $fem_ending);
if ($fem_end) {
return 'F' if $fscore / $mscore >= ($threshold/4);
} else {
return 'M' if $mscore / $fscore >= ($threshold/4);
}
return undef;
}
sub prepareCommonNames {
for my $n (split(/\n/,$COMMON_SURNAMES)) {
next unless $n =~ /^(.+?)\s+(.+?)\s/;
$commonSurnames{uc $1} = $2;
}
for my $n (split(/\n/,$COMMON_MALE_FIRSTNAMES)) {
next unless $n =~ /^(.+?)\s+(.+?)\s/;
$commonMaleFirstnames{$1} = $2;
}
for my $n (split(/\n/,$COMMON_FEMALE_FIRSTNAMES)) {
next unless $n =~ /^(.+?)\s+(.+?)\s/;
$commonFemaleFirstnames{$1} = $2;
}
$namesInitialized = 1;
}
sub reverseName {
my $n = shift();
return undef unless defined($n);
my @n = split(/,\s*/,$n);
return "$n[1] $n[0]";
}
sub composeName {
my ($given,$last) = @_;
my $r = $last;
$r .= ", $given" if $given;
return $r;
}
sub normalizeNameWhitespace {
my $in = shift;
return undef unless defined $in;
#print "in: $in\n";
# this used to be optional, but then we never know in advance
#my $initialsCanBeLowerCase = shift;
#if ($initialsCanBeLowerCase) {
$in =~ s/\b([a-z])\b/uc $1/ge;
#}
$in =~ s/^\s+//g; # remove initial spaces
$in =~ s/\s+$//g; # remove term spaces
$in =~ s/\s+,/,/g; # remove spaces before coma
$in =~ s/,\s*/, /g; # normalize spaces after coma
$in =~ s/\.\s*([A-Z])/. $1/g; # adjust spacing between initials
#print "in: $in\n";
$in =~ s/([A-Z])\.\s([A-Z])\./$1. $2./g;
$in =~ s/\b([A-Z])\b(?![\.'’])/$1./g;
while ($in =~ s/([\.\s][A-Z])(\s|$)/$1.$2/g) {};
$in =~ s/\.\s*([A-Z])/. $1/g; # adjust spacing between initials
#print "normalized: $in\n";
$in;
}
sub parseName {
my $in = shift;
return undef unless defined $in;
#print "-->parseName in: $in\n";
$in =~ s/^\s*and\s+//;
my $jr = ($in =~ s/,?\sJr\.?(\s|$)//i);
$in =~ s/^\s*by\s+//;
$in =~ s/\W*et\.? al\.?\W*//;
$in =~ s/\.\s*$//; # remove . at the end
#print "$in -->";
$in = normalizeNameWhitespace($in);
#print "$in'\n";
# check if we have a case of Lastname I. without comma
if ($in !~ /,/ and $in=~ /^(.*?\s)((?:[A-Z][\-\.\s]{0,2}){1,3})$/) {
#warn "Got a reversed name without comma: $1, $2";
my $init = $2;
my $rest = $1;
#print "\n\nmatched, rest:$rest--$2\n";
# add . as needed
# if ($init !~ /\./) {
$init =~ s/([A-Z])([^.]|$)/$1.$2/g;
$init =~ s/([A-Z])([^.]|$)/$1.$2/g;
# }
$rest =~ s/\s$//;
$in = normalizeNameWhitespace("$rest, $init");
} elsif ($in =~ /^[^,]+\s\w\.?$/) {
#print "case\n";
$in =~ s/^(.+?)\s((?:[A-Z]\.?-?\s?){1,3})$/$1,$2/;
}
#print "now:$in\n";
# standard cases
if ($in =~ /(.*),\s*(.*)/) {
return ($2, $1);
} else {
my @bits = split(' ',$in);
#print join(" - ", @bits);
if ($#bits == -1) {
return ($in,"");
}
my $lastname = splice(@bits,-1,1);
if ($lastname =~ /^Jr\.?$/i and $#bits > -1) {
$lastname = $bits[-1] . " $lastname";
splice(@bits,-1,1);
}
$lastname = "$lastname Jr" if $jr;
# add prefixes or Jr to lastname
#warn join(" - ",@bits);
while (defined $bits[-1] and $bits[-1] =~ /^$PREFIXES$/i) {
#warn "GOT PREFIX: $bits[-1]";
$lastname = splice(@bits,-1,1) . " $lastname";
}
return (join(' ',@bits),$lastname);
#my $firstname = splice(@bits,0,1);
#while ($#bits > -1 and $bits[0] =~ /^\s*\w\.?\s*$/) {
# $firstname .= " ".splice(@bits,0,1);
#}
#my $lastname = join(' ', @bits);
#return ($firstname, join(' ',@bits));
=crap
my @surnames = $#bits > 1 ? @bits[1,$#bits] : ($bits[1]);
#warn "doing " . join(" ",@bits);
#while ($#bits > 0) {
# @surnames = pop @bits;
#}
#my $surname = pop @bits;
return ($bits[0], join(' ',@surnames));
=cut
}
}
sub parseNames {
my $in = shift;
my $reverse = shift; # means names are stupidly written like this: David, Bourget
return undef if !defined $in;
while($in =~ s/(^|\W)(dr|prof\.? em\.?|prof|profdr|prof|sir|mrs|ms|mr)\.?(\W)/$1 $3/gi) {}
$in =~ s/^\s+//;
$in =~ s/([^A-Z]{2,2})\.\s*/$1/; # remove . at the end
$in =~ s/\(.+\)\s*$//; # remove trailing parens
$in =~ s/(,\s*)?\d\d\d\d-$//;
$in =~ s/^\s*[bB]y(\W)/$1/; #remove "By ";
$in =~ s/,?\s*et\.? al\.?\s*$//; # et al
$in =~ s/^\W+//;
#print "== $in\n";
# semi-colon separated
if ($in =~ /;/) {
return parseNameList(split(/$SEMI_AND/i,$in),$reverse);
}
# no comma and no semi-colon, so one or two not-reversed names
elsif ($in !~ /,/) {
return parseNameList(split(/$AND/i,$in),$reverse);
}
# now that's messy: one or more commas, no semi
else {
# is there a "and"?
#print "$in\n";
if ($in =~ /$AND/i) {
#print "AND:$in\n";
# now we check for double duty for commas
# We fix what would be missing commas on this hypothesis
my $t = $in;
$t =~ s/([a-z])\s+([A-Z])(\.|\s|$)/$1, $2$3/g;
# we check if it's a silly case of commas playing double duty
if ($t =~ /,.+,.+,.+$AND/) {
#print "SILLY: $t\n";
my @to;
my @tokens = split(/$COMMA_AND/i,$t);
for (my $ti=0; $ti <= $#tokens;$ti+=2) {
push @to, join(", ",@tokens[$ti..$ti+1]);
}
return parseNameList(@to,$reverse);
}
# no silliness. what's after the AND will tell us the format
# if there's a comma after, it's probably reversed
if ($in =~ /$AND.*,/i) {
return parseNameList(split(/$SEMI_AND/i,$in),$reverse);
}
else {
my @parts = split(/$COMMA_AND/i,$in);
return parseNameList(@parts,$reverse);
}
} else {
#print "- no and\n";
# no semi, no and, and one or more comma
# if 2 or more commas
if ($in =~ /,.+,/) {
# need to check if this is a silly case of commas with reversed names
# check that by looking for two or more ,token, with only one part, and odd number of ,
my @tokens = split(/$MERE_COMMA/i,$in);
my $silly = 0;
for my $tok (@tokens) {
$silly++ unless $tok =~ m/[\w\.]$SPACE[\w\.]/i;
}
# if silly combination, every other comma separates two names
if ($silly >=2 and $#tokens %2 ==1) {
my @to;
for (my $ti=0; $ti <= $#tokens;$ti+=2) {
push @to, join(", ",@tokens[$ti..$ti+1]);
}
@tokens = @to;
}
return parseNameList(@tokens,$reverse);
}
# else, one comma, no semi, and no and
else {
# now that's ambiguous between "Doe, John" and "John Doe, John Doe"
# but we assume there are no names like "Herrera Abreu, Maria Teresa"
# (which there are, this is a real one). that is, if the comma separates
# two tokens on each side (not counting de,di,von, etc.), we suppose
# these tokens make distinct names
my @toks = split(/,/,$in);
my @copy = @toks;
foreach (@copy) {
s/$PREFIXES|(\WJr(\W|$))/ /ig;
my @bits = split(' ',$_);
if ($#bits <= 0) {
# found one side with only one non-trivial token
# so there is only one author in $in
return parseNameList(($in),$reverse);
}
}
return parseNameList(@toks,$reverse);
}
}
}
return ();
}
sub parseNameList {
my @auths;
#print "Got: " . join("---", @auths) . "\n";
my $reverse;
if (defined($_[-1]) and $_[-1] eq 'reverse') {
pop @_;
$reverse = 1;
}
# first we correct for overly split names like 'Bourget; D; John Doe'
my @new;
#print Dumper(\@_); use Data::Dumper;
for (@_) {
# if the part looks like an initial, we add it to the previous name part
next unless $_;
if (/^([A-Z](\.|\s|$)\s?)+$/ and $#new > -1) {
if ($new[-1] =~ /,/) {
$new[-1] = "$new[-1] $_";
} else {
$new[-1] = "$new[-1], $_";
}
} else {
push @new, $_;
}
}
foreach my $a (@new) {
next unless $a;
my ($f,$l) = parseName($a);
push @auths, ($reverse ? "$f, $l" : "$l, $f");
}
return @auths;
}
sub parseName2 {
my $in = shift;
my ($i,$s);
return ("","") unless defined $in;
my ($l,$f) = split(/,\s*/,$in);
$f ||= '';
$l ||= '';
# get suffix
if ($l =~ s/\s+(Jr\.?|[IV]{2,10})\s*$//) {
$s = $1;
}
#print "f: $f\nl:$l\n";
# separate firstname/initial
# if has only initials
if ($f =~ /^\s*([A-Z](?:\.|\s|$))(.+)$/) {
$f = $1;
$i = $2;
$i =~ s/^\s*//;
}
# has a full firstname
else {
if ($f =~ /^([^\s]+?)\s+((?:[A-Z](?:\.|\s+|$)\s*)+)$/) {
$f = $1;
$i = $2;
}
}
return ($f,$i,$l,$s);
}
sub abbreviationOf {
my ($a,$b) = @_;
return 0 unless $ABBREVIATIONS_LC{lc $a};
return $ABBREVIATIONS_LC{lc $a}->{lc $b} ? 1 : 0;
}
# if the two names passed as params are such that they could belong to the same person, returns a merged name
sub samePerson {
my ($a,$b, %opts) = @_; #name1,name2
return undef if !defined($a) or !defined($b);
my $a_expd = 0;
my $b_expd = 0;
my ($lasta,$firsta) = split(',',cleanName($a,' ','reparse'));
my ($lastb,$firstb) = split(',',cleanName($b,' ','reparse'));
return undef if defined($firsta) and !defined($firstb);
return undef if defined($firstb) and !defined($firsta);
return undef if defined($lasta) and !defined($lastb);
return undef if defined($lastb) and !defined($lasta);
#print "here '$lasta'-'$lastb'\n";
$lasta =~ s/\s+Jr\.?$// if defined $lasta;
$lastb =~ s/\s+Jr\.?$// if defined $lastb;
# check for reversed name if loose
if (!equivtext($lasta,$lastb)) {
if (!$opts{loose}) {
return undef;
} else {
return samePerson("$firsta, $lasta", "$lastb, $firstb", loose=>0) || samePerson("$firsta $lasta","$firstb $lastb", loose=>0);
}
}
=old
# regimentation
$firsta =~ s/\./ /g;
$firstb =~ s/\./ /g;
$firsta =~ s/\s+/ /g;
$firstb =~ s/\s+/ /g;
=cut
my @at = split(" ",$firsta || '');
my @bt = split(" ",$firstb || '');
#print "AT: " . join("-",@at) . "\n";
#print "BT: " . join("-",@bt) . "\n";
# compare each token pair as follows:
# if reached the end of tokens on either side, compat
# if both are greater than 1 char and diff, not compat
# if they don't start by the same letter, not compat
# else merge the tokens, compat so far, move on to next token pair
#
my $merged = "$lasta,";
for (my $i=0; $i <= $#at || $i <= $#bt; $i++) {
#print "$i ($merged):" . $at[$i] . "-" . $bt[$i]. "-\n";
# end of tokens reached on one side
if ($i > $#at) {
#print "END ($merged)\n";
#return undef if $b_expd;
$merged .= " ". join(" ",@bt[$i..$#bt]);
return cleanName($merged,'');
} elsif ($i > $#bt) {
#print "END ($merged)\n";
#return undef if $a_expd;
$merged .= " ". join(" ",@at[$i..$#at]);
return cleanName($merged,'');
}
# if different tokens
if (!equivtext($at[$i],$bt[$i])) {
# if different first letters, not compat
return undef if !equivtext(substr($at[$i],0,1),substr($bt[$i],0,1));
# otherwise they might be compatible
# token a is full word
if (length($at[$i]) > 2) {
# b is too, they are not compat unless one is a short for the other
if (length($bt[$i]) > 2) {
if ( abbreviationOf($at[$i],$bt[$i]) ) {
$merged .= " " . $bt[$i];
next;
} elsif ( abbreviationOf($bt[$i],$at[$i]) ) {
$merged .= " " . $at[$i];
next;
} else {
return undef;
}
}
# b is initial, they are compat so far
else {
$b_expd = 1;
$merged .= " " . $at[$i];
}
# a is initial
} else {
# b is full word
$a_expd = 1 if length($bt[$i]) > 2;
# keep going
$merged .= " " . $bt[$i];
}
}
# otherwise move on to next token pair straight
else {
$merged .= " " .$at[$i];
}
}
# if we get there, the two names are compatible and $merged contains the richest name from the two
# print "merged: $merged\n";
return cleanName($merged,'');
}
sub equivtext {
my ($a,$b) = @_;
$a = lc rmDiacritics($a);
$b = lc rmDiacritics($b);
$a =~ s/\.\s*$//;
$b =~ s/\.\s*$//;
#warn "$a == $b == " . distance($a,$b);
# we allow one character difference, except for initial tokens. this is because some diacritics change the underlying letter when removed, e.g. Björklund -> Bjarklund, even though one might naturally write 'Bjorklund'
return (length($a) > 1 && length($b) > 1) ? distance($a,$b) <= 1 : $a eq $b;
}
sub cleanParseName {
my $n = shift;
# I think that one is overkill..
return parseName(cleanName(composeName(parseName($n))));
}
sub cleanName {
my ($n, $space, $reparse) = @_;
# Some of the cleaning-up here is redundant because also in parseName, which is called last. But it doesn't hurt.. If it works don't try and fix it.
return undef unless defined $n;
#print "Cleaning name: $n\n";
$n =~ s/\.( \.)+/./g;
$n =~ s/\.($APOST)/'/g;
# if ", john doe"
if ($n =~ s/^\s*,\s+//) { }
# if 'john doe,'
if ($n =~ s/^([^,]+?)\s*,\s*$/$1/) { }
$n =~ s/Get checked abstract//g;
$n = rmTags($n);
$n =~ s/, By$//i;
#if ($reparse and $n =~ s/,/) {
# my ($l,$f) = split(/,\s*/,$n);
# my ($f,$l) = parseName(join(' ',($f,$l)));
# $n = "$l, $f";
#}
# Fix for O'Something => O.'Something
#$n =~ s/O\.'/O'/;
$n =~ s/[\r\n]/ /gsm;
$n =~ s/(\w)\s*,/$1,/g;
$n =~ s/([a-z]{2,})\./$1/gi; #remove unwanted .
$n =~ s/(\W|\.|\s)([A-Z])(\s|$)/$1$2.$3/g; #add . to initials
$n =~ s/(\W|\.|\s)([A-Z])(\s|$)/$1$2.$3/g; #add . to initials (repeat for overlaps)
$n =~ s/\.\s*([A-Z])/". " . uc $1/ieg; # adjust spacing between initials
$n =~ s/\W*\d{4,4}\W*//g; # misplaced dates
$n =~ s/\(.*$//; #parentheses
# misplaced jr
$n =~ s/([\w'-])\s*,(.*)\sJr(\s.*|$)/$1 Jr,$2 $3/i;
# misplaced prefixe
#warn $n;
#$n =~ s/([\w'-])\s*,(.*)\s(van|von|von\sder|van\sder|di|de|del|du|da)(\s.*|$)/(lc $3) . $1 . "," . $2 . $4/ie;
#warn $n;
# replace Iep by UNKNOWN (for PP)
$n =~ s/^Iep,$/Unknown, Unknown/;
#links aren't names
$n = "Unknown, Unknown" if $n =~ /http:\/\//;
# capitalize if nocaps
if ($n !~ /[A-Z]/) {
$n = capitalize($n,notSentence=>1);#_title($n, PRESERVE_ANYCAPS=>1, NOT_CAPITALIZED=>\@PREFIXES);
}
# do we have initials stuck on the surname like so: RawlsJ.
unless ($n =~ /,/ or $n =~ /\w \w/) {
$n =~ s/([A-Z][a-z]{1,})((?:[A-Z](?:$|\.|\s|)\s*)+)\s*$/$1, $2/g;
}
#warn "$n";
#unless it's all caps, the caps are initials. we unstuck them and add .
if ($n =~ /[a-z]/ and $n !~ /[A-Z]{2,} [A-Z]{2,}/) {
$n =~ s/(\s|^)([A-Z]{2,3})(\.|\s|$)/$1 . toInitials($2) . $3/ge;
} else {
}
#warn $n;
my ($f,$l) = parseName($n);
#warn "** $l, $f";
#warn "$l, $f";
$n = composeName($f,$l);
# now final capitalization
$n = capitalize($n,notSentence=>1); #,PRESERVE_ANYCAPS=>1, NOT_CAPITALIZED=>\@PREFIXES);
return $n;
}
sub toInitials {
my $s = shift;
#warn "init: $s";
return $s if grep { lc $_ eq lc $s } @NAME_PREFIXES;
$s =~ s/^([A-Z])([A-Z])([A-Z])$/$1. $2. $3./;
$s =~ s/^([A-Z])([A-Z])$/$1. $2./;
return $s;
}
sub weakenings {
my( $firstname, $lastname ) = @_;
my @warnings;
# default firstname aliases: every middle name can be either in full, initialized, or absent
my @first_parts = split(/\s+/,normalizeNameWhitespace($firstname));
my $reduced = 0;
if( scalar @first_parts > 3 ){
$reduced = 1;
splice( @first_parts, 3 );
push @warnings, "Too many parts in first name: '$firstname'\n";
}
my $first = shift @first_parts;
for my $i (0..$#first_parts) {
my $value = $first_parts[$i];
$first_parts[$i] = [$value]; # the default value is good
# try downgrading to initial
push @{$first_parts[$i]}, $value if ($value =~ s/(\w)[^\s\.]+/$1./);
}
my @first_aliases = ( $first );
push @first_aliases, "$1." if $first =~ /(\w)[^\s\.]+/;
#print Dumper(\@first_parts);
for my $i (0..$#first_parts) {
my @new;
for my $current (@first_aliases) {
for (@{$first_parts[$i]}) {
push @new, "$current $_";
}
push @new, $current;
}
@first_aliases = @new;
}
#print Dumper(\@first_aliases);
$lastname = normalizeNameWhitespace($lastname);
my @prefixes = map "\\b$_\\b", @NAME_PREFIXES, 'y', 'los';
my $prefixes = join '|', @prefixes;
$lastname =~ s/($prefixes) /$1+/ig;
my @parts = reverse ( ( split(/\s+/,$lastname) ) );
my @last_aliases;
my $lastlast = shift @parts;
for my $variation ( variations( $lastlast ) ){
push @last_aliases, $variation;
}
if( scalar @parts < 3 ){
for my $lpart ( @parts ){
my @curr = @last_aliases;
for my $variation ( variations( $lpart ) ){
for my $alias ( @curr ){
next if $variation =~ /-/ && $alias =~ / /;
next if $variation =~ / / && $alias =~ /-/;
push @last_aliases, "$variation $alias" if $variation !~ /-/ && $alias !~ /-/;
push @last_aliases, "$variation-$alias" if $variation !~ / / && $alias !~ / /;
}
}
}
}
else{
push @warnings, "Too many parts in last name: '$lastname'\n";
push @last_aliases, $lastname;
}
my @aliases;
unshift @first_aliases, $firstname if $reduced;
ALIAS:
for my $f ( @first_aliases ) {
for my $l (@last_aliases) {
push @aliases, { firstname => $f, lastname => $l };
if( scalar @aliases > 25 ){
push @warnings, 'More than 25 aliases';
last ALIAS;
}
}
}
return \@warnings, @aliases;
}
sub variations {
my $part = shift;
my @parts = split /\+/, $part;
if( scalar @parts <= 1 ){
return $part;
}
else{
return join( ' ', @parts ), $parts[-1];
}
}
sub rmTags {
my $in = shift;
while ($in =~ s/(<|(?:\<))\/?[^>]*?(>|(?:\>))/ /g) {};
return $in;
}
sub rmDiacritics {
my $str = shift;
my $nstr = '';
for ( $str ) { # the variable we work on
## convert to Unicode first
## if your data comes in Latin-1, then uncomment:
#$_ = Encode::decode( 'iso-8859-1', $_ );
return "" if !defined $_;
$_ = NFD( $_ ); ## decompose
s/\pM//g; ## strip combining characters
s/[^\0-\x80]//g; ## clear everything else
$nstr .= $_;
}
$nstr;
}
sub rmDiacriticsNOTGOOD {
my $str = shift;
my $nstr = '';
#
# This code (c) Ivan Kurmanov, http://ahinea.com/en/tech/accented-translate.html
#
for ( $str ) { # the variable we work on
## convert to Unicode first
## if your data comes in Latin-1, then uncomment:
#$_ = Encode::decode( 'iso-8859-1', $_ );
s/\xe4/ae/g; ## treat characters ä ñ ö ü ÿ
s/\xf1/ny/g; ## this was wrong in previous version of this doc
s/\xf6/oe/g;
s/\xfc/ue/g;
s/\xff/yu/g;
$_ = NFD( $_ ); ## decompose (Unicode Normalization Form D)
s/\pM//g; ## strip combining characters
# additional normalizations:
s/\x{00df}/ss/g; ## German beta â<80><9c>Ã<9f>â<80><9d> -> â<80><9c>ssâ<80><9d>
s/\x{00c6}/AE/g; ## Ã<86>
s/\x{00e6}/ae/g; ## æ
s/\x{0132}/IJ/g; ## IJ
s/\x{0133}/ij/g; ## ij
s/\x{0152}/Oe/g; ## Å<92>
s/\x{0153}/oe/g; ## Å<93>
tr/\x{00d0}\x{0110}\x{00f0}\x{0111}\x{0126}\x{0127}/DDddHh/; # Ã<90>Ä<90>ðÄ<91>Ħħ
tr/\x{0131}\x{0138}\x{013f}\x{0141}\x{0140}\x{0142}/ikLLll/; # ıĸĿÅ<81>Å<80>Å<82>
tr/\x{014a}\x{0149}\x{014b}\x{00d8}\x{00f8}\x{017f}/NnnOos/; # Å<8a>Å<89>Å<8b>Ã<98>øſ
tr/\x{00de}\x{0166}\x{00fe}\x{0167}/TTtt/; # Ã<9e>Ŧþŧ
s/[^\0-\x80]/ /g; ## space for everything else; optional
$nstr .= $_;
}
$nstr;
}
sub capitalize {
my $txt = shift;
my %args = @_;
#print "bef: $txt\n";
# we don't want to recapitalize when it look ok
# what doesn't look ok is a token with all lowercase (4 or more chars) or allcaps (2 or more chars)
return $txt unless $txt =~ /\b[A-Z]{2,}\b/ or $txt =~ /\b[a-z]{4,}\b/;
my $t = capitalize_title($txt);
if ($args{notSentence}) {
$t =~ s/^($PREFIXES)/lc $1/ie;
}
#fix for bug in text::capitalize
$t =~ s/&Quot;?(\.?)$/"$1/g;
return $t;
}
#
# Top 1000 most common male first names in the US according to the 1990 US survey, with relative frequency (%, first column)
#
$COMMON_MALE_FIRSTNAMES = <