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


line stmt bran cond sub pod time code
1             package MP3::Tag::Cue;
2              
3 6     6   41 use strict;
  6         10  
  6         188  
4 6     6   30 use File::Basename;
  6         11  
  6         354  
5             #use File::Spec;
6 6     6   33 use vars qw /$VERSION @ISA/;
  6         26  
  6         9104  
7              
8             $VERSION="1.00";
9             @ISA = 'MP3::Tag::__hasparent';
10              
11             =pod
12              
13             =head1 NAME
14              
15             MP3::Tag::Cue - Module for parsing F<.cue> files.
16              
17             =head1 SYNOPSIS
18              
19             my $db = MP3::Tag::Cue->new($filename, $track); # Name of audio file
20             my $db = MP3::Tag::Cue->new_from($record, $track); # Contents of .cue file
21              
22             ($title, $artist, $album, $year, $comment, $track) = $db->parse();
23              
24             see L
25              
26             =head1 DESCRIPTION
27              
28             MP3::Tag::Cue is designed to be called from the MP3::Tag module.
29              
30             It parses the content of a F<.cue> file.
31              
32             The F<.cue> file is looked for in the same directory as audio file; one of the
33             following conditions must be satisfied:
34              
35             =over 4
36              
37             =item *
38              
39             The "audio" file is specified is actually a F<.cue> file;
40              
41             =item *
42              
43             There is exactly one F<.cue> file in the directory of audio file;
44              
45             =item *
46              
47             There is exactly one F<.cue> file in the directory of audio file
48             with basename which is a beginning of the name of audio file.
49              
50             =item *
51              
52             There is exactly one F<.cue> file in the directory of audio file
53             with basename which matches (case-insensitive) a beginning of the
54             name of audio file.
55              
56             =back
57              
58             If no F<.cue> file is found in the directory of audio file, the same process
59             is repeated once one directory uplevel, with the name of the file's directory
60             used instead of the file name. E.g., with the files like this
61              
62             Foo/bar.cue
63             Foo/bar/04.wav
64              
65             audio file F will be associated with F.
66              
67             =cut
68              
69              
70             # Constructor
71              
72             sub new_from {
73 0     0 0 0 my ($class, $data, $track) = @_;
74 0         0 bless {data => [split /\n/, $data], track => $track}, $class;
75             }
76              
77             sub matches($$$) {
78 0     0 0 0 my ($f1, $f, $case) = (shift, shift, shift);
79 0         0 substr($f1, -4, 4) = '';
80 0 0       0 return $f1 eq substr $f, 0, length $f1 if $case;
81 0         0 return lc $f1 eq lc substr $f, 0, length $f1;
82             }
83              
84             sub find_cue ($$) {
85 170     170 0 361 my ($f, $d, %seen) = (shift, shift);
86 170         762 require File::Glob; # "usual" glob() fails on spaces...
87 170         15833 my @cue = (File::Glob::bsd_glob("$d/*.cue"), File::Glob::bsd_glob('$d/*.CUE'));
88 170         748 @seen{@cue} = (1) x @cue; # remove duplicates:
89 170         376 @cue = keys %seen;
90 170         272 my $c = @cue;
91 170 50       447 @cue = grep matches($_, $f, 0), @cue if @cue > 1;
92 170 50       373 @cue = grep matches($_, $f, 1), @cue if @cue > 1;
93 170         575 ($c, @cue)
94             }
95              
96             sub new_with_parent {
97 85     85 0 264 my ($class, $f, $p, $e, %seen, @cue) = (shift, shift, shift);
98 85 50       340 $f = $f->filename if ref $f;
99 85         324 $f = MP3::Tag->rel2abs($f);
100 85 50 33     532 if ($f =~ /\.cue$/i and -f $f) {
101 0         0 @cue = $f;
102             } else {
103 85         2524 my $d = dirname($f);
104 85         272 (my $c, @cue) = find_cue($f, $d);
105 85 50       215 unless ($c) {
106 85         2664 my $d1 = dirname($d);
107 85         231 (my $c, @cue) = find_cue($d, $d1);
108             }
109             }
110 85 50       397 return unless @cue == 1;
111 0           local *F;
112 0 0         open F, "< $cue[0]" or die "Can't open `$cue[0]': $!";
113 0 0 0       if ($e = ($p or 'MP3::Tag')->get_config1('decode_encoding_cue_file')) {
114 0           eval "binmode F, ':encoding($e->[0])'"; # old binmode won't compile...
115             }
116 0           my @data = ;
117 0 0         close F or die "Error closing `$cue[0]': $!";
118 0           bless {filename => $cue[0], data => \@data, track => shift,
119             parent => $p}, $class;
120             }
121              
122             sub new {
123 0     0 0   my ($class, $f) = (shift, shift);
124 0           $class->new_with_parent($f, undef, @_);
125             }
126              
127             # Destructor
128              
129       0     sub DESTROY {}
130              
131             =over 4
132              
133             =item parse()
134              
135             ($title, $artist, $album, $year, $comment, $track) =
136             $db->parse($what);
137              
138             parse_filename() extracts information about artist, title, track number,
139             album and year from the F<.cue> file. $what is optional; it maybe title,
140             track, artist, album, year, genre or comment. If $what is defined parse() will return
141             only this element.
142              
143             Additionally, $what can take values C (returns the value of
144             artist in the whole-disk-info field C, C.
145              
146             =cut
147              
148             sub return_parsed {
149 0     0 0   my ($self,$what) = @_;
150 0 0         if (defined $what) {
151 0 0         return $self->{parsed}{collection_performer} if $what =~/^artist_collection/i;
152 0 0         return $self->{parsed}{album} if $what =~/^al/i;
153 0 0         return $self->{parsed}{performer} if $what =~/^a/i;
154 0 0         return $self->{parsed}{songwriter} if $what =~/^songwriter/i;
155 0 0         return $self->{parsed}{track} if $what =~/^tr/i;
156 0 0         return $self->{parsed}{date} if $what =~/^y/i;
157 0 0         return $self->{parsed}{comment}if $what =~/^c/i;
158 0 0         return $self->{parsed}{genre} if $what =~/^g/i;
159 0           return $self->{parsed}{title};
160             }
161            
162 0 0         return $self->{parsed} unless wantarray;
163 0           return map $self->{parsed}{$_} , qw(title artist album year comment track);
164             }
165              
166             my %r = ( 'n' => "\n", 't' => "\t", '\\' => "\\" );
167              
168             sub parse_lines {
169 0     0 0   my ($self) = @_;
170             # return if $self->{fields};
171 0           my $track_seen = '';
172 0           my $track = $self->track;
173 0 0 0       $track = -1e100 unless $track or length $track;
174 0           for my $l (@{$self->{data}}) {
  0            
175             # http://digitalx.org/cuesheetsyntax.php
176             # http://wiki.hydrogenaudio.org/index.php?title=Cuesheet
177             # What about http://cue2toc.sourceforge.net/ ? Can it deal with .toc of cdrecord?
178             # http://www.willwap.co.uk/Programs/vbrfix.php - may inspect gap info???
179 0 0         next unless $l =~ /^\s*(REM\s+)?
180             (GENRE|DATE|DISCID|COMMENT|PERFORMER|TITLE
181             |ISRC|POSTGAP|PREGAP|SONGWRITER
182             |FILE|INDEX|TRACK|CATALOG|CDTEXTFILE|FLAGS)\s+(.*)/x;
183 0           my $field = lc $2;
184 0           my $val = $3;
185 0           $val =~ s/^\"(.*)\"/$1/; # Ignore trailing fields after TRACK, FILE
186 0 0 0       $track_seen = $1 if $field eq 'track' and $val =~ /^0?(\d+)/;
187 0 0 0       next if length $track_seen and $track_seen != $track;
188              
189 0           $self->{fields}{$field} = $val; # unless exists $self->{fields}{$field};
190 0 0         next if length $track_seen;
191 0 0         $self->{fields}{album} = $val if $field eq 'title';
192 0 0         $self->{fields}{collection_performer} = $val if $field eq 'performer';
193             }
194             }
195              
196             sub parse {
197 0     0 1   my ($self,$what) = @_;
198 0 0         return $self->return_parsed($what) if exists $self->{parsed};
199 0           $self->parse_lines;
200 0           $self->{parsed} = { %{$self->{fields}} }; # Make a copy
  0            
201 0           $self->return_parsed($what);
202             }
203              
204             =pod
205              
206             =item title()
207              
208             $title = $db->title();
209              
210             Returns the title, obtained from the C<'Tracktitle'> entry of the file.
211              
212             =cut
213              
214             # *song = \&title;
215              
216             sub title {
217 0     0 1   return shift->parse("title");
218             }
219              
220             =pod
221              
222             =item artist()
223              
224             $artist = $db->artist();
225              
226             Returns the artist name, obtained from the C<'Performer'> or
227             C<'Albumperformer'> entries (the first which is present) of the file.
228              
229             =cut
230              
231             sub artist {
232 0     0 1   return shift->parse("artist");
233             }
234              
235             =pod
236              
237             =item track()
238              
239             $track = $db->track();
240              
241             Returns the track number, stored during object creation, or queried from
242             the parent.
243              
244             =cut
245              
246             sub track {
247 0     0 1   my $self = shift;
248 0 0         return $self->{track} if defined $self->{track};
249 0 0 0       return if $self->{recursive} or not $self->parent_ok;
250 0           local $self->{recursive} = 1;
251 0           return $self->{parent}->track1;
252             }
253              
254             =item year()
255              
256             $year = $db->year();
257              
258             Returns the year, obtained from the C<'Year'> entry of the file. (Often
259             not present.)
260              
261             =cut
262              
263             sub year {
264 0     0 1   return shift->parse("year");
265             }
266              
267             =pod
268              
269             =item album()
270              
271             $album = $db->album();
272              
273             Returns the album name, obtained from the C<'Albumtitle'> entry of the file.
274              
275             =cut
276              
277             sub album {
278 0     0 1   return shift->parse("album");
279             }
280              
281             =item comment()
282              
283             $comment = $db->comment();
284              
285             Returns the C<'REM COMMENT'> entry of the file. (Often not present.)
286              
287             =cut
288              
289             sub comment {
290 0     0 1   return shift->parse("comment");
291             }
292              
293             =item genre()
294              
295             $genre = $db->genre($filename);
296              
297             =cut
298              
299             sub genre {
300 0     0 1   return shift->parse("genre");
301             }
302              
303             for my $elt ( qw( artist_collection songwriter ) ) {
304 6     6   232 no strict 'refs';
  6         19  
  6         553  
305             *$elt = sub (;$) {
306 0     0     return shift->parse($elt);
307             }
308             }
309              
310             1;