File Coverage

blib/lib/Music/Lyrics/LRC.pm

Criterion	Covered	Total	%
statement	81	81	100.0
branch	17	30	56.6
condition			n/a
subroutine	16	16	100.0
pod	8	8	100.0
total	122	135	90.3

package Music::Lyrics::LRC;

# Force me to write this properly
use strict;
use warnings;
use utf8;

# Target reasonably old Perl
use 5.006;

# Include required modules
use Carp;
use English '-no_match_vars';

# Declare package version
our $VERSION = '0.15';

# Patterns to match elements of the LRC file; these are somewhat tolerant
our %RE = (

    # A blank line
    blank => qr{
        \A      # Start of string
        \s*     # Any whitespace
        \z      # End of string
    }msx,

    # A meta tag line
    tag => qr{
        \A          # Start of string
        \s*         # Any whitespace
        \[          # Opening left bracket
            ([^:\r\n]+)  # Tag name, capture
            :            # Colon
            (.*)         # Tag value, capture
        \]          # Closing right bracket
        \s*         # Any whitespace
        \z          # End of string
    }msx,

    # A lyric line
    lyric => qr{
        \A            # Start of string
        \s*           # Any whitespace
        \[            # Opening left bracket
            (\d+)         # Minutes, capture
            :             # Colon
            (             # Seconds group, capture
                \d{1,2}       # Whole seconds
                (?:           # Group for fractional seconds
                    [.]           # Period
                    \d+           # At least one digit
                )?            # End optional fractional seconds group
            )             # End seconds group
        \]            # Closing right bracket
        [\t ]*        # Any tabs or spaces
        (             # Lyric line group, capture
            (?:.*\S)?     # Anything ending with non-whitespace
        )             # End lyric line group
        \s*           # Any whitespace
        \z            # End of string
    }msx,
);

# Parser functions to consume and process captures from the above patterns
my %parsers = (

    # A meta tag line
    tag => sub {
        my ( $self, $tag, $value ) = @_;
        $self->set_tag( $tag, $value );
    },

    # A lyric line
    lyric => sub {
        my ( $self, $min, $sec, $text ) = @_;

        # Calculate the number of milliseconds
        my $msec = $self->_min_sec_to_msec( $min, $sec );

        # Push a lyric hashref onto our list
        $self->add_lyric( $msec, $text );
    },
);

# Oldschool constructor
sub new {
    my ( $class, %opts ) = @_;

    # Declare a hash to build the object around
    my %self;

    # Start with empty tags and lyrics
    $self{tags}   = {};
    $self{lyrics} = [];

    # Read in the "verbose" flag if defined, default to zero
    $self{verbose} =
      exists $opts{verbose}
      ? !!$opts{verbose}
      : 0;

    # Perlician, bless thyself
    return bless \%self, $class;
}

# Read-only accessor for lyrics, sorted by time
sub lyrics {
    my $self = shift;
    my @lyrics = sort { $a->{time} <=> $b->{time} } @{ $self->{lyrics} };
    return \@lyrics;
}

# Read-only accessor for tags
sub tags {
    my $self = shift;
    my %tags = %{ $self->{tags} };
    return \%tags;
}

# Add a new lyric to the object
sub add_lyric {
    my ( $self, $time, $text ) = @_;

    # Check parameters
    int $time >= 0
      or croak 'Bad lyric time';
    $text !~ m/ [\r\n] /msx
      or croak 'Bad lyric line';

    # Push the lyric onto our list
    return push @{ $self->{lyrics} },
      {
        time => $time,
        text => $text,
      };
}

# Set the value of a tag
sub set_tag {
    my ( $self, $name, $value ) = @_;

    # Check parameters
    $name !~ m/ [:\r\n] /msx
      or croak 'Bad tag name';

    # Tag content cannot have vertical whitespace
    $value !~ m/ [\r\n] /msx
      or croak 'Bad tag value';

    # Set the tag's value on our hash
    return ( $self->{tags}{$name} = $value );
}

# Unset a tag
sub unset_tag {
    my ( $self, $name ) = @_;

    # Check parameters
    $name !~ m/ [:\r\n] /msx
      or croak 'Bad tag name';
    exists $self->{tags}{$name}
      or carp 'Tag not set';

    # Delete the tag's value
    return defined delete $self->{tags}{$name};
}

# Parse an LRC file from a given filehandle
sub load {
    my ( $self, $fh ) = @_;

    # Panic if this doesn't look like a filehandle
    ref $fh eq 'GLOB'
      or croak 'Not a filehandle';

    # Iterate through lines
  LINE: while ( my $line = <$fh> ) {

        # Iterate through line types until one matches
      TYPE: for my $type (qw(lyric tag blank)) {
            my @vals = $line =~ $RE{$type}
              or next TYPE;
            exists $parsers{$type}
              or next LINE;
            $parsers{$type}->( $self, @vals );
            next LINE;
        }

        # No line format match, warn if verbose
        warn "Unknown format for line $NR\n" if $self->{verbose};
    }

    # Check we got to the end of the file
    eof $fh or die "Failed file read: $ERRNO\n";

    # All done, return the number of lyrics we have now
    return scalar @{ $self->lyrics };
}

# Write an LRC file to a given filehandle
sub save {
    my ( $self, $fh ) = @_;

    # Panic if this doesn't look like a filehandle
    ref $fh eq 'GLOB'
      or croak 'Not a filehandle';

    # Start counting lines written
    my $lines = 0;

    # Iterate through tags
    for my $name ( sort keys %{ $self->{tags} } ) {
        my $value = $self->{tags}{$name};
        $lines += printf {$fh} "[%s:%s]\n", $name, $value
          or die "Failed tag write: $ERRNO\n";
    }

    # Iterate through lyrics (sorted by time)
    for my $lyric ( @{ $self->lyrics } ) {

        # Convert milliseconds to timestamp hash
        my $msec = $lyric->{time};
        my ( $min, $sec ) = $self->_msec_to_min_sec($msec);

        # Write the line to the file, counting the lines
        $lines += printf {$fh} "[%02u:%05.2f]%s\n", $min, $sec, $lyric->{text}
          or die "Failed lyric write: $ERRNO\n";
    }

    # Return the number of lines written
    return $lines;
}

# Named constants for the conversion functions
# This stands for "millisecond factors"
my %MSF = (
    sec => 1_000,
    min => 60_000,
);

# Convert a minutes-seconds pair to milliseconds
sub _min_sec_to_msec {
    my ( $self, $min, $sec ) = @_;
    my $msec = 0;
    $msec += int $min * $MSF{min};
    $msec += $sec * $MSF{sec};
    return $msec;
}

# Convert milliseconds to a minutes-seconds pair
sub _msec_to_min_sec {
    my ( $self, $msec ) = @_;
    my $min = int $msec / $MSF{min};
    my $sec = ( int $msec ) % $MSF{min} / $MSF{sec};
    return ( $min, $sec );
}

1;

__END__