Lingua::EN::NameParse - routines for manipulating a person's name

    use Lingua::EN::NameParse qw(clean case_surname);

    # optional configuration arguments
    my %args =
    (
        auto_clean      => 1,
        force_case      => 1,
        lc_prefix       => 1,
        initials        => 3,
        allow_reversed  => 1,
        joint_names     => 0,
        extended_titles => 0
    );

    my $name = new Lingua::EN::NameParse(%args);

    $error = $name->parse("MR AC DE SILVA");

    %name_comps = $name->components;
    $surname = $name_comps{surname_1}; # DE SILVA

    $correct_casing = $name->case_all; # Mr AC de Silva

    $correct_casing = $name->case_all_reversed ; # de Silva, AC

    $good_name = &clean("Bad Na9me   "); # "Bad Name"

    $salutation = $name->salutation(salutation => 'Dear',sal_default => 'Friend')); # Dear Mr de Silva

    %my_properties = $name->properties;
    $number_surnames = $my_properties{number}; # 1
    $bad_input = $my_properties{non_matching};

    $name->report; # create a report listing all information about the parsed name

    $lc_prefix = 0;
    $correct_case = &case_surname("DE SILVA-MACNAY",$lc_prefix); # De Silva-MacNay

    Mr AB & M/s CD MacNay-Smith
    MR J.L. D'ANGELO
    Estate Of The Late Lieutenant Colonel AB Van Der Heiden

   converting upper or lower case values to name case (Mr AB MacNay   )
   creating a personalised greeting or salutation     (Dear Mr MacNay )
   extracting the names individual components         (Mr,AB,MacNay   )
   determining the type of format the name is in      (Mr_A_Smith     )

   Precursor   - Estate of (The Late), Right Honourable ...
   Title       - Mr, Mrs, Ms., Sir, Dr, Major, Reverend ...
   Conjunction - word to separate names or initials, such as "And"
   Initials    - 1-3 letters, each with an optional space and/or dot
   Surname     - De Silva, Van Der Heiden, MacNay-Smith, O'Reilly ...
   Suffix      - Snr., Jnr, III, V ...

    Mr_John_Smith_&_Ms_Mary_Jones
    Mr_A_Smith_&_Ms_B_Jones
    Mr_&_Ms_A_&_B_Smith
    Mr_A_&_Ms_B_Smith
    Mr_&_Ms_A_Smith
    Mr_A_&_B_Smith
    John_Smith_&_Mary_Jones
    John_&_Mary_Smith
    A_Smith_&_B_Jones

    Mr_John_Adam_Smith
    Mr_John_A_Smith
    Mr_J_Adam_Smith
    Mr_John_Smith
    Mr_A_Smith
    John_Adam_Smith
    John_A_Smith
    J_Adam_Smith
    John_Smith
    A_Smith
    John

   my %args =
   (
      auto_clean     => 1,
      force_case     => 1,
      lc_prefix      => 1,
      initials       => 3,
      allow_reversed => 1
   );




   my $name = new Lingua::EN::NameParse(%args);

    $error = $name->parse("MR AC DE SILVA");

    $correct_casing = $name->case_all;

   initials remain capitalised
   surname spelling such as MacNay-Smith, O'Brien and Van Der Heiden are preserved
   - see C<surname_prefs.txt> for user defined exceptions

    $correct_casing = $name->case_all_reversed;

   %my_name = $name->case_components;
   $cased_surname = $my_name{surname_1};

   precursor
   title_1
   title_2
   given_name_1
   given_name_2
   initials_1
   initials_2
   middle_name
   conjunction_1
   conjunction_2
   surname_1
   surname_2
   suffix

   %name = $name->components;
   $surname = $my_name{surname_1};

   $correct_casing = &case_surname("DE SILVA-MACNAY" [,$lc_prefix]);

   Macquarie
   MacHado

    $salutation = $name->salutation(salutation => 'Dear',sal_default => 'Friend',sal_type => 'given_name'));

    salutation:

    The greeting word such as 'Dear' or 'Greetings'. If not spefied than 'Dear' is used

    sal_default:

    The default word used when a personalised salution cannot be generated. If not
    specified, than 'Friend' is used.

    sal_type:

    Can be either 'given_name' such as 'Dear Sue' or 'title_plus_name' such as 'Dear Ms Smith'
    If not specified, than 'given_name' is used.

   $good_name = &clean("Bad Na9me");

   all repeating spaces removed
   all characters not in the set (A-Z a-z - ' , . &) removed

   Macbeth or MacBeth, are both valid spellings
   Is ED WOOD E.D. Wood or Edward Wood
   Is 'Mr Rapid Print' a name or a company
   Does  John Bradfield Smith have a middle name of Bradfield, or a surname of Bradfield-Smith?

   Add filtering of very long names
   Add diagnostic messages explaining why parsing failed
   Add transforming methods to do things like remove dots from initials
   Try to derive gender (Mr... is male, Ms, Mrs... is female)

   QM Industries <http://www.qmi.com.au>
   Damian Conway,  author of Parse::RecDescent
   Mark Summerfield author of Lingua::EN::NameCase,
   Ron Savage, Alastair Adam Huffman, Douglas Wilson
   Peter Schendzielorz

#-------------------------------------------------------------------------------

package Lingua::EN::NameParse;

use strict;
use warnings;

use Lingua::EN::NameParse::Grammar;
use Parse::RecDescent;

use Exporter;
use vars qw (@ISA @EXPORT_OK);

our $VERSION = '1.30';
@ISA       = qw(Exporter);
@EXPORT_OK = qw(&clean &case_surname);

#-------------------------------------------------------------------------------
# Create a new instance of a name parsing object. This step is time consuming
# and should normally only be called once in your program.

sub new
{
    my $class = shift;
    my %args = @_;
    
    my $name = {};
    bless($name,$class);
    
    # Default to 2 initials per name. Can be overwritten if user defines
    # 'initials' as a key in the hash supplied to new method.
    $name->{initials} = 2;
    
    my $current_key;
    foreach my $current_key (keys %args)
    {
        $name->{$current_key} = $args{$current_key};
    }
    
    my $grammar = &Lingua::EN::NameParse::Grammar::_create($name);
    $name->{parse} = new Parse::RecDescent($grammar);
    
    return ($name);
}
#-------------------------------------------------------------------------------
# Attempt to parse a string and retrieve it's components and properties
# Requires a name object to have been created with the 'new' method'
# Returns: an error code, 0 for success, 1 for failure

sub parse
{
    my $name = shift;
    my ($input_string) = @_;
    
    chomp($input_string);
    
    # If reverse ordered names are allowed, swap the surname component, before
    # the comma, with the rest of the name. Rejoin the name, replacing comma
    # with a space.
    
    if ( $name->{allow_reversed} and $input_string =~ /,/ )
    {   
        my ($first,$second) = split(/,/,$input_string);
        $input_string = join(' ',$second,$first);
    }
    
    $name->{components} = ();
    $name->{properties} = ();
    $name->{properties}{type} = 'unknown';
    $name->{error} = 0;
    
    $name->{input_string} = $input_string;
    
    $name = &_pre_parse($name);
    unless ( $name->{error} )
    {
        $name = &_assemble($name);
        &_validate($name);
    
        if ( $name->{error} and $name->{auto_clean} )
        {
            $name->{input_string} = &clean($name->{input_string});
            $name = &_assemble($name);
            &_validate($name);
        }
    }

   return($name->{error});
}
#-------------------------------------------------------------------------------
# Clean the input string. Can be called as a stand alone function.

sub clean
{
    my ($input_string) = @_;
    
    # remove illegal characters
    $input_string =~ s/[^A-Za-z\-\'\.&\/ ]//go;
    
    # remove repeating spaces
    $input_string =~ s/  +/ /go ;
    
    # remove any remaining leading or trailing space
    $input_string =~ s/^ //;
    $input_string =~ s/ $//;
    
    return($input_string);
}
#-------------------------------------------------------------------------------
# Given a name object, returns all components in a hash

sub components
{
    my $name = shift;
    if ( $name->{properties}{type} eq 'unknown'  )
    {
        return(undef);
    }
    else
    {
        return(%{ $name->{components} });
    }
}
#-------------------------------------------------------------------------------
# Given a name object, apply correct capitalisation to each component of a
# person's name. Return all cased components in a hash.

sub case_components
{
    my $name = shift;

    if ( $name->{properties}{type} eq 'unknown'  )
    {
        return(undef);
    }
    else
    {
        my %orig_components = $name->components;

        my ($current_key,%cased_components);
        foreach $current_key ( keys %orig_components )
        {
            my $cased_value;
            if ( $current_key =~ /initials/ ) # initials_1, possibly initials_2
            {
                $cased_value = uc($orig_components{$current_key});
            }
            elsif ( $current_key =~ /surname|suffix/ )
            {
               $cased_value = &case_surname($orig_components{$current_key},$name->{lc_prefix});
            }
            else
            {
                $cased_value = &_case_word($orig_components{$current_key});
            }

            $cased_components{$current_key} = $cased_value;
        }
        return(%cased_components);
    }
}

#-------------------------------------------------------------------------------
# Hash of of lists, indicating the order that name components are assembled in.
# Each list element is itself the name of the key value in a name object.
# Used by the case_all and case_all_reversed  methods.
# These hashes are created here globally, as quite a large overhead is
# imposed if the are created locally, each time the method is invoked

my %component_order=
(
    'Mr_John_Smith_&_Ms_Mary_Jones' => ['title_1','given_name_1','surname_1','conjunction_1','title_2','given_name_2','surname_2'],
    'Mr_A_Smith_&_Ms_B_Jones' => ['title_1','initials_1','surname_1','conjunction_1','title_2','initials_2','surname_2'],
    'Mr_&_Ms_A_&_B_Smith'     => ['title_1','conjunction_1','title_2','initials_1','conjunction_1','initials_2','surname_1'],
    'Mr_A_&_Ms_B_Smith'       => ['title_1','initials_1','conjunction_1','title_2','initials_2','surname_1'],
    'Mr_&_Ms_A_Smith'         => ['title_1','conjunction_1','title_2','initials_1','surname_1'],
    'Mr_A_&_B_Smith'          => ['title_1','initials_1','conjunction_1','initials_2','surname_1'],
    'John_Smith_&_Mary_Jones' => ['given_name_1','surname_1','conjunction_1','given_name_2','surname_2'],
    'John_&_Mary_Smith'       => ['given_name_1','conjunction_1','given_name_2','surname_1'],
    'A_Smith_&_B_Jones'       => ['initials_1','surname_1','conjunction_1','initials_2','surname_2'],

    'Mr_John_Adam_Smith'      => ['precursor','title_1','given_name_1','middle_name','surname_1','suffix'],
    'Mr_John_A_Smith'         => ['precursor','title_1','given_name_1','initials_1','surname_1','suffix'],
    'Mr_J_Adam_Smith'         => ['precursor','title_1','initials_1','middle_name','surname_1','suffix'],    
    'Mr_John_Smith'           => ['precursor','title_1','given_name_1','surname_1','suffix'],
    'Mr_A_Smith'              => ['precursor','title_1','initials_1','surname_1','suffix'],
    'John_Adam_Smith'         => ['precursor','given_name_1','middle_name','surname_1','suffix'],
    'John_A_Smith'            => ['precursor','given_name_1','initials_1','surname_1','suffix'],
    'J_Adam_Smith'            => ['precursor','initials_1','middle_name','surname_1','suffix'],
    'John_Smith'              => ['precursor','given_name_1','surname_1','suffix'],
    'A_Smith'                 => ['precursor','initials_1','surname_1','suffix'],
    'John'                    => ['given_name_1']
);


# only include names with a single surname
my %reverse_component_order=
(
   'Mr_&_Ms_A_&_B_Smith'  => ['surname_1','title_1','conjunction_1','title_2','initials_1','conjunction_1','initials_2'],
   'Mr_A_&_Ms_B_Smith'    => ['surname_1','title_1','initials_1','conjunction_1','title_2','initials_2'],
   'Mr_&_Ms_A_Smith'      => ['surname_1','title_1','title_1','conjunction_1','title_2','initials_1'],    
   'Mr_A_&_B_Smith'       => ['surname_1','title_1','initials_1','conjunction_1','initials_2'],
   'John_&_Mary_Smith'    => ['surname_1','given_name_1','conjunction_1','given_name_2'],
   
   'Mr_John_Adam_Smith'   => ['surname_1','title_1','given_name_1','middle_name','suffix'],
   'Mr_John_A_Smith'      => ['surname_1','title_1','given_name_1','initials_1','suffix'],
   'Mr_J_Adam_Smith'      => ['surname_1','title_1','initials_1','middle_name','suffix'],   
   'Mr_John_Smith'        => ['surname_1','title_1','given_name_1','suffix'],
   'Mr_A_Smith'           => ['surname_1','title_1','initials_1','suffix'],
   'John_Adam_Smith'      => ['surname_1','given_name_1','middle_name','suffix'],
   'John_A_Smith'         => ['surname_1','given_name_1','initials_1','suffix'],
   'J_Adam_Smith'         => ['surname_1','initials_1','middle_name','suffix'],
   'John_Smith'           => ['surname_1','given_name_1','suffix'],
   'A_Smith'              => ['surname_1','initials_1','suffix']
);

#-------------------------------------------------------------------------------
# Apply correct capitalisation to a person's entire name
# If the name type is unknown, return undef
# Else, return a string of all cased components in correct order

sub case_all
{
    my $name = shift;
    
    my @cased_name;
    
    if ( $name->{properties}{type} eq 'unknown' )
    {
        return undef; 
    }
    
    unless ( $component_order{$name->{properties}{type}} )
    {
        # component order missing in array defined above
        warn "Component order not defined for: $name->{properties}{type}";
        return undef;
    }
        
    my %component_vals = $name->case_components;
    my @order = @{ $component_order{$name->{properties}{type}} };
    
    foreach my $component_key ( @order )
    {
        # As some components such as precursors are optional, they will appear
        # in the order array but may or may not have have a value, so only
        # process defined values
        if ( $component_vals{$component_key} )
        {
           push(@cased_name,$component_vals{$component_key});
        }
    }
    if ( $name->{error} and $name->{force_case} )
    {
       # Despite errors, try to name case non-matching section. As the format
       # of this section is unknown, surname case will provide the best
       # approximation, but still fail on initials of more than 1 letter
       push(@cased_name,&case_surname($name->{properties}{non_matching},$name->{lc_prefix}));
    }
    
    return(join(' ',@cased_name));    
}
    
#-------------------------------------------------------------------------------

sub case_all_reversed
{
    my $name = shift;
    
    my @cased_name_reversed;
    
    unless ( $name->{properties}{type} eq 'unknown'  )
    {
        unless ( $reverse_component_order{$name->{properties}{type} } )
        {
            # this type of name should not be reversed, such as two surnames
            return undef;    
        }
        my %component_vals = $name->case_components;
        my @reverse_order = @{ $reverse_component_order{$name->{properties}{type} } };
        
        foreach my $component_key ( @reverse_order )
        {
            # As some components such as precursors are optional, they will appear
            # in the order array but may or may not have have a value, so only
            # process defined values
            
            my $component_value = $component_vals{$component_key};
            if ( $component_value )
            {
                if ($component_key eq 'surname_1')
                {
                    $component_value .= ',';
                }
                push(@cased_name_reversed,$component_value);
            }
        }
    }
    return(join(' ',@cased_name_reversed));
}
#-------------------------------------------------------------------------------
# The user may specify their own preferred spelling for surnames.
# These should be placed in a text file called surname_prefs.txt
# in the same location as the module itself.

BEGIN
{
   # Obtain the full path to NameParse module, defined in the %INC hash.
   my $prefs_file_location = $INC{"Lingua/EN/NameParse.pm"};
   # Now substitute the name of the preferences file
   $prefs_file_location =~ s/NameParse\.pm$/surname_prefs.txt/;

   if ( open(PREFERENCES_FH,"<$prefs_file_location") )
   {
      my @surnames = <PREFERENCES_FH>;
      foreach my $name ( @surnames )
      {
         chomp($name);
         # Build hash, lower case name is key for case insensitive
         # comparison, while value holds the actual capitalisation
         $Lingua::EN::surname_preferences{lc($name)} = $name;
      }
      close(PREFERENCES_FH);
   }
}
#-------------------------------------------------------------------------------
# Apply correct capitalisation to a person's surname. Can be called as a
# stand alone function.

sub case_surname
{
    my ($surname,$lc_prefix) = @_;

    # If the user has specified a preferred capitalisation for this
    # surname in the surname_prefs.txt, it should be returned now.
    if ($Lingua::EN::surname_preferences{lc($surname)} )
    {
        return($Lingua::EN::surname_preferences{lc($surname)});
    }

    # Lowercase everything
    $surname = lc($surname);

    # Now uppercase first letter of every word. By checking on word boundaries,
    # we will account for apostrophes (D'Angelo) and hyphenated names
    $surname =~ s/\b(\w)/\u$1/g;

    # Name case Macs and Mcs
    # Exclude names with 1-2 letters after prefix like Mack, Macky, Mace
    # Exclude names ending in a,c,i,o,z or j, typically Polish or Italian

    if ( $surname =~ /\bMac[a-z]{2,}[^a|c|i|o|z|j]\b/i  )
    {
        $surname =~ s/\b(Mac)([a-z]+)/$1\u$2/ig;

        # Now correct for "Mac" exceptions
        $surname =~ s/MacHin/Machin/;
        $surname =~ s/MacHlin/Machlin/;
        $surname =~ s/MacHar/Machar/;
        $surname =~ s/MacKle/Mackle/;
        $surname =~ s/MacKlin/Macklin/;
        $surname =~ s/MacKie/Mackie/;

        # Portuguese
        $surname =~ s/MacHado/Machado/;

        # Lithuanian
        $surname =~ s/MacEvicius/Macevicius/;
        $surname =~ s/MacIulis/Maciulis/;
        $surname =~ s/MacIas/Macias/;
    }
    elsif ( $surname =~ /\bMc/i )
    {
        $surname =~ s/\b(Mc)([a-z]+)/$1\u$2/ig;
    }
    # Exceptions (only 'Mac' name ending in 'o' ?)
    $surname =~ s/Macmurdo/MacMurdo/;


    if ( $lc_prefix )
    {
        # Lowercase first letter of every word in prefix. The trailing space
        # prevents the surname from being altered. Note that spellings like
        # d'Angelo are not accounted for.
        $surname =~ s/\b(\w+ )/\l$1/g;
    }

    # Correct for possessives such as "John's" or "Australia's". Although this
    # should not occur in a person's name, they are valid for proper names.
    # As this subroutine may be used to capitalise words other than names,
    # we may need to account for this case. Note that the 's' must be at the
    # end of the string
    $surname =~ s/(\w+)'S(\s+)/$1's$2/;
    $surname =~ s/(\w+)'S$/$1's/;

    # Correct for roman numerals, excluding single letter cases I,V and X,
    # which will work with the above code
    $surname =~ s/\b(I{2,3})\b/\U$1/i;  # 2nd, 3rd
    $surname =~ s/\b(IV)\b/\U$1/i;      # 4th
    $surname =~ s/\b(VI{1,3})\b/\U$1/i; # 6th, 7th, 8th
    $surname =~ s/\b(IX)\b/\U$1/i;      # 9th
    $surname =~ s/\b(XI{1,3})\b/\U$1/i; # 11th, 12th, 13th

    return($surname);
}
#-------------------------------------------------------------------------------
# Create a personalised greeting from one or two person's names
# Returns the salutation as a string, such as "Dear Mr Smith", or "Dear Sue"

sub salutation
{
    my $name = shift;
    my %args = @_;
    
    my $salutation = 'Dear';
    my $sal_default = 'Friend';
    my $sal_type = 'title_plus_surname';

    # Check to see if we should override defualts with any user specified preferences
    if ( %args )
    {
        foreach my $current_key (keys %args)
        {        
            $current_key eq 'salutation' and $salutation = $args{$current_key};
            $current_key eq 'sal_default' and $sal_default = $args{$current_key};
            $current_key eq 'sal_type' and $sal_type = $args{$current_key};
        }
    }
    

    my @greeting;
    push(@greeting,$salutation);
    
    # Personalised salutations cannot be created for Estates or people
    # without some title
    if
    (
        $name->{error} or
        ( $name->{components}{precursor} and  $name->{components}{precursor} =~ /Estate/i)
    )
    {    
        # Despite an error, the presence of a conjunction probably
        # means we are dealing with 2 or more people.
        # For example Mr AB Smith & John Jones
        if ( $name->{input_string} =~ / (And|&) /i )
        {
           $sal_default .= 's';
        }
        push(@greeting,$sal_default);
    }
    else
    {
        my %component_vals = $name->case_components;
        
        if ( $sal_type eq 'given_name')
        {
            if ( $component_vals{'given_name_1'} )
            {
                push(@greeting,$component_vals{'given_name_1'});
                if ( $component_vals{'given_name_2'} )
                {
                    push(@greeting,$component_vals{'conjunction_1'});
                    push(@greeting,$component_vals{'given_name_2'});
                }
            }
            else
            {
                # No given name such as 'A_Smith','J_Adam_Smith','Mr_A_Smith'
                # Must use default
                push(@greeting,$sal_default);
            }
        }
        elsif ( $sal_type eq 'title_plus_surname' )
        {
            if ( $name->{properties}{number} == 1 )
            {            
                if ( $component_vals{'title_1'} )
                {
                    push(@greeting,$component_vals{'title_1'});
                    push(@greeting,$component_vals{'surname_1'});
                }
                else
                {
                    # No title such as 'A_Smith','J_Adam_Smith', so must use default
                    push(@greeting,$sal_default);
                }
            }
            elsif ( $name->{properties}{number} == 2 )
            {
                # a joint name
                
                my $type = $name->{properties}{type};
                if ( $type eq 'Mr_&_Ms_A_Smith' or $type eq 'Mr_A_&_Ms_B_Smith' or $type eq 'Mr_&_Ms_A_&_B_Smith' )
                {
                    # common surname
                    push(@greeting,$component_vals{'title_1'});
                    push(@greeting,$component_vals{'conjunction_1'});
                    push(@greeting,$component_vals{'title_2'});
                    push(@greeting,$component_vals{'surname_1'});
                    
                }
                elsif ( $type eq 'Mr_A_Smith_&_Ms_B_Jones' or $type eq 'Mr_John_Smith_&_Ms_Mary_Jones' )
                {
                    push(@greeting,$component_vals{'title_1'});
                    push(@greeting,$component_vals{'surname_1'});                    
                    push(@greeting,$component_vals{'conjunction_1'});
                    push(@greeting,$component_vals{'title_2'});
                    push(@greeting,$component_vals{'surname_2'});                                        
                }
                else
                {
                    # No title such as A_Smith_&_B_Jones', 'John_Smith_&_Mary_Jones'
                    # Must use default
                    push(@greeting,$sal_default);
                }
            }            
        }
        else
        {
            warn "Invalid sal_type : ", $sal_type;
            push(@greeting,$sal_default);
        }
    }
    return(join(' ',@greeting));
}
#-------------------------------------------------------------------------------
# Return all name properties as a hash

sub properties
{
    my $name = shift;
    return(%{ $name->{properties} });
}

#-------------------------------------------------------------------------------
# Create a text report to standard output listing 
# - the input string, 
# - the name of each defined component, if it exists 
# - any non matching component

sub report
{
    my $name = shift;

    printf("%-17.17s : %-40.40s\n","Input",$name->{input_string});
    
    my %props = $name->properties;
    unless ($props{type} eq 'unknown')
    {
        my %comps = $name->case_components;
        if ( %comps )
        {
            foreach my $comp ( sort keys %comps)
            {
                printf("%-17.17s : %s\n",$comp,$comps{$comp});
            }
        }
    }

    if ( $props{type} )
    {
        printf("%-17.17s : %-40.40s\n","Name type",$props{type});
    }

    if ( $props{non_matching} )
    {
        printf("%-17.17s : %-40.40s\n","Parsing Error","Yes");
        printf("%-17.17s : %-40.40s\n","Non matching part",$props{non_matching});
    }
}
#-------------------------------------------------------------------------------

# PRIVATE METHODS

#-------------------------------------------------------------------------------

sub _pre_parse
{
    my $name = shift;
    # Check that common reserved word (as found in company names) do not appear
    if ( $name->{input_string} =~ 
         /\bPty\.? Ltd\.?$|\bLtd\.?$|\bPLC$|Association|Department|National|Society/i )
    {
        $name->{error} = 1;
        $name->{properties}{non_matching} = $name->{input_string};
    }
    
    # For the case of a single name such as 'Voltaire' we need to add a trailing space
    # to the input string. This is because the grammar tree expects a terminator (the space)
    # optionally followed by other productions or non matching text
   if ( $name->{input_string} =~ /^[A-Z]{2,}(\-)?[A-Z]{0,}$/i )
    {
        $name->{input_string} .= ' ';
    }
    return($name);

}
#-------------------------------------------------------------------------------
# Initialise all components to empty string. Assemble hashes of components 
# and properties as part of the name object
# 
sub _assemble
{
    my $name = shift;
    
    # $::RD_TRACE  = 1;  # for debugging RecDescent output
    # Use Parse::RecDescent to do the parsing. 'full_name' is a label for the complete grammar tree
    # defined in Lingua::EN::NameParse::Grammar
    my $parsed_name = $name->{parse}->full_name($name->{input_string});
    
    # Place components into a separate hash, so they can be easily returned
    # for the user to inspect and modify.
    
    # For correct matching, the grammar of each component must include the
    # trailing space that separates it from any following word. This should
    # now be removed from the components, and will be restored by the
    # case_all and salutation methods, if called.
    
    $name->{components}{precursor} = q{};
    if ( $parsed_name->{precursor} )
    {
        $name->{components}{precursor} = &_trim_space($parsed_name->{precursor});
    }
    
    $name->{components}{title_1} = q{};
    if ( $parsed_name->{title_1} )
    {
        $name->{components}{title_1} = &_trim_space($parsed_name->{title_1});
    }
    
    $name->{components}{title_2} = q{};
    if ( $parsed_name->{title_2} )
    {
        $name->{components}{title_2} = &_trim_space($parsed_name->{title_2});
    }
    
    $name->{components}{given_name_1} = q{};
    if ( $parsed_name->{given_name_1} )
    {
        $name->{components}{given_name_1} = &_trim_space($parsed_name->{given_name_1});
    }
    
    $name->{components}{given_name_2} = q{};
    if ( $parsed_name->{given_name_2} )
    {
        $name->{components}{given_name_2} = &_trim_space($parsed_name->{given_name_2});
    }
    
    
    $name->{components}{middle_name} = q{};
    if ( $parsed_name->{middle_name} )
    {
        $name->{components}{middle_name} = &_trim_space($parsed_name->{middle_name});
    }
    
    $name->{components}{initials_1} = q{};
    if ( $parsed_name->{initials_1} )
    {
        $name->{components}{initials_1} = &_trim_space($parsed_name->{initials_1});
    }
    
    $name->{components}{initials_2} = q{};
    if ( $parsed_name->{initials_2} )
    {
        $name->{components}{initials_2} = &_trim_space($parsed_name->{initials_2});
    }
    
    $name->{components}{conjunction_1} = q{};
    if ( $parsed_name->{conjunction_1} )
    {
        $name->{components}{conjunction_1} = &_trim_space($parsed_name->{conjunction_1});
    }
    
    $name->{components}{conjunction_2} = q{};
    if ( $parsed_name->{conjunction_2} )
    {
        $name->{components}{conjunction_2} = &_trim_space($parsed_name->{conjunction_2});
    }
    
    $name->{components}{surname_1} = q{};
    if ( $parsed_name->{surname_1} )
    {
        $name->{components}{surname_1} = &_trim_space($parsed_name->{surname_1});
    }
    
    $name->{components}{surname_2} = q{};
    if ( $parsed_name->{surname_2} )
    {
        $name->{components}{surname_2} = &_trim_space($parsed_name->{surname_2});
    }
    
    $name->{components}{suffix} = q{};
    if ( $parsed_name->{suffix} )
    {
        $name->{components}{suffix} = &_trim_space($parsed_name->{suffix});
    }
    
    
    $name->{properties}{non_matching} = q{};
    if ( $parsed_name->{non_matching} ) 
    {
        $name->{properties}{non_matching}  = $parsed_name->{non_matching};
    }
    
    $name->{properties}{number} = 0;     
    $name->{properties}{number} = $parsed_name->{number};
    $name->{properties}{type}   = $parsed_name->{type};
    
    return($name);
}
#-------------------------------------------------------------------------------
# Remove any trailing spaces

sub _trim_space
{
    my ($string) = @_;
    $string =~ s/ $//;
    return($string);
}
#-------------------------------------------------------------------------------
# Check if any name components have illegal characters, or do not have the
# correct syntax for a valid name.


sub _validate
{
    my $name = shift;
    
    if ( $name->{properties}{non_matching} )
    {
        $name->{error} = 1;
    }
    # illegal characters found
    elsif ( $name->{input_string} =~ /[^A-Za-z\-\'\.,&\/ ]/ )
    {
        $name->{error} = 1;
    }
    elsif ( not &_valid_name($name->{components}{given_name_1}) )
    {
        $name->{error} = 1;
    }
    elsif ( not &_valid_name($name->{components}{middle_name}) )
    {
        $name->{error} = 1;
    }
    
    elsif ( not &_valid_name($name->{components}{surname_1}) )
    {
        $name->{error} = 1;
    }
    elsif ( not &_valid_name($name->{components}{surname_2}) )
    {
        $name->{error} = 1;
    }
    else
    {
        $name->{error} = 0;
    }
}
#-------------------------------------------------------------------------------
# If the name has an assigned value, check that it contains a vowel sound,
# or matches the exceptions to this rule.
# Returns 1 if name is valid, otherwise 0

sub _valid_name
{
    my ($name) = @_;
    if ( not $name )
    {
        return(1);
    }
    # Names should have a vowel sound, 
    # valid exceptions are Ng, Tsz,Md, Cng,Hng,Chng etc
    elsif ( $name and $name =~ /[aeiouyj]|^(ng|tsz|md|(c?h|[pts])ng)$/i )
    {
        return(1);
    }
    else
    {
        return(0);
    }
}
#-------------------------------------------------------------------------------
# Upper case first letter, lower case the rest, for all words in string
sub _case_word
{
    my ($word) = @_;
    
    $word =~ s/(\w+)/\u\L$1/g;
    return($word);
}
#-------------------------------------------------------------------------------
return(1);