lib/Text/Names/Abbreviate.pm

        start → end → jump
        

    1: package Text::Names::Abbreviate;
    2: 
    3: use strict;
    4: use warnings;
    5: use autodie qw(:all);
    6: use utf8;
    7: 
    8: use Carp;
    9: use Exporter 'import';
   10: use Params::Get 0.13;
   11: use Params::Validate::Strict 0.13;
   12: use Readonly;
   13: use Unicode::Normalize ();
   14: 
   15: our @EXPORT_OK = qw(abbreviate);
   16: 
   17: =head1 NAME
   18: 
   19: Text::Names::Abbreviate - Create abbreviated name formats from full names
   20: 
   21: =head2 VERSION
   22: 
   23: Version 0.04
   24: 
   25: =cut
   26: 
   27: our $VERSION = '0.04';
   28: 
   29: # ---------------------------------------------------------------------------
   30: # Named constants -- eliminate magic strings throughout the logic
   31: # ---------------------------------------------------------------------------
   32: Readonly my $FMT_DEFAULT   => 'default';
   33: Readonly my $FMT_INITIALS  => 'initials';
   34: Readonly my $FMT_COMPACT   => 'compact';
   35: Readonly my $FMT_SHORTLAST => 'shortlast';
   36: Readonly my $STY_FIRST     => 'first_last';
   37: Readonly my $STY_LAST      => 'last_first';
   38: Readonly my $DEFAULT_SEP   => '.';
   39: 
   40: # Common surname particles across Dutch, German, French, Italian, Spanish,
   41: # Portuguese, Arabic, and Scandinavian naming traditions.  Matching is
   42: # case-sensitive: only lowercase tokens are eligible.
   43: Readonly my @DEFAULT_PARTICLES => qw(
   44:     van de di da von der den des du
   45:     la le las los el al
   46:     te ten ter
   47:     af av
   48:     bin bint ibn
   49:     y do dos das del
   50:     zu zum zur
   51: );
   52: 
   53: # Single source of truth for parameter validation; also reflected in POD below.
   54: Readonly my %PARAM_SCHEMA => (
   55: 	name => {
   56: 		type     => 'string',
   57: 		min      => 1,
   58: 		optional => 0,
   59: 	},
   60: 	format => {
   61: 		type     => 'string',
   62: 		memberof => [ $FMT_DEFAULT, $FMT_INITIALS, $FMT_COMPACT, $FMT_SHORTLAST ],
   63: 		optional => 1,
   64: 	},
   65: 	style => {
   66: 		type     => 'string',
   67: 		memberof => [ $STY_FIRST, $STY_LAST ],
   68: 		optional => 1,
   69: 	},
   70: 	separator => {
   71: 		type     => 'string',
   72: 		optional => 1,
   73: 	},
   74: 	particles => {
   75: 		type     => ['boolean', 'arrayref'],
   76: 		optional => 1,
   77: 	},
   78: );
   79: 
   80: =head1 SYNOPSIS
   81: 
   82:   use Text::Names::Abbreviate qw(abbreviate);
   83: 
   84:   say abbreviate('John Quincy Adams');                            # J. Q. Adams
   85:   say abbreviate('Adams, John Quincy');                          # J. Q. Adams
   86:   say abbreviate('George R R Martin', { format => 'initials' }); # G.R.R.M.
   87:   say abbreviate('Ludwig van Beethoven');                         # L. van Beethoven
   88:   say abbreviate("R\x{e9}mi Dupr\x{e9}");                       # R. Dupr\x{e9}
   89: 
   90: =head1 DESCRIPTION
   91: 
   92: This module provides simple abbreviation logic for full personal names with
   93: multiple formatting options and styles.  Input is expected to be a personal
   94: name consisting of one or more whitespace-separated components interpreted as:
   95: 
   96:   First [Middle ...] Last
   97: 
   98: Names consisting of a single component are returned unchanged.
   99: 
  100: =head1 SUBROUTINES/METHODS
  101: 
  102: =head2 abbreviate
  103: 
  104: Produce an abbreviated form of a personal name.
  105: 
  106: =head3 Purpose
  107: 
  108: Accept a full name in either C<First Middle Last> or C<Last, First Middle>
  109: form and return a formatted abbreviated string according to the requested
  110: C<format>, C<style>, C<separator>, and C<particles> options.  Input is
  111: NFC-normalised before processing, so strings differing only in Unicode
  112: normalisation form produce identical output.  Surname particles (C<van>,
  113: C<de>, C<von>, etc.) are absorbed into the last-name component by default.
  114: 
  115: =head3 Args
  116: 
  117: =over 4
  118: 
  119: =item name (required)
  120: 
  121: Non-empty string.  Accepted in two forms:
  122: 
  123: =over 4
  124: 
  125: =item C<First [Middle ...] Last>
  126: 
  127: =item C<Last, First [Middle ...]>
  128: 
  129: =back
  130: 
  131: A leading comma (C<", John">) signals that no last name is present; only
  132: initials are produced.
  133: 
  134: =item format (optional, default C<default>)
  135: 
  136: One of C<default>, C<initials>, C<compact>, C<shortlast>.
  137: 
  138: =over 4
  139: 
  140: =item C<default>   -- C<J. Q. Adams>
  141: 
  142: =item C<initials>  -- C<J.Q.A.>
  143: 
  144: =item C<compact>   -- C<JQA>
  145: 
  146: =item C<shortlast> -- initials then full last name; honours C<last_first> style
  147: (e.g. C<Adams, J. Q.>).
  148: 
  149: =back
  150: 
  151: =item style (optional, default C<first_last>)
  152: 
  153: One of C<first_last>, C<last_first>.  All formats honour this option.
  154: 
  155: =item separator (optional, default C<.>)
  156: 
  157: String appended after each initial.  Empty string removes all punctuation.
  158: 
  159: =item particles (optional, default enabled)
  160: 
  161: Controls detection of surname particles (C<van>, C<de>, C<von>, etc.) that
  162: prefix the last name.  Tokens immediately before the last name that appear in
  163: the particle list are absorbed into the last-name component.  Matching is
  164: case-sensitive: only lowercase tokens are eligible.
  165: 
  166: =over 4
  167: 
  168: =item omitted or C<1> - use the built-in particle list
  169: 
  170: =item C<0> - disable particle detection entirely
  171: 
  172: =item arrayref of strings - use that list instead of the built-in one
  173: 
  174: =back
  175: 
  176:   abbreviate('Ludwig van Beethoven');                           # L. van Beethoven
  177:   abbreviate('Ludwig van Beethoven', { particles => 0 });      # L. v. Beethoven
  178:   abbreviate('Felipe de la Cruz', { particles => ['de','la'] }); # F. de la Cruz
  179: 
  180: =back
  181: 
  182: =head3 Returns
  183: 
  184: A plain string.  Returns C<''> for inputs that normalise to nothing (e.g. a
  185: bare comma).
  186: 
  187: =head3 Side Effects
  188: 
  189: None.  The function is purely functional with no persistent state.
  190: 
  191: =head3 Usage
  192: 
  193:   # Positional
  194:   my $abbrev = abbreviate('John Quincy Adams');
  195: 
  196:   # Options hashref
  197:   my $abbrev = abbreviate('John Quincy Adams', {
  198:       format    => 'initials',
  199:       style     => 'last_first',
  200:       separator => '-',
  201:   });
  202: 
  203: =head3 API SPECIFICATION
  204: 
  205:   INPUT
  206:   {
  207:     name      => { type => 'string', min => 1, optional => 0 },
  208:     format    => { type => 'string',
  209:                    memberof => [qw(default initials compact shortlast)],
  210:                    optional => 1 },
  211:     style     => { type => 'string',
  212:                    memberof => [qw(first_last last_first)],
  213:                    optional => 1 },
  214:     separator => { type => 'string', optional => 1 },
  215:     particles => { type => ['boolean', 'arrayref'], optional => 1 },
  216:   }
  217: 
  218:   OUTPUT
  219:   { type => 'string' }    # croaks on argument error
  220: 
  221: =head3 MESSAGES
  222: 
  223:   Error                                    Meaning / Resolution
  224:   ---------------------------------------  -----------------------------------------------
  225:   name parameter missing or undefined      Called without a name argument; supply one.
  226:   name must be a non-empty string          Passed '' or undef; supply a non-empty string.
  227:   format must be one of: ...               Invalid format constant; see API SPECIFICATION.
  228:   style must be one of: ...               Invalid style constant; see API SPECIFICATION.
  229:   particles: must be one of boolean,       Passed a string or hashref; pass 0/1 or an
  230:     arrayref                               arrayref of particle strings instead.
  231: 
  232: =head3 PSEUDOCODE
  233: 
  234:   FUNCTION abbreviate(name, options):
  235:      Validate parameters via %PARAM_SCHEMA       (croak on violation)
  236:      Assign defaults: format=default, style=first_last, sep=".", particles=built-in list
  237:      _normalize_name(name):
  238:          - NFC-normalize to precomposed Unicode form
  239:          - collapse consecutive commas
  240:          - detect and reorder "Last, First" form
  241:          - track $had_leading_comma (input had no last-name component)
  242:          - collapse internal whitespace; trim
  243:      Return '' if normalized name is empty
  244:      _extract_parts(name, had_leading_comma, format, style, particles):
  245:          - tokenize on whitespace
  246:          - pop last token as $last_name (unless leading-comma form)
  247:          - if particles enabled: while last remaining token is a particle,
  248:            pop it and prepend to $last_name
  249:          - build @initials from remaining tokens (first char each)
  250:          - if style=last_first and format!=default: unshift last initial, clear $last_name
  251:          - filter empty initials
  252:      Format result:
  253:          compact   -> join('', @initials, first($last_name))
  254:          initials  -> join($sep, @all_letters) . $sep
  255:          shortlast -> join(' ', map {"$_$sep"} @initials) . " $last_name"
  256:          default   -> joined initials; prepend/append $last_name per $style
  257: 
  258: =cut
  259: 
  260: # ---------------------------------------------------------------------------
  261: # Private helpers
  262: # ---------------------------------------------------------------------------
  263: 
  264: # Purpose:      Resolve "Last, First" and leading-comma forms into a canonical
  265: #               "First ... Last" string, collapsing all internal whitespace.
  266: # Entry Criteria: $raw is a defined, non-empty string (validated by the caller).
  267: # Exit Status:  Returns ($normalized, $had_leading_comma).  $normalized is
  268: #               whitespace-collapsed and trimmed.  $had_leading_comma is 1 when
  269: #               the original input began with a comma (no last-name component).
  270: # Side Effects: None.
  271: sub _normalize_name {
●272 → 279 → 297  272: 	my ($raw) = @_;
  273: 
  274: 	$raw = Unicode::Normalize::NFC($raw);
  275: 	$raw =~ s/,+/,/g;    # collapse any run of commas to one before splitting
  276: 
  277: 	my $had_leading_comma = 0;
  278: 
  279: 	if ($raw =~ /,/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  280: 		my ($last, $rest) = map { s/^\s+|\s+$//gr } split /\s*,\s*/, $raw, 2;
  281: 		$rest //= q{};
  282: 		$last //= q{};
  283: 
  284: 		$had_leading_comma = 1 if !length($last) && length($rest);
  285: 
  286: 		if (length($last) && length($rest)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  287: 			$raw = "$rest $last";
  288: 		} elsif (length $rest) {
  289: 			$raw = $rest;
  290: 		} elsif (length $last) {
  291: 			$raw = $last;
  292: 		} else {
  293: 			return (q{}, 0);
  294: 		}
  295: 	}
  296: 
  297: 	$raw =~ s/^\s+|\s+$//g;
  298: 	$raw =~ s/\s+/ /g;
  299: 
  300: 	return ($raw, $had_leading_comma);
  301: }
  302: 
  303: # Purpose:      Derive the ordered list of initials and the preserved last name
  304: #               from a normalized name string, honouring format, style, and particles.
  305: # Entry Criteria: $name is output of _normalize_name (trimmed, single-spaced).
  306: #                 $had_leading_comma is the boolean from _normalize_name.
  307: #                 $format and $style are validated constants (FMT_*/STY_*).
  308: #                 $particles is an arrayref of particle strings, or undef to disable.
  309: # Exit Status:  Returns ($initials_ref, $last_name).  $initials_ref is an
  310: #               arrayref of single-character strings with empty entries removed.
  311: #               $last_name is '' when consumed by style/format reordering.
  312: # Side Effects: None.
  313: sub _extract_parts {
●314 → 321 → 345  314: 	my ($name, $had_leading_comma, $format, $style, $particles) = @_;
  315: 
  316: 	my @parts = split /\s+/, $name;
  317: 	return ([], q{}) unless @parts;
  318: 
  319: 	my ($last_name, @initials);
  320: 
  321: 	if ($had_leading_comma) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  322: 		$last_name = q{};
  323: 		@initials  = map { substr $_, 0, 1 } @parts;
  324: 	} else {
  325: 		$last_name = pop @parts;
  326: 
  327: 		# Absorb surname particles immediately preceding the last name.
  328: 		if ($particles && @parts) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  329: 			my %is_particle = map { $_ => 1 } grep { defined } @{$particles};
  330: 			while (@parts && $is_particle{ $parts[-1] }) {
  331: 				$last_name = (pop @parts) . q{ } . $last_name;
  332: 			}
  333: 		}
  334: 
  335: 		@initials  = map { substr $_, 0, 1 } @parts;
  336: 
  337: 		# last_first on non-default formats (except shortlast, which keeps the full last name):
  338: 		# move the last-name initial to the front and discard the full last name
  339: 		if ($style eq $STY_LAST && $format ne $FMT_DEFAULT && $format ne $FMT_SHORTLAST && length $last_name) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  340: 			unshift @initials, substr $last_name, 0, 1;
  341: 			$last_name = q{};
  342: 		}
  343: 	}
  344: 
  345: 	@initials = grep { length $_ } @initials;
  346: 
  347: 	return (\@initials, $last_name);
  348: }
  349: 
  350: # ---------------------------------------------------------------------------
  351: # Public API
  352: # ---------------------------------------------------------------------------
  353: 
  354: sub abbreviate {
●355 → 379 → 384  355: 	my $params = Params::Validate::Strict::validate_strict({
  356: 		args   => Params::Get::get_params('name', @_),
  357: 		schema => \%PARAM_SCHEMA,
  358: 	});
  359: 
  360: 	Carp::croak(__PACKAGE__ . '::abbreviate: name parameter is required and must be defined')
  361: 		unless defined $params->{name};
  362: 
  363: 	my $format = $params->{format}    // $FMT_DEFAULT;
  364: 	my $style  = $params->{style}     // $STY_FIRST;
  365: 	my $sep    = $params->{separator} // $DEFAULT_SEP;
  366: 
  367: 	my $raw_particles = $params->{particles};
  368: 	my $particles_ref =
  369: 		!defined $raw_particles          ? \@DEFAULT_PARTICLES
  370: 		: ref $raw_particles eq 'ARRAY'  ? $raw_particles
  371: 		: $raw_particles                 ? \@DEFAULT_PARTICLES
  372: 		:                                  undef;
  373: 
  374: 	my ($name, $had_leading_comma) = _normalize_name($params->{name});
  375: 	return q{} unless length $name;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  376: 
  377: 	my ($initials, $last_name) = _extract_parts($name, $had_leading_comma, $format, $style, $particles_ref);
  378: 
  379: 	if ($format eq $FMT_COMPACT) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  380: 		return join q{}, @{$initials},
  Mutants (Total: 2, Killed: 2, Survived: 0)
  381: 			(length $last_name ? (substr $last_name, 0, 1) : ());
  382: 	}
  383: 
●384 → 384 → 390  384: 	if ($format eq $FMT_INITIALS) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  385: 		my @letters = @{$initials};
  386: 		push @letters, substr($last_name, 0, 1) if length $last_name;
  387: 		return join($sep, @letters) . $sep;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  388: 	}
  389: 
●390 → 390 → 401  390: 	if ($format eq $FMT_SHORTLAST) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_390_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  391: 		my $joined = @{$initials} ? join(' ', map { $_ . $sep } @{$initials}) : q{};
  392: 		if ($style eq $STY_LAST && length $last_name) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  393: 			return length($joined) ? "$last_name, $joined" : $last_name;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  394: 		}
  395: 		return length($joined)
  Mutants (Total: 2, Killed: 2, Survived: 0)
  396: 			? (length($last_name) ? "$joined $last_name" : $joined)
  397: 			: $last_name;
  398: 	}
  399: 
  400: 	# default format
  401: 	return $last_name unless @{$initials};
  Mutants (Total: 2, Killed: 2, Survived: 0)
  402: 	my $joined = join ' ', map { $_ . $sep } @{$initials};
  403: 	return ($style eq $STY_LAST && length $last_name)
  Mutants (Total: 2, Killed: 2, Survived: 0)
  404: 		? "$last_name, $joined"
  405: 		: (length $last_name ? "$joined $last_name" : $joined);
  406: }
  407: 
  408: 1;
  409: 
  410: __END__
  411: 
  412: =head1 LIMITATIONS
  413: 
  414: =over 4
  415: 
  416: =item *
  417: 
  418: Honorifics (C<Dr.>, C<Prof.>) and suffixes (C<Jr.>, C<III>) are not
  419: detected or stripped; they are treated as name components.
  420: 
  421: =item *
  422: 
  423: Initials are taken verbatim from the first character of each token.
  424: Non-alphabetic leading characters (digits, punctuation) are included as-is.
  425: 
  426: =item *
  427: 
  428: Multiple consecutive commas collapse to a single comma before parsing.
  429: Names with two legitimate comma-separated clauses are not supported.
  430: 
  431: =item *
  432: 
  433: C<compact> and C<initials> formats are lossy: passing their output back into
  434: C<abbreviate> does not reproduce the original result.
  435: 
  436: =item *
  437: 
  438: Particle detection is case-sensitive.  A token is only absorbed into the
  439: last-name component when it exactly matches a particle string (all lowercase).
  440: Capitalised tokens such as C<Van> or C<De> are treated as ordinary name
  441: components.
  442: 
  443: =item *
  444: 
  445: For C<compact> and C<initials> formats with C<last_first> style, only the
  446: first character of the full particle-inclusive last name is used as the last
  447: initial (e.g. C<van Beethoven> contributes initial C<v>).
  448: 
  449: =item *
  450: 
  451: Unicode input is NFC-normalised before processing.  Strings that differ only
  452: in normalisation form (e.g. precomposed C<\x{e9}> vs. combining C<e\x{301}>)
  453: produce identical output.
  454: 
  455: =back
  456: 
  457: =head1 AUTHOR
  458: 
  459: Nigel Horne, C<< <njh at nigelhorne.com> >>
  460: 
  461: =head1 BUGS
  462: 
  463: Please report bugs to C<bug-text-names-abbreviate at rt.cpan.org> or via
  464: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Text-Names-Abbreviate>.
  465: 
  466: =head1 REPOSITORY
  467: 
  468: L<https://github.com/nigelhorne/Text-Names-Abbreviate>
  469: 
  470: =head1 SEE ALSO
  471: 
  472: =over 4
  473: 
  474: =item * L<Test Dashboard|https://nigelhorne.github.io/Text-Names-Abbreviate/coverage/>
  475: 
  476: =back
  477: 
  478: =head1 SUPPORT
  479: 
  480: This module is provided as-is without any warranty.
  481: 
  482:   perldoc Text::Names::Abbreviate
  483: 
  484: =over 4
  485: 
  486: =item * MetaCPAN: L<https://metacpan.org/dist/Text-Names-Abbreviate>
  487: 
  488: =item * RT tracker: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Text-Names-Abbreviate>
  489: 
  490: =item * CPAN Testers: L<http://matrix.cpantesters.org/?dist=Text-Names-Abbreviate>
  491: 
  492: =back
  493: 
  494: =head1 FORMAL SPECIFICATION
  495: 
  496: =head2 abbreviate
  497: 
  498:   Let Sigma* denote the set of all Unicode strings.
  499:   Let epsilon denote the empty string.
  500: 
  501:   Sigma+ = Sigma* \ {epsilon}
  502:   Format = {default, initials, compact, shortlast}
  503:   Style  = {first_last, last_first}
  504: 
  505:   collapse(s) -- replace runs of whitespace with a single space, then trim
  506: 
  507:   normalize : Sigma+ -> Sigma* x Bool
  508:   normalize(n) =
  509:     let n0 = NFC(n)             -- Unicode NFC normalisation
  510:     let n1 = gsub(n0, ",+", ",")
  511:     if "," not-in n1 then (collapse(n1), false)
  512:     else
  513:       let (L, R) = split(n1, ",", 2) each trimmed
  514:       case
  515:         L = epsilon ^ R != epsilon  ->  (collapse(R), true)
  516:         L != epsilon ^ R != epsilon ->  (collapse(R ++ " " ++ L), false)
  517:         L != epsilon ^ R = epsilon  ->  (collapse(L), false)
  518:         L = epsilon ^ R = epsilon   ->  (epsilon, false)
  519:       end
  520: 
  521:   Particles = seq Sigma* | undef    -- arrayref of particle strings, or disabled
  522: 
  523:   collect_particles : seq Sigma* x Particles -> Sigma* x seq Sigma*
  524:   collect_particles(ps, P) =
  525:     if P = undef then (epsilon, ps)
  526:     else
  527:       let particle_set = { p | p <- P }
  528:       iterate: while ps != [] ^ last(ps) in particle_set:
  529:         prepend last(ps) to accumulator; remove from ps
  530:       (join(" ", accumulator), ps)
  531: 
  532:   extract : Sigma* x Bool x Format x Style x Particles -> (seq Sigma) x Sigma*
  533:   extract(n, leading, fmt, sty, P) =
  534:     let ps = tokenize(n)    -- split on whitespace
  535:     if ps = [] then ([], epsilon)
  536:     else if leading then
  537:       ([ first(p) | p <- ps ], epsilon)
  538:     else
  539:       let base  = ps[#ps]
  540:           rest  = ps[1..#ps-1]
  541:       let (prefix, rest') = collect_particles(rest, P)
  542:       let last  = if prefix != epsilon then prefix ++ " " ++ base else base
  543:           inits = [ first(p) | p <- rest' ]
  544:       if sty = last_first ^ fmt != default ^ fmt != shortlast ^ last != epsilon
  545:         then ([first(last)] ++ inits, epsilon)
  546:         else (inits, last)
  547: 
  548:   abbreviate : Sigma+ x Format x Style x Sigma* x Particles -> Sigma*
  549:   abbreviate = format_result . extract . normalize
  550: 
  551: =head1 LICENCE AND COPYRIGHT
  552: 
  553: Copyright 2025-2026 Nigel Horne.
  554: 
  555: Usage is subject to the terms of GPL2.
  556: If you use it,
  557: please let me know.
  558: 
  559: =cut