File Coverage

blib/lib/Music/PitchNum/German.pm

Criterion	Covered	Total	%
statement	39	39	100.0
branch	20	22	90.9
condition			n/a
subroutine	7	7	100.0
pod	2	2	100.0
total	68	70	97.1

# -*- Perl -*-
#
# For BACH, or, compatibility with the lilypond "\language deutsch"
# format. See Dutch.pm of this distribution for the default lilypond
# format (nederlands).
#
# Run perldoc(1) on this file for additional documentation.

package Music::PitchNum::German;

use 5.010000;
use Moo::Role;
use POSIX qw/floor/;
use Scalar::Util qw/looks_like_number/;

our $VERSION = '0.08';

##############################################################################
#
# ATTRIBUTES

has NOTE2NUM => (
  is      => 'rw',
  default => sub {
    { C => 0,
      D => 2,
      E => 4,
      F => 5,
      G => 7,
      A => 9,
      B => 10,
      H => 11,
    };
  },
);
# NOTE lilypond picky about "ees" and "aes" in deutsch mode
has NUM2NOTE => (
  is      => 'rw',
  default => sub {
    { 0  => 'c',
      1  => 'des',
      2  => 'd',
      3  => 'es',
      4  => 'e',
      5  => 'f',
      6  => 'ges',
      7  => 'g',
      8  => 'as',
      9  => 'a',
      10 => 'b',
      11 => 'h',
    };
  },
);

has ignore_octave => (
  is     => 'rw',
  coerce => sub {
    $_[0] ? 1 : 0;
  },
  default => 0,
);

##############################################################################
#
# METHODS

sub pitchname {
  my ( $self, $number ) = @_;
  die "need a number for pitchname\n" if !looks_like_number $number;

  my $note = $self->NUM2NOTE->{ $number % 12 };

  if ( !$self->ignore_octave ) {
    my $octave = floor( $number / 12 ) - 1;
    if ( $octave > 3 ) {
      $note .= (q{'}) x ( $octave - 3 );
    } elsif ( $octave < 3 ) {
      $note .= (q{,}) x ( 3 - $octave );
    }
  }

  return $note;
}

sub pitchnum {
  my ( $self, $name ) = @_;

  # already a pitch number, but nix the decimal foo
  return int $name if looks_like_number $name;

  my $pitchnum;

  # octave indication only follows accidental, accidental only after note
  # plus complication for "as", "ases", "es", "eses" special cases
  if (
    $name =~ m/ (? [A-Ha-h] )
       (? es(?:es)? | is(?:is)? | (?<=[AEae]) s(?:es)? )?
       (? [,]{1,10}|[']{1,10} )?
       /x
    ) {
    my $octave = $+{octave};
    my $chrome = $+{chrome};
    my $note   = $+{note};

    $pitchnum = $self->NOTE2NUM->{ uc $note } + 12 * 4;

    if ( defined $octave ) {
      $pitchnum += 12 * length($octave) * ( $octave =~ m/[,]/ ? -1 : 1 );
    }

    if ( defined $chrome ) {
      if ( $chrome =~ m/^s/ ) {    # as/ases klugery
        $chrome = "e$chrome";
      }
      $chrome =~ tr/s//d;
      $pitchnum += length($chrome) * ( $chrome =~ m/e/ ? -1 : 1 );
    }
  }

  return $pitchnum;
}

1;
__END__