Getting abbreviations or initials

[Lady_Aleena]

This little script returns the abbreviation of a name. The only required option to use this is name. The script will die if name is not initialized.

my $abbreviation = abbr( name => "Jane Q. Public", );

This script will strip off articles at the beginning of the string input. "The Lord of the Rings" will return "LotR". If only one word is entered or left after the initial article in the string, the word will be returned. "Cher" will return "Cher"; "The Police" will return "The Police". Strings will be broken at spaces, underscores, hyphens, or a combination thereof. "Compact Disc read-only memory" will be returned as "CDrom", see the options below for how to return "CDROM".

There are three options that are not required.

periods

If you want periods after each letter in the abbreviation, the option periods can be yes, true, or 1.

my $abbreviation = abbr(
  name => "Jane Q. Public",
  periods => "yes",
);

ALLCAPS

If you want all of the letters in the abbreviation to be capitalized, the option ALLCAPS can be yes, true, or 1.

my $abbreviation = abbr(
  name => "The International House of Pancakes",
  ALLCAPS => "yes",
);

HTML

If you want the output to be wrapped in the HTML tag, the option HTML can be yes, true, or 1. I added this because, as some here know, I use Perl to output a lot of HTML. :)

my $abbreviation = abbr(
  name => "frequently asked question",
  ALLCAPs => "yes",
  HTML => "yes",
);

That will output:

<abbr title="frequently asked question">FAQ</abbr>

Alternate name

I included an alternate subroutine called initials which is the same as abbr.

Now here is the code...

sub abbr {
  my %opt = @_;

  die("Sorry, I can't return an abbreviation if you don't give me a na
+me.") if !$opt{name};

  my $name = $opt{name};
     $name =~ s/^(The|A|An) //i;

  if ($name !~ /[ _-]/) {
    return $opt{name};
  }
  else {
    my @abbr;
    for my $word (split(/[ _-]/,$name)) {
      push @abbr, substr($word,0,1);
    }
    
    my $raw_abbr = $opt{periods} && $opt{periods} =~ /^[yt1]/i ? join(
+'',map { $_ =~ s/$/./; $_; } @abbr) : join('',@abbr);
    
    my $final_abbr = $opt{ALLCAPS} && $opt{ALLCAPS} =~ /^[yt1]/i ? uc 
+$raw_abbr : $raw_abbr;
    
    if ($opt{HTML} && $opt{HTML} =~ /^[yt1]/i) {
      return qq(<abbr title="$opt{name}">$final_abbr</abbr>);
    }
    else {
      return $final_abbr;
    }
  }
}

sub initials {
  my %opt = @_;
  
  my $initials = abbr(
    name => $opt{name} ? $opt{name} : die("Sorry, I can't return initi
+als if you don't give me a name."),
    periods => $opt{periods} ? $opt{periods} : undef,
    ALLCAPS => $opt{ALLCAPS} ? $opt{ALLCAPS} : undef,
    HTML => $opt{HTML} ? $opt{HTML} : undef,
  );
  
  return $initials;
}

As always, I would love to know where I can clean this up.