package Sources::Address;

use strict;
use warnings;

use Mail::Address;


use vars qw(@ISA);

@ISA = qw( Mail::Address );

sub _extract_name
{
    local $_ = shift || '';

    # Bug in unicode \U, perl 5.8.0 breaks when casing utf8 in regex
    if($] eq 5.008)
    {   require utf8;
        eval 'utf8::downgrade($_)';
    }

    # trim whitespace
    s/^\s+//;
    s/\s+$//;
    s/\s+/ /;

    # Disregard numeric names (e.g. [EMAIL=123456.1234@compuserve.com]123456.1234@compuserve.com[/EMAIL])
    return "" if /^[\d ]+$/;

    # remove outermost parenthesis
    s/^\(|\)$//g;

    # remove outer quotation marks
    s/^"|"$//g;

    # remove embedded comments
    # s/[^\\]\(.*[^\\]\)//g;
    s/^\s*\(((?:[^)\\]+|\\.)*)\)//;

    # remove quotes
    s/\\(.)/$1/g;

    # reverse "Last, First M." if applicable
    s/^([^\s]+) ?, ?(.*)$/$2 $1/;
    s/,.*//;

    # Set the case of the name to first char upper rest lower
    # Upcase first letter on name
    s/\b([a-zA-ZäüöÄÜÖß]+)/\L\u$1/igo;

    # Scottish names such as 'McLeod'
    s/\bMc([a-zA-ZäüöÄÜÖß])/Mc\u$1/igo;

    # Irish names such as 'O'Malley, O'Reilly'
    s/\bo'([a-zA-ZäüöÄÜÖß])/O'\u$1/igo;

    # Roman numerals, eg 'Level III Support'
    s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo;

    # some cleanup
    s/\[[^\]]*\]//g;
    s/(^[\s'"]+|[\s'"]+$)//g;
    s/\s{2,}/ /g;

    return $_;
}

sub name
{
    my $me = shift;
    my $phrase = $me->phrase;
    my $addr = $me->address;

    $phrase = $me->comment unless(defined($phrase) && length($phrase));

    my $name = _extract_name($phrase);

    # first.last@domain address
    if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/o)
    {
	($name = $1) =~ s/[\._]+/ /go;
	$name = _extract_name($name);
    }

    if($name eq '' && $addr =~ m#/g=#oi)
    # X400 style address
    {
	my ($f) = $addr =~ m#g=([^/]*)#oi;
	my ($l) = $addr =~ m#s=([^/]*)#io;

	$name = _extract_name($f . " " . $l);
    }

    return length($name) ? $name : undef;
}

1;