File Coverage

blib/lib/MP3/Tag/Cue.pm

Criterion	Covered	Total	%
statement	31	94	32.9
branch	6	60	10.0
condition	1	17	5.8
subroutine	6	21	28.5
pod	8	15	53.3
total	52	207	25.1

package MP3::Tag::Cue;

use strict;
use File::Basename;
#use File::Spec;
use vars qw /$VERSION @ISA/;

$VERSION="1.00";
@ISA = 'MP3::Tag::__hasparent';

=pod

=head1 NAME

MP3::Tag::Cue - Module for parsing F<.cue> files.

=head1 SYNOPSIS

  my $db = MP3::Tag::Cue->new($filename, $track);	# Name of audio file
  my $db = MP3::Tag::Cue->new_from($record, $track); # Contents of .cue file

  ($title, $artist, $album, $year, $comment, $track) = $db->parse();

see L

=head1 DESCRIPTION

MP3::Tag::Cue is designed to be called from the MP3::Tag module.

It parses the content of a F<.cue> file.

The F<.cue> file is looked for in the same directory as audio file; one of the
following conditions must be satisfied:

=over 4

=item *

The "audio" file is specified is actually a F<.cue> file;

=item *

There is exactly one F<.cue> file in the directory of audio file;

=item *

There is exactly one F<.cue> file in the directory of audio file
with basename which is a beginning of the name of audio file.

=item *

There is exactly one F<.cue> file in the directory of audio file
with basename which matches (case-insensitive) a beginning of the
name of audio file.

=back

If no F<.cue> file is found in the directory of audio file, the same process
is repeated once one directory uplevel, with the name of the file's directory
used instead of the file name.  E.g., with the files like this

   Foo/bar.cue
   Foo/bar/04.wav

audio file F will be associated with F.

=cut


# Constructor

sub new_from {
    my ($class, $data, $track) = @_;
    bless {data => [split /\n/, $data], track => $track}, $class;
}

sub matches($$$) {
  my ($f1, $f, $case) =  (shift, shift, shift);
  substr($f1, -4, 4) = '';
  return $f1 eq substr $f, 0, length $f1 if $case;
  return lc $f1 eq lc substr $f, 0, length $f1;
}

sub find_cue ($$) {
  my ($f, $d, %seen) = (shift, shift);
  require File::Glob;			# "usual" glob() fails on spaces...
  my @cue = (File::Glob::bsd_glob("$d/*.cue"), File::Glob::bsd_glob('$d/*.CUE'));
  @seen{@cue} = (1) x @cue;		    # remove duplicates:
  @cue = keys %seen;
  my $c = @cue;
  @cue = grep matches($_, $f, 0), @cue if @cue > 1;
  @cue = grep matches($_, $f, 1), @cue if @cue > 1;
  ($c, @cue)
}

sub new_with_parent {
    my ($class, $f, $p, $e, %seen, @cue) = (shift, shift, shift);
    $f = $f->filename if ref $f;
    $f = MP3::Tag->rel2abs($f);
    if ($f =~ /\.cue$/i and -f $f) {
      @cue = $f;
    } else {
      my $d = dirname($f);
      (my $c, @cue) = find_cue($f, $d);
      unless ($c) {
	my $d1 = dirname($d);
        (my $c, @cue) = find_cue($d, $d1);
      }
    }
    return unless @cue == 1;
    local *F;
    open F, "< $cue[0]" or die "Can't open `$cue[0]': $!";
    if ($e = ($p or 'MP3::Tag')->get_config1('decode_encoding_cue_file')) {
      eval "binmode F, ':encoding($e->[0])'"; # old binmode won't compile...
    }
    my @data = ;
    close F or die "Error closing `$cue[0]': $!";
    bless {filename => $cue[0], data => \@data, track => shift,
	   parent => $p}, $class;
}

sub new {
    my ($class, $f) = (shift, shift);
    $class->new_with_parent($f, undef, @_);
}

# Destructor

sub DESTROY {}

=over 4

=item parse()

  ($title, $artist, $album, $year, $comment, $track) =
     $db->parse($what);

parse_filename() extracts information about artist, title, track number,
album and year from the F<.cue> file.  $what is optional; it maybe title,
track, artist, album, year, genre or comment. If $what is defined parse() will return
only this element.

Additionally, $what can take values C (returns the value of
artist in the whole-disk-info field C, C.

=cut

sub return_parsed {
    my ($self,$what) = @_;
    if (defined $what) {
	return $self->{parsed}{collection_performer}  if $what =~/^artist_collection/i;
	return $self->{parsed}{album}  if $what =~/^al/i;
	return $self->{parsed}{performer} if $what =~/^a/i;
	return $self->{parsed}{songwriter} if $what =~/^songwriter/i;
	return $self->{parsed}{track}  if $what =~/^tr/i;
	return $self->{parsed}{date}   if $what =~/^y/i;
	return $self->{parsed}{comment}if $what =~/^c/i;
	return $self->{parsed}{genre}  if $what =~/^g/i;
	return $self->{parsed}{title};
    }

    return $self->{parsed} unless wantarray;
    return map $self->{parsed}{$_} , qw(title artist album year comment track);
}

my %r = ( 'n' => "\n", 't' => "\t", '\\' => "\\"  );

sub parse_lines {
    my ($self) = @_;
#    return if $self->{fields};
    my $track_seen = '';
    my $track = $self->track;
    $track = -1e100 unless $track or length $track;
    for my $l (@{$self->{data}}) {
	# http://digitalx.org/cuesheetsyntax.php
	# http://wiki.hydrogenaudio.org/index.php?title=Cuesheet
	# What about http://cue2toc.sourceforge.net/ ?  Can it deal with .toc of cdrecord?
	# http://www.willwap.co.uk/Programs/vbrfix.php - may inspect gap info???
	next unless $l =~ /^\s*(REM\s+)?
			    (GENRE|DATE|DISCID|COMMENT|PERFORMER|TITLE
			     |ISRC|POSTGAP|PREGAP|SONGWRITER
			     |FILE|INDEX|TRACK|CATALOG|CDTEXTFILE|FLAGS)\s+(.*)/x;
	my $field = lc $2;
	my $val = $3;
	$val =~ s/^\"(.*)\"/$1/;	# Ignore trailing fields after TRACK, FILE
	$track_seen = $1 if $field eq 'track' and $val =~ /^0?(\d+)/;
	next if length $track_seen and $track_seen != $track;

	$self->{fields}{$field} = $val;	# unless exists $self->{fields}{$field};
	next if length $track_seen;
	$self->{fields}{album} = $val if $field eq 'title';
	$self->{fields}{collection_performer} = $val if $field eq 'performer';
    }
}

sub parse {
    my ($self,$what) = @_;
    return $self->return_parsed($what)	if exists $self->{parsed};
    $self->parse_lines;
    $self->{parsed} = { %{$self->{fields}} };	# Make a copy
    $self->return_parsed($what);
}

=pod

=item title()

 $title = $db->title();

Returns the title, obtained from the C<'Tracktitle'> entry of the file.

=cut

# *song = \&title;

sub title {
    return shift->parse("title");
}

=pod

=item artist()

 $artist = $db->artist();

Returns the artist name, obtained from the C<'Performer'> or
C<'Albumperformer'> entries (the first which is present) of the file.

=cut

sub artist {
    return shift->parse("artist");
}

=pod

=item track()

 $track = $db->track();

Returns the track number, stored during object creation, or queried from
the parent.

=cut

sub track {
  my $self = shift;
  return $self->{track} if defined $self->{track};
  return if $self->{recursive} or not $self->parent_ok;
  local $self->{recursive} = 1;
  return $self->{parent}->track1;
}

=item year()

 $year = $db->year();

Returns the year, obtained from the C<'Year'> entry of the file.  (Often
not present.)

=cut

sub year {
    return shift->parse("year");
}

=pod

=item album()

 $album = $db->album();

Returns the album name, obtained from the C<'Albumtitle'> entry of the file.

=cut

sub album {
    return shift->parse("album");
}

=item comment()

 $comment = $db->comment();

Returns the C<'REM COMMENT'> entry of the file.  (Often not present.)

=cut

sub comment {
    return shift->parse("comment");
}

=item genre()

 $genre = $db->genre($filename);

=cut

sub genre {
    return shift->parse("genre");
}

for my $elt ( qw( artist_collection songwriter ) ) {
  no strict 'refs';
  *$elt = sub (;$) {
    return shift->parse($elt);
  }
}

1;