File Coverage

lib/Convert/Morse.pm

Criterion	Covered	Total	%
statement	63	63	100.0
branch	15	18	83.3
condition	6	10	60.0
subroutine	12	12	100.0
pod	6	6	100.0
total	102	109	93.5

#############################################################################
# Convert/Morse.pm -- package to convert between ASCII and MORSE code.
#
#############################################################################

# TODO:

# German umlaute etc (how to represent in ASCII?).
# see: http://member.nifty.ne.jp/je1trv/CW_J_e.htm
# see: http://burks.brighton.ac.uk/burks/foldoc/61/75.htm

package Convert::Morse;
use vars qw($VERSION);
$VERSION = 0.06;	# Current version of this package
use 5.008001;		# requires this Perl version or later

use Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw( as_morse as_ascii is_morse is_morsable);
use strict;

#############################################################################
# global variables

my $morse_ascii;	# hash of morse symbols (morse => ascii)
my $ascii_morse;	# hash of ascii symbols (ascii => morse)
my $regexp_ascii_morse;	# compiled regexp
my $regexp_morse_ascii;	# compiled regexp
my $error;		# last error message

sub as_morse
  {
  # convert ASCII text into morse code
  my $ascii = shift; # no || "" because fail for '0'
  return "" if !defined $ascii || $ascii eq "";
  undef $error;
  $ascii = uc($ascii);	# 'Helo' => 'HELO'
  $ascii =~ s/\G$regexp_ascii_morse/_convert($1,$ascii_morse);/ge;
  $ascii =~ s/\s\z//;  	# remove last space
  $ascii;
  }

sub as_ascii
  {
  # convert morse text into ascii code
  my $morse = shift;
  return "" if !defined $morse || $morse eq "";
  # because regexps expects a space (to avoid testing for \s|$)
  $morse .= ' ' if substr($morse,-1,1) ne ' ';
  undef $error;
  $morse =~ s/\G$regexp_morse_ascii/_convert($1,$morse_ascii);/ge;
  $morse =~ s/ +/ /;  	# collapse multiple spaces
  $morse =~ s/\s\z//;  	# remove last space
  $morse;
  }

sub _convert
  {
  my ($token,$hash) = @_;
  return '' if !defined $token;
  $token =~ s/\s$// if length($token) > 1; # remove trailing space if not ' '
  my $sym = $hash->{$token};
  if (!defined $sym)
    {
    $error = "Undefined token '$token'"; return $token;
    }
  #print "'",quotemeta($token),"' => '",quotemeta($sym),"'\n";
  $sym;
  }

sub is_morsable
  {
  # returns true wether input can be completely expressed as morse
  my $text = shift || "";
  my $morse = as_morse($text);
  error() ? undef : 1;
  }

sub is_morse
  {
  # returns true wether input is valid Morse code
  my $text = shift || "";
  my $ascii = as_ascii($text);
  error() ? undef : 1;
  }

sub error
  {
  # return last parse error or undef for ok
  $error;
  }

#############################################################################
# self initalization

sub tokens
  {
  # set/return hash of valid/invalid tokens (in form of ascii => morse)
  my $tokens = shift;
  if (defined $tokens)
    {
    $morse_ascii = {}; $ascii_morse = {};
    foreach (keys %$tokens)
      {
      $ascii_morse->{$_} = $tokens->{$_}.' ';
      $morse_ascii->{$tokens->{$_}} = $_;
      }
    # fix space handling
    foreach (" ")
      {
      $ascii_morse->{$_} = $_;
      $morse_ascii->{$_} = $_;
      }
    # preserve spaces
    # compile a big regexp for token parsing
    $regexp_ascii_morse = '(' .
      join('|', map { quotemeta } keys %$ascii_morse)
      . '|.|[\n\r\t])';
    $regexp_morse_ascii = '(' .
      join('\s|', map { quotemeta } keys %$morse_ascii)
      . '\s|.|[\n\r\t])';
    #print STDERR "$regexp_ascii_morse\n";
    #print STDERR "$regexp_morse_ascii\n";
    #foreach (keys %$ascii_morse)
    #  {
    #  print "'$_' => '$ascii_morse->{$_}'\n";
    #  }
    }
  # return current token set
  my $copy = {};
  foreach (keys %$ascii_morse) { $copy->{$_} = $ascii_morse->{$_}; }
  $copy;
  }

BEGIN
  {
  tokens( {
	'.'	=>	'.-.-.-',
	','	=>	'--..--',
	':'	=>	'---...',
	'?'	=>	'..--..',
	"'"	=>	'.----.',
	'-'	=>	'-....-',
	';'	=>	'-.-.-',
	'/'	=>	'-..-.',
	'('	=>	'-.--.',
	')'	=>	'-.--.-',
	'"'	=>	'.-..-.',
	'_'	=>	'..--.-',
	'='	=>	'-...-',
	'+'	=>	'.-.-.',
	'!'	=>	'-.-.--',
	'@'	=>	'.--.-.',
	qw(
	A	.-
	B	-...
	C	-.-.
	D	-..
	E	.
	F	..-.
	G	--.
	H	....
	I	..
	J	.---
	K	-.-
	L	.-..
	M	--
	N	-.
	O	---
	P	.--.
	Q	--.-
	R	.-.
	S	...
	T	-
	U	..-
	V	...-
	W	.--
	X	-..-
	Y	-.--
	Z	--..
	0	-----
	1	.----
	2	..---
	3	...--
	4	....-
	5	.....
	6	-....
	7	--...
	8	---..
	9	----.),
	# russian
  qw(
        EH	..-..
  	YU	..--
	YA	.-.-
	CHEH	---.
	SHA	----
        ),
	# japanese (WABUN) (not done, needs support for
        # escaping sequences DO & SN
  qw(
        )
  } );
  # Ä	.-.-
  # Ö	---.
  # Ü	..--
  # adash	.--.-
  # angstroem 	.--.-	 (same as adash? huh?)
  # ch		----
  # Edash	..-..
  # N ntilde	--.--
  }

#############################################################################
1;

__END__