File Coverage

lib/SMS/Ringtone/RTTTL/Parser.pm

Criterion	Covered	Total	%
statement	127	338	37.5
branch	46	130	35.3
condition	5	15	33.3
subroutine	14	35	40.0
pod	27	27	100.0
total	219	545	40.1

package SMS::Ringtone::RTTTL::Parser;
#### Package information ####
# Description and copyright:
#   See POD (i.e. perldoc SMS::Ringtone::RTTTL::Parser).
####

#### Class information ####
# Protected fields:
#	-DEFAULTS: Reference to hash of defaults containing keys d,o,b,l,v,s.
#	-ERRORS: Reference to array of errors.
#	-NOTES: Reference to array of [duration, note, octave, dots] elements.
#	-P1.VALID: Is part 1 valid?
#	-P2.VALID: Is part 2 valid?
#	-P3.VALID: Is part 3 valid?
#	-PARTS: Reference to array of the 3 parts.
#	-RTTTL: RTTTL string.
#	-WARNINGS: Reference to array of warnings.
# Constructors:
#	new()
# Protected methods:
#	_parse()
#	_parse_name()
#	_parse_defaults()
#	_parse_notes()
# Public methods:
#	get_bpm(): Returns the effective BPM setting.
#	get_errors(): Returns an array of error messages.
#	get_part_defaults(): Returns the defaults part.
#	get_part_name(): Returns name part.
#	get_part_notes(): Returns notes part.
#	get_note_count(): Return the amount of notes.
#	get_notes(): Returns an array of [duration, note, octave, dots] elements.
#	get_repeat(): Returns the effective repeat length.
#	get_rtttl(): Returns the RTTTL string.
#	get_style(): Returns the effective style.
#	get_volume(): Returns the effective volume.
#	get_warnings(): Returns an array of warning messages.
#	has_errors()
#	has_warnings()
#	is_name_valid()
#	is_defaults_valid()
#	is_notes_valid()
#	puke(): Dump parse results to STDOUT.
####

use strict;
use Carp;
our @ISA = qw(Exporter);
our @EXPORT = qw(is_valid_bpm
                 is_valid_duration
                 is_valid_octave
                 is_valid_repeat
                 is_valid_volume
                 nearest_bpm
                 nearest_duration
                 nearest_octave);
our $VERSION = '0.07';

1;

sub _get_nearest {
 my $value = shift;
 my $aref = shift;
 my $i = 0;
 while ($i < @{$aref}) {
  if ($aref->[$i] == $value) {
   return $aref->[$i];
  }
  if ($aref->[$i] > $value) {
   if ($i >= 1) {
    my $l = $aref->[$i-1];
    my $h = $aref->[$i];
    return ($value - $l) < ($h - $value) ? $l : $h;
   }
   return $aref->[$i];
  }
  $i++;
 }
 return $aref->[scalar(@{$aref})-1];
}

sub _inarray {
 my $e = shift;
 my $aref = shift;
 foreach (@{$aref}) {
  if ($e eq $_) {
   return 1;
  }
 }
 return 0;
}

our @BPM = (	'25',  '28',  '31',  '35',  '40',  '45',  '50',
		'56',  '63',  '70',  '80',  '90',  '100', '112',
		'125', '140', '160', '180', '200', '225', '250',
		'285', '320', '355', '400', '450', '500', '565',
		'635', '715', '800', '900');

sub is_valid_bpm {
 return &_inarray(pop,\@BPM);
}

sub nearest_bpm {
 return &_get_nearest(pop,\@BPM);
}

our @DURATION = ('1','2','4','8','16','32');

sub is_valid_duration {
 return &_inarray(pop,\@DURATION);
}

sub nearest_duration {
 return &_get_nearest(pop,\@DURATION);
}

our @OCTAVE = ('4','5','6','7'); # Octave 4 note A is 440Hz.

sub is_valid_octave {
 return &_inarray(pop,\@OCTAVE);
}

sub nearest_octave {
 return &_get_nearest(pop,\@OCTAVE);
}

sub is_valid_repeat {
 my $i = pop;
 return(($i =~ /^\d+$/o) && ($i >= 0) && ($i <= 15));
}

sub is_valid_volume {
 my $i = pop;
 return(($i =~ /^\d+$/o) && ($i >= 0) && ($i <= 15));
}

our %DEFAULTS = ('d' => 4, 'o' => 6, 'b' => 63, 'v' => 7, 's' => 'n', 'l' => 0);

####
# Constructor new()
# Parameters:
#	1. RTTTL string
#	2. Optional reference to hash of options.
####
sub new {
 my $package = shift;
 my $rtttl = shift;
 my $options = shift;
 my $self  = {};
 bless $self;

 # Check parameters
 unless(defined($rtttl)) {
  croak("RTTTL parameter missing or undefined!\n");
 }

 # Set private fields
 my %defs = %DEFAULTS;
 $self->{'-DEFAULTS'} = \%defs;
 $self->{'-ERRORS'} = [];
 $self->{'-NOTES'} = [];
 $self->{'-P1.VALID'} = 0;
 $self->{'-P2.VALID'} = 0;
 $self->{'-P3.VALID'} = 0;
 $self->{'-PARTS'} = [];
 $self->{'-RTTTL'} = $rtttl;
 $self->{'-WARNINGS'} = [];
 if (defined($options) && defined($options->{'STRICT_NOTE_PART_ORDER'})) {
  $self->{'-STRICT_NOTE_PART_ORDER'} = $options->{'STRICT_NOTE_PART_ORDER'};
 }
 else {
  $self->{'-STRICT_NOTE_PART_ORDER'} = 1;
 }

 # Parse RTTTL
 $self->_parse();

 # Return self reference
 return $self;
}

####
# Method	: _parse
# Description	: Parses RTTTL string
# Parameters	: none.
# Returns	: Boolean result.
#####
sub _parse {
 my $self = shift;
 my $rtttl = $self->{'-RTTTL'};
 #if ($rtttl =~ s/\s+$//o) {
 # push(@{$self->{'-WARNINGS'}},'Trailing white space found and removed from RTTTL string.');
 #}
 # Split parts
 my @parts = split(':',$rtttl);
 unless(@parts == 3) {
  push(@{$self->{'-ERRORS'}},'Invalid number of parts. Should be 3 parts:   []  +');
  return 0;
 }
 @{$self->{'-PARTS'}} = @parts;

 # Parse name
 $self->{'-P1.VALID'} = $self->_parse_name($parts[0]);

 # Parse defaults
 $self->{'-P2.VALID'} = $self->_parse_defaults($parts[1]);

 # Parse notes
 $self->{'-P3.VALID'} = $self->_parse_notes($parts[2]);
 return 1;
}

####
# Method	: _parse_name
# Description	: Parses name part of RTTTL string
# Parameters	: 1. Name part.
# Returns	: Boolean result.
#####
sub _parse_name {
 my $self = shift;
 my $name = shift;
 if (length($name) <= 15) {
  $self->{'-P1.VALID'} = 1;
  return 1;
 }
 else {
  push(@{$self->{'-WARNINGS'}},"Length of name part exceeds 15 characters:  $name");
 }
 return 0;
}

####
# Method	: _parse_defaults
# Description	: Parses defaults part of RTTTL string
# Parameters	: 1. Defaults part.
# Returns	: Boolean result.
#####
sub _parse_defaults {
 my $self = shift;
 my $part = shift;
 my $errors = $self->{'-ERRORS'};
 my $warnings = $self->{'-WARNINGS'};
 my $result = 1;
 my $d;
 my $o;
 my $b;
 my $l;
 my $v;
 my $s;
 #if ($part =~ s/\s//go) {
 # push(@{$warnings},'White space found and removed from defaults part.');
 #}
 if (length($part)) {
  my @defs = split(',',$part);
  foreach my $def (@defs) {
   unless ($def =~ /^(([doblv])=(\d+)|(s)=([ncs]))$/o) {
    push(@{$warnings},"Invalid entry in defaults part: $def");
    $result = 0;
    next;
   }
   my $key;
   my $value;
   if (defined($2)) {
    $key = $2;
    $value = $3;
   }
   else {
    $key = $4;
    $value = $5;
   }
   if ($key eq 'd') {
    if (defined($d)) {
     push(@{$warnings},"Duration entry in defaults specified more than once: $part");
     $result = 0;
    }
    my $i = $value;
    unless(&is_valid_duration($i)) {
     my $nearest = &nearest_octave($i);
     push(@{$errors},"Invalid duration setting $i in defaults replaced with $nearest: $part");
     $i = $nearest;
     $result = 0;
    }
    $d = $i;
   }
   elsif ($key eq 'o') {
    if (defined($o)) {
     push(@{$warnings},"Octave (scale) entry in defaults specified more than once: $part");
     $result = 0;
    }
    my $i = $value;
    unless(&is_valid_octave($i)) {
     my $nearest = &nearest_octave($i);
     push(@{$errors},"Invalid octave (scale) setting $i in defaults replaced with $nearest: $part");
     $i = $nearest;
     $result = 0;
    }
    $o = $i;
   }
   elsif ($key eq 'b') {
    if (defined($b)) {
     push(@{$warnings},"BPM entry in defaults specified more than once: $part");
     $result = 0;
    }
    my $i = $value;
    unless(&is_valid_bpm($i)) {
     my $nearest = &nearest_bpm($i);
     push(@{$warnings},"Invalid BPM setting $i in defaults replaced with $nearest: $part");
     $i = $nearest;
     $result = 0;
    }
    $b = $i;
   }
   elsif ($key eq 'l') {
    if (defined($l)) {
     push(@{$warnings},"Length entry in defaults specified more than once: $part");
     $result = 0;
    }
    if (&is_valid_repeat($value)) {
     $l = $value;
    }
    else {
     push(@{$errors},"Invalid length setting $value in defaults.");
     $result = 0;
    }
   }
   elsif ($key eq 'v') {
    if (defined($v)) {
     push(@{$warnings},"Volume entry in defaults specified more than once: $part");
     $result = 0;
    }
    if (&is_valid_volume($value)) {
     $v = $value;
    }
    else {
     push(@{$errors},"Invalid volume setting $value in defaults.");
     $result = 0;
    }
   }
   elsif ($key eq 's') {
    if (defined($s)) {
     push(@{$warnings},"Style entry in defaults specified more than once: $part");
     $result = 0;
    }
    $s = $value;
   }
  }
 }
 if (defined($d)) {
  $self->{'-DEFAULTS'}->{'d'} = $d;
 }
 if (defined($o)) {
  $self->{'-DEFAULTS'}->{'o'} = $o;
 }
 if (defined($b)) {
  $self->{'-DEFAULTS'}->{'b'} = $b;
 }
 if (defined($l)) {
  $self->{'-DEFAULTS'}->{'l'} = $l;
 }
 if (defined($v)) {
  $self->{'-DEFAULTS'}->{'v'} = $v;
 }
 if (defined($s)) {
  $self->{'-DEFAULTS'}->{'s'} = $s;
 }
 return $result;
}

####
# Method	: _parse_notes
# Description	: Parses notes part of RTTTL string
# Parameters	: 1. Notes part.
# Returns	: Boolean result.
#####
sub _parse_notes {
 my $self = shift;
 my @notespart = split(',',shift);
 my $errors = $self->{'-ERRORS'};
 my $strict_note_part_order = $self->{'-STRICT_NOTE_PART_ORDER'};
 unless(@notespart) {
  push(@{$errors},'No notes present in notes part.');
  return 0;
 }
 my $result = 1;
 my $warnings = $self->{'-WARNINGS'};
 my $def_d = $self->{'-DEFAULTS'}->{'d'};
 my $def_o = $self->{'-DEFAULTS'}->{'o'};
 my $notes = $self->{'-NOTES'};
 my $i = 0;
 foreach my $e (@notespart) {
  $i++;
  # The substitution below was added in v0.06 by Igor Ivoilov
  # because there are a lot of RTTTL generators that generate rtttl that
  # doesn't strictly follow the specification but have a not form like:
  #  := []  [] []
  # instead of:
  #  := []  [] []
  if (!$strict_note_part_order && ($e =~ /^(\d*)([P;BEH]|[CDFGA]#?)([\.;&]?)(\d*)$/oi)) {
   $e = "$1$2$4$3";
  }
  unless($e =~ /^(\d*)([P;BEH]|[CDFGA]#?)(\d*)([\.;&])?$/oi) {
   push(@{$errors},"Invalid syntax in note $i: $e");
   $result = 0;
   next;
  }
  my $duration = length($1) ? $1 : $def_d;
  unless(&is_valid_duration($duration)) {
   push(@{$errors},"Invalid duration $duration in note $i: $e");
   $result = 0;
  }
  my $note = uc($2);
  if ($note eq 'H') {
   $note = 'B';
  }
  elsif ($note eq ';') {
   $note = 'P';
  }
  my $octave = length($3) ? $3 : $def_o;
  unless(&is_valid_octave($octave)) {
   push(@{$errors},"Invalid octave $octave in note $i: $e");
   $result = 0;
  }
  my $dots = 0;
  if (defined($4) && length($4)) {
   if ($4 eq '.') {
    $dots = 1;
   }
   elsif ($4 eq ';') {
    $dots = 2;
   }
   elsif ($4 eq '&') {
    $dots = 3;
   }
  }
  push(@{$notes},[$duration,$note,$octave,$dots]);
 }
 return $result;
}

####
# Method	: get_bpm()
# Description	: Returns BPM setting of RTTTL string.
# Parameters	: none
# Returns	: Decimal result
#####
sub get_bpm {
 my $self = shift;
 return $self->{'-DEFAULTS'}->{'b'};
}

####
# Method	: get_part_defaults()
# Description	: Returns defaults part of RTTTL string.
# Parameters	: none
# Returns	: String result
#####
sub get_part_defaults {
 my $self = shift;
 return $self->{'-PARTS'}->[1];
}

####
# Method	: get_part_name()
# Description	: Returns name part of RTTTL string.
# Parameters	: none
# Returns	: String result
#####
sub get_part_name {
 my $self = shift;
 return $self->{'-PARTS'}->[0];
}

####
# Method	: get_part_notes()
# Description	: Returns notes part of RTTTL string.
# Parameters	: none
# Returns	: String result
#####
sub get_part_notes {
 my $self = shift;
 return $self->{'-PARTS'}->[2];
}

####
# Method	: get_errors()
# Description	: Returns (a reference to) an array of parse errors.
# Parameters	: none
# Returns	: Array or array reference.
#####
sub get_errors {
 my $self = shift;
 if (wantarray) {
  return @{$self->{'-ERRORS'}};
 }
 else {
  return $self->{'-ERRORS'};
 }
}

####
# Method	: get_note_count()
# Description	: Returns note count of RTTTL string.
# Parameters	: none
# Returns	: Decimal result
#####
sub get_note_count {
 my $self = shift;
 return scalar(@{$self->{'-NOTES'}});
}

####
# Method	: get_notes()
# Description	: Returns an array of [duration, note, octave, dots] elements.
# Parameters	: none
# Returns	: Array or array reference.
#####
sub get_notes {
 my $self = shift;
 if (wantarray) {
  return @{$self->{'-NOTES'}};
 }
 else {
  return $self->{'-NOTES'};
 }
}

####
# Method	: get_repeat()
# Description	: Returns repeat length setting of RTTTL string.
# Parameters	: none
# Returns	: Decimal result
#####
sub get_repeat {
 my $self = shift;
 return $self->{'-DEFAULTS'}->{'l'};
}

####
# Method	: get_rtttl()
# Description	: Reconstructs the RTTTL string.
# Parameters	: none
# Returns	: Optimized RTTTL string or undef if errors present.
#####
sub get_rtttl {
 my $self = shift;
 if ($self->has_errors()) {
  return undef;
 }
 my $name = substr($self->get_part_name(),0,15);
 # Find the most common duration and most common octave
 my %d = map{$_,0} @DURATION;
 my %o = map{$_,0} @OCTAVE;
 my $notes = $self->get_notes();
 foreach my $n (@{$notes}) { #[duration, note, octave, dots]
  $d{$n->[0]}++;
  $o{$n->[2]}++;
 }
 my $defdur = $DURATION[0];
 my $maxuse = 0;
 foreach (keys %d) {
  if ($d{$_} > $maxuse) {
   $defdur = $_;
   $maxuse = $d{$_};
  }
 }
 my $defoct = $OCTAVE[0];
 $maxuse = 0;
 foreach (keys %o) {
  if ($o{$_} > $maxuse) {
   $defoct = $_;
   $maxuse = $o{$_};
  }
 }
 my @defs;
 # Add most common duration and octave to defaults.
 unless($defdur == $DEFAULTS{'d'}) {
  push(@defs,"d=$defdur");
 }
 unless($defoct == $DEFAULTS{'o'}) {
  push(@defs,"o=$defoct");
 }
 unless($self->get_bpm() == $DEFAULTS{'b'}) {
  push(@defs,'b=' . $self->get_bpm());
 }
 unless($self->get_style() eq $DEFAULTS{'s'}) {
  push(@defs,'s=' . $self->get_style());
 }
 unless($self->get_repeat() == $DEFAULTS{'l'}) {
  push(@defs,'l=' . $self->get_repeat());
 }
 unless($self->get_volume() == $DEFAULTS{'v'}) {
  push(@defs,'v=' . $self->get_volume());
 }
 # Construct notes.
 my @rtttlnotes;
 foreach my $n (@{$notes}) { #[duration, note, octave, dots]
  my $note = '';
  unless($defdur == $n->[0]) {
   $note .= $n->[0];
  }
  $note .= $n->[1];
  unless($defoct == $n->[2]) {
   $note .= $n->[2];
  }
  if ($n->[3] > 0) {
   if ($n->[3] == 1) {
    $note .= '.';
   }
   elsif ($n->[3] == 2) {
    $note .= ';';
   }
   else {
    $note .= '&';
   }
  }
  push(@rtttlnotes,$note);
 }
 return "$name:" . join(',',@defs) . ':' . join(',',@rtttlnotes);
}

####
# Method	: get_style()
# Description	: Returns style setting of RTTTL string.
# Parameters	: none
# Returns	: Decimal result
#####
sub get_style {
 my $self = shift;
 return $self->{'-DEFAULTS'}->{'s'};
}

####
# Method	: get_volume()
# Description	: Returns volume setting of RTTTL string.
# Parameters	: none
# Returns	: Decimal result
#####
sub get_volume {
 my $self = shift;
 return $self->{'-DEFAULTS'}->{'v'};
}

####
# Method	: get_warnings()
# Description	: Returns (a reference to) an array of parse warnings.
# Parameters	: none
# Returns	: Array or array reference.
#####
sub get_warnings {
 my $self = shift;
 if (wantarray) {
  return @{$self->{'-WARNINGS'}};
 }
 else {
  return $self->{'-WARNINGS'};
 }
}

####
# Method	: has_errors()
# Description	: Indicates if any parse errors occured.
# Parameters	: none
# Returns	: The amount of errors.
#####
sub has_errors {
 my $self = shift;
 return scalar(@{$self->{'-ERRORS'}});
}

####
# Method	: has_warnings()
# Description	: Indicates if any parse warnings occured.
# Parameters	: none
# Returns	: The amount of warnings.
#####
sub has_warnings {
 my $self = shift;
 return scalar(@{$self->{'-WARNINGS'}});
}

####
# Method	: is_name_valid()
# Description	: Tells if name part of RTTTL string is valid.
# Parameters	: none
# Returns	: Boolean result
#####
sub is_name_valid {
 my $self = shift;
 return $self->{'-P1.VALID'};
}

####
# Method	: is_defaults_valid()
# Description	: Tells if defaults part of RTTTL string is valid.
# Parameters	: none
# Returns	: Boolean result
#####
sub is_defaults_valid {
 my $self = shift;
 return $self->{'-P2.VALID'};
}

####
# Method	: is_notes_valid()
# Description	: Tells if notes part of RTTTL string is valid.
# Parameters	: none
# Returns	: Boolean result
#####
sub is_notes_valid {
 my $self = shift;
 return $self->{'-P3.VALID'};
}

####
# Method	: puke()
# Description	: Dumps parse results to STDOUT.
# Parameters	: none
# Returns	: void
#####
sub puke {
 my $self = shift;
 print 'Name part: ' . $self->get_part_name() . "\n";
 print 'Defaults part: ' . $self->get_part_defaults() . "\n";
 print 'Notes part: ' . $self->get_part_notes() . "\n";
 my $defs = $self->{'-DEFAULTS'};
 print 'Effective defaults: d=' . $defs->{'d'} . ',o=' . $defs->{'o'} .  ',b=' . $defs->{'b'} . "\n";
 print "Effective notes (duration,note,octave,dots):\n";
 foreach my $note ($self->get_notes()) {
  print "\t[ " . sprintf('%2s',$note->[0]) . ' , ' . sprintf('%2s',$note->[1]) .  ' , ' . $note->[2] . ' , ' . $note->[3] . " ]\n";
 }
 print "WARNINGS:\n";
 foreach ($self->get_warnings()) {
  print "\t$_\n";
 }
 print "ERRORS:\n";
 foreach ($self->get_errors()) {
  print "\t$_\n";
 }
}

__END__