<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!/usr/bin/perl -w

#########################
# NormalizeSurnames.pl
# Version 0.01
# (c) Ed Egan 2009
#########################

=head1 NAME

NormalizeSurnames.pl  v0.01

=head1 DESCRIPTION &amp; AUTHOR

'Process files of (human) name data, extracting surnames and normalizing the name-strings'

Written by Ed Egan &lt;ed@edegan.com&gt;

Copyright (C) 2009. Be nice.

=head1 SYNOPSIS

perl NormalizeSurnames.pl [-i=&lt;file&gt;] [-o=&lt;file&gt;] [-ncol=&lt;int&gt;] [-r(0|1)] [-rcol=&lt;int&gt;] [tact=&lt;int&gt;] [dact=&lt;int&gt;]

=head1 OPTIONS

   -i=&lt;file&gt;:       Infile name: Name of the surname file to read 
   -o=&lt;file&gt;:       Outfile name (default=infile.-Normalized.txt): Name of processed file that will be created 
   -t=&lt;file&gt;:       Tussenvoegsel filename (default=Names-Tussenvoegsel.txt): Name of file containing Tussenvoegsel
   -s=&lt;file&gt;:       Stopword filename (default=Names-Stopwords.txt): Name of file containing Stopwords
   -ncol=&lt;int&gt;:     Name column (default=0): The column number of the name, zero indexed
   -comma=[0,1];    Set the Comma option: Expect the comma name format through-out (ignore reserval options) - Surname, Firstname Initial
   -r=[0,1]:        Reversal (default=0): Set to 1 indicate global reversal of name ordering (Surname FirstName MiddleName)
   -rcol=&lt;int&gt;:     Reversal column: Set the column number (zero indexed) for idiosyncratic name order reversal indicators
   -tact=&lt;int&gt;:     Tussenvoegsel action (default=0): 0 append to surname, 1 discard
   -dact=&lt;int&gt;:     Double-barrelled name action (default=0): 0 take second barrel only, 1 merge the barrels
   -h:              Display this semi-informative help

=cut

#Load Packages
use strict;
use Unicode::Normalize;
use Text::Unidecode;
use warnings;
use Getopt::Long;
use Data::Dumper;
use Pod::Usage;

# Read command-line arguments / Define global variables
my $opt_show_help=0;
my ($opt_infile, $opt_outfile, $opt_rcol);
my $opt_sfile="Names-Stopwords.txt";
my $opt_tfile="Names-Tussenvoegsel.txt";
my $opt_ncol=0; my $opt_r=0; my $opt_tact=0; my $opt_dact=0; my $opt_comma=0;
GetOptions(
      "i=s"     =&gt; \$opt_infile,
      "o=s"     =&gt; \$opt_outfile,
      "t=s"     =&gt; \$opt_tfile,
      "s=s"     =&gt; \$opt_sfile,
      "ncol=i"  =&gt; \$opt_ncol,
      "comma=i" =&gt; \$opt_comma,
      "rcol=i"  =&gt; \$opt_rcol,
      "r=i"     =&gt; \$opt_r,
      "tact=i"  =&gt; \$opt_tact,
      "dact=i"  =&gt; \$opt_dact,
      "h"       =&gt; \$opt_show_help
) || die pod2usage(2);
if ($opt_show_help) {
   pod2usage(-exitstatus =&gt; 0, -verbose =&gt; 2);
}
my $min_length=2; #Set the minimum length for a surname
my $min_nonames=2; #Set the minimum number of words in the name string
my $ifileheader=1;
my $filename=$opt_infile;
$filename=~s/\.\w{3,3}$//i;
if (!$opt_outfile) {$opt_outfile=$filename."-Normalized.txt";}

#Find the input file
print "#######################################\n";
print "#        NormalizeSurnames.pl         #\n";
print "#                 v0.01               #\n";
print "#          (c) Ed Egan, 2009          #\n";
print "#######################################\n\n";
print "Starting the program...\t\t[Done]\n";
print "Locating the source file(s)...\t";
my $inputfile=undef;
if (-e $opt_infile) {$inputfile=$opt_infile;}
else {&amp;error(1,$opt_infile);}
my $tfile=undef;
if (-e $opt_tfile) {$tfile=$opt_tfile;}
else {&amp;error(3,$opt_tfile);}
my $sfile=undef;
if (-e $opt_sfile) {$sfile=$opt_sfile;}
else {&amp;error(4,$opt_sfile);}
print "[Done]\n";

#Reconfigure settings
if ($opt_comma) {
   print "Using comma format...\t\t";
   $opt_r=1;
   print "[OK]\n";
}

#Load up the input file with an index
print "Reading the input file...\t";
my $data;
my $index=0;
undef my @inputheader;
open (INFILE,"$inputfile") || &amp;error(2);
while (&lt;INFILE&gt;) {
    chomp ($_);
    if ($ifileheader &amp;&amp; !@inputheader) {@inputheader=split("\t",$_); next;}
    my @temp=split("\t",$_);
    $data-&gt;{$index}-&gt;{name}=$temp[$opt_ncol];
    $data-&gt;{$index}-&gt;{originalname}=$temp[$opt_ncol];
    if ($opt_r) {$data-&gt;{$index}-&gt;{reverse}=$opt_r;}
    elsif ($opt_rcol) {$data-&gt;{$index}-&gt;{reverse}=$temp[$opt_rcol];}
    else {$data-&gt;{$index}-&gt;{reverse}=0;}
    $data-&gt;{$index}-&gt;{sourcedata}=\@temp;
    $data-&gt;{$index}-&gt;{encoding}=0; #Flag encoding changes
    $data-&gt;{$index}-&gt;{discard}=0; #Flag names to be discarded
    $data-&gt;{$index}-&gt;{tussen}="";
    $index++;
}
close (INFILE);
print "[Done]\n";

#Force the encoding to Latin with spaces and hypens (no fullstops or other punctuations)
print "Forcing the names to Latin...\t";
foreach my $index (keys (%$data)){
    my $name=$data-&gt;{$index}-&gt;{name};
    $name=NFKD($name);
    $name=unidecode($name);    
    $name=&amp;purify($name);
    if ($name ne $data-&gt;{$index}-&gt;{originalname}) {$data-&gt;{$index}-&gt;{encoding}=1;}
    $name=~s/  / /g; #double spaces
    $name=~s/^ / /g; #start spaces
    $name=~s/ $/ /g; #end spaces
    $name=~s/_/ /g; #remove underscores
    $name=~s/-/_/g; #change hypens to underscores (alphanumberic)
    $name=~s/__/_/g; #Remove any double underscores
    if ($opt_comma) {$name=~s/,/__/g;}
    $name=~s/\W/ /g; #all non-word to space
    $name=~s/[0-9]/ /g; #all numbers to space
    if ($opt_comma) {$name=~s/__/,/g;}
    $name=~s/_/-/g; #hypens back
    $name=~s/\s{1,}/ /g; #duplicate spaces
    $name=~s/\s{0,1}-\s{0,1}/-/g; #hypen-spacing
    $data-&gt;{$index}-&gt;{name}=$name;
}
print "[Done]\n";

#Load up the stopwords hash with its meanings (1=true, 0=false/no-info) - col1 is removal place (0=safe, 1=frontonly, 2=backonly)
print "Loading the Stopwords...\t";
open (SFILE,"$sfile") || error(4);
my $stopwords={};
undef my @sheader;
while (&lt;SFILE&gt;) {
   chomp ($_);
   if (!@sheader){
      @sheader=split("\t",$_);
      shift(@sheader); shift(@sheader); #removes colheading for stopword and removalplace
      next;
   }
   my @temp=split("\t",$_);
   my $currentstopword=shift(@temp);
   my $removalplace=shift(@temp);
   $stopwords-&gt;{$currentstopword}-&gt;{place}=$removalplace;
   for (my $i=0;$i&lt;=$#temp;$i++) {
      $stopwords-&gt;{$currentstopword}-&gt;{$sheader[$i]}=$temp[$i];
   }
}
close (SFILE);
print "[Done]\n";

#Remove the stopwords and key the entries
print "Removing the Stopwords...\t";
foreach my $index (keys (%$data)){
   my $name=$data-&gt;{$index}-&gt;{name};
   my $stable=0;
   until ($stable==1) {
      $stable=1;
      foreach my $stopword (keys (%$stopwords)) {
         if ($stopword=~/Al/i) { #Make a special exception for "Al"
            $name=~s/ (Al)-(\w)/ $1$2/ig;
            $name=~s/(\w+) (Al)$/ $2$1/i;
         }
         if ($stopwords-&gt;{$stopword}-&gt;{place}==0) { #Front or Back is ok
            if ($name=~/^$stopword /i) {
               $name=~s/^$stopword //i;
               $stable=0;
               foreach my $stopkey (keys (%{$stopwords-&gt;{$stopword}})) {
                  $data-&gt;{$index}-&gt;{stopkeys}-&gt;{$stopkey}=$stopwords-&gt;{$stopword}-&gt;{$stopkey};
               }
            }
            if ($name=~/ $stopword$/i) {
               $name=~s/ $stopword$//i;
               $stable=0;
               foreach my $stopkey (keys (%{$stopwords-&gt;{$stopword}})) {
                  $data-&gt;{$index}-&gt;{stopkeys}-&gt;{$stopkey}=$stopwords-&gt;{$stopword}-&gt;{$stopkey};
               }
            }
         }
         elsif ($stopwords-&gt;{$stopword}-&gt;{place}==1) { #Only Front is ok
            if ($name=~/^$stopword /i) {
               if (scalar(my @temp=split(" ",$name))&lt;$min_nonames) {next;} #Don't throw away too much
               $name=~s/^$stopword //i;
               $stable=0;
               foreach my $stopkey (keys (%{$stopwords-&gt;{$stopword}})) {
                  $data-&gt;{$index}-&gt;{stopkeys}-&gt;{$stopkey}=$stopwords-&gt;{$stopword}-&gt;{$stopkey};
               }
            }            
         }
         elsif ($stopwords-&gt;{$stopword}-&gt;{place}==2) { #Only Back is ok
            if ($name=~/ $stopword$/i) {
               if (scalar(my @temp=split(" ",$name))&lt;$min_nonames) {next;} #Don't throw away too much
               $name=~s/ $stopword$//i;
               $stable=0;
               foreach my $stopkey (keys (%{$stopwords-&gt;{$stopword}})) {
                  $data-&gt;{$index}-&gt;{stopkeys}-&gt;{$stopkey}=$stopwords-&gt;{$stopword}-&gt;{$stopkey};
               }
            }            
         }
         $name=~s/\s{1,}/ /g;
         $name=~s/^\s//g;
         $name=~s/\s$//g;
         if ($name eq "") { #The entire string was stop words...
            $data-&gt;{$index}-&gt;{discard}=1;
            $stable=1;
         }
      }
   }
   $data-&gt;{$index}-&gt;{name}=$name;
}
print "[Done]\n";

if (!$opt_comma) { #Comma format names have thier tussen processed differently
   #Load the Tussenvoegsel file
   print "Loading the Tussenvoegsel...\t";
   open (TFILE,"$tfile") || error(3);
   my @tussen;
   while (&lt;TFILE&gt;) {
      chomp ($_);
      push (@tussen, $_);
   }
   close (TFILE);
   print "[Done]\n";
   
   #Process Tussenvoegsel
   print "Processing the Tussenvoegsel...\t";
   foreach my $index (keys (%$data)){
      if ($data-&gt;{$index}-&gt;{discard}) {next;}
      my $name=$data-&gt;{$index}-&gt;{name};
      foreach my $tussen (@tussen) {
         $name=~/^$tussen (.*)/i;
         if (defined ($1)){
            my $remaining=$1;
            if (!($remaining=~/ /i)){
               next; #Don't remove this (potential Tussen as it will compromise the name string)
            }
         }
         if ($data-&gt;{$index}-&gt;{reverse}==1) {
            if ($opt_tact==1) {#Remove the Tussen from the front
               if ($name=~s/^($tussen) //i) {$data-&gt;{$index}-&gt;{Tussen}=$1;}
            }
            else { #Collapse the Tussen to the name
               my $collapsedtussen=$tussen;
               $collapsedtussen=~s/ //g;
               if ($name=~s/^($tussen) /$collapsedtussen/i) {$data-&gt;{$index}-&gt;{Tussen}=$1;}
            }             
         }
         else {
            if ($opt_tact==1) {#Remove the Tussen from the back (barring the surname)
               if ($name=~s/ ($tussen) (\w{$min_length,})$/ $1/i) {$data-&gt;{$index}-&gt;{Tussen}=$1;}
            }
            else {  #Collapse the Tussen to the name
               my $collapsedtussen=$tussen;
               $collapsedtussen=~s/ //g;
               if ($name=~s/ ($tussen) (\w{$min_length,})/ $collapsedtussen$2/i) {$data-&gt;{$index}-&gt;{Tussen}=$1;}
            }           
         }
      }
      $data-&gt;{$index}-&gt;{name}=$name;
   }
   print "[Done]\n";
}
else {
   foreach my $index (keys (%$data)){
      if ($data-&gt;{$index}-&gt;{discard}) {next;}
      my $name=$data-&gt;{$index}-&gt;{name};
      my @nameparts=split(",",$name);
      $nameparts[0]=~s/ //g;
      $name=join("",@nameparts);
      $data-&gt;{$index}-&gt;{name}=$name;
   }
}

#Process Double-Barrelled Surnames
print "Processing Double-Barrels...\t";
foreach my $index (keys (%$data)){
   if ($data-&gt;{$index}-&gt;{discard}) {next;}
   my $name=$data-&gt;{$index}-&gt;{name};
   if ($opt_dact == 1) {
      $name=~s/-//g;
   }
   else {
      if ($name=~s/(\w+)-(\w+)/$2/) {$data-&gt;{$index}-&gt;{FirstBarrel}=$1;}
   }
   $data-&gt;{$index}-&gt;{name}=$name;
}
print "[Done]\n";

#Do the discards (of names that are too short or only one word)
print "Marking the discards...\t\t";
my $count=0;
my $discards=0;
foreach my $index (keys (%$data)){
   my $name=$data-&gt;{$index}-&gt;{name};
   my @temp=split(/ /,$name);
   if (scalar(@temp) &lt; $min_nonames) {
      my $name=$data-&gt;{$index}-&gt;{discard}=1;
      $discards++;
   }
   if ($data-&gt;{$index}-&gt;{reverse}) {
      if (length($temp[0])&lt;$min_length) {
         my $name=$data-&gt;{$index}-&gt;{discard}=1;
         $discards++;
      }
   }
   else {
      if (length($temp[$#temp])&lt;$min_length) {
         my $name=$data-&gt;{$index}-&gt;{discard}=1;
         $discards++;
      }
   }
   $count++;
}
print "[Discarded: $discards of $count]\n";

#Now "extract" the surname!
print "Extracting the surnames...\t";
foreach my $index (keys (%$data)){
   if ($data-&gt;{$index}-&gt;{discard}) {$data-&gt;{$index}-&gt;{surname}="NULL"; next;}
   my $name=$data-&gt;{$index}-&gt;{name};
   if ($data-&gt;{$index}-&gt;{reverse} == 1) {
      $name=~/^(\w{$min_length,}) /i;
      $data-&gt;{$index}-&gt;{surname}=ucfirst(lc($1));
   }
   else {
      $name=~/ (\w{$min_length,})$/i;
      $data-&gt;{$index}-&gt;{surname}=ucfirst(lc($1));
   }
   #Check the validity of the surname?
   if (!($data-&gt;{$index}-&gt;{surname}=~/^\w{$min_length,}$/)) {
      $data-&gt;{$index}-&gt;{surname}="INVALID";
      $data-&gt;{$index}-&gt;{discard}=1;
   }
}
print "[Done]\n";

#Now "extract" the firstname surname pair (no initials)
print "Extracting the name pairs...\t";
foreach my $index (keys (%$data)){
   if ($data-&gt;{$index}-&gt;{discard}) {$data-&gt;{$index}-&gt;{namepair}="NULL"; next;}
   my $name=$data-&gt;{$index}-&gt;{name};
   my $sup_length=$min_length-1;
   $name=~s/ \w{1,$sup_length}$//g;
   $name=~s/ \w{1,$sup_length} //g;
   $name=~s/^\w{1,$sup_length} //g;
   if ($data-&gt;{$index}-&gt;{reverse} == 1) {
      $name=~/^(\w{$min_length,}) (\w{$min_length,})/i;
      $data-&gt;{$index}-&gt;{namepair}=ucfirst(lc($2))." ".ucfirst(lc($1));
   }
   else {
      $name=~/^(\w{$min_length,}) .*?(\w{$min_length,})$/i;
      $data-&gt;{$index}-&gt;{namepair}=ucfirst(lc($1))." ".ucfirst(lc($2));
   }
   #Check the validity of the namepair?
   if (!($data-&gt;{$index}-&gt;{namepair}=~/^\w{$min_length,} \w{$min_length,}$/)) {
      $data-&gt;{$index}-&gt;{namepair}="INVALID";
      $data-&gt;{$index}-&gt;{discard}=1;
   }
}
print "[Done]\n";

#Finally produce the output file
print "Producing the output file...\t";
open (OUTFILE,"&gt;$opt_outfile") || die &amp;error(5);
print OUTFILE "Surname\tCleanedName\tOriginalName\tReversal\tEncoding\tDiscard";
foreach (@inputheader) {print OUTFILE "\t".$_;} #print up the original input headers
foreach (@sheader) {print OUTFILE "\t".$_;} #print up the stopword headers
print OUTFILE "\n";
foreach my $index (sort {$a cmp $b} (keys(%$data))){
   print OUTFILE $data-&gt;{$index}-&gt;{surname}."\t";
   print OUTFILE $data-&gt;{$index}-&gt;{namepair}."\t";
   print OUTFILE $data-&gt;{$index}-&gt;{originalname}."\t";
   print OUTFILE $data-&gt;{$index}-&gt;{reverse}."\t";
   print OUTFILE $data-&gt;{$index}-&gt;{encoding}."\t";
   print OUTFILE $data-&gt;{$index}-&gt;{discard};
   foreach (@{$data-&gt;{$index}-&gt;{sourcedata}}) {print OUTFILE "\t".$_;}
   if (defined ($data-&gt;{$index}-&gt;{stopkeys})) {
      foreach (@sheader) {print OUTFILE "\t".$data-&gt;{$index}-&gt;{stopkeys}-&gt;{$_};}
   }
   else {foreach (@sheader) {print OUTFILE "\t"."0";}} #insert the 0 value as defaults
   print OUTFILE "\n";
}
print "[Done]\n";
print "=======================================\n";
close (OUTFILE);
print "The output file ($opt_outfile) has been written...\t[Done]\n";
print "(c)Ed Egan, 2009. Please thank the author.\n";

###SUBROUTINES

#Remove unwanted characters generated using unidecode module
sub purify {
    my $name=shift(@_);
    $name=~s/A\!/A/g;
    $name=~s/A ([a-z])/A$1/g;
    $name=~s/A1\/2/A/g;
    $name=~s/A1\/4/A/g;
    $name=~s/A3\/4/A/g;
    $name=~s/A\|/A/g;
    $name=~s/A\+/A/g;
    $name=~s/A\$\?/A/g;
    $name=~s/A\&lt;\&lt;/A/g;
    $name=~s/Ac\//C/g;
    return $name;
}

#Prepare the error messages
sub error {
    my $error=shift(@_);
    my $otherinfo=shift(@_);
    if (defined($otherinfo)) {$otherinfo="(".$otherinfo.")";}
    if (!defined($otherinfo)) {$otherinfo="";}
    my %errormessages=(
    1=&gt;"An input file was specified but was not found",
    2=&gt;"An input file was found but could not be opened",
    3=&gt;"A Tussenvoegsel file was specified but not found",
    4=&gt;"A Stop Words file was specified but not found",  
    5=&gt;"The output file could not be opened"  
    );
    print "[Failed]\n";
    print "\n=======================================\n";
    print $errormessages{$error}.$otherinfo."\n";
    print "\n=======================================\n";
    print "Sorry for you troubles - Please try again\n";
    print "\n#######################################\n";
    exit;
}</pre></body></html>