File Coverage

blib/lib/Lingua/Alphabet/Phonetic/Password.pm

Criterion	Covered	Total	%
statement	23	24	95.8
branch	7	8	87.5
condition	1	3	33.3
subroutine	5	5	100.0
pod			n/a
total	36	40	90.0

#
# $Id: Password.pm 142 2004-11-30 19:42:11Z james $
#

=head1 NAME

Lingua::Alphabet::Phonetic::Password - enunciate a password as words

=head1 SYNOPSIS

This is a specialization of Lingua::Alphabet::Phonetic. You should not use
this module; all interaction should be done with an object of type
Lingua::Alphabet::Phonetic.

  use Lingua::Alphabet::Phonetic;
  my $phonetic = new Lingua::Alphabet::Phonetic('Password');
  my @phonetic_pw = $phonetic->enunciate('qOusiENi');

=head1 DESCRIPTION

This module is a dictionary for Lingua::Alphabet::Phonetic.  It allows for
enunciation of passwords, using the following rules:

=over 4

=item * lowercase letters

enunciated using the NATO alphabet per Lingua::Alphabet::Phonetic::NATO, but
the word will be lowercased.

=item * uppercase letters

enunciated using the NATO alphabet per Lingua::Alphabet::Phonetic::NATO, but
the word will be uppercased.

=item * numbers

enunciated as an initialcaps word for the english pronuciation of the number.

=item * special characters

enunciated as a mixedcaps word for the english punctuation of the character:

  @ At
  ? Question
  _ Underscore
  # Hash
  & Ampersand
  ! Exclamation
  - Dash
  * Asterisk
  + Plus
  = Equals
  " DoubleQuote
  % Percent
  ' SingleQuote
  ( LeftParens
  ) RightParens
  , Comma
  . Period
  / ForeSlash
  \ BackSlash
  : Colon
  ; SemiColon
  < LessThan
  > GreaterThan
  [ LeftBracket
  ] RightBracket
  { LeftBrace
  } RightBrace
  ^ Caret
  ` Backtick
  | Pipe
  ~ Tilde

=back

A character which does not fall into any of these categories is dispatched
back to the base class for conversion.  In the case of
Lingua::Alphabet::Phonetic, this returns the character unchanged.

=cut

package Lingua::Alphabet::Phonetic::Password;

use strict;
use warnings;

# if you really need to support lower, mail me
use 5.006_001;

# we are but a lowly subclass
use base 'Lingua::Alphabet::Phonetic';

# our version
our $VERSION = '0.11';

# a Lingua::Alphabet::Phonetic::NATO object for use later
my $nato;
eval { $nato = Lingua::Alphabet::Phonetic->new('NATO') };
if( $@ ) {
    require Carp;
    Carp::croak "cannot instantiate Lingua::Alphabet::" .
                "Phonetic::NATO object: $@";
}

# regex to determine if a character is uppercase
my $isupper = qr/^[[:upper:]]$/;

# number to name mappings
my %number_map = (
    0 => 'Zero',
    1 => 'One',
    2 => 'Two',
    3 => 'Three',
    4 => 'Four',
    5 => 'Five',
    6 => 'Six',
    7 => 'Seven',
    8 => 'Eight',
    9 => 'Nine',
);

# special character to name mappings
my %special_map = (
    '@' => 'At',
    '?' => 'Question',
    '_' => 'Underscore',
    '#' => 'Hash',
    '&' => 'Ampersand',
    '!' => 'Exclamation',
    '-' => 'Dash',
    '*' => 'Asterisk',
    '+' => 'Plus',
    '=' => 'Equals',
    '"' => 'DoubleQuote',
    '%' => 'Percent',
    '$' => 'Dollars',
    q/'/ => 'SingleQuote',
    '(' => 'LeftParens',
    ')' => 'RightParens',
    ',' => 'Comma',
    '.' => 'Period',
    '/' => 'ForeSlash',
    '\\' => 'BackSlash',
    ':' => 'Colon',
    ';' => 'SemiColon',
    '<' => 'LessThan',
    '>' => 'GreaterThan',
    '[' => 'LeftBracket',
    ']' => 'RightBracket',
    '{' => 'LeftBrace',
    '}' => 'RightBrace',
    '^' => 'Caret',
    '`' => 'Backtick',
    '|' => 'Pipe',
    '~' => 'Tilde',
);

sub _name_of_letter
{

    my $self = shift;
    my $s = shift;
    # If we get more than one character, ignore the rest:
    my $c = substr($s, 0, 1);

    my $word;

    # first we handle special characters
    if( exists $special_map{$c} ) {
        $word = $special_map{$c};
    }

    # then numbers
    elsif( exists $number_map{$c} ) {
        $word = $number_map{$c};
    }

    # then if it's in the NATO dictionary, we upper or lowercase
    elsif( ($word = ($nato->enunciate($c))[0]) && $word ne $c ) {
        if( $c =~ m/$isupper/ ) {
            $word = uc $word;
        }
        else {
            $word = lc $word;
        }
    }

    # otherwise we dispatch back to our base class
    else {
        $word = $self->SUPER::_name_of_letter($c);
    }

    return $word;

}

# keep require happy
1;


__END__