File Coverage

blib/lib/Lingua/EN/NameCase.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	34	34	100.0
condition	18	21	85.7
subroutine	8	8	100.0
pod	2	2	100.0
total	149	152	98.0

package Lingua::EN::NameCase;

use warnings;
use strict;
use locale;

use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $HEBREW $SPANISH $ROMAN $POSTNOMINAL );

$VERSION = '1.19';

#--------------------------------------------------------------------------
# Modules

use Carp;
use Exporter();

@ISA        = qw( Exporter );
@EXPORT     = qw( nc );
@EXPORT_OK  = qw( NameCase nc );

#--------------------------------------------------------------------------
# Variables

$HEBREW         = 1;
$SPANISH        = 0;
$ROMAN          = 1;
$POSTNOMINAL    = 1;

my @POST_NOMINAL_INITIALS = qw(
    VC GC KG LG KT LT KP GCB OM GCSI GCMG GCIE GCVO GBE CH KCB DCB KCSI KCMG
    DCMG KCIE KCVO DCVO KBE DBE CB CSI CMG CIE CVO CBE DSO LVO OBE ISO MVO MBE
    IOM CGC RRC DSC MC DFC AFC ARRC OBI DCM CGM GM IDSM DSM MM DFM AFM SGM IOM
    CPM QGM RVM BEM QPM QFSM QAM CPM MSM ERD VD TD UD ED RD VRD AE

    PC ADC QHP QHS QHDS QHNS QHC SCJ J LJ QS SL QC KC JP DL MP MSP MSYP AM AM
    MLA MEP  DBEnv DConstMgt DREst EdD DPhil PhD DLitt DSocSci MD EngD DD LLD
    DProf MA MArch MAnth MSc MMORSE MMath MMathStat MPharm MPhil MSc MSci MSt
    MRes MEng MChem MBiochem MSocSc MMus LLM BCL MPhys MComp MAcc MFin MBA MPA
    MEd MEP MEnt MCGI MGeol MLitt MEarthSc MClinRes BA BSc LLB BEng MBChB FdA
    FdSc FdEng PgDip PgD PgCert PgC PgCLTHE AUH AKC AUS HNC HNCert HND HNDip
    DipHE Dip OND CertHE ACSM MCSM DIC AICSM ARSM ARCS LLB LLM BCL MJur DPhil
    PhD LLD DipLP FCILEx GCILEx ACILEx CQSW DipSW BSW MSW FCILT CMILT MILT CPL
    CTP CML PLS CTL DLP PLog EJLog ESLog EMLog JrLog Log SrLog BArch MArch ARB
    RIBA RIAS RIAI RSAW MB BM BS BCh BChir MRCS FRCS MS MCh. MRCP FRCP MRCPCH
    FRCPCH MRCPath MFPM FFPM BDS MRCPsych FRCPsych MRCOG FRCOG MCEM FCEM FRCA
    FFPMRCA MRCGP FRCGP BSc MScChiro MChiro MSc DC LFHOM MFHOM FFHOM FADO FBDO
    FCOptom MCOptom MOst DPT MCSP FCSP. SROT MSCR FSCR. CPhT RN VN RVN BVSc
    BVetMed VetMB BVM&S MRCVS FRCVS FAWM PGCAP PGCHE PGCE PGDE BEd NPQH QTS
    CSci CSciTeach RSci RSciTech CEng IEng EngTech ICTTech DEM MM CMarEng
    CMarSci CMarTech IMarEng MarEngTech RGN SRN RMN RSCN SEN EN RNMH RN RM RN1
    RNA RN2 RN3 RNMH RN4 RN5 RNLD RN6 RN8 RNC RN7 RN9 RHV RSN ROH RFHN SPAN
    SPMH SPCN SPLD SPHP SCHM SCLD SPCC SPDN V100 V200 V300 LPE MSc
);

#--------------------------------------------------------------------------
# Functions

sub NameCase {
    croak "Usage: \$SCALAR|\@ARRAY = NameCase [\\]\$SCALAR|\@ARRAY"
        if ref $_[0] and ( ref $_[0] ne 'ARRAY' and ref $_[0] ne 'SCALAR' );

    local( $_ );

    if( wantarray and ( scalar @_ > 1 or ref $_[0] eq 'ARRAY' ) ) {
        # We have received an array or array reference in a list context
        # so we will return an array.
        map { nc( $_ ) } @{ ref( $_[0] ) ? $_[0] : \@_ };

    } elsif( ref $_[0] eq 'ARRAY' ) {
        # We have received an array reference in a scalar or void context
        # so we will work on the array in-place.
        foreach ( @{ $_[0] } ) {
            $_ = nc( $_ );
        }

    } elsif( ref $_[0] eq 'SCALAR' ) {
        # We don't work on scalar references in-place; we take the value
        # and return a name-cased copy.
        nc( ${ $_[0] } );

    } elsif( scalar @_ == 1 ) {
        # We've received a scalar: we return a name-cased copy.
        nc( $_[0] );

    } else {
        croak "NameCase only accepts a single scalar, array or array ref";
    }
}

sub nc {
    croak "Usage: nc [[\\]\$SCALAR]"
        if scalar @_ > 1 or ( ref $_[0] and ref $_[0] ne 'SCALAR' );

    local( $_ ) = @_ if @_;
    $_ = ${$_} if ref( $_ ) ;           # Replace reference with value.

    return $_   unless($_);

    $_ = lc ;                           # Lowercase the lot.
    s{ \b (\w)   }{\u$1}gx;             # Uppercase first letter of every word.
    s{ (\'\w) \b }{\L$1}gx;             # Lowercase 's.

    # Name case Mcs and Macs - taken straight from NameParse.pm incl. comments.
    # Exclude names with 1-2 letters after prefix like Mack, Macky, Mace
    # Exclude names ending in a,c,i,o, or j are typically Polish or Italian

    if ( /\bMac[A-Za-z]{2,}[^aciozj]\b/ or /\bMc/ ) {
        s/\b(Ma?c)([A-Za-z]+)/$1\u$2/g;

        # Now correct for "Mac" exceptions
        s/\bMacEvicius/Macevicius/g;    # Lithuanian
        s/\bMacHado/Machado/g;          # Portuguese
        s/\bMacHar/Machar/g;
        s/\bMacHin/Machin/g;
        s/\bMacHlin/Machlin/g;
        s/\bMacIas/Macias/g;
        s/\bMacIulis/Maciulis/g;
        s/\bMacKie/Mackie/g;
        s/\bMacKle/Mackle/g;
        s/\bMacKlin/Macklin/g;
        s/\bMacQuarie/Macquarie/g;
        s/\bMacOmber/Macomber/g;
        s/\bMacIn/Macin/g;
        s/\bMacKintosh/Mackintosh/g;
        s/\bMacKen/Macken/g;
        s/\bMacHen/Machen/g;
        s/\bMacisaac/MacIsaac/g;
        s/\bMacHiel/Machiel/g;
        s/\bMacIol/Maciol/g;
        s/\bMacKell/Mackell/g;
        s/\bMacKlem/Macklem/g;
        s/\bMacKrell/Mackrell/g;
        s/\bMacLin/Maclin/g;
        s/\bMacKey/Mackey/g;
        s/\bMacKley/Mackley/g;
        s/\bMacHell/Machell/g;
        s/\bMacHon/Machon/g;
    }
    s/Macmurdo/MacMurdo/g;

    # Fixes for "son (daughter) of" etc. in various languages.
    s{ \b Al(?=\s+\w)  }{al}gx;                     # al Arabic or forename Al.
    s{ \b Ap        \b }{ap}gx;                     # ap Welsh.
    #  search for: followed by ben
    # without first (?<=\S\s), first name of 'ben jones' remains lowercase
    s{ (?<=\S\s)\bBen(?=\s+\w) }{ben}gx if $HEBREW; # ben Hebrew or forename Ben.
    s{ (?<=\S\s)\bBat(?=\s+\w) }{bat}gx if $HEBREW; # bat Hebrew or forename Bat.
    s{ \b Dell([ae])\b }{dell$1}gx;                 # della and delle Italian.
    s{ \b D([aeiu]) \b }{d$1}gx;                    # da, de, di Italian; du French.
    s{ \b De([lr])  \b }{de$1}gx;                   # del Italian; der Dutch/Flemish.
    s{ \b El        \b }{el}gx  unless $SPANISH;    # el Greek or El Spanish.
    s{ \b La        \b }{la}gx  unless $SPANISH;    # la French or La Spanish.
    s{ \b L([eo])   \b }{l$1}gx;                    # lo Italian; le French.
    s{ \b Van(?=\s+\w) }{van}gx;                    # van German or forename Van.
    s{ \b Von       \b }{von}gx;                    # von Dutch/Flemish

    if($ROMAN) {
        # Fixes for roman numeral names, e.g. Henry VIII, up to 89, LXXXIX
        s{ \b ( (?: [Xx]{1,3} | [Xx][Ll]   | [Ll][Xx]{0,3} )?
                (?: [Ii]{1,3} | [Ii][VvXx] | [Vv][Ii]{0,3} )? ) \b }{\U$1}gx;
    }

    if($POSTNOMINAL) {
        # post-nominal initials
        for my $pni (@POST_NOMINAL_INITIALS) {
            s{ \b ($pni)    $}{$pni}ix;
        }
    }

    $_;
}

1;

__END__