├── lib ├── Parallel │ └── ForkManager.pm ├── MP3 │ └── Tag │ │ ├── LastResort.pm │ │ ├── ImageSize.pm │ │ ├── ImageExifTool.pm │ │ ├── Inf.pm │ │ ├── Cue.pm │ │ ├── ID3v2_Data.pod │ │ ├── ParseData.pm │ │ ├── CDDB_File.pm │ │ ├── File.pm │ │ └── ID3v1.pm ├── Number │ └── Compare.pm ├── Text │ └── Glob.pm ├── File │ ├── Which.pm │ └── Find │ │ └── Rule.pm ├── FreezeThaw.pm └── Audio │ └── FLAC │ └── Header.pm ├── todo.txt ├── utils ├── makerelease.pl └── makerelease.sh ├── patches ├── flac2mp3.pl-r107-quotemeta.patch └── musicbrainz.patch ├── readme.txt ├── changelog.txt └── flac2mp3.pl /lib/Parallel/ForkManager.pm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/robinbowes/flac2mp3/HEAD/lib/Parallel/ForkManager.pm -------------------------------------------------------------------------------- /todo.txt: -------------------------------------------------------------------------------- 1 | # To-do: 2 | # - Add ReplyGain support 3 | # - Double-check how we handle special shell chars in filenames, e.g. 4 | # Rock `N' Roll Suicide.flac 5 | # - Clean up filepaths (check for double // in dirnames) 6 | # - Investigate using Audio::FLAC::Decode and Audio::MPEG instead of 7 | # flac and lame programs used from system call 8 | # - Write OO Audio file objects that know how to decode/encode/get 9 | # tags/set tags for themselves - should open up the way to allow for 10 | # transcoding between additional formats. 11 | # - google for a standard perl script template include things like 12 | # options, pod, GPL statement, how to set program version, etc. etc. 13 | # - Use Shell::Quote module 14 | -------------------------------------------------------------------------------- /utils/makerelease.pl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # utility to create a release 4 | 5 | # Steps: 6 | # 7 | # Pre-release work: 8 | # ================ 9 | # - Update change log 10 | # - tag release in subversion 11 | # svn copy trunk tags/RELEASE-x.y.z 12 | # 13 | 14 | export $VER=0.3.0 15 | 16 | # Building a release 17 | # ================== 18 | # - export release tag into temp dir 19 | svn export \ 20 | http://robinbowes.com/svn/flac2mp3/tags/RELEASE-$VER \ 21 | flac2mp3-$VER 22 | # - remove some dirs from the export so they aren't packaged 23 | rm -rf flac2mp3-$VER/patches 24 | # - create tarball and gzip 25 | tar cvzf flac2mp3-$VER.tar.gz flac2mp3-$VER 26 | # - create zip file (for windows users) 27 | zip -r9 flac2mp3-$VER.zip flac2mp3-$VER 28 | # - copy to download directory 29 | -------------------------------------------------------------------------------- /utils/makerelease.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # utility to create a release 4 | 5 | # Steps: 6 | # 7 | # Pre-release work: 8 | # ================ 9 | # - Update change log 10 | # - tag release in subversion 11 | # svn copy trunk tags/RELEASE-x.y.z 12 | # 13 | 14 | export VER="0.3.0rc3" 15 | 16 | # Building a release 17 | # ================== 18 | # - export release tag into temp dir 19 | svn export \ 20 | http://projects.robinbowes.com/svn/flac2mp3/tags/RELEASE-${VER} \ 21 | flac2mp3-${VER} && 22 | # - remove some dirs from the export so they aren't packaged 23 | rm -rf flac2mp3-${VER}/patches flac2mp3-${VER}/utils && 24 | # - create tarball and gzip 25 | tar cvzf flac2mp3-${VER}.tar.gz flac2mp3-${VER} && 26 | # - create zip file (for windows users) 27 | zip -r9 flac2mp3-${VER}.zip flac2mp3-${VER} && 28 | # - copy to download directory 29 | scp \ 30 | flac2mp3-${VER}.tar.gz \ 31 | flac2mp3-${VER}.zip \ 32 | root@projects.robinbowes.com:/var/www/projects/htdocs/download/flac2mp3 33 | -------------------------------------------------------------------------------- /lib/MP3/Tag/LastResort.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::LastResort; 2 | 3 | use strict; 4 | use vars qw /$VERSION @ISA/; 5 | 6 | $VERSION="1.00"; 7 | @ISA = 'MP3::Tag::__hasparent'; 8 | 9 | =pod 10 | 11 | =head1 NAME 12 | 13 | MP3::Tag::LastResort - Module for using other fields to fill autoinfo fields. 14 | 15 | =head1 SYNOPSIS 16 | 17 | my $mp3extra = MP3::Tag::LastResort::new_with_parent($filename, $parent); 18 | $comment = $mp3inf->comment(); 19 | 20 | see L 21 | 22 | =head1 DESCRIPTION 23 | 24 | MP3::Tag::LastResort is designed to be called from the MP3::Tag module. 25 | 26 | It uses the artist_collection() as comment() if comment() is not otherwise 27 | defined. 28 | 29 | =cut 30 | 31 | 32 | # Constructor 33 | 34 | sub new_with_parent { 35 | my ($class, $filename, $parent) = @_; 36 | bless {parent => $parent}, $class; 37 | } 38 | 39 | # Destructor 40 | 41 | sub DESTROY {} 42 | 43 | for my $elt ( qw( title track artist album year genre ) ) { 44 | no strict 'refs'; 45 | *$elt = sub (;$) { return }; 46 | } 47 | 48 | sub comment { 49 | shift->{parent}->artist_collection() 50 | } 51 | 52 | 1; 53 | -------------------------------------------------------------------------------- /lib/MP3/Tag/ImageSize.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::ImageSize; 2 | 3 | use strict; 4 | use File::Basename; 5 | #use File::Spec; 6 | use vars qw /$VERSION @ISA/; 7 | 8 | $VERSION="0.01"; 9 | @ISA = 'MP3::Tag::__hasparent'; 10 | 11 | =pod 12 | 13 | =head1 NAME 14 | 15 | MP3::Tag::ImageSize - extract size info from image files via L. 16 | 17 | =head1 SYNOPSIS 18 | 19 | my $db = MP3::Tag::ImageSize->new($filename); # Name of multimedia file 20 | 21 | see L 22 | 23 | =head1 DESCRIPTION 24 | 25 | MP3::Tag::ImageSize is designed to be called from the MP3::Tag module. 26 | 27 | It implements width(), height() and mime_type() methods (sizes in pixels). 28 | 29 | They return C if C is not available, or does not return valid data. 30 | 31 | =head1 SEE ALSO 32 | 33 | L, L 34 | 35 | =cut 36 | 37 | 38 | # Constructor 39 | 40 | sub new_with_parent { 41 | my ($class, $f, $p, $e, %seen, @cue) = (shift, shift, shift); 42 | $f = $f->filename if ref $f; 43 | bless [$f], $class; 44 | } 45 | 46 | sub new { 47 | my ($class, $f) = (shift, shift); 48 | $class->new_with_parent($f, undef, @_); 49 | } 50 | 51 | # Destructor 52 | 53 | sub DESTROY {} 54 | 55 | my @fields = qw( 0 0 width height img_type mime_type ); 56 | for my $elt ( 2, 3, 4, 5 ) { # i_bitdepth 57 | my $r = sub (;$) { 58 | my $self = shift; 59 | unless ($self->[1]) { 60 | my ($w, $h, $t) = eval { require Image::Size; 61 | Image::Size::imgsize($self->[0]) }; 62 | defined $w or @$self[1..4] = (1,undef,undef,undef), return; 63 | my $tt = "image/\L$t"; 64 | @$self[1..5] = (1, $w, $h, $t, $tt); 65 | } 66 | return $self->[$elt]; 67 | }; 68 | no strict 'refs'; 69 | *{$fields[$elt]} = $r; 70 | } 71 | 72 | for my $elt ( qw( title track artist album year genre comment ) ) { 73 | no strict 'refs'; 74 | *$elt = sub (;$) { return }; 75 | } 76 | 77 | 1; 78 | -------------------------------------------------------------------------------- /patches/flac2mp3.pl-r107-quotemeta.patch: -------------------------------------------------------------------------------- 1 | --- flac2mp3.pl 2008-03-30 15:44:48.000000000 +0100 2 | +++ flac2mp3-quotemeta-patch.pl 2008-03-30 15:41:35.000000000 +0100 3 | @@ -465,24 +465,26 @@ 4 | 5 | # Building command used to convert file (tagging done afterwards) 6 | # Needs some work on quoting filenames containing special characters 7 | - my $quotedsrc = $srcfilename; 8 | - my $quoteddest = $destfilename; 9 | + my $quotedsrc = quotemeta $srcfilename; 10 | + my $quoteddest = quotemeta $destfilename; 11 | 12 | if ( ( !$pflags{exists} || $pflags{md5} || $::Options{force} ) 13 | && !$::Options{tagsonly} ) 14 | { 15 | 16 | $::Options{info} 17 | - && msg( $pretendString . "Transcoding \"$quotedsrc\"" ); 18 | + && msg( $pretendString . "Transcoding \"$srcfilename\"" ); 19 | 20 | # Transcode to a temp file in the destdir. 21 | # Rename the file if the conversion completes sucessfully 22 | # This avoids leaving incomplete files in the destdir 23 | # If we're "pretending", don't create a File::Temp object 24 | my $tmpfilename; 25 | + my $quotedtmp; 26 | my $tmpfh; 27 | if ( $::Options{pretend} ) { 28 | - $tmpfilename = $quoteddest; 29 | + $tmpfilename = $destfilename; 30 | + $quotedtmp = $quoteddest; 31 | } 32 | else { 33 | 34 | @@ -497,11 +499,12 @@ 35 | SUFFIX => '.tmp' 36 | ); 37 | $tmpfilename = $tmpfh->filename; 38 | + $quotedtmp = quotemeta $tmpfilename; 39 | } 40 | 41 | my $convert_command = 42 | - "\"$flaccmd\" @flacargs \"$quotedsrc\"" 43 | - . "| \"$lamecmd\" @lameargs - \"$tmpfilename\""; 44 | + "\"$flaccmd\" @flacargs $quotedsrc" 45 | + . "| \"$lamecmd\" @lameargs - $quotedtmp"; 46 | 47 | $::Options{debug} && msg("$convert_command"); 48 | 49 | -------------------------------------------------------------------------------- /patches/musicbrainz.patch: -------------------------------------------------------------------------------- 1 | --- flac2mp3-0.2.6-dist.pl 2005-08-31 18:56:32.261493095 +0200 2 | +++ flac2mp3-0.2.6.pl 2005-09-06 17:29:04.466870634 +0200 3 | @@ -60,9 +60,28 @@ 4 | 'GENRE' => 'TCON', 5 | 'TITLE' => 'TIT2', 6 | 'TRACKNUMBER' => 'TRCK', 7 | + 'MUSICBRAINZ_ALBUMID' => 'TXXX', 8 | + 'MUSICBRAINZ_ALBUMSTATUS' => 'TXXX', 9 | + 'MUSICBRAINZ_ALBUMTYPE' => 'TXXX', 10 | + 'MUSICBRAINZ_ARTISTID' => 'TXXX', 11 | + 'MUSICBRAINZ_SORTNAME' => 'TXXX', 12 | + 'MUSICBRAINZ_TRACKID' => 'UFID', 13 | + 'MUSICBRAINZ_TRMID' => 'TXXX' 14 | ); 15 | 16 | -# Hash telling us which key to use if a complex frame hash is encountered 17 | + 18 | +our %MP3frametexts = ( 19 | + 'MUSICBRAINZ_ALBUMARTISTID' => 'MusicBrainz Album Artist Id', 20 | + 'MUSICBRAINZ_ALBUMID' => 'MusicBrainz Album Id', 21 | + 'MUSICBRAINZ_ALBUMSTATUS' => 'MusicBrainz Album Status', 22 | + 'MUSICBRAINZ_ALBUMTYPE' => 'MusicBrainz Album Type', 23 | + 'MUSICBRAINZ_ARTISTID' => 'MusicBrainz Artist Id', 24 | + 'MUSICBRAINZ_SORTNAME' => 'MusicBrainz Sortname', 25 | + 'MUSICBRAINZ_TRACKID' => 'MB-Trackid', 26 | + 'MUSICBRAINZ_TRMID' => 'MusicBrainz TRM Id', 27 | +); 28 | + 29 | +# us which key to use if a complex frame hash is encountered 30 | # For example, the COMM frame is complex and returns a hash with the 31 | # following keys (with example values): 32 | # 'Language' => 'ENG' 33 | @@ -70,7 +89,7 @@ 34 | # 'Text' => 'This is the actual comment field' 35 | # 36 | # In this case, we want to grab the content of the 'Text' key. 37 | -our %Complex_Frame_Keys = ( 'COMM' => 'Text', ); 38 | +our %Complex_Frame_Keys = ( 'COMM' => 'Text', , 'TXXX' => 'Description'); 39 | 40 | our %Options; 41 | 42 | @@ -387,6 +406,13 @@ 43 | if ( $method eq "COMM" ) { 44 | $mp3->{"ID3v2"} 45 | ->add_frame( $method, 'ENG', 'Short text', $framestring ); 46 | + } elsif ( $method eq "TXXX" ) { 47 | + 48 | + my $frametext = $MP3frametexts{$frame}; 49 | + $frametext = $frame if (!(defined($frametext))); 50 | + 51 | + $mp3->{"ID3v2"} 52 | + ->add_frame( $method, 'ENG', $frametext, $framestring ); 53 | } 54 | else { 55 | $mp3->{"ID3v2"}->add_frame( $method, $framestring ); 56 | 57 | -------------------------------------------------------------------------------- /lib/Number/Compare.pm: -------------------------------------------------------------------------------- 1 | # $Id: Compare.pm 846 2002-10-25 15:46:01Z richardc $ 2 | package Number::Compare; 3 | use strict; 4 | use Carp qw(croak); 5 | use vars qw/$VERSION/; 6 | $VERSION = '0.01'; 7 | 8 | sub new { 9 | my $referent = shift; 10 | my $class = ref $referent || $referent; 11 | my $expr = $class->parse_to_perl( shift ); 12 | 13 | bless eval "sub { \$_[0] $expr }", $class; 14 | } 15 | 16 | sub parse_to_perl { 17 | shift; 18 | my $test = shift; 19 | 20 | $test =~ m{^ 21 | ([<>]=?)? # comparison 22 | (.*?) # value 23 | ([kmg]i?)? # magnitude 24 | $}ix 25 | or croak "don't understand '$test' as a test"; 26 | 27 | my $comparison = $1 || '=='; 28 | my $target = $2; 29 | my $magnitude = $3; 30 | $target *= 1000 if lc $magnitude eq 'k'; 31 | $target *= 1024 if lc $magnitude eq 'ki'; 32 | $target *= 1000000 if lc $magnitude eq 'm'; 33 | $target *= 1024*1024 if lc $magnitude eq 'mi'; 34 | $target *= 1000000000 if lc $magnitude eq 'g'; 35 | $target *= 1024*1024*1024 if lc $magnitude eq 'gi'; 36 | 37 | return "$comparison $target"; 38 | } 39 | 40 | sub test { $_[0]->( $_[1] ) } 41 | 42 | 1; 43 | 44 | __END__ 45 | 46 | =head1 NAME 47 | 48 | Number::Compare - numeric comparisons 49 | 50 | =head1 SYNOPSIS 51 | 52 | Number::Compare->new(">1Ki")->test(1025); # is 1025 > 1024 53 | 54 | my $c = Number::Compare->new(">1M"); 55 | $c->(1_200_000); # slightly terser invocation 56 | 57 | =head1 DESCRIPTION 58 | 59 | Number::Compare compiles a simple comparison to an anonymous 60 | subroutine, which you can call with a value to be tested again. 61 | 62 | Now this would be very pointless, if Number::Compare didn't understand 63 | magnitudes. 64 | 65 | The target value may use magnitudes of kilobytes (C, C), 66 | megabytes (C, C), or gigabytes (C, C). Those suffixed 67 | with an C use the appropriate 2**n version in accordance with the 68 | IEC standard: http://physics.nist.gov/cuu/Units/binary.html 69 | 70 | =head1 METHODS 71 | 72 | =head2 ->new( $test ) 73 | 74 | Returns a new object that compares the specified test. 75 | 76 | =head2 ->test( $value ) 77 | 78 | A longhanded version of $compare->( $value ). Predates blessed 79 | subroutine reference implementation. 80 | 81 | =head2 ->parse_to_perl( $test ) 82 | 83 | Returns a perl code fragment equivalent to the test. 84 | 85 | =head1 AUTHOR 86 | 87 | Richard Clamp 88 | 89 | =head1 COPYRIGHT 90 | 91 | Copyright (C) 2002 Richard Clamp. All Rights Reserved. 92 | 93 | This module is free software; you can redistribute it and/or modify it 94 | under the same terms as Perl itself. 95 | 96 | =head1 SEE ALSO 97 | 98 | http://physics.nist.gov/cuu/Units/binary.html 99 | 100 | =cut 101 | -------------------------------------------------------------------------------- /lib/MP3/Tag/ImageExifTool.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::ImageExifTool; 2 | 3 | use strict; 4 | use File::Basename; 5 | #use File::Spec; 6 | use vars qw /$VERSION @ISA/; 7 | 8 | $VERSION="1.14"; 9 | @ISA = 'MP3::Tag::__hasparent'; 10 | 11 | =pod 12 | 13 | =head1 NAME 14 | 15 | MP3::Tag::ImageExifTool - extract size info from image files via L. 16 | 17 | =head1 SYNOPSIS 18 | 19 | my $db = MP3::Tag::ImageExifTool->new($filename); # Name of multimedia file 20 | 21 | see L 22 | 23 | =head1 DESCRIPTION 24 | 25 | MP3::Tag::ImageExifTool is designed to be called from the MP3::Tag module. 26 | 27 | It implements the (standard) methods qw(title track artist album year genre comment), 28 | as well as width(), height(), bit_depth(), _duration() and mime_type() methods (sizes in pixels). 29 | 30 | Use method C to access a particular field provided by C. 31 | 32 | These methods return C if C is not available, or does not return valid data. 33 | 34 | =cut 35 | 36 | 37 | # Constructor 38 | 39 | sub new_with_parent { 40 | my ($class, $f, $p, $e, %seen, @cue) = (shift, shift, shift); 41 | $f = $f->filename if ref $f; 42 | bless [$f], $class; 43 | } 44 | 45 | sub new { 46 | my ($class, $f) = (shift, shift); 47 | $class->new_with_parent($f, undef, @_); 48 | } 49 | 50 | # Destructor 51 | 52 | sub DESTROY {} 53 | 54 | sub __info ($) { 55 | my $self = shift; 56 | unless (defined $self->[1]) { 57 | my $v = eval { require Image::ExifTool; 58 | Image::ExifTool->new()->ImageInfo($self->[0], '-id3:*') }; 59 | # How to detect errors? 60 | $self->[1] = $v->{Error} ? '' : $v; 61 | } 62 | return $self->[1]; 63 | } 64 | 65 | my %tr = qw( mime_type MIMEType year Date width ImageWidth height ImageHeight 66 | bit_depth BitDepth ); 67 | 68 | for my $elt ( qw( title track artist album year genre comment mime_type 69 | width height ) ) { 70 | my $n = ($tr{$elt} or ucfirst $elt); 71 | my $is_genre = ($elt eq 'genre'); 72 | my $r = sub ($) { 73 | my $info = shift()->__info; 74 | return unless $info; 75 | my $v = $info->{$n}; 76 | $v =~ s/^None$// if $is_genre and $v; 77 | return $v; 78 | }; 79 | no strict 'refs'; 80 | *$elt = $r; 81 | } 82 | 83 | sub bit_depth ($) { 84 | my $info = shift()->__info; 85 | return unless $info; 86 | $info->{BitsPerSample} || $info->{Depth} || $info->{BitDepth} 87 | } 88 | 89 | sub field ($$) { 90 | my $info = shift()->__info; 91 | return unless $info; 92 | $info->{shift()} 93 | } 94 | 95 | sub _duration ($) { 96 | my $info = shift()->__info; 97 | return unless $info; 98 | my($d, $dd) = $info->{Duration}; 99 | if (defined $d and $d =~ /\d/) { 100 | $dd = 1; 101 | return $d if $d =~ /^\d*(\.\d*)?$/; 102 | } 103 | # Probably this is already covered by Duration? No, it is usually rounded... 104 | my($c, $r, $r1) = map $info->{$_}, qw(FrameCount VideoFrameRate FrameRate); 105 | unless (defined $c and $r ||= $r1) { # $d usually contains rounded value 106 | return $1*3600 + $2*60 + $3 if $dd and $d =~ /^(\d+):(\d+):(\d+(\.\d*)?)$/; 107 | return $1*60 + $2 if $dd and $d =~ /^(\d+):(\d+(\.\d*)?)$/; 108 | return; 109 | } 110 | $r = 30/1.001 if $r =~ /^29.97\d*^/; 111 | $r = 24/1.001 if $r =~ /^23.9(7\d*|8)$/; 112 | $c/$r 113 | } 114 | 115 | sub img_type ($) { 116 | my $self = shift; 117 | my $t = $self->mime_type; 118 | return uc $1 if $t =~ m(^image/(.*)); 119 | return; 120 | } 121 | 122 | 1; 123 | -------------------------------------------------------------------------------- /readme.txt: -------------------------------------------------------------------------------- 1 | About flac2mp3 2 | ============== 3 | 4 | flac2mp3 is a perl script that will search for flac files within 5 | a directory hierarchy and convert them all to mp3 format, creating a 6 | matching directory structure in the process. 7 | 8 | I wrote it as I have a large collection of flac files but need to 9 | convert them to mp3 format for use with my iPod. 10 | 11 | There are a few programs that can do basic file format conversion 12 | but I found that it was hard to detect which files were new in my 13 | flac collection and to convert just those files. I also find I update 14 | the metadata in my flac files fairly often (when I spot mistakes, etc.) 15 | and needed a way to update just the tags rather than running the whole 16 | conversion process again. 17 | 18 | flac2mp3 can do this. 19 | 20 | It can take a directory structure like this: 21 | 22 | lossless 23 | | 24 | +--Coldplay 25 | | | 26 | | +--Parachutes 27 | | | 28 | | +-- 01 - Don't Panic.flac 29 | | 02 - Shiver.flac 30 | +--The Chameleons 31 | | 32 | +Script of the Bridge 33 | | 34 | +-- 01 - Don't Fall.flac 35 | 02 - Here Today.flac 36 | 37 | And produce a directory structure like this: 38 | 39 | lossy 40 | | 41 | +--Coldplay 42 | | | 43 | | +--Parachutes 44 | | | 45 | | +-- 01 - Don't Panic.mp3 46 | | 02 - Shiver.mp3 47 | +--The Chameleons 48 | | 49 | +Script of the Bridge 50 | | 51 | +-- 01 - Don't Fall.mp3 52 | 02 - Here Today.mp3 53 | 54 | The command to do this is: 55 | 56 | flac2mp3.pl /path/to/lossless /path/to/lossy 57 | 58 | Now, suppose I notice that I've spelled "coldplay" wrongly. I simply 59 | use a tag editor to correct the flac files then run flac2mp3 again 60 | to update the tags in the mp3 files: 61 | 62 | flac2mp3.pl /path/to/lossless /path/to/lossy 63 | 64 | flac2mp3 will detect that just the tags have changed in the flac files 65 | and update the mp3 files without re-transcoding. 66 | 67 | Command-line options can be seen by typing "flac2mp3.pl" with no options: 68 | 69 | Usage: ./flac2mp3.pl [--pretend] [--quiet] [--debug] [--tagsonly] [--force] 70 | [--tagdiff] 71 | --pretend Don't actually do anything 72 | --quiet Disable informational output to stdout 73 | --debug Enable debugging output. For developers only! 74 | --tagsonly Don't do any transcoding - just update tags 75 | --force Force transcoding and tag update even if not required 76 | --tagdiff Print source/dest tag values if different 77 | 78 | Installation 79 | ============ 80 | 81 | As of v0.2.6 all non-standard perl modules are supplied in the archive. 82 | Installation should be as simple as extracting the archive into a 83 | directory of your choice. 84 | 85 | For example, on linux: 86 | 87 | # cd ~/bin 88 | # tar zxvf flac2mp3-0.3.0.tar.gz 89 | 90 | On Windows, you can use Winzip or other utility to unzip the file and 91 | extract the archive. 92 | 93 | Mailing lists 94 | ============= 95 | 96 | The following mailing lists are available: 97 | 98 | List address: flac2mp3-announce@robinbowes.com 99 | Description: Read-only list for announcements 100 | To subscribe: flac2mp3-announce-subscribe@robinbowes.com 101 | 102 | List address: flac2mp3-devel@robinbowes.com 103 | Description: Developer discussion 104 | To subscribe: flac2mp3-devel-subscribe@robinbowes.com 105 | 106 | List address: flac2mp3-general@robinbowes.com 107 | Description: General user discussion 108 | To subscribe: flac2mp3-general-subscribe@robinbowes.com 109 | 110 | Please report any issues to robin-flac2mp3@robinbowes.com 111 | 112 | Robin Bowes 113 | July 2007 114 | -------------------------------------------------------------------------------- /lib/MP3/Tag/Inf.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::Inf; 2 | 3 | use strict; 4 | use vars qw /$VERSION @ISA/; 5 | 6 | $VERSION="1.00"; 7 | @ISA = 'MP3::Tag::__hasparent'; 8 | 9 | =pod 10 | 11 | =head1 NAME 12 | 13 | MP3::Tag::Inf - Module for parsing F<.inf> files associated with music tracks. 14 | 15 | =head1 SYNOPSIS 16 | 17 | my $mp3inf = MP3::Tag::Inf->new($filename); # Name of MP3 or .INF file 18 | # or an MP3::Tag::File object 19 | 20 | ($title, $artist, $album, $year, $comment, $track) = $mp3inf->parse(); 21 | 22 | see L 23 | 24 | =head1 DESCRIPTION 25 | 26 | MP3::Tag::Inf is designed to be called from the MP3::Tag module. 27 | 28 | It parses the content of F<.inf> file (created, e.g., by cdda2wav). 29 | 30 | =over 4 31 | 32 | =cut 33 | 34 | 35 | # Constructor 36 | 37 | sub new_with_parent { 38 | my ($class, $filename, $parent) = @_; 39 | my $self = bless {parent => $parent}, $class; 40 | 41 | $filename = $filename->filename if ref $filename; 42 | my $ext_rex = $self->get_config('extension')->[0]; 43 | $filename =~ s/($ext_rex)|$/.inf/; # replace extension 44 | return unless -f $filename; 45 | $self->{filename} = $filename; 46 | $self; 47 | } 48 | 49 | # Destructor 50 | 51 | sub DESTROY {} 52 | 53 | =item parse() 54 | 55 | ($title, $artist, $album, $year, $comment, $track) = 56 | $mp3inf->parse($what); 57 | 58 | parse_filename() extracts information about artist, title, track number, 59 | album and year from the F<.inf> file. $what is optional; it maybe title, 60 | track, artist, album, year or comment. If $what is defined parse() will return 61 | only this element. 62 | 63 | As a side effect of this call, $mp3inf->{info} is set to the hash reference 64 | with the content of particular elements of the F<.inf> file. Typically present 65 | are the following fields: 66 | 67 | CDINDEX_DISCID 68 | CDDB_DISCID 69 | MCN 70 | ISRC 71 | Albumperformer 72 | Performer 73 | Albumtitle 74 | Tracktitle 75 | Tracknumber 76 | Trackstart 77 | Tracklength 78 | Pre-emphasis 79 | Channels 80 | Copy_permitted 81 | Endianess 82 | Index 83 | 84 | The following fields are also recognized: 85 | 86 | Year 87 | Trackcomment 88 | 89 | =cut 90 | 91 | sub return_parsed { 92 | my ($self,$what) = @_; 93 | if (defined $what) { 94 | return $self->{parsed}{album} if $what =~/^al/i; 95 | return $self->{parsed}{artist} if $what =~/^a/i; 96 | return $self->{parsed}{track} if $what =~/^tr/i; 97 | return $self->{parsed}{year} if $what =~/^y/i; 98 | return $self->{parsed}{genre} if $what =~/^g/i; 99 | if ($what =~/^cddb_id/i) { 100 | my $o = $self->{parsed}{Cddb_discid}; 101 | $o =~ s/^0x//i if $o; 102 | return $o; 103 | } 104 | return $self->{parsed}{Cdindex_discid} if $what =~/^cdindex_id/i; 105 | return $self->{parsed}{comment}if $what =~/^c/i; 106 | return $self->{parsed}{title}; 107 | } 108 | 109 | return $self->{parsed} unless wantarray; 110 | return map $self->{parsed}{$_} , qw(title artist album year comment track); 111 | } 112 | 113 | sub parse { 114 | my ($self,$what) = @_; 115 | 116 | $self->return_parsed($what) if exists $self->{parsed}; 117 | local *IN; 118 | open IN, "< $self->{filename}" or die "Error opening `$self->{filename}': $!"; 119 | my $e; 120 | if ($e = $self->get_config('decode_encoding_inf') and $e->[0]) { 121 | eval "binmode IN, ':encoding($e->[0])'"; # old binmode won't compile... 122 | } 123 | my ($line, %info); 124 | for $line () { 125 | $self->{info}{ucfirst lc $1} = $2 126 | if $line =~ /^(\S+)\s*=\s*['"]?(.*?)['"]?\s*$/; 127 | } 128 | close IN or die "Error closing `$self->{filename}': $!"; 129 | my %parsed; 130 | @parsed{ qw( title artist album year comment track Cddb_discid Cdindex_discid ) } = 131 | @{ $self->{info} }{ qw( Tracktitle Performer Albumtitle 132 | Year Trackcomment Tracknumber 133 | Cddb_discid Cdindex_discid) }; 134 | $parsed{artist} = $self->{info}{Albumperformer} 135 | unless defined $parsed{artist}; 136 | $self->{parsed} = \%parsed; 137 | $self->return_parsed($what); 138 | } 139 | 140 | for my $elt ( qw( title track artist album comment year genre cddb_id cdindex_id ) ) { 141 | no strict 'refs'; 142 | *$elt = sub (;$) { 143 | my $self = shift; 144 | $self->parse($elt, @_); 145 | } 146 | } 147 | 148 | 1; 149 | -------------------------------------------------------------------------------- /changelog.txt: -------------------------------------------------------------------------------- 1 | v1.0.0 2 | - Lots of bugs fixed and features added so decided to release v1.0.0 3 | - --version option now works! 4 | v0.3.0 5 | - Remove File::Glob (it's in core) and add Text::Glob 6 | - Re-work & refactor the search/checking code 7 | - Update to bundled CPAN modules (MP3::Tag 1.11, File::Which 1.09) 8 | - Use FLAC MD5 checksum to determine whether or not to transcode the file 9 | - Add "--pretend" option 10 | - Handle multiple tags of the same type, e.g. multiple Artist tags 11 | - Update how command-line switches interact (--tagsonly now overrides 12 | --force) 13 | - Write two separate notifications - one for transcoding, one for tags 14 | - make file search case-insensitive (.flac and .FLAC) 15 | - only check for ".flac" at the end of the filename 16 | - Fix detection of flac/lame executables 17 | - Add instructions about how to specify flac/lame paths 18 | - Change quoting of flac/lame command 19 | - Change shebang (apparently, env is usually in /usr/bin) 20 | - Update CPAN modules distributed with package 21 | - Transcode to a temp file and rename if successful 22 | - Remove fork/exec code and revert to "system" command. 23 | - Add ALBUMARTIST and COMPILATION tags 24 | - Add "--noreplaygain" to lame options 25 | - Add "--pretend" 26 | - Various code clean-ups and bug fixes 27 | v0.2.9 28 | - Rewrite of fork/exec code to work on Windows 29 | (thanks Darren Warner ) 30 | - Check that flac and lame commands are available at startup 31 | v0.2.8 32 | - fixups related to checking of TRACKNUMBER tag 33 | - Added support for Composer,Conductor, ISRC, Lyricist, Publisher, 34 | Discnumber tags 35 | - Fixed complex tags - Comments and Musicbrainz tags now work 36 | - correctly 37 | - Strip trailing spaces from source file tag values to work around a 38 | bug in MP3::Tag (it doesn't write trailing spaces) 39 | - Added "--tagdif" option - when enabled it prints any changed tag 40 | values 41 | - Use fork/exec to run flac/lame. Bypasses any shell quoting issues. 42 | However, will it work on Windows? 43 | (thanks Darren Warner ) 44 | - added new options: 45 | --usage 46 | --help 47 | --version 48 | - follow symlinks when searching for files 49 | (thanks Max Spicer 50 | - fixed bug when directories specified as relative paths 51 | (thanks Max Spicer 52 | - fixed bug in count of no. flac files found (ticket #1) 53 | v0.2.7 54 | - changed the way file and directory names are processed to be 55 | more portable (Now make more extensive use of File::Spec) 56 | - Now processes MusicBrainz tags 57 | (thanks Hakan ) 58 | v0.2.6 59 | - Now ships with additional non-standard modules 60 | - Now works on Windows (tested with ActiveState Perl v5.8.7 61 | - Moved Revision history to separate file 62 | - Added some documentation 63 | v0.2.5 64 | - Added better handling of complex frames, e.g. Comments 65 | - use File::Find::Rule instead of custom recursive sub 66 | - Moved command-line options into hash 67 | - fix up SRC track number as well as DEST 68 | v0.2.4 69 | - Handle extended characters better (accents, etc.) [thanks Dan Sully] 70 | - Don't reset timestamp of destination file 71 | - Moved flags into a hash structures (%Options, %pflags} 72 | - Other code restructuring 73 | v0.2.3 74 | - Added --force option to force conversion 75 | - files/directories now processed alphabetically 76 | - Now handles Comments correctly (Comments are complex frames) 77 | - Tidied up code with perltidy (http://perltidy.sf.net) 78 | v0.2.2 79 | - Bug-fix: timestamp comparison not quite right 80 | - Be more robust when converting files 81 | (thanks Darren Warner ) 82 | v0.2.1 83 | - Bug-fix: omitted File::Path module include 84 | v0.2.0 85 | - Only create directories if files are found in them 86 | - Make output less cluttered (only display filenames, not whole path) 87 | - Changed command-line options. 88 | - Major overhaul of tag handling. Now using MP3::Tag module 89 | to write tags to mp3 files. Allows tags to be read separately 90 | v0.1.4 91 | - Fix for files with multiple periods in filename, e.g. "01 - Back In 92 | The U.S.S.R..flac" would be converted as "Back In The U.mp3" 93 | - Fix for timestamp comparison (got it the right way round this 94 | time!) 95 | v0.1.3 96 | - added --quiet option to flac and lame commands 97 | - only run conversion if dest file doesn't exist or if src file is 98 | newer than dest file 99 | - set modification time of dest file to same as src file 100 | - check exit value of conversion command 101 | - fixed problem with certain characters in file/directory name quoting 102 | v0.1.1 103 | - Changes to filename quoting 104 | v0.1.0 105 | - Initial version 106 | v0.1.2 107 | - Fixed filename quoting 108 | v0.1.1 109 | - Changes to filename quoting 110 | v0.1.0 111 | - Initial version 112 | -------------------------------------------------------------------------------- /lib/Text/Glob.pm: -------------------------------------------------------------------------------- 1 | package Text::Glob; 2 | use strict; 3 | use Exporter; 4 | use vars qw/$VERSION @ISA @EXPORT_OK 5 | $strict_leading_dot $strict_wildcard_slash/; 6 | $VERSION = '0.08'; 7 | @ISA = 'Exporter'; 8 | @EXPORT_OK = qw( glob_to_regex glob_to_regex_string match_glob ); 9 | 10 | $strict_leading_dot = 1; 11 | $strict_wildcard_slash = 1; 12 | 13 | use constant debug => 0; 14 | 15 | sub glob_to_regex { 16 | my $glob = shift; 17 | my $regex = glob_to_regex_string($glob); 18 | return qr/^$regex$/; 19 | } 20 | 21 | sub glob_to_regex_string 22 | { 23 | my $glob = shift; 24 | my ($regex, $in_curlies, $escaping); 25 | local $_; 26 | my $first_byte = 1; 27 | for ($glob =~ m/(.)/gs) { 28 | if ($first_byte) { 29 | if ($strict_leading_dot) { 30 | $regex .= '(?=[^\.])' unless $_ eq '.'; 31 | } 32 | $first_byte = 0; 33 | } 34 | if ($_ eq '/') { 35 | $first_byte = 1; 36 | } 37 | if ($_ eq '.' || $_ eq '(' || $_ eq ')' || $_ eq '|' || 38 | $_ eq '+' || $_ eq '^' || $_ eq '$' || $_ eq '@' || $_ eq '%' ) { 39 | $regex .= "\\$_"; 40 | } 41 | elsif ($_ eq '*') { 42 | $regex .= $escaping ? "\\*" : 43 | $strict_wildcard_slash ? "[^/]*" : ".*"; 44 | } 45 | elsif ($_ eq '?') { 46 | $regex .= $escaping ? "\\?" : 47 | $strict_wildcard_slash ? "[^/]" : "."; 48 | } 49 | elsif ($_ eq '{') { 50 | $regex .= $escaping ? "\\{" : "("; 51 | ++$in_curlies unless $escaping; 52 | } 53 | elsif ($_ eq '}' && $in_curlies) { 54 | $regex .= $escaping ? "}" : ")"; 55 | --$in_curlies unless $escaping; 56 | } 57 | elsif ($_ eq ',' && $in_curlies) { 58 | $regex .= $escaping ? "," : "|"; 59 | } 60 | elsif ($_ eq "\\") { 61 | if ($escaping) { 62 | $regex .= "\\\\"; 63 | $escaping = 0; 64 | } 65 | else { 66 | $escaping = 1; 67 | } 68 | next; 69 | } 70 | else { 71 | $regex .= $_; 72 | $escaping = 0; 73 | } 74 | $escaping = 0; 75 | } 76 | print "# $glob $regex\n" if debug; 77 | 78 | return $regex; 79 | } 80 | 81 | sub match_glob { 82 | print "# ", join(', ', map { "'$_'" } @_), "\n" if debug; 83 | my $glob = shift; 84 | my $regex = glob_to_regex $glob; 85 | local $_; 86 | grep { $_ =~ $regex } @_; 87 | } 88 | 89 | 1; 90 | __END__ 91 | 92 | =head1 NAME 93 | 94 | Text::Glob - match globbing patterns against text 95 | 96 | =head1 SYNOPSIS 97 | 98 | use Text::Glob qw( match_glob glob_to_regex ); 99 | 100 | print "matched\n" if match_glob( "foo.*", "foo.bar" ); 101 | 102 | # prints foo.bar and foo.baz 103 | my $regex = glob_to_regex( "foo.*" ); 104 | for ( qw( foo.bar foo.baz foo bar ) ) { 105 | print "matched: $_\n" if /$regex/; 106 | } 107 | 108 | =head1 DESCRIPTION 109 | 110 | Text::Glob implements glob(3) style matching that can be used to match 111 | against text, rather than fetching names from a filesystem. If you 112 | want to do full file globbing use the File::Glob module instead. 113 | 114 | =head2 Routines 115 | 116 | =over 117 | 118 | =item match_glob( $glob, @things_to_test ) 119 | 120 | Returns the list of things which match the glob from the source list. 121 | 122 | =item glob_to_regex( $glob ) 123 | 124 | Returns a compiled regex which is the equiavlent of the globbing 125 | pattern. 126 | 127 | =item glob_to_regex_string( $glob ) 128 | 129 | Returns a regex string which is the equiavlent of the globbing 130 | pattern. 131 | 132 | =back 133 | 134 | =head1 SYNTAX 135 | 136 | The following metacharacters and rules are respected. 137 | 138 | =over 139 | 140 | =item C<*> - match zero or more characters 141 | 142 | C matches C, C, C and many many more. 143 | 144 | =item C - match exactly one character 145 | 146 | C matches C, but not C, or C 147 | 148 | =item Character sets/ranges 149 | 150 | C matches C and C 151 | 152 | C matches C, C, and C 153 | 154 | =item alternation 155 | 156 | C matches C, C, and 157 | C 158 | 159 | =item leading . must be explictly matched 160 | 161 | C<*.foo> does not match C<.bar.foo>. For this you must either specify 162 | the leading . in the glob pattern (C<.*.foo>), or set 163 | C<$Text::Glob::strict_leading_dot> to a false value while compiling 164 | the regex. 165 | 166 | =item C<*> and C do not match / 167 | 168 | C<*.foo> does not match C. For this you must either 169 | explicitly match the / in the glob (C<*/*.foo>), or set 170 | C<$Text::Glob::strict_wildcard_slash> to a false value with compiling 171 | the regex. 172 | 173 | =back 174 | 175 | =head1 BUGS 176 | 177 | The code uses qr// to produce compiled regexes, therefore this module 178 | requires perl version 5.005_03 or newer. 179 | 180 | =head1 AUTHOR 181 | 182 | Richard Clamp 183 | 184 | =head1 COPYRIGHT 185 | 186 | Copyright (C) 2002, 2003, 2006, 2007 Richard Clamp. All Rights Reserved. 187 | 188 | This module is free software; you can redistribute it and/or modify it 189 | under the same terms as Perl itself. 190 | 191 | =head1 SEE ALSO 192 | 193 | L, glob(3) 194 | 195 | =cut 196 | -------------------------------------------------------------------------------- /lib/File/Which.pm: -------------------------------------------------------------------------------- 1 | package File::Which; 2 | 3 | use 5.004; 4 | use strict; 5 | use Exporter (); 6 | use File::Spec (); 7 | 8 | use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK}; 9 | BEGIN { 10 | $VERSION = '1.09'; 11 | @ISA = 'Exporter'; 12 | @EXPORT = 'which'; 13 | @EXPORT_OK = 'where'; 14 | } 15 | 16 | use constant IS_VMS => ($^O eq 'VMS'); 17 | use constant IS_MAC => ($^O eq 'MacOS'); 18 | use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2'); 19 | 20 | # For Win32 systems, stores the extensions used for 21 | # executable files 22 | # For others, the empty string is used 23 | # because 'perl' . '' eq 'perl' => easier 24 | my @PATHEXT = (''); 25 | if ( IS_DOS ) { 26 | # WinNT. PATHEXT might be set on Cygwin, but not used. 27 | if ( $ENV{PATHEXT} ) { 28 | push @PATHEXT, split ';', $ENV{PATHEXT}; 29 | } else { 30 | # Win9X or other: doesn't have PATHEXT, so needs hardcoded. 31 | push @PATHEXT, qw{.com .exe .bat}; 32 | } 33 | } elsif ( IS_VMS ) { 34 | push @PATHEXT, qw{.exe .com}; 35 | } 36 | 37 | sub which { 38 | my ($exec) = @_; 39 | 40 | return undef unless $exec; 41 | 42 | my $all = wantarray; 43 | my @results = (); 44 | 45 | # check for aliases first 46 | if ( IS_VMS ) { 47 | my $symbol = `SHOW SYMBOL $exec`; 48 | chomp($symbol); 49 | unless ( $? ) { 50 | return $symbol unless $all; 51 | push @results, $symbol; 52 | } 53 | } 54 | if ( IS_MAC ) { 55 | my @aliases = split /\,/, $ENV{Aliases}; 56 | foreach my $alias ( @aliases ) { 57 | # This has not been tested!! 58 | # PPT which says MPW-Perl cannot resolve `Alias $alias`, 59 | # let's just hope it's fixed 60 | if ( lc($alias) eq lc($exec) ) { 61 | chomp(my $file = `Alias $alias`); 62 | last unless $file; # if it failed, just go on the normal way 63 | return $file unless $all; 64 | push @results, $file; 65 | # we can stop this loop as if it finds more aliases matching, 66 | # it'll just be the same result anyway 67 | last; 68 | } 69 | } 70 | } 71 | 72 | my @path = File::Spec->path; 73 | if ( IS_DOS or IS_VMS or IS_MAC ) { 74 | unshift @path, File::Spec->curdir; 75 | } 76 | 77 | foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) { 78 | for my $ext ( @PATHEXT ) { 79 | my $file = $base.$ext; 80 | 81 | # We don't want dirs (as they are -x) 82 | next if -d $file; 83 | 84 | if ( 85 | # Executable, normal case 86 | -x _ 87 | or ( 88 | # MacOS doesn't mark as executable so we check -e 89 | IS_MAC 90 | || 91 | ( 92 | IS_DOS 93 | and 94 | grep { 95 | $file =~ /$_\z/i 96 | } @PATHEXT[1..$#PATHEXT] 97 | ) 98 | # DOSish systems don't pass -x on 99 | # non-exe/bat/com files. so we check -e. 100 | # However, we don't want to pass -e on files 101 | # that aren't in PATHEXT, like README. 102 | and -e _ 103 | ) 104 | ) { 105 | return $file unless $all; 106 | push @results, $file; 107 | } 108 | } 109 | } 110 | 111 | if ( $all ) { 112 | return @results; 113 | } else { 114 | return undef; 115 | } 116 | } 117 | 118 | sub where { 119 | # force wantarray 120 | my @res = which($_[0]); 121 | return @res; 122 | } 123 | 124 | 1; 125 | 126 | __END__ 127 | 128 | =pod 129 | 130 | =head1 NAME 131 | 132 | File::Which - Portable implementation of the `which' utility 133 | 134 | =head1 SYNOPSIS 135 | 136 | use File::Which; # exports which() 137 | use File::Which qw(which where); # exports which() and where() 138 | 139 | my $exe_path = which('perldoc'); 140 | 141 | my @paths = where('perl'); 142 | - Or - 143 | my @paths = which('perl'); # an array forces search for all of them 144 | 145 | =head1 DESCRIPTION 146 | 147 | C was created to be able to get the paths to executable programs 148 | on systems under which the `which' program wasn't implemented in the shell. 149 | 150 | C searches the directories of the user's C (as returned by 151 | Cpath()>), looking for executable files having the name 152 | specified as a parameter to C. Under Win32 systems, which do not have a 153 | notion of directly executable files, but uses special extensions such as C<.exe> 154 | and C<.bat> to identify them, C takes extra steps to assure that 155 | you will find the correct file (so for example, you might be searching for 156 | C, it'll try F, F, etc.) 157 | 158 | =head1 Steps Used on Win32, DOS, OS2 and VMS 159 | 160 | =head2 Windows NT 161 | 162 | Windows NT has a special environment variable called C, which is used 163 | by the shell to look for executable files. Usually, it will contain a list in 164 | the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C finds such an 165 | environment variable, it parses the list and uses it as the different 166 | extensions. 167 | 168 | =head2 Windows 9x and other ancient Win/DOS/OS2 169 | 170 | This set of operating systems don't have the C variable, and usually 171 | you will find executable files there with the extensions C<.exe>, C<.bat> and 172 | (less likely) C<.com>. C uses this hardcoded list if it's running 173 | under Win32 but does not find a C variable. 174 | 175 | =head2 VMS 176 | 177 | Same case as Windows 9x: uses C<.exe> and C<.com> (in that order). 178 | 179 | =head1 Functions 180 | 181 | =head2 which($short_exe_name) 182 | 183 | Exported by default. 184 | 185 | C<$short_exe_name> is the name used in the shell to call the program (for 186 | example, C). 187 | 188 | If it finds an executable with the name you specified, C will return 189 | the absolute path leading to this executable (for example, F or 190 | F). 191 | 192 | If it does I find the executable, it returns C. 193 | 194 | If C is called in list context, it will return I the 195 | matches. 196 | 197 | =head2 where($short_exe_name) 198 | 199 | Not exported by default. 200 | 201 | Same as C in array context. Same as the 202 | C<`where'> utility, will return an array containing all the path names 203 | matching C<$short_exe_name>. 204 | 205 | =head1 BUGS AND CAVEATS 206 | 207 | Not tested on VMS or MacOS, although there is platform specific code 208 | for those. Anyone who haves a second would be very kind to send me a 209 | report of how it went. 210 | 211 | File::Spec adds the current directory to the front of PATH if on 212 | Win32, VMS or MacOS. I have no knowledge of those so don't know if the 213 | current directory is searced first or not. Could someone please tell 214 | me? 215 | 216 | =head1 SUPPORT 217 | 218 | Bugs should be reported via the CPAN bug tracker at 219 | 220 | L 221 | 222 | For other issues, contact the maintainer. 223 | 224 | =head1 AUTHOR 225 | 226 | Adam Kennedy Eadamk@cpan.orgE 227 | 228 | Per Einar Ellefsen Epereinar@cpan.orgE 229 | 230 | Originated in F. Changed for use in DocSet 231 | (for the mod_perl site) and Win32-awareness by me, with slight modifications 232 | by Stas Bekman, then extracted to create C. 233 | 234 | Version 0.04 had some significant platform-related changes, taken from 235 | the Perl Power Tools C<`which'> implementation by Abigail with 236 | enhancements from Peter Prymmer. See 237 | L for more 238 | information. 239 | 240 | =head1 COPYRIGHT 241 | 242 | Copyright 2002 Per Einar Ellefsen. 243 | 244 | Some parts copyright 2009 Adam Kennedy. 245 | 246 | This program is free software; you can redistribute it and/or modify 247 | it under the same terms as Perl itself. 248 | 249 | =head1 SEE ALSO 250 | 251 | L, L, Perl Power Tools: 252 | L. 253 | 254 | =cut 255 | -------------------------------------------------------------------------------- /lib/MP3/Tag/Cue.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::Cue; 2 | 3 | use strict; 4 | use File::Basename; 5 | #use File::Spec; 6 | use vars qw /$VERSION @ISA/; 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 | my ($class, $data, $track) = @_; 74 | bless {data => [split /\n/, $data], track => $track}, $class; 75 | } 76 | 77 | sub matches($$$) { 78 | my ($f1, $f, $case) = (shift, shift, shift); 79 | substr($f1, -4, 4) = ''; 80 | return $f1 eq substr $f, 0, length $f1 if $case; 81 | return lc $f1 eq lc substr $f, 0, length $f1; 82 | } 83 | 84 | sub find_cue ($$) { 85 | my ($f, $d, %seen) = (shift, shift); 86 | require File::Glob; # "usual" glob() fails on spaces... 87 | my @cue = (File::Glob::bsd_glob("$d/*.cue"), File::Glob::bsd_glob('$d/*.CUE')); 88 | @seen{@cue} = (1) x @cue; # remove duplicates: 89 | @cue = keys %seen; 90 | my $c = @cue; 91 | @cue = grep matches($_, $f, 0), @cue if @cue > 1; 92 | @cue = grep matches($_, $f, 1), @cue if @cue > 1; 93 | ($c, @cue) 94 | } 95 | 96 | sub new_with_parent { 97 | my ($class, $f, $p, $e, %seen, @cue) = (shift, shift, shift); 98 | $f = $f->filename if ref $f; 99 | $f = MP3::Tag->rel2abs($f); 100 | if ($f =~ /\.cue$/i and -f $f) { 101 | @cue = $f; 102 | } else { 103 | my $d = dirname($f); 104 | (my $c, @cue) = find_cue($f, $d); 105 | unless ($c) { 106 | my $d1 = dirname($d); 107 | (my $c, @cue) = find_cue($d, $d1); 108 | } 109 | } 110 | return unless @cue == 1; 111 | local *F; 112 | open F, "< $cue[0]" or die "Can't open `$cue[0]': $!"; 113 | if ($e = ($p or 'MP3::Tag')->get_config1('decode_encoding_cue_file')) { 114 | eval "binmode F, ':encoding($e->[0])'"; # old binmode won't compile... 115 | } 116 | my @data = ; 117 | close F or die "Error closing `$cue[0]': $!"; 118 | bless {filename => $cue[0], data => \@data, track => shift, 119 | parent => $p}, $class; 120 | } 121 | 122 | sub new { 123 | my ($class, $f) = (shift, shift); 124 | $class->new_with_parent($f, undef, @_); 125 | } 126 | 127 | # Destructor 128 | 129 | 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 | my ($self,$what) = @_; 150 | if (defined $what) { 151 | return $self->{parsed}{collection_performer} if $what =~/^artist_collection/i; 152 | return $self->{parsed}{album} if $what =~/^al/i; 153 | return $self->{parsed}{performer} if $what =~/^a/i; 154 | return $self->{parsed}{songwriter} if $what =~/^songwriter/i; 155 | return $self->{parsed}{track} if $what =~/^tr/i; 156 | return $self->{parsed}{date} if $what =~/^y/i; 157 | return $self->{parsed}{comment}if $what =~/^c/i; 158 | return $self->{parsed}{genre} if $what =~/^g/i; 159 | return $self->{parsed}{title}; 160 | } 161 | 162 | return $self->{parsed} unless wantarray; 163 | 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 | my ($self) = @_; 170 | # return if $self->{fields}; 171 | my $track_seen = ''; 172 | my $track = $self->track; 173 | $track = -1e100 unless $track or length $track; 174 | for my $l (@{$self->{data}}) { 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 | 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 | my $field = lc $2; 184 | my $val = $3; 185 | $val =~ s/^\"(.*)\"/$1/; # Ignore trailing fields after TRACK, FILE 186 | $track_seen = $1 if $field eq 'track' and $val =~ /^0?(\d+)/; 187 | next if length $track_seen and $track_seen != $track; 188 | 189 | $self->{fields}{$field} = $val; # unless exists $self->{fields}{$field}; 190 | next if length $track_seen; 191 | $self->{fields}{album} = $val if $field eq 'title'; 192 | $self->{fields}{collection_performer} = $val if $field eq 'performer'; 193 | } 194 | } 195 | 196 | sub parse { 197 | my ($self,$what) = @_; 198 | return $self->return_parsed($what) if exists $self->{parsed}; 199 | $self->parse_lines; 200 | $self->{parsed} = { %{$self->{fields}} }; # Make a copy 201 | $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 | 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 | 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 | my $self = shift; 248 | return $self->{track} if defined $self->{track}; 249 | return if $self->{recursive} or not $self->parent_ok; 250 | local $self->{recursive} = 1; 251 | 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 | 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 | 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 | return shift->parse("comment"); 291 | } 292 | 293 | =item genre() 294 | 295 | $genre = $db->genre($filename); 296 | 297 | =cut 298 | 299 | sub genre { 300 | return shift->parse("genre"); 301 | } 302 | 303 | for my $elt ( qw( artist_collection songwriter ) ) { 304 | no strict 'refs'; 305 | *$elt = sub (;$) { 306 | return shift->parse($elt); 307 | } 308 | } 309 | 310 | 1; 311 | -------------------------------------------------------------------------------- /lib/MP3/Tag/ID3v2_Data.pod: -------------------------------------------------------------------------------- 1 | 2 | =head1 NAME 3 | 4 | MP3::Tag::ID3v2_Data - get_frame() data format and supported frames 5 | 6 | =head1 SYNOPSIS 7 | 8 | $mp3 = MP3::Tag->new($filename); 9 | $mp3->get_tags(); 10 | $id3v2 = $mp3->{ID3v2} if exists $mp3->{id3v2}; 11 | 12 | ($info, $long) = $id3v2->get_frame($id); # or 13 | 14 | ($info, $long) = $id3v2->get_frame($id, 'raw'); 15 | 16 | 17 | =head1 DESCRIPTION 18 | 19 | This document describes how to use the results of the get_frame function of 20 | MP3::Tag::ID3v2, thus the data format of frames retrieved with 21 | MP3::Tag::ID3v2::get_frame(). 22 | 23 | It contains also a list of all supported ID3v2-Frames. 24 | 25 | =head2 get_frame() 26 | 27 | ($info, $long) = $id3v2->get_frame($id); # or 28 | 29 | ($info, $long) = $id3v2->get_frame($id, 'raw'); 30 | 31 | $id has to be a name of a frame like "APIC". For more variants of calling 32 | see L. 33 | 34 | The names of all frames found in a tag can be retrieved with the L function. 35 | 36 | =head2 Using the returned data 37 | 38 | In the ID3v2.3 specifications 73 frames are defined, which can contain very 39 | different information. That means that get_frame returns the information 40 | of different frames also in different ways. 41 | 42 | =over 4 43 | 44 | =item Simple Frames 45 | 46 | A lot of the tags contain only a text string and encoding information. If 47 | you call ($info, $long) = $id3v2->get_frame($id) for such a frame, $info will contain 48 | the text string and $long will contain the english name of the frame. 49 | 50 | Example: 51 | get_frame("TIT2"); # returns 52 | 53 | ("Birdhouse In Your Soul", "Title/songname/content description") 54 | 55 | =item Complex Frames 56 | 57 | For more complex frames the returned $info is a reference to a hash, where 58 | each entry of the hash decribes a part of the information found in the 59 | frame. The key of a hash entry contains the name of this part, the according 60 | value contains the information itself. 61 | 62 | Example: 63 | get_frame("APIC"); # returns 64 | 65 | ( { "Description" => "Flood", 66 | "MIME Type" => "/image/jpeg", 67 | "Picture Type" => "Cover (front)", 68 | "_Data" => "..data of jpeg picture (binary).." 69 | }, 70 | "Attached Picture"); 71 | 72 | =item Other Frames 73 | 74 | Some frames are not supported at the moment, ie the data found in the frame 75 | is not returned in a descriptive way. But you can read the data of this 76 | frames (and also of all other frames too) in raw mode. Then the complete 77 | data field of the frame is returned, without any modifications. This means 78 | that the returned data will be almost binary data. 79 | 80 | Example: 81 | get_frame("TIT2", 'raw'); # returns 82 | 83 | ("\x00Birdhouse In Your Soul", "Title/songname/content description") 84 | 85 | =back 86 | 87 | The frames which (in addition to C/C) contain only 88 | C and C fields are in some intermediate position 89 | between "simple" and "complex" frames. They can be handled very similarly 90 | to "simple" frames by using "long names", such as C 91 | or C, and the corresponding "quick" API such 92 | as frame_select(). 93 | 94 | 95 | 96 | =head2 List of Simple Frames 97 | 98 | Following Frames are supported 99 | and return a single string (text). In the List you can find the frame IDs 100 | and the long names of the frames as returned by $id3v2->get_frame(): 101 | 102 | =over 4 103 | 104 | 105 | =item IPLS : Involved people list 106 | 107 | =item MCDI : Music CD identifier 108 | 109 | =item PCNT : Play counter 110 | 111 | =item TALB : Album/Movie/Show title 112 | 113 | =item TBPM : BPM (beats per minute) 114 | 115 | =item TCOM : Composer 116 | 117 | =item TCON : Content type 118 | 119 | =item TCOP : Copyright message 120 | 121 | =item TDAT : Date 122 | 123 | =item TDLY : Playlist delay 124 | 125 | =item TDRC : Recording time 126 | 127 | =item TENC : Encoded by 128 | 129 | =item TEXT : Lyricist/Text writer 130 | 131 | =item TFLT : File type 132 | 133 | =item TIME : Time 134 | 135 | =item TIPL : Involved people list 136 | 137 | =item TIT1 : Content group description 138 | 139 | =item TIT2 : Title/songname/content description 140 | 141 | =item TIT3 : Subtitle/Description refinement 142 | 143 | =item TKEY : Initial key 144 | 145 | =item TLAN : Language(s) 146 | 147 | =item TLEN : Length 148 | 149 | =item TMCL : Musician credits list 150 | 151 | =item TMED : Media type 152 | 153 | =item TOAL : Original album/movie/show title 154 | 155 | =item TOFN : Original filename 156 | 157 | =item TOLY : Original lyricist(s)/text writer(s) 158 | 159 | =item TOPE : Original artist(s)/performer(s) 160 | 161 | =item TORY : Original release year 162 | 163 | =item TOWN : File owner/licensee 164 | 165 | =item TPE1 : Lead performer(s)/Soloist(s) 166 | 167 | =item TPE2 : Band/orchestra/accompaniment 168 | 169 | =item TPE3 : Conductor/performer refinement 170 | 171 | =item TPE4 : Interpreted, remixed, or otherwise modified by 172 | 173 | =item TPOS : Part of a set 174 | 175 | =item TPUB : Publisher 176 | 177 | =item TRCK : Track number/Position in set 178 | 179 | =item TRDA : Recording dates 180 | 181 | =item TRSN : Internet radio station name 182 | 183 | =item TRSO : Internet radio station owner 184 | 185 | =item TSIZ : Size 186 | 187 | =item TSRC : ISRC (international standard recording code) 188 | 189 | =item TSSE : Software/Hardware and settings used for encoding 190 | 191 | =item TYER : Year 192 | 193 | =item WCOM : Commercial information 194 | 195 | =item WCOP : Copyright/Legal information 196 | 197 | =item WOAF : Official audio file webpage 198 | 199 | =item WOAR : Official artist/performer webpage 200 | 201 | =item WOAS : Official audio source webpage 202 | 203 | =item WORS : Official internet radio station homepage 204 | 205 | =item WPAY : Payment 206 | 207 | =item WPUB : Publishers official webpage 208 | 209 | =back 210 | 211 | 212 | 213 | =head2 List of Complex Frames 214 | 215 | Following frames are supported and return a reference to a hash. The 216 | list shows which keys can be found in the returned hash: 217 | 218 | =over 4 219 | 220 | 221 | =item AENC : Audio encryption 222 | 223 | Keys: URL, Preview start, Preview length, _Data 224 | 225 | =item APIC : Attached picture 226 | 227 | Keys: MIME type, Picture Type, Description, _Data 228 | 229 | =item COMM : Comments 230 | 231 | Keys: Language, Description, Text 232 | 233 | =item COMR : Commercial frame 234 | 235 | Keys: Price, Valid until, URL, Received as, Name of Seller, Description, MIME type, _Logo 236 | 237 | =item ENCR : Encryption method registration 238 | 239 | Keys: Owner ID, Method symbol, _Data 240 | 241 | =item GEOB : General encapsulated object 242 | 243 | Keys: MIME type, Filename, Description, _Data 244 | 245 | =item GRID : Group identification registration 246 | 247 | Keys: Owner, Symbol, _Data 248 | 249 | =item LINK : Linked information 250 | 251 | Keys: ID, URL, Text 252 | 253 | =item OWNE : Ownership frame 254 | 255 | Keys: Price payed, Date of purchase, Text 256 | 257 | =item POPM : Popularimeter 258 | 259 | Keys: URL, Rating, Counter 260 | 261 | =item PRIV : Private frame 262 | 263 | Keys: Text, _Data 264 | 265 | =item RBUF : Recommended buffer size 266 | 267 | Keys: Buffer size, Embedded info flag, Offset to next tag 268 | 269 | =item RVRB : Reverb 270 | 271 | Keys: Reverb left (ms), Reverb right (ms), Reverb bounces (left), Reverb bounces (right), Reverb feedback (left to left), Reverb feedback (left to right), Reverb feedback (right to right), Reverb feedback (right to left), Premix left to right, Premix right to left 272 | 273 | =item SYTC : Synchronized tempo codes 274 | 275 | Keys: Time Stamp Format, _Data 276 | 277 | =item TXXX : User defined text information frame 278 | 279 | Keys: Description, Text 280 | 281 | =item UFID : Unique file identifier 282 | 283 | Keys: Text, _Data 284 | 285 | =item USER : Terms of use 286 | 287 | Keys: Language, Text 288 | 289 | =item USLT : Unsychronized lyric/text transcription 290 | 291 | Keys: Language, Description, Text 292 | 293 | =item WXXX : User defined URL link frame 294 | 295 | Keys: Description, URL 296 | 297 | =back 298 | 299 | 300 | 301 | =head2 List of Other Frames 302 | 303 | Following frames are only supported in raw mode: 304 | 305 | =over 4 306 | 307 | 308 | =item CRM : Encrypted meta frame 309 | 310 | =item EQUA : Equalization 311 | 312 | =item ETCO : Event timing codes 313 | 314 | =item LNK : Linked information 315 | 316 | =item MLLT : MPEG location lookup table 317 | 318 | =item PIC : Attached picture 319 | 320 | =item POSS : Position synchronisation frame 321 | 322 | =item RVAD : Relative volume adjustment 323 | 324 | =item SYLT : Synchronized lyric/text 325 | 326 | =back 327 | 328 | 329 | =head1 SEE ALSO 330 | 331 | L, L 332 | 333 | -------------------------------------------------------------------------------- /lib/MP3/Tag/ParseData.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::ParseData; 2 | 3 | use strict; 4 | use vars qw /$VERSION @ISA/; 5 | 6 | $VERSION="1.00"; 7 | @ISA = 'MP3::Tag::__hasparent'; 8 | 9 | =pod 10 | 11 | =head1 NAME 12 | 13 | MP3::Tag::ParseData - Module for parsing arbitrary data associated with music files. 14 | 15 | =head1 SYNOPSIS 16 | 17 | # parses the file name according to one of the patterns: 18 | $mp3->config('parse_data', ['i', '%f', '%t - %n - %a.%e', '%t - %y.%e']); 19 | $title = $mp3->title; 20 | 21 | see L 22 | 23 | =head1 DESCRIPTION 24 | 25 | MP3::Tag::ParseData is designed to be called from the MP3::Tag module. 26 | 27 | Each option of configuration item C should be of the form 28 | C<[$flag, $string, $pattern1, ...]>. For each of the option, patterns of 29 | the option are matched agains the $string of the option, until one of them 30 | succeeds. The information obtained from later options takes precedence over 31 | the information obtained from earlier ones. 32 | 33 | The meaning of the patterns is the same as for parse() or parse_rex() methods 34 | of C. Since the default for C is empty, by default this 35 | handler has no effect. 36 | 37 | $flag is split into 1-character-long flags (unknown flags are ignored): 38 | 39 | =over 40 | 41 | =item C 42 | 43 | the string-to-parse is interpolated first; 44 | 45 | =item C 46 | 47 | the string-to-parse is interpreted as the name of the file to read; 48 | 49 | =item C 50 | 51 | added to C, makes it non-fatal if the file does not exist; 52 | 53 | =item C 54 | 55 | the file should be read in C mode; 56 | 57 | =item C 58 | 59 | the string-to-parse is interpreted as collection of lines, one per track; 60 | 61 | =item C 62 | 63 | the string-to-parse is interpreted as collection of lines, and the first 64 | matched is chosen; 65 | 66 | =item C 67 | 68 | the resulting string is interpolated before parsing. 69 | 70 | =item C 71 | 72 | Do not strip the leading and trailing blanks. (With output to file, 73 | the output is performed in binary mode too.) 74 | 75 | =item C 76 | 77 | the patterns are considered as regular expressions. 78 | 79 | =item C 80 | 81 | one of the patterns must match. 82 | 83 | =item C, C, C 84 | 85 | With C or C interpret the pattern as a name of file to output 86 | parse-data to. With C the name of output file is interpolated. 87 | When C is present, intermediate directories are created. 88 | 89 | =item C 90 | 91 | Do not ignore a field even if the result is a 0-length string. 92 | 93 | =back 94 | 95 | Unless C option is given, the resulting values have starting and 96 | trailing whitespace trimmed. (Actually, split()ing into lines is done 97 | using the configuration item C; it defaults to C<"\n">.) 98 | 99 | If the configuration item C has multiple options, the $strings 100 | which are interpolated will use information set by preceding options; 101 | similarly, any interolated option may use information obtained by other 102 | handlers - even if these handers are later in the pecking order than 103 | C (which by default is the first handler). For 104 | example, with 105 | 106 | ['i', '%t' => '%t (%y)'], ['i', '%t' => '%t - %c'] 107 | 108 | and a local CDDB file which identifies title to C<'Merry old - another 109 | interpretation (1905)'>, the first field will interpolate C<'%t'> into this 110 | title, then will split it into the year and the rest. The second field will 111 | split the rest into a title-proper and comment. 112 | 113 | Note that one can use fields of the form 114 | 115 | ['mz', 'This is a forced title' => '%t'] 116 | 117 | to force particular values for parts of the MP3 tag. 118 | 119 | The usual methods C, C, C<album>, C<comment>, C<year>, C<track>, 120 | C<year> can be used to access the results of the parse. 121 | 122 | It is possible to set individual id3v2 frames; use %{TIT1} or 123 | some such. Setting to an empty string deletes the frame if config 124 | parameter C<id3v2_frame_empty_ok> is false (the default value). 125 | Setting ID3v2 frames uses the same translation rules as 126 | select_id3v2_frame_by_descr(). 127 | 128 | =head2 SEE ALSO 129 | 130 | The flags C<i f F B l m I b> are identical to flags of the method 131 | interpolate_with_flags() of MP3::Tag (see L<MP3::Tag/"interpolate_with_flags">). 132 | Essentially, the other flags (C<R m o O D z>) are applied to the result of 133 | calling the latter method. 134 | 135 | =cut 136 | 137 | 138 | # Constructor 139 | 140 | sub new_with_parent { 141 | my ($class, $filename, $parent) = @_; 142 | $filename = $filename->filename if ref $filename; 143 | bless {filename => $filename, parent => $parent}, $class; 144 | } 145 | 146 | # Destructor 147 | 148 | sub DESTROY {} 149 | 150 | sub parse_one { 151 | my ($self, $in) = @_; 152 | 153 | my @patterns = @$in; # Apply shift to a copy, not original... 154 | my $flags = shift @patterns; 155 | my $data = shift @patterns; 156 | 157 | my @data = $self->{parent}->interpolate_with_flags($data, $flags); 158 | my $res; 159 | my @opatterns = @patterns; 160 | 161 | if ($flags =~ /[oO]/) { 162 | @patterns = map $self->{parent}->interpolate($_), @patterns 163 | if $flags =~ /O/; 164 | return unless length $data[0] or $flags =~ /z/; 165 | for my $file (@patterns) { 166 | if ($flags =~ /D/ and $file =~ m,(.*)[/\\],s) { 167 | require File::Path; 168 | File::Path::mkpath($1); 169 | } 170 | open OUT, "> $file" or die "open(`$file') for write: $!"; 171 | if ($flags =~ /b/) { 172 | binmode OUT; 173 | } else { 174 | my $e; 175 | if ($e = $self->get_config('encode_encoding_files') and $e->[0]) { 176 | eval "binmode OUT, ':encoding($e->[0])'"; # old binmode won't compile... 177 | } 178 | } 179 | local ($/, $,) = ('', ''); 180 | print OUT $data[0]; 181 | close OUT or die "close(`$file') for write: $!"; 182 | } 183 | return; 184 | } 185 | if ($flags =~ /R/) { 186 | @patterns = map $self->{parent}->parse_rex_prepare($_), @patterns; 187 | } else { 188 | @patterns = map $self->{parent}->parse_prepare($_), @patterns; 189 | } 190 | for $data (@data) { 191 | my $pattern; 192 | for $pattern (@patterns) { 193 | last if $res = $self->{parent}->parse_rex_match($pattern, $data); 194 | } 195 | last if $res; 196 | } 197 | { local $" = "' `"; 198 | die "Pattern(s) `@opatterns' did not succeed vs `@data'" 199 | if $flags =~ /m/ and not $res; 200 | } 201 | my $k; 202 | for $k (keys %$res) { 203 | unless ($flags =~ /b/) { 204 | $res->{$k} =~ s/^\s+//; 205 | $res->{$k} =~ s/\s+$//; 206 | } 207 | delete $res->{$k} unless length $res->{$k} or $flags =~ /z/; 208 | } 209 | return unless $res and keys %$res; 210 | return $res; 211 | } 212 | 213 | # XXX Two decisions: which entries can access results of which ones, 214 | # and which entries overwrite which ones; the user can reverse one of them 215 | # by sorting config('parse_data') in the opposite order; but not both. 216 | # Only practice can show whether our choice is correct... How to customize? 217 | 218 | sub parse { # Later recipies can access results of earlier ones. 219 | my ($self,$what) = @_; 220 | 221 | return $self->{parsed}->{$what} # Recalculate during recursive calls 222 | if not $self->{parsing} and exists $self->{parsed}; # Do not recalc after finish 223 | 224 | my $data = $self->get_config('parse_data'); 225 | return unless $data and @$data; 226 | my $parsing = $self->{parsing}; 227 | local $self->{parsing}; 228 | 229 | my (%res, $d, $c); 230 | for $d (@$data) { 231 | $c++; 232 | $self->{parsing} = $c; 233 | # Protect against recursion: later $d can access results of earlier ones 234 | last if $parsing and $parsing <= $c; 235 | my $res = $self->parse_one($d); 236 | # warn "Failure: [@$d]\n" unless $res; 237 | # Set user-scratch space data immediately 238 | for my $k (keys %$res) { 239 | if ($k eq 'year') { # Do nothing 240 | } elsif ($k =~ /^U(\d{1,2})$/) { 241 | $self->{parent}->set_user($1, delete $res->{$k}) 242 | } elsif (0 and $k =~ /^\w{4}(\d{2,})?$/) { 243 | if (length $res->{$k} 244 | or $self->get_config('id3v2_frame_empty_ok')->[0]) { 245 | $self->{parent}->set_id3v2_frame($k, delete $res->{$k}) 246 | } else { 247 | delete $res->{$k}; 248 | $self->{parent}->set_id3v2_frame($k); # delete 249 | } 250 | } elsif ($k =~ /^\w{4}(\d{2,}|(?:\(([^()]*(?:\([^()]+\)[^()]*)*)\))?(?:\[(\\.|[^]\\]*)\])?)$/) { 251 | my $r = delete $res->{$k}; 252 | $r = undef unless length $r or $self->get_config('id3v2_frame_empty_ok')->[0]; 253 | if (defined $r or $self->{parent}->_get_tag('ID3v2')) { 254 | $self->{parent}->select_id3v2_frame_by_descr($k, $r); 255 | } 256 | } 257 | } 258 | # later ones overwrite earlier 259 | %res = (%res, %$res) if $res; 260 | } 261 | $self->{parsed} = \%res; 262 | # return unless keys %res; 263 | return $self->{parsed}->{$what}; 264 | } 265 | 266 | for my $elt ( qw( title track artist album comment year genre ) ) { 267 | no strict 'refs'; 268 | *$elt = sub (;$) { 269 | my $self = shift; 270 | $self->parse($elt, @_); 271 | } 272 | } 273 | 274 | 1; 275 | -------------------------------------------------------------------------------- /lib/MP3/Tag/CDDB_File.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::CDDB_File; 2 | 3 | use strict; 4 | use File::Basename; 5 | use File::Spec; 6 | use vars qw /$VERSION @ISA/; 7 | 8 | $VERSION="1.00"; 9 | @ISA = 'MP3::Tag::__hasparent'; 10 | 11 | =pod 12 | 13 | =head1 NAME 14 | 15 | MP3::Tag::CDDB_File - Module for parsing CDDB files. 16 | 17 | =head1 SYNOPSIS 18 | 19 | my $db = MP3::Tag::CDDB_File->new($filename, $track); # Name of audio file 20 | my $db = MP3::Tag::CDDB_File->new_from($record, $track); # Contents of CDDB 21 | 22 | ($title, $artist, $album, $year, $comment, $track) = $db->parse(); 23 | 24 | see L<MP3::Tag> 25 | 26 | =head1 DESCRIPTION 27 | 28 | MP3::Tag::CDDB_File is designed to be called from the MP3::Tag module. 29 | 30 | It parses the content of CDDB file. 31 | 32 | The file is found in the same directory as audio file; the list of possible 33 | file names is taken from the field C<cddb_files> if set by MP3::Tag config() 34 | method. 35 | 36 | =over 4 37 | 38 | =cut 39 | 40 | 41 | # Constructor 42 | 43 | sub new_from { 44 | my ($class, $data, $track) = @_; 45 | bless {data => [split /\n/, $data], track => $track}, $class; 46 | } 47 | 48 | sub new_setdir { 49 | my $class = shift; 50 | my $filename = shift; 51 | $filename = $filename->filename if ref $filename; 52 | $filename = dirname($filename); 53 | return bless {dir => $filename}, $class; # bless to enable get_config() 54 | } 55 | 56 | sub new_fromdir { 57 | my $class = shift; 58 | my $h = shift; 59 | my $dir = $h->{dir}; 60 | my ($found, $e); 61 | my $l = $h->get_config('cddb_files'); 62 | for my $file (@$l) { 63 | my $f = File::Spec->catdir($dir, $file); 64 | $found = $f, last if -r $f; 65 | } 66 | return unless $found; 67 | local *F; 68 | open F, "< $found" or die "Can't open `$found': $!"; 69 | if ($e = $h->get_config('decode_encoding_cddb_file') and $e->[0]) { 70 | eval "binmode F, ':encoding($e->[0])'"; # old binmode won't compile... 71 | } 72 | my @data = <F>; 73 | close F or die "Error closing `$found': $!"; 74 | bless {filename => $found, data => \@data, track => shift, 75 | parent => $h->{parent}}, $class; 76 | } 77 | 78 | sub new { 79 | my $class = shift; 80 | my $h = $class->new_setdir(@_); 81 | $class->new_fromdir($h); 82 | } 83 | 84 | sub new_with_parent { 85 | my ($class, $filename, $parent) = @_; 86 | my $h = $class->new_setdir($filename); 87 | $h->{parent} = $parent; 88 | $class->new_fromdir($h); 89 | } 90 | 91 | # Destructor 92 | 93 | sub DESTROY {} 94 | 95 | =item parse() 96 | 97 | ($title, $artist, $album, $year, $comment, $track) = 98 | $db->parse($what); 99 | 100 | parse_filename() extracts information about artist, title, track number, 101 | album and year from the CDDB record. $what is optional; it maybe title, 102 | track, artist, album, year, genre or comment. If $what is defined parse() will return 103 | only this element. 104 | 105 | Additionally, $what can take values C<artist_collection> (returns the value of 106 | artist in the disk-info field DTITLE, but only if author is specified in the 107 | track-info field TTITLE), C<title_track> (returns the title specifically from 108 | track-info field - the C<track> may fall back to the info from disk-info 109 | field), C<comment_collection> (processed EXTD comment), C<comment_track> 110 | (processed EXTT comment). 111 | 112 | The returned year and genre is taken from DYEAR, DGENRE, EXTT, EXTD fields; 113 | recognized prefixes in the two last fields are YEAR, ID3Y, ID3G. 114 | The declarations of this form are stripped from the returned comment. 115 | 116 | An alternative 117 | syntax "Recorded"/"Recorded on"/"Recorded in"/ is also supported; the format 118 | of the date recognized by ID3v2::year(), or just a date field without a prefix. 119 | 120 | =cut 121 | 122 | sub return_parsed { 123 | my ($self,$what) = @_; 124 | if (defined $what) { 125 | return $self->{parsed}{a_in_title} if $what =~/^artist_collection/i; 126 | return $self->{parsed}{t_in_track} if $what =~/^title_track/i; 127 | return $self->{parsed}{extt} if $what =~/^comment_track/i; 128 | return $self->{parsed}{extd} if $what =~/^comment_collection/i; 129 | return $self->{parsed}{DISCID} if $what =~/^cddb_id/i; 130 | return $self->{parsed}{album} if $what =~/^al/i; 131 | return $self->{parsed}{artist} if $what =~/^a/i; 132 | return $self->{parsed}{track} if $what =~/^tr/i; 133 | return $self->{parsed}{year} if $what =~/^y/i; 134 | return $self->{parsed}{comment}if $what =~/^c/i; 135 | return $self->{parsed}{genre} if $what =~/^g/i; 136 | return $self->{parsed}{title}; 137 | } 138 | 139 | return $self->{parsed} unless wantarray; 140 | return map $self->{parsed}{$_} , qw(title artist album year comment track); 141 | } 142 | 143 | my %r = ( 'n' => "\n", 't' => "\t", '\\' => "\\" ); 144 | 145 | sub parse_lines { 146 | my ($self) = @_; 147 | return if $self->{fields}; 148 | for my $l (@{$self->{data}}) { 149 | next unless $l =~ /^\s*(\w+)\s*=(\s*(.*))/; 150 | my $app = $2; 151 | $self->{fields}{$1} = "", $app = $3 unless exists $self->{fields}{$1}; 152 | $self->{fields}{$1} .= $app; 153 | $self->{last} = $1 if $1 =~ /\d+$/; 154 | } 155 | s/\\([nt\\])/$r{$1}/g for values %{$self->{fields}}; 156 | } 157 | 158 | sub parse { 159 | my ($self,$what) = @_; 160 | return $self->return_parsed($what) if exists $self->{parsed}; 161 | $self->parse_lines; 162 | my %parsed; 163 | my ($t1, $c1, $t2, $c2) = map $self->{fields}{$_}, qw(DTITLE EXTD); 164 | my $track = $self->track; 165 | if ($track) { 166 | my $t = $track - 1; 167 | ($t2, $c2) = map $self->{fields}{$_}, "TTITLE$t", "EXTT$t"; 168 | } 169 | my ($a, $t, $aa, $tt, $a_in_title, $t_in_track); 170 | ($a, $t) = split /\s+\/\s+/, $t1, 2 if defined $t1; 171 | ($a, $t) = ($t, $a) unless defined $t; 172 | ($aa, $tt) = split /\s+\/\s+/, $t2, 2 if defined $t2; 173 | ($aa, $tt) = ($tt, $aa) unless defined $tt; 174 | undef $a if defined $a and $a =~ 175 | /^\s*(<<\s*)?(Various Artists|compilation disc)\s*(>>\s*)?$/i; 176 | undef $aa if defined $aa and $aa =~ 177 | /^\s*(<<\s*)?(Various Artists|compilation disc)\s*(>>\s*)?$/i; 178 | $a_in_title = $a if defined $a and length $a and defined $aa and length $aa; 179 | $aa = $a unless defined $aa and length $aa; 180 | $t_in_track = $tt; 181 | $tt = $t unless defined $tt and length $tt; 182 | 183 | my ($y, $cat) = ($self->{fields}{DYEAR}, $self->{fields}{DGENRE}); 184 | for my $f ($c2, $c1) { 185 | if (defined $f and length $f) { # Process old style declarations 186 | while ($f =~ s/^\s*((YEAR|ID3Y)|ID3G)\b:?\s*(\d+)\b\s*(([;.,]|\s-\s)\s*)?//i 187 | || $f =~ s/(?:\s*(?:[;.,]|\s-\s))?\s*\b((YEAR|ID3Y)|ID3G)\b:?\s*(\d+)\s*([;.,]\s*)?$//i) { 188 | $y = $3 if $2 and not $y; 189 | $cat = $3 if not $2 and not $cat; 190 | } 191 | if ($f =~ s{ 192 | ((^|[;,.]|\s+-\s) # 1,2 193 | \s* 194 | (Recorded (\s+[io]n)? \s* (:\s*)? )? # 3, 4, 5 195 | (\d{4}([-,][-\d\/,]+)?) # 6, 7 196 | \b \s* (?: [.;] \s* )? 197 | ((?:[;.,]|\s-\s|$)\s*)) # 8 198 | } 199 | { 200 | ((($self->{parent}->get_config('comment_remove_date'))->[0] 201 | and not ($2 and $8)) 202 | ? '' : $1) . ($2 && $8 ? $8 : '') 203 | }xeim and not ($2 and $8)) { 204 | # Overwrite the disk year for longer forms 205 | $y = $6 if $3 or $7 or not $y or $c2 and $f eq $c2; 206 | } 207 | $f =~ s/^\s+//; 208 | $f =~ s/\s+$//; 209 | undef $f unless length $f; 210 | } 211 | } 212 | my ($cc1, $cc2) = ($c1, $c2); 213 | if (defined $c2 and length $c2) { # Merge unless one is truncation of another 214 | if ( defined $c1 and length $c1 215 | and $c1 ne substr $c2, 0, length $c1 216 | and $c1 ne substr $c2, -length $c1 ) { 217 | $c2 =~ s/\s*[.,:;]$//; 218 | my $sep = (("$c1$c2" =~ /\n/) ? "\n" : '; '); 219 | $c1 = "$c2$sep$c1"; 220 | } else { 221 | $c1 = $c2; 222 | } 223 | } 224 | if (defined $cat and $cat =~ /^\d+$/) { 225 | require MP3::Tag::ID3v1; 226 | $cat = $MP3::Tag::ID3v1::winamp_genres[$cat] if $cat < scalar @MP3::Tag::ID3v1::winamp_genres; 227 | } 228 | 229 | @parsed{ qw( title artist album year comment track genre 230 | a_in_title t_in_track extt extd) } = 231 | ($tt, $aa, $t, $y, $c1, $track, $cat, $a_in_title, $t_in_track, $cc2, $cc1); 232 | $parsed{DISCID} = $self->{fields}{DISCID}; 233 | $self->{parsed} = \%parsed; 234 | $self->return_parsed($what); 235 | } 236 | 237 | 238 | =pod 239 | 240 | =item title() 241 | 242 | $title = $db->title(); 243 | 244 | Returns the title, obtained from the C<'Tracktitle'> entry of the file. 245 | 246 | =cut 247 | 248 | *song = \&title; 249 | 250 | sub title { 251 | return shift->parse("title"); 252 | } 253 | 254 | =pod 255 | 256 | =item artist() 257 | 258 | $artist = $db->artist(); 259 | 260 | Returns the artist name, obtained from the C<'Performer'> or 261 | C<'Albumperformer'> entries (the first which is present) of the file. 262 | 263 | =cut 264 | 265 | sub artist { 266 | return shift->parse("artist"); 267 | } 268 | 269 | =pod 270 | 271 | =item track() 272 | 273 | $track = $db->track(); 274 | 275 | Returns the track number, stored during object creation, or queried from 276 | the parent. 277 | 278 | 279 | =cut 280 | 281 | sub track { 282 | my $self = shift; 283 | return $self->{track} if defined $self->{track}; 284 | return if $self->{recursive} or not $self->parent_ok; 285 | local $self->{recursive} = 1; 286 | return $self->{parent}->track1; 287 | } 288 | 289 | =item year() 290 | 291 | $year = $db->year(); 292 | 293 | Returns the year, obtained from the C<'Year'> entry of the file. (Often 294 | not present.) 295 | 296 | =cut 297 | 298 | sub year { 299 | return shift->parse("year"); 300 | } 301 | 302 | =pod 303 | 304 | =item album() 305 | 306 | $album = $db->album(); 307 | 308 | Returns the album name, obtained from the C<'Albumtitle'> entry of the file. 309 | 310 | =cut 311 | 312 | sub album { 313 | return shift->parse("album"); 314 | } 315 | 316 | =item comment() 317 | 318 | $comment = $db->comment(); 319 | 320 | Returns the C<'Trackcomment'> entry of the file. (Often not present.) 321 | 322 | =cut 323 | 324 | sub comment { 325 | return shift->parse("comment"); 326 | } 327 | 328 | =item genre() 329 | 330 | $genre = $db->genre($filename); 331 | 332 | =cut 333 | 334 | sub genre { 335 | return shift->parse("genre"); 336 | } 337 | 338 | for my $elt ( qw( cddb_id ) ) { 339 | no strict 'refs'; 340 | *$elt = sub (;$) { 341 | return shift->parse($elt); 342 | } 343 | } 344 | 345 | 1; 346 | -------------------------------------------------------------------------------- /lib/MP3/Tag/File.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::File; 2 | 3 | use strict; 4 | use Fcntl; 5 | use File::Basename; 6 | use vars qw /$VERSION @ISA/; 7 | 8 | $VERSION="1.00"; 9 | @ISA = 'MP3::Tag::__hasparent'; 10 | 11 | =pod 12 | 13 | =head1 NAME 14 | 15 | MP3::Tag::File - Module for reading / writing files 16 | 17 | =head1 SYNOPSIS 18 | 19 | my $mp3 = MP3::Tag->new($filename); 20 | 21 | ($title, $artist, $no, $album, $year) = $mp3->parse_filename(); 22 | 23 | see L<MP3::Tag> 24 | 25 | =head1 DESCRIPTION 26 | 27 | MP3::Tag::File is designed to be called from the MP3::Tag module. 28 | 29 | It offers possibilities to read/write data from files via read(), write(), 30 | truncate(), seek(), tell(), open(), close(); one can find the filename via 31 | the filename() method. 32 | 33 | =cut 34 | 35 | 36 | # Constructor 37 | 38 | sub new_with_parent { 39 | my ($class, $filename, $parent) = @_; 40 | return undef unless -f $filename or -c $filename; 41 | return bless {filename => $filename, parent => $parent}, $class; 42 | } 43 | *new = \&new_with_parent; # Obsolete handler 44 | 45 | # Destructor 46 | 47 | sub DESTROY { 48 | my $self=shift; 49 | if (exists $self->{FH} and defined $self->{FH}) { 50 | $self->close; 51 | } 52 | } 53 | 54 | # File subs 55 | 56 | sub filename { shift->{filename} } 57 | 58 | sub open { 59 | my $self=shift; 60 | my $mode= shift; 61 | if (defined $mode and $mode =~ /w/i) { 62 | $mode=O_RDWR; # read/write mode 63 | } else { 64 | $mode=O_RDONLY; # read only mode 65 | } 66 | unless (exists $self->{FH}) { 67 | local *FH; 68 | if (sysopen (FH, $self->filename, $mode)) { 69 | $self->{FH} = *FH; 70 | binmode $self->{FH}; 71 | } else { 72 | warn "Open `" . $self->filename() . "' failed: $!\n"; 73 | } 74 | } 75 | return exists $self->{FH}; 76 | } 77 | 78 | 79 | sub close { 80 | my $self=shift; 81 | if (exists $self->{FH}) { 82 | close $self->{FH}; 83 | delete $self->{FH}; 84 | } 85 | } 86 | 87 | sub write { 88 | my ($self, $data) = @_; 89 | if (exists $self->{FH}) { 90 | local $\ = ''; 91 | print {$self->{FH}} $data; 92 | } 93 | } 94 | 95 | sub truncate { 96 | my ($self, $length) = @_; 97 | if ($length<0) { 98 | my @stat = stat $self->{FH}; 99 | $length = $stat[7] + $length; 100 | } 101 | if (exists $self->{FH}) { 102 | truncate $self->{FH}, $length; 103 | } 104 | } 105 | 106 | sub size { 107 | my ($self) = @_; 108 | return -s $self->{FH} if exists $self->{FH}; 109 | return -s ($self->filename); 110 | } 111 | 112 | sub seek { 113 | my ($self, $pos, $whence)=@_; 114 | $self->open unless exists $self->{FH}; 115 | seek $self->{FH}, $pos, $whence; 116 | } 117 | 118 | sub tell { 119 | my ($self, $pos, $whence)=@_; 120 | return undef unless exists $self->{FH}; 121 | return tell $self->{FH}; 122 | } 123 | 124 | sub read { 125 | my ($self, $buf_, $length) = @_; 126 | $self->open unless exists $self->{FH}; 127 | return read $self->{FH}, $$buf_, $length; 128 | } 129 | 130 | sub is_open { 131 | return exists shift->{FH}; 132 | } 133 | 134 | # keep the old name 135 | *isOpen = \&is_open; 136 | 137 | # read and decode the header of the mp3 part of the file 138 | # the raw content of the header fields is stored, the values 139 | # are not interpreted in any way (e.g. layer==3 means 'Layer I' 140 | # as specified in the mp3 format) 141 | sub get_mp3_frame_header { 142 | my ($self, $start) = @_; 143 | 144 | $start = 0 unless $start; 145 | 146 | if (exists $self->{mp3header}) { 147 | return $self->{mp3header}; 148 | } 149 | 150 | $self->seek($start, 0); 151 | my ($data, $bits)=""; 152 | while (1) { 153 | my $nextdata; 154 | $self->read(\$nextdata, 512); 155 | return unless $nextdata; # no header found 156 | $data .= $nextdata; 157 | if ($data =~ /(\xFF[\xE0-\xFF]..)/) { 158 | $bits = unpack("B32", $1); 159 | last; 160 | } 161 | $data = substr $data, -3 162 | } 163 | 164 | my @fields; 165 | for (qw/11 2 2 1 4 2 1 1 1 2 2 1 1 2/) { 166 | push @fields, oct "0b" . substr $bits, 0, $_; 167 | $bits = substr $bits, $_ if length $bits > $_; 168 | } 169 | 170 | $self->{mp3header}={}; 171 | for (qw/sync version layer proctection bitrate_id sampling_rate_id padding private 172 | channel_mode mode_ext copyright original emphasis/) { 173 | $self->{mp3header}->{$_}=shift @fields; 174 | } 175 | 176 | return $self->{mp3header} 177 | } 178 | 179 | 180 | # use filename to determine information about song/artist/album 181 | 182 | =pod 183 | 184 | =over 4 185 | 186 | =item parse_filename() 187 | 188 | ($title, $artist, $no, $album, $year) = $mp3->parse_filename($what, $filename); 189 | 190 | parse_filename() tries to extract information about artist, title, 191 | track number, album and year from the filename. (For backward 192 | compatibility it may be also called by deprecated name 193 | read_filename().) 194 | 195 | This is likely to fail for a lot of filenames, especially the album will 196 | be often wrongly guessed, as the name of the parent directory is taken as 197 | album name. 198 | 199 | $what and $filename are optional. $what maybe title, track, artist, album 200 | or year. If $what is defined parse_filename() will return only this element. 201 | 202 | If $filename is defined this filename will be used and not the real 203 | filename which was set by L<MP3::Tag> with 204 | C<MP3::Tag-E<gt>new($filename)>. Otherwise the actual filename is used 205 | (subject to configuration variable C<decode_encoding_filename>). 206 | 207 | Following formats will be hopefully recognized: 208 | 209 | - album name/artist name - song name.mp3 210 | 211 | - album_name/artist_name-song_name.mp3 212 | 213 | - album.name/artist.name_song.name.mp3 214 | 215 | - album name/(artist name) song name.mp3 216 | 217 | - album name/01. artist name - song name.mp3 218 | 219 | - album name/artist name - 01 - song.name.mp3 220 | 221 | If artist or title end in C<(NUMBER)> with 4-digit NUMBER, it is considered 222 | the year. 223 | 224 | =cut 225 | 226 | *read_filename = \&parse_filename; 227 | 228 | sub return_parsed { 229 | my ($self,$what) = @_; 230 | if (defined $what) { 231 | return $self->{parsed}{album} if $what =~/^al/i; 232 | return $self->{parsed}{artist} if $what =~/^a/i; 233 | return $self->{parsed}{no} if $what =~/^tr/i; 234 | return $self->{parsed}{year} if $what =~/^y/i; 235 | return $self->{parsed}{title}; 236 | } 237 | 238 | return $self->{parsed} unless wantarray; 239 | return map $self->{parsed}{$_} , qw(title artist no album year); 240 | } 241 | 242 | sub parse_filename { 243 | my ($self,$what,$filename) = @_; 244 | unless (defined $filename) { 245 | $filename = $self->filename; 246 | my $e; 247 | if ($e = $self->get_config('decode_encoding_filename') and $e->[0]) { 248 | require Encode; 249 | $filename = Encode::decode($e->[0], $filename); 250 | } 251 | } 252 | my $pathandfile = $filename; 253 | 254 | $self->return_parsed($what) if exists $self->{parsed_filename} 255 | and $self->{parsed_filename} eq $filename; 256 | 257 | # prepare pathandfile for easier use 258 | my $ext_rex = $self->get_config('extension')->[0]; 259 | $pathandfile =~ s/$ext_rex//; # remove extension 260 | $pathandfile =~ s/ +/ /g; # replace several spaces by one space 261 | 262 | # Keep two last components of the file name 263 | my ($file, $path) = fileparse($pathandfile, ""); 264 | ($path) = fileparse($path, ""); 265 | my $orig_file = $file; 266 | 267 | # check which chars are used for seperating words 268 | # assumption: spaces between words 269 | 270 | unless ($file =~/ /) { 271 | # no spaces used, find word seperator 272 | my $Ndot = $file =~ tr/././; 273 | my $Nunderscore = $file =~ tr/_/_/; 274 | my $Ndash = $file =~ tr/-/-/; 275 | if (($Ndot>$Nunderscore) && ($Ndot>1)) { 276 | $file =~ s/\./ /g; 277 | } 278 | elsif ($Nunderscore > 1) { 279 | $file =~ s/_/ /g; 280 | } 281 | elsif ($Ndash>2) { 282 | $file =~ s/-/ /g; 283 | } 284 | } 285 | 286 | # check wich chars are used for seperating parts 287 | # assumption: " - " is used 288 | 289 | my $partsep = " - "; 290 | 291 | unless ($file =~ / - /) { 292 | if ($file =~ /-/) { 293 | $partsep = "-"; 294 | } elsif ($file =~ /^\(.*\)/) { 295 | # replace brackets by - 296 | $file =~ s/^\((.*?)\)/$1 - /; 297 | $file =~ s/ +/ /; 298 | $partsep = " - "; 299 | } elsif ($file =~ /_/) { 300 | $partsep = "_"; 301 | } else { 302 | $partsep = "DoesNotExist"; 303 | } 304 | } 305 | 306 | # get parts of name 307 | my ($title, $artist, $no, $album, $year)=("","","","",""); 308 | 309 | # try to find a track-number in front of filename 310 | if ($file =~ /^ *(\d+)[\W_]/) { 311 | $no=$1; # store number 312 | $file =~ s/^ *\d+//; # and delete it 313 | $file =~ s/^$partsep// || $file =~ s/^.//; 314 | $file =~ s/^ +//; 315 | } 316 | 317 | $file =~ s/_+/ /g unless $partsep =~ /_/; #remove underscore unless they are needed for part seperation 318 | my @parts = split /$partsep/, $file; 319 | if (@parts == 1) { 320 | $title=$parts[0]; 321 | $no = $file if $title and $title =~ /^\d{1,2}$/; 322 | } elsif (@parts == 2) { 323 | if ($parts[0] =~ /^\d{1,2}$/) { 324 | $no = $parts[0]; 325 | $title = $file; 326 | } elsif ($parts[1] =~ /^\d{1,2}$/) { 327 | $no = $parts[1]; 328 | $title = $file; 329 | } else { 330 | $artist=$parts[0]; 331 | $title=$parts[1]; 332 | } 333 | } elsif (@parts > 2) { 334 | my $temp = ""; 335 | $artist = shift @parts; 336 | foreach (@parts) { 337 | if (/^ *(\d+)\.? *$/) { 338 | $artist.= $partsep . $temp if $temp; 339 | $temp=""; 340 | $no=$1; 341 | } else { 342 | $temp .= $partsep if $temp; 343 | $temp .= $_; 344 | } 345 | } 346 | $title=$temp; 347 | } 348 | 349 | $title =~ s/ +$//; 350 | $artist =~ s/ +$//; 351 | $no =~ s/ +$//; 352 | 353 | # Special-case names like audio12 etc created by some software 354 | # (cdda2wav, gramofile, etc) 355 | $no = $+ if not $no and $title =~ /^(\d+)?(?:audio|track|processed)\s*(\d+)?$/i and $+; 356 | 357 | $no =~ s/^0+//; 358 | 359 | if ($path) { 360 | unless ($artist) { 361 | $artist = $path; 362 | } else { 363 | $album = $path; 364 | } 365 | } 366 | # Keep the year in the title/artist (XXXX Should we?) 367 | $year = $1 if $title =~ /\((\d{4})\)/ or $artist =~ /\((\d{4})\)/; 368 | 369 | $self->{parsed_filename} = $filename; 370 | $self->{parsed} = { artist=>$artist, song=>$title, no=>$no, 371 | album=>$album, title=>$title, year => $year}; 372 | $self->return_parsed($what); 373 | } 374 | 375 | 376 | =pod 377 | 378 | =item title() 379 | 380 | $title = $mp3->title($filename); 381 | 382 | Returns the title, guessed from the filename. See also parse_filename(). (For 383 | backward compatibility, can be called by deprecated name song().) 384 | 385 | $filename is optional and will be used instead of the real filename if defined. 386 | 387 | =cut 388 | 389 | *song = \&title; 390 | 391 | sub title { 392 | my $self = shift; 393 | return $self->parse_filename("title", @_); 394 | } 395 | 396 | =pod 397 | 398 | =item artist() 399 | 400 | $artist = $mp3->artist($filename); 401 | 402 | Returns the artist name, guessed from the filename. See also parse_filename() 403 | 404 | $filename is optional and will be used instead of the real filename if defined. 405 | 406 | =cut 407 | 408 | sub artist { 409 | my $self = shift; 410 | return $self->parse_filename("artist", @_); 411 | } 412 | 413 | =pod 414 | 415 | =item track() 416 | 417 | $track = $mp3->track($filename); 418 | 419 | Returns the track number, guessed from the filename. See also parse_filename() 420 | 421 | $filename is optional and will be used instead of the real filename if defined. 422 | 423 | =cut 424 | 425 | sub track { 426 | my $self = shift; 427 | return $self->parse_filename("track", @_); 428 | } 429 | 430 | =item year() 431 | 432 | $year = $mp3->year($filename); 433 | 434 | Returns the year, guessed from the filename. See also parse_filename() 435 | 436 | $filename is optional and will be used instead of the real filename if defined. 437 | 438 | =cut 439 | 440 | sub year { 441 | my $self = shift; 442 | my $y = $self->parse_filename("year", @_); 443 | return $y if length $y; 444 | return; 445 | } 446 | 447 | =pod 448 | 449 | =item album() 450 | 451 | $album = $mp3->album($filename); 452 | 453 | Returns the album name, guessed from the filename. See also parse_filename() 454 | The album name is guessed from the parent directory, so it is very likely to fail. 455 | 456 | $filename is optional and will be used instead of the real filename if defined. 457 | 458 | =cut 459 | 460 | sub album { 461 | my $self = shift; 462 | return $self->parse_filename("album", @_); 463 | } 464 | 465 | =item comment() 466 | 467 | $comment = $mp3->comment($filename); # Always undef 468 | 469 | =cut 470 | 471 | sub comment {} 472 | 473 | =item genre() 474 | 475 | $genre = $mp3->genre($filename); # Always undef 476 | 477 | =cut 478 | 479 | sub genre {} 480 | 481 | 1; 482 | -------------------------------------------------------------------------------- /lib/MP3/Tag/ID3v1.pm: -------------------------------------------------------------------------------- 1 | package MP3::Tag::ID3v1; 2 | 3 | # Copyright (c) 2000-2004 Thomas Geffert. All rights reserved. 4 | # 5 | # This program is free software; you can redistribute it and/or 6 | # modify it under the terms of the Artistic License, distributed 7 | # with Perl. 8 | 9 | use strict; 10 | use vars qw /@mp3_genres @winamp_genres $AUTOLOAD %ok_length $VERSION @ISA/; 11 | 12 | $VERSION="1.00"; 13 | @ISA = 'MP3::Tag::__hasparent'; 14 | 15 | # allowed fields in ID3v1.1 and max length of this fields (except for track and genre which are coded later) 16 | %ok_length = (title => 30, artist => 30, album => 30, comment => 28, track => 3, genre => 3000, year=>4, genreID=>1); 17 | 18 | =pod 19 | 20 | =head1 NAME 21 | 22 | MP3::Tag::ID3v1 - Module for reading / writing ID3v1 tags of MP3 audio files 23 | 24 | =head1 SYNOPSIS 25 | 26 | MP3::Tag::ID3v1 is designed to be called from the MP3::Tag module. 27 | 28 | use MP3::Tag; 29 | $mp3 = MP3::Tag->new($filename); 30 | 31 | # read an existing tag 32 | $mp3->get_tags(); 33 | $id3v1 = $mp3->{ID3v1} if exists $mp3->{ID3v1}; 34 | 35 | # or create a new tag 36 | $id3v1 = $mp3->new_tag("ID3v1"); 37 | 38 | See L<MP3::Tag|according documentation> for information on the above used functions. 39 | 40 | * Reading the tag 41 | 42 | print " Title: " .$id3v1->title . "\n"; 43 | print " Artist: " .$id3v1->artist . "\n"; 44 | print " Album: " .$id3v1->album . "\n"; 45 | print "Comment: " .$id3v1->comment . "\n"; 46 | print " Year: " .$id3v1->year . "\n"; 47 | print " Genre: " .$id3v1->genre . "\n"; 48 | print " Track: " .$id3v1->track . "\n"; 49 | 50 | # or at once 51 | @tagdata = $mp3->all(); 52 | foreach $tag (@tagdata) { 53 | print $tag; 54 | } 55 | 56 | * Changing / Writing the tag 57 | 58 | $id3v1->comment("This is only a Test Tag"); 59 | $id3v1->title("testing"); 60 | $id3v1->artist("Artest"); 61 | $id3v1->album("Test it"); 62 | $id3v1->year("1965"); 63 | $id3v1->track("5"); 64 | $id3v1->genre("Blues"); 65 | # or at once 66 | $id3v1->all("song title","artist","album","1900","comment",10,"Ska"); 67 | $id3v1->write_tag(); 68 | 69 | * Removing the tag from the file 70 | 71 | $id3v1->remove_tag(); 72 | 73 | =head1 AUTHOR 74 | 75 | Thomas Geffert, thg@users.sourceforge.net 76 | 77 | =head1 DESCRIPTION 78 | 79 | =pod 80 | 81 | =over 82 | 83 | =item title(), artist(), album(), year(), comment(), track(), genre() 84 | 85 | $artist = $id3v1->artist; 86 | $artist = $id3v1->artist($artist); 87 | $album = $id3v1->album; 88 | $album = $id3v1->album($album); 89 | $year = $id3v1->year; 90 | $year = $id3v1->year($year); 91 | $comment = $id3v1->comment; 92 | $comment = $id3v1->comment($comment); 93 | $track = $id3v1->track; 94 | $track = $id3v1->track($track); 95 | $genre = $id3v1->genre; 96 | $genre = $id3v1->genre($genre); 97 | 98 | Use these functions to retrieve the date of these fields, 99 | or to set the data. 100 | 101 | $genre can be a string with the name of the genre, or a number 102 | describing the genre. 103 | 104 | =cut 105 | 106 | sub AUTOLOAD { 107 | my $self = shift; 108 | my $attr = $AUTOLOAD; 109 | 110 | # is it an allowed field 111 | $attr =~ s/.*:://; 112 | return unless $attr =~ /[^A-Z]/; 113 | $attr = 'title' if $attr eq 'song'; 114 | warn "invalid field: ->$attr()" unless $ok_length{$attr}; 115 | 116 | if (@_) { 117 | my $new = shift; 118 | $new =~ s/ *$//; 119 | if ($attr eq "genre") { 120 | if ($new =~ /^\d+$/) { 121 | $self->{genreID} = $new; 122 | } else { 123 | $self->{genreID} = genre2id($new); 124 | } 125 | $new = id2genre($self->{genreID}) 126 | if defined $self->{genreID} and $self->{genreID} < @winamp_genres; 127 | } 128 | $new = substr $new, 0, $ok_length{$attr}; 129 | $self->{$attr}=$new; 130 | $self->{changed} = 1; 131 | } 132 | $self->{$attr} =~ s/ +$//; 133 | return $self->{$attr}; 134 | } 135 | 136 | =pod 137 | 138 | =item all() 139 | 140 | @tagdata = $id3v1->all; 141 | @tagdata = $id3v1->all($title, $artist, $album, $year, $comment, $track, $genre); 142 | 143 | Returns all information of the tag in a list. 144 | You can use this sub also to set the data of the complete tag. 145 | 146 | The order of the data is always title, artist, album, year, comment, track, and genre. 147 | genre has to be a string with the name of the genre, or a number identifying the genre. 148 | 149 | =cut 150 | 151 | sub all { 152 | my $self=shift; 153 | if ($#_ == 6) { 154 | my $new; 155 | for (qw/title artist album year comment track genre/) { 156 | $new = shift; 157 | $new =~ s/ +$//; 158 | $new = substr $new, 0, $ok_length{$_}; 159 | $self->{$_}=$new; 160 | } 161 | if ($self->{genre} =~ /^\d+$/) { 162 | $self->{genreID} = $self->{genre}; 163 | } else { 164 | $self->{genreID} = genre2id($self->{genre}); 165 | } 166 | $self->{genre} = id2genre($self->{genreID}) 167 | if defined $self->{genreID} and $self->{genreID} < @winamp_genres; 168 | $self->{changed} = 1; 169 | } 170 | for (qw/title artist album year comment track genre/) { 171 | $self->{$_} =~ s/ +$//; 172 | } 173 | if (wantarray) { 174 | return ($self->{title},$self->{artist},$self->{album}, 175 | $self->{year},$self->{comment}, $self->{track}, $self->{genre}); 176 | } 177 | return $self->{title}; 178 | } 179 | 180 | =pod 181 | 182 | =item fits_tag() 183 | 184 | warn "data truncated" unless $id3v1->fits_tag($hash); 185 | 186 | Check whether the info in ID3v1 tag fits into the format of the file. 187 | 188 | =cut 189 | 190 | sub fits_tag { 191 | my ($self, $hash) = (shift, shift); 192 | my $elt; 193 | if (defined (my $track = $hash->{track})) { 194 | $track = $track->[0] if ref $track; 195 | return unless $track =~ /^\d{0,3}$/ and ($track eq '' or $track < 256); 196 | } 197 | my $s = ''; 198 | for $elt (qw(title artist album comment year)) { 199 | next unless defined (my $data = $hash->{$elt}); 200 | $data = $data->[0] if ref $data; 201 | return if $data =~ /[^\x00-\xFF]/; 202 | $s .= $data; 203 | next if $ok_length{$elt} >= length $data; 204 | next 205 | if $elt eq 'comment' and not $hash->{track} and length $data <= 30; 206 | return; 207 | } 208 | if (defined (my $genre = $hash->{genre})) { 209 | $genre = $genre->[0] if ref $genre; 210 | my @g = MP3::Tag::Implemenation::_massage_genres($genre); 211 | return if @g > 1; 212 | my $id = MP3::Tag::Implemenation::_massage_genres($genre, 'num'); 213 | return if not defined $id or $id eq '' or $id == 255; 214 | } 215 | if ($s =~ /[^\x00-\x7E]/) { 216 | my $w = ($self->get_config('encode_encoding_v1') || [0])->[0]; 217 | my $r = ($self->get_config('decode_encoding_v1') || [0])->[0]; 218 | $_ = (lc or 'iso-8859-1') for $r, $w; 219 | # Safe: per-standard and read+write is idempotent: 220 | return 1 if $r eq $w and $w eq 'iso-8859-1'; 221 | return !(($self->get_config('encoded_v1_fits')||[0])->[0]) 222 | if $w eq 'iso-8859-1'; # read+write not idempotent 223 | return if $w ne $r 224 | and not (($self->get_config('encoded_v1_fits')||[0])->[0]); 225 | } 226 | return 1; 227 | } 228 | 229 | =item as_bin() 230 | 231 | $str = $id3v1->as_bin(); 232 | 233 | Returns the ID3v1 tag as a string. 234 | 235 | =item write_tag() 236 | 237 | $id3v1->write_tag(); 238 | 239 | [old name: writeTag() . The old name is still available, but you should use the new name] 240 | 241 | Writes the ID3v1 tag to the file. 242 | 243 | =cut 244 | 245 | sub as_bin { 246 | my $self = shift; 247 | my($t) = ( $self->{track} =~ m[^(\d+)(?:/|$)], 0 ); 248 | my (%f, $f, $e); 249 | for $f (qw(title artist album comment) ) { 250 | $f{$f} = $self->{$f}; 251 | } 252 | 253 | if ($e = $self->get_config('encode_encoding_v1') and $e->[0]) { 254 | my $field; 255 | require Encode; 256 | 257 | for $field (qw(title artist album comment)) { 258 | $f{$field} = Encode::encode($e->[0], $f{$field}); 259 | } 260 | } 261 | 262 | $f{comment} = pack "a28 x C", $f{comment}, $t if $t; 263 | $self->{genreID}=255 unless $self->{genreID} =~ /^\d+$/; 264 | 265 | return pack("a3a30a30a30a4a30C","TAG",$f{title}, $f{artist}, 266 | $f{album}, $self->{year}, $f{comment}, $self->{genreID}); 267 | } 268 | 269 | sub write_tag { 270 | my $self = shift; 271 | return undef unless exists $self->{title} && exists $self->{changed}; 272 | my $data = $self->as_bin(); 273 | my $mp3obj = $self->{mp3}; 274 | my $mp3tag; 275 | $mp3obj->close; 276 | if ($mp3obj->open("write")) { 277 | $mp3obj->seek(-128,2); 278 | $mp3obj->read(\$mp3tag, 3); 279 | if ($mp3tag eq "TAG") { 280 | $mp3obj->seek(-125,2); # neccessary for windows 281 | $mp3obj->write(substr $data, 3); 282 | } else { 283 | $mp3obj->seek(0,2); 284 | $mp3obj->write($data); 285 | } 286 | } else { 287 | warn "Couldn't open file `" . $mp3obj->filename() . "' to write tag"; 288 | return 0; 289 | } 290 | return 1; 291 | } 292 | 293 | *writeTag = \&write_tag; 294 | 295 | =pod 296 | 297 | =item remove_tag() 298 | 299 | $id3v1->remove_tag(); 300 | 301 | Removes the ID3v1 tag from the file. Returns negative on failure, 302 | FALSE if no tag was found. 303 | 304 | (Caveat: only I<one tag> is removed; some - broken - files may have 305 | many chain-loaded one after another; you may need to call remove_tag() 306 | in a loop to handle such beasts.) 307 | 308 | [old name: removeTag() . The old name is still available, but you 309 | should use the new name] 310 | 311 | =cut 312 | 313 | sub remove_tag { 314 | my $self = shift; 315 | my $mp3obj = $self->{mp3}; 316 | my $mp3tag; 317 | $mp3obj->seek(-128,2); 318 | $mp3obj->read(\$mp3tag, 3); 319 | if ($mp3tag eq "TAG") { 320 | $mp3obj->close; 321 | if ($mp3obj->open("write")) { 322 | $mp3obj->truncate(-128); 323 | $self->all("","","","","",0,255); 324 | $mp3obj->close; 325 | $self->{changed} = 1; 326 | return 1; 327 | } 328 | return -1; 329 | } 330 | return 0; 331 | } 332 | 333 | *removeTag = \&remove_tag; 334 | 335 | =pod 336 | 337 | =item genres() 338 | 339 | @allgenres = $id3v1->genres; 340 | $genreName = $id3v1->genres($genreID); 341 | $genreID = $id3v1->genres($genreName); 342 | 343 | Returns a list of all genres, or the according name or id to 344 | a given id or name. 345 | 346 | =cut 347 | 348 | sub genres { 349 | # return an array with all genres, of if a parameter is given, the according genre 350 | my ($self, $genre) = @_; 351 | if ( (defined $self) and (not defined $genre) and ($self !~ /MP3::Tag/)) { 352 | ## genres may be called directly via MP3::Tag::ID3v1::genres() 353 | ## and $self is then not used for an id3v1 object 354 | $genre = $self; 355 | } 356 | 357 | return \@winamp_genres unless defined $genre; 358 | 359 | if ($genre =~ /^\d+$/) { 360 | return $winamp_genres[$genre] if $genre<scalar @winamp_genres; 361 | return undef; 362 | } 363 | 364 | my ($id, $found)=0; 365 | foreach (@winamp_genres) { 366 | if (uc $_ eq uc $genre) { 367 | $found = 1; 368 | last; 369 | } 370 | $id++; 371 | } 372 | $id=255 unless $found; 373 | return $id; 374 | } 375 | 376 | =item new() 377 | 378 | $id3v1 = MP3::Tag::ID3v1->new($mp3fileobj[, $create]); 379 | 380 | Generally called from MP3::Tag, because a $mp3fileobj is needed. 381 | If $create is true, a new tag is created. Otherwise undef is 382 | returned, if now ID3v1 tag is found in the $mp3obj. 383 | 384 | Please use 385 | 386 | $mp3 = MP3::Tag->new($filename); 387 | $id3v1 = $mp3->new_tag("ID3v1"); # Empty new tag 388 | 389 | or 390 | 391 | $mp3 = MP3::Tag->new($filename); 392 | $mp3->get_tags(); 393 | $id3v1 = $mp3->{ID3v1}; # Existing tag (if present) 394 | 395 | instead of using this function directly 396 | 397 | =back 398 | 399 | =cut 400 | 401 | # create a ID3v1 object 402 | sub new { 403 | my ($class, $fileobj, $create) = @_; 404 | my $self={mp3=>$fileobj}; 405 | my $buffer; 406 | 407 | if ($create) { 408 | $self->{new} = 1; 409 | } else { 410 | $fileobj->open or return unless $fileobj->is_open; 411 | $fileobj->seek(-128,2); 412 | $fileobj->read(\$buffer, 128); 413 | return undef unless substr ($buffer,0,3) eq "TAG"; 414 | } 415 | 416 | bless $self, $class; 417 | $self->read_tag($buffer); # $buffer unused if ->{new} 418 | return $self; 419 | } 420 | 421 | sub new_with_parent { 422 | my ($class, $filename, $parent) = @_; 423 | return unless my $new = $class->new($filename, undef); 424 | $new->{parent} = $parent; 425 | $new; 426 | } 427 | 428 | ################# 429 | ## 430 | ## internal subs 431 | 432 | # actually read the tag data 433 | sub read_tag { 434 | my ($self, $buffer) = @_; 435 | my ($id3v1, $e); 436 | 437 | if ($self->{new}) { 438 | ($self->{title}, $self->{artist}, $self->{album}, $self->{year}, 439 | $self->{comment}, $self->{track}, $self->{genre}, $self->{genreID}) = ("","","","","",'',"",255); 440 | $self->{changed} = 1; 441 | } else { 442 | (undef, $self->{title}, $self->{artist}, $self->{album}, $self->{year}, 443 | $self->{comment}, $id3v1, $self->{track}, $self->{genreID}) = 444 | unpack (($] < 5.6 445 | ? "a3 A30 A30 A30 A4 A28 C C C" # Trailing spaces stripped too 446 | : "a3 Z30 Z30 Z30 Z4 Z28 C C C"), 447 | $buffer); 448 | 449 | if ($id3v1!=0) { # ID3v1 tag found: track is not valid, comment two chars longer 450 | $self->{comment} .= chr($id3v1); 451 | $self->{comment} .= chr($self->{track}) 452 | if $self->{track} and $self->{track}!=32; 453 | $self->{track} = ''; 454 | }; 455 | $self->{track} = '' unless $self->{track}; 456 | $self->{genre} = id2genre($self->{genreID}); 457 | if ($e = $self->get_config('decode_encoding_v1') and $e->[0]) { 458 | my $field; 459 | require Encode; 460 | 461 | for $field (qw(title artist album comment)) { 462 | $self->{$field} = Encode::decode($e->[0], $self->{$field}); 463 | } 464 | } 465 | } 466 | } 467 | 468 | # convert small integer id to genre name 469 | sub id2genre { 470 | my $id=shift; 471 | return "" unless defined $id and $id < @winamp_genres; 472 | return $winamp_genres[$id]; 473 | } 474 | 475 | # convert genre name to small integer id 476 | sub genre2id { 477 | my $genre = MP3::Tag::Implemenation::_massage_genres(shift, 'num'); 478 | return $genre if defined $genre; 479 | return 255; 480 | } 481 | 482 | # nothing to do for destroy 483 | sub DESTROY { 484 | } 485 | 486 | 1; 487 | 488 | ######## define all the genres 489 | 490 | BEGIN { @mp3_genres = ( 'Blues', 'Classic Rock', 'Country', 'Dance', 491 | 'Disco', 'Funk', 'Grunge', 'Hip-Hop', 'Jazz', 'Metal', 'New Age', 492 | 'Oldies', 'Other', 'Pop', 'R&B', 'Rap', 'Reggae', 'Rock', 'Techno', 493 | 'Industrial', 'Alternative', 'Ska', 'Death Metal', 'Pranks', 494 | 'Soundtrack', 'Euro-Techno', 'Ambient', 'Trip-Hop', 'Vocal', 495 | 'Jazz+Funk', 'Fusion', 'Trance', 'Classical', 'Instrumental', 'Acid', 496 | 'House', 'Game', 'Sound Clip', 'Gospel', 'Noise', 'AlternRock', 497 | 'Bass', 'Soul', 'Punk', 'Space', 'Meditative', 'Instrumental Pop', 498 | 'Instrumental Rock', 'Ethnic', 'Gothic', 'Darkwave', 499 | 'Techno-Industrial', 'Electronic', 'Pop-Folk', 'Eurodance', 'Dream', 500 | 'Southern Rock', 'Comedy', 'Cult', 'Gangsta', 'Top 40', 501 | 'Christian Rap', 'Pop/Funk', 'Jungle', 'Native American', 'Cabaret', 'New Wave', 502 | 'Psychadelic', 'Rave', 'Showtunes', 'Trailer', 'Lo-Fi', 'Tribal', 503 | 'Acid Punk', 'Acid Jazz', 'Polka', 'Retro', 'Musical', 'Rock & Roll', 504 | 'Hard Rock', ); 505 | 506 | @winamp_genres = ( @mp3_genres, 'Folk', 'Folk-Rock', 507 | 'National Folk', 'Swing', 'Fast Fusion', 'Bebob', 'Latin', 'Revival', 508 | 'Celtic', 'Bluegrass', 'Avantgarde', 'Gothic Rock', 509 | 'Progressive Rock', 'Psychedelic Rock', 'Symphonic Rock', 510 | 'Slow Rock', 'Big Band', 'Chorus', 'Easy Listening', 511 | 'Acoustic', 'Humour', 'Speech', 'Chanson', 'Opera', 512 | 'Chamber Music', 'Sonata', 'Symphony', 'Booty Bass', 'Primus', 513 | 'Porn Groove', 'Satire', 'Slow Jam', 'Club', 'Tango', 'Samba', 514 | 'Folklore', 'Ballad', 'Power Ballad', 'Rhythmic Soul', 515 | 'Freestyle', 'Duet', 'Punk Rock', 'Drum Solo', 'Acapella', 516 | 'Euro-House', 'Dance Hall', 517 | # More from MP3::Info 518 | 'Goa', 'Drum & Bass', 'Club-House', 'Hardcore', 519 | 'Terror', 'Indie', 'BritPop', 'Negerpunk', 520 | 'Polsk Punk', 'Beat', 'Christian Gangsta Rap', 521 | 'Heavy Metal', 'Black Metal', 'Crossover', 522 | 'Contemporary Christian Music', 'Christian Rock', 523 | 'Merengue', 'Salsa', 'Thrash Metal', 'Anime', 524 | 'JPop', 'SynthPop', # 149 525 | ); 526 | } 527 | 528 | =pod 529 | 530 | =head1 SEE ALSO 531 | 532 | L<MP3::Tag>, L<MP3::Tag::ID3v2> 533 | 534 | ID3v1 standard - http://www.id3.org 535 | 536 | =head1 COPYRIGHT 537 | 538 | Copyright (c) 2000-2004 Thomas Geffert. All rights reserved. 539 | 540 | This program is free software; you can redistribute it and/or 541 | modify it under the terms of the Artistic License, distributed 542 | with Perl. 543 | 544 | =cut 545 | -------------------------------------------------------------------------------- /lib/File/Find/Rule.pm: -------------------------------------------------------------------------------- 1 | # $Id: /mirror/lab/perl/File-Find-Rule/lib/File/Find/Rule.pm 2102 2006-06-01T15:39:03.942922Z richardc $ 2 | 3 | package File::Find::Rule; 4 | use strict; 5 | use vars qw/$VERSION $AUTOLOAD/; 6 | use File::Spec; 7 | use Text::Glob 'glob_to_regex'; 8 | use Number::Compare; 9 | use Carp qw/croak/; 10 | use File::Find (); # we're only wrapping for now 11 | use Cwd; # 5.00503s File::Find goes screwy with max_depth == 0 12 | 13 | $VERSION = '0.30'; 14 | 15 | # we'd just inherit from Exporter, but I want the colon 16 | sub import { 17 | my $pkg = shift; 18 | my $to = caller; 19 | for my $sym ( qw( find rule ) ) { 20 | no strict 'refs'; 21 | *{"$to\::$sym"} = \&{$sym}; 22 | } 23 | for (grep /^:/, @_) { 24 | my ($extension) = /^:(.*)/; 25 | eval "require File::Find::Rule::$extension"; 26 | croak "couldn't bootstrap File::Find::Rule::$extension: $@" if $@; 27 | } 28 | } 29 | 30 | =head1 NAME 31 | 32 | File::Find::Rule - Alternative interface to File::Find 33 | 34 | =head1 SYNOPSIS 35 | 36 | use File::Find::Rule; 37 | # find all the subdirectories of a given directory 38 | my @subdirs = File::Find::Rule->directory->in( $directory ); 39 | 40 | # find all the .pm files in @INC 41 | my @files = File::Find::Rule->file() 42 | ->name( '*.pm' ) 43 | ->in( @INC ); 44 | 45 | # as above, but without method chaining 46 | my $rule = File::Find::Rule->new; 47 | $rule->file; 48 | $rule->name( '*.pm' ); 49 | my @files = $rule->in( @INC ); 50 | 51 | =head1 DESCRIPTION 52 | 53 | File::Find::Rule is a friendlier interface to File::Find. It allows 54 | you to build rules which specify the desired files and directories. 55 | 56 | =cut 57 | 58 | # the procedural shim 59 | 60 | *rule = \&find; 61 | sub find { 62 | my $object = __PACKAGE__->new(); 63 | my $not = 0; 64 | 65 | while (@_) { 66 | my $method = shift; 67 | my @args; 68 | 69 | if ($method =~ s/^\!//) { 70 | # jinkies, we're really negating this 71 | unshift @_, $method; 72 | $not = 1; 73 | next; 74 | } 75 | unless (defined prototype $method) { 76 | my $args = shift; 77 | @args = ref $args eq 'ARRAY' ? @$args : $args; 78 | } 79 | if ($not) { 80 | $not = 0; 81 | @args = $object->new->$method(@args); 82 | $method = "not"; 83 | } 84 | 85 | my @return = $object->$method(@args); 86 | return @return if $method eq 'in'; 87 | } 88 | $object; 89 | } 90 | 91 | 92 | =head1 METHODS 93 | 94 | =over 95 | 96 | =item C<new> 97 | 98 | A constructor. You need not invoke C<new> manually unless you wish 99 | to, as each of the rule-making methods will auto-create a suitable 100 | object if called as class methods. 101 | 102 | =cut 103 | 104 | sub new { 105 | my $referent = shift; 106 | my $class = ref $referent || $referent; 107 | bless { 108 | rules => [], # [0] 109 | subs => [], # [1] 110 | iterator => [], 111 | extras => {}, 112 | maxdepth => undef, 113 | mindepth => undef, 114 | }, $class; 115 | } 116 | 117 | sub _force_object { 118 | my $object = shift; 119 | $object = $object->new() 120 | unless ref $object; 121 | $object; 122 | } 123 | 124 | =back 125 | 126 | =head2 Matching Rules 127 | 128 | =over 129 | 130 | =item C<name( @patterns )> 131 | 132 | Specifies names that should match. May be globs or regular 133 | expressions. 134 | 135 | $set->name( '*.mp3', '*.ogg' ); # mp3s or oggs 136 | $set->name( qr/\.(mp3|ogg)$/ ); # the same as a regex 137 | $set->name( 'foo.bar' ); # just things named foo.bar 138 | 139 | =cut 140 | 141 | sub _flatten { 142 | my @flat; 143 | while (@_) { 144 | my $item = shift; 145 | ref $item eq 'ARRAY' ? push @_, @{ $item } : push @flat, $item; 146 | } 147 | return @flat; 148 | } 149 | 150 | sub name { 151 | my $self = _force_object shift; 152 | my @names = map { ref $_ eq "Regexp" ? $_ : glob_to_regex $_ } _flatten( @_ ); 153 | 154 | push @{ $self->{rules} }, { 155 | rule => 'name', 156 | code => join( ' || ', map { "m($_)" } @names ), 157 | args => \@_, 158 | }; 159 | 160 | $self; 161 | } 162 | 163 | =item -X tests 164 | 165 | Synonyms are provided for each of the -X tests. See L<perlfunc/-X> for 166 | details. None of these methods take arguments. 167 | 168 | Test | Method Test | Method 169 | ------|------------- ------|---------------- 170 | -r | readable -R | r_readable 171 | -w | writeable -W | r_writeable 172 | -w | writable -W | r_writable 173 | -x | executable -X | r_executable 174 | -o | owned -O | r_owned 175 | | | 176 | -e | exists -f | file 177 | -z | empty -d | directory 178 | -s | nonempty -l | symlink 179 | | -p | fifo 180 | -u | setuid -S | socket 181 | -g | setgid -b | block 182 | -k | sticky -c | character 183 | | -t | tty 184 | -M | modified | 185 | -A | accessed -T | ascii 186 | -C | changed -B | binary 187 | 188 | Though some tests are fairly meaningless as binary flags (C<modified>, 189 | C<accessed>, C<changed>), they have been included for completeness. 190 | 191 | # find nonempty files 192 | $rule->file, 193 | ->nonempty; 194 | 195 | =cut 196 | 197 | use vars qw( %X_tests ); 198 | %X_tests = ( 199 | -r => readable => -R => r_readable => 200 | -w => writeable => -W => r_writeable => 201 | -w => writable => -W => r_writable => 202 | -x => executable => -X => r_executable => 203 | -o => owned => -O => r_owned => 204 | 205 | -e => exists => -f => file => 206 | -z => empty => -d => directory => 207 | -s => nonempty => -l => symlink => 208 | => -p => fifo => 209 | -u => setuid => -S => socket => 210 | -g => setgid => -b => block => 211 | -k => sticky => -c => character => 212 | => -t => tty => 213 | -M => modified => 214 | -A => accessed => -T => ascii => 215 | -C => changed => -B => binary => 216 | ); 217 | 218 | for my $test (keys %X_tests) { 219 | my $sub = eval 'sub () { 220 | my $self = _force_object shift; 221 | push @{ $self->{rules} }, { 222 | code => "' . $test . ' \$_", 223 | rule => "'.$X_tests{$test}.'", 224 | }; 225 | $self; 226 | } '; 227 | no strict 'refs'; 228 | *{ $X_tests{$test} } = $sub; 229 | } 230 | 231 | 232 | =item stat tests 233 | 234 | The following C<stat> based methods are provided: C<dev>, C<ino>, 235 | C<mode>, C<nlink>, C<uid>, C<gid>, C<rdev>, C<size>, C<atime>, 236 | C<mtime>, C<ctime>, C<blksize>, and C<blocks>. See L<perlfunc/stat> 237 | for details. 238 | 239 | Each of these can take a number of targets, which will follow 240 | L<Number::Compare> semantics. 241 | 242 | $rule->size( 7 ); # exactly 7 243 | $rule->size( ">7Ki" ); # larger than 7 * 1024 * 1024 bytes 244 | $rule->size( ">=7" ) 245 | ->size( "<=90" ); # between 7 and 90, inclusive 246 | $rule->size( 7, 9, 42 ); # 7, 9 or 42 247 | 248 | =cut 249 | 250 | use vars qw( @stat_tests ); 251 | @stat_tests = qw( dev ino mode nlink uid gid rdev 252 | size atime mtime ctime blksize blocks ); 253 | { 254 | my $i = 0; 255 | for my $test (@stat_tests) { 256 | my $index = $i++; # to close over 257 | my $sub = sub { 258 | my $self = _force_object shift; 259 | 260 | my @tests = map { Number::Compare->parse_to_perl($_) } @_; 261 | 262 | push @{ $self->{rules} }, { 263 | rule => $test, 264 | args => \@_, 265 | code => 'do { my $val = (stat $_)['.$index.'] || 0;'. 266 | join ('||', map { "(\$val $_)" } @tests ).' }', 267 | }; 268 | $self; 269 | }; 270 | no strict 'refs'; 271 | *$test = $sub; 272 | } 273 | } 274 | 275 | =item C<any( @rules )> 276 | 277 | =item C<or( @rules )> 278 | 279 | Allows shortcircuiting boolean evaluation as an alternative to the 280 | default and-like nature of combined rules. C<any> and C<or> are 281 | interchangeable. 282 | 283 | # find avis, movs, things over 200M and empty files 284 | $rule->any( File::Find::Rule->name( '*.avi', '*.mov' ), 285 | File::Find::Rule->size( '>200M' ), 286 | File::Find::Rule->file->empty, 287 | ); 288 | 289 | =cut 290 | 291 | sub any { 292 | my $self = _force_object shift; 293 | my @rulesets = @_; 294 | 295 | push @{ $self->{rules} }, { 296 | rule => 'any', 297 | code => '(' . join( ' || ', map { 298 | "( " . $_->_compile( $self->{subs} ) . " )" 299 | } @_ ) . ")", 300 | args => \@_, 301 | }; 302 | $self; 303 | } 304 | 305 | *or = \&any; 306 | 307 | =item C<none( @rules )> 308 | 309 | =item C<not( @rules )> 310 | 311 | Negates a rule. (The inverse of C<any>.) C<none> and C<not> are 312 | interchangeable. 313 | 314 | # files that aren't 8.3 safe 315 | $rule->file 316 | ->not( $rule->new->name( qr/^[^.]{1,8}(\.[^.]{0,3})?$/ ) ); 317 | 318 | =cut 319 | 320 | sub not { 321 | my $self = _force_object shift; 322 | my @rulesets = @_; 323 | 324 | push @{ $self->{rules} }, { 325 | rule => 'not', 326 | args => \@rulesets, 327 | code => '(' . join ( ' && ', map { 328 | "!(". $_->_compile( $self->{subs} ) . ")" 329 | } @_ ) . ")", 330 | }; 331 | $self; 332 | } 333 | 334 | *none = \¬ 335 | 336 | =item C<prune> 337 | 338 | Traverse no further. This rule always matches. 339 | 340 | =cut 341 | 342 | sub prune () { 343 | my $self = _force_object shift; 344 | 345 | push @{ $self->{rules} }, 346 | { 347 | rule => 'prune', 348 | code => '$File::Find::prune = 1' 349 | }; 350 | $self; 351 | } 352 | 353 | =item C<discard> 354 | 355 | Don't keep this file. This rule always matches. 356 | 357 | =cut 358 | 359 | sub discard () { 360 | my $self = _force_object shift; 361 | 362 | push @{ $self->{rules} }, { 363 | rule => 'discard', 364 | code => '$discarded = 1', 365 | }; 366 | $self; 367 | } 368 | 369 | =item C<exec( \&subroutine( $shortname, $path, $fullname ) )> 370 | 371 | Allows user-defined rules. Your subroutine will be invoked with C<$_> 372 | set to the current short name, and with parameters of the name, the 373 | path you're in, and the full relative filename. 374 | 375 | Return a true value if your rule matched. 376 | 377 | # get things with long names 378 | $rules->exec( sub { length > 20 } ); 379 | 380 | =cut 381 | 382 | sub exec { 383 | my $self = _force_object shift; 384 | my $code = shift; 385 | 386 | push @{ $self->{rules} }, { 387 | rule => 'exec', 388 | code => $code, 389 | }; 390 | $self; 391 | } 392 | 393 | =item ->grep( @specifiers ); 394 | 395 | Opens a file and tests it each line at a time. 396 | 397 | For each line it evaluates each of the specifiers, stopping at the 398 | first successful match. A specifier may be a regular expression or a 399 | subroutine. The subroutine will be invoked with the same parameters 400 | as an ->exec subroutine. 401 | 402 | It is possible to provide a set of negative specifiers by enclosing 403 | them in anonymous arrays. Should a negative specifier match the 404 | iteration is aborted and the clause is failed. For example: 405 | 406 | $rule->grep( qr/^#!.*\bperl/, [ sub { 1 } ] ); 407 | 408 | Is a passing clause if the first line of a file looks like a perl 409 | shebang line. 410 | 411 | =cut 412 | 413 | sub grep { 414 | my $self = _force_object shift; 415 | my @pattern = map { 416 | ref $_ 417 | ? ref $_ eq 'ARRAY' 418 | ? map { [ ( ref $_ ? $_ : qr/$_/ ) => 0 ] } @$_ 419 | : [ $_ => 1 ] 420 | : [ qr/$_/ => 1 ] 421 | } @_; 422 | 423 | $self->exec( sub { 424 | local *FILE; 425 | open FILE, $_ or return; 426 | local ($_, $.); 427 | while (<FILE>) { 428 | for my $p (@pattern) { 429 | my ($rule, $ret) = @$p; 430 | return $ret 431 | if ref $rule eq 'Regexp' 432 | ? /$rule/ 433 | : $rule->(@_); 434 | } 435 | } 436 | return; 437 | } ); 438 | } 439 | 440 | =item C<maxdepth( $level )> 441 | 442 | Descend at most C<$level> (a non-negative integer) levels of directories 443 | below the starting point. 444 | 445 | May be invoked many times per rule, but only the most recent value is 446 | used. 447 | 448 | =item C<mindepth( $level )> 449 | 450 | Do not apply any tests at levels less than C<$level> (a non-negative 451 | integer). 452 | 453 | =item C<extras( \%extras )> 454 | 455 | Specifies extra values to pass through to C<File::File::find> as part 456 | of the options hash. 457 | 458 | For example this allows you to specify following of symlinks like so: 459 | 460 | my $rule = File::Find::Rule->extras({ follow => 1 }); 461 | 462 | May be invoked many times per rule, but only the most recent value is 463 | used. 464 | 465 | =cut 466 | 467 | for my $setter (qw( maxdepth mindepth extras )) { 468 | my $sub = sub { 469 | my $self = _force_object shift; 470 | $self->{$setter} = shift; 471 | $self; 472 | }; 473 | no strict 'refs'; 474 | *$setter = $sub; 475 | } 476 | 477 | 478 | =item C<relative> 479 | 480 | Trim the leading portion of any path found 481 | 482 | =cut 483 | 484 | sub relative () { 485 | my $self = _force_object shift; 486 | $self->{relative} = 1; 487 | $self; 488 | } 489 | 490 | =item C<not_*> 491 | 492 | Negated version of the rule. An effective shortand related to ! in 493 | the procedural interface. 494 | 495 | $foo->not_name('*.pl'); 496 | 497 | $foo->not( $foo->new->name('*.pl' ) ); 498 | 499 | =cut 500 | 501 | sub DESTROY {} 502 | sub AUTOLOAD { 503 | $AUTOLOAD =~ /::not_([^:]*)$/ 504 | or croak "Can't locate method $AUTOLOAD"; 505 | my $method = $1; 506 | 507 | my $sub = sub { 508 | my $self = _force_object shift; 509 | $self->not( $self->new->$method(@_) ); 510 | }; 511 | { 512 | no strict 'refs'; 513 | *$AUTOLOAD = $sub; 514 | } 515 | &$sub; 516 | } 517 | 518 | =back 519 | 520 | =head2 Query Methods 521 | 522 | =over 523 | 524 | =item C<in( @directories )> 525 | 526 | Evaluates the rule, returns a list of paths to matching files and 527 | directories. 528 | 529 | =cut 530 | 531 | sub in { 532 | my $self = _force_object shift; 533 | 534 | my @found; 535 | my $fragment = $self->_compile( $self->{subs} ); 536 | my @subs = @{ $self->{subs} }; 537 | 538 | warn "relative mode handed multiple paths - that's a bit silly\n" 539 | if $self->{relative} && @_ > 1; 540 | 541 | my $topdir; 542 | my $code = 'sub { 543 | (my $path = $File::Find::name) =~ s#^(?:\./+)+##; 544 | my @args = ($_, $File::Find::dir, $path); 545 | my $maxdepth = $self->{maxdepth}; 546 | my $mindepth = $self->{mindepth}; 547 | my $relative = $self->{relative}; 548 | 549 | # figure out the relative path and depth 550 | my $relpath = $File::Find::name; 551 | $relpath =~ s{^\Q$topdir\E/?}{}; 552 | my $depth = scalar File::Spec->splitdir($relpath); 553 | #print "name: \'$File::Find::name\' "; 554 | #print "relpath: \'$relpath\' depth: $depth relative: $relative\n"; 555 | 556 | defined $maxdepth && $depth >= $maxdepth 557 | and $File::Find::prune = 1; 558 | 559 | defined $mindepth && $depth < $mindepth 560 | and return; 561 | 562 | #print "Testing \'$_\'\n"; 563 | 564 | my $discarded; 565 | return unless ' . $fragment . '; 566 | return if $discarded; 567 | if ($relative) { 568 | push @found, $relpath if $relpath ne ""; 569 | } 570 | else { 571 | push @found, $path; 572 | } 573 | }'; 574 | 575 | #use Data::Dumper; 576 | #print Dumper \@subs; 577 | #warn "Compiled sub: '$code'\n"; 578 | 579 | my $sub = eval "$code" or die "compile error '$code' $@"; 580 | my $cwd = getcwd; 581 | for my $path (@_) { 582 | # $topdir is used for relative and maxdepth 583 | $topdir = $path; 584 | # slice off the trailing slash if there is one (the 585 | # maxdepth/mindepth code is fussy) 586 | $topdir =~ s{/?$}{} 587 | unless $topdir eq '/'; 588 | $self->_call_find( { %{ $self->{extras} }, wanted => $sub }, $path ); 589 | } 590 | chdir $cwd; 591 | 592 | return @found; 593 | } 594 | 595 | sub _call_find { 596 | my $self = shift; 597 | File::Find::find( @_ ); 598 | } 599 | 600 | sub _compile { 601 | my $self = shift; 602 | my $subs = shift; # [1] 603 | 604 | return '1' unless @{ $self->{rules} }; 605 | my $code = join " && ", map { 606 | if (ref $_->{code}) { 607 | push @$subs, $_->{code}; 608 | "\$subs[$#{$subs}]->(\@args) # $_->{rule}\n"; 609 | } 610 | else { 611 | "( $_->{code} ) # $_->{rule}\n"; 612 | } 613 | } @{ $self->{rules} }; 614 | 615 | return $code; 616 | } 617 | 618 | =item C<start( @directories )> 619 | 620 | Starts a find across the specified directories. Matching items may 621 | then be queried using L</match>. This allows you to use a rule as an 622 | iterator. 623 | 624 | my $rule = File::Find::Rule->file->name("*.jpeg")->start( "/web" ); 625 | while ( my $image = $rule->match ) { 626 | ... 627 | } 628 | 629 | =cut 630 | 631 | sub start { 632 | my $self = _force_object shift; 633 | 634 | $self->{iterator} = [ $self->in( @_ ) ]; 635 | $self; 636 | } 637 | 638 | =item C<match> 639 | 640 | Returns the next file which matches, false if there are no more. 641 | 642 | =cut 643 | 644 | sub match { 645 | my $self = _force_object shift; 646 | 647 | return shift @{ $self->{iterator} }; 648 | } 649 | 650 | 1; 651 | 652 | __END__ 653 | 654 | =back 655 | 656 | =head2 Extensions 657 | 658 | Extension modules are available from CPAN in the File::Find::Rule 659 | namespace. In order to use these extensions either use them directly: 660 | 661 | use File::Find::Rule::ImageSize; 662 | use File::Find::Rule::MMagic; 663 | 664 | # now your rules can use the clauses supplied by the ImageSize and 665 | # MMagic extension 666 | 667 | or, specify that File::Find::Rule should load them for you: 668 | 669 | use File::Find::Rule qw( :ImageSize :MMagic ); 670 | 671 | For notes on implementing your own extensions, consult 672 | L<File::Find::Rule::Extending> 673 | 674 | =head2 Further examples 675 | 676 | =over 677 | 678 | =item Finding perl scripts 679 | 680 | my $finder = File::Find::Rule->or 681 | ( 682 | File::Find::Rule->name( '*.pl' ), 683 | File::Find::Rule->exec( 684 | sub { 685 | if (open my $fh, $_) { 686 | my $shebang = <$fh>; 687 | close $fh; 688 | return $shebang =~ /^#!.*\bperl/; 689 | } 690 | return 0; 691 | } ), 692 | ); 693 | 694 | Based upon this message http://use.perl.org/comments.pl?sid=7052&cid=10842 695 | 696 | =item ignore CVS directories 697 | 698 | my $rule = File::Find::Rule->new; 699 | $rule->or($rule->new 700 | ->directory 701 | ->name('CVS') 702 | ->prune 703 | ->discard, 704 | $rule->new); 705 | 706 | Note here the use of a null rule. Null rules match anything they see, 707 | so the effect is to match (and discard) directories called 'CVS' or to 708 | match anything. 709 | 710 | =back 711 | 712 | =head1 TWO FOR THE PRICE OF ONE 713 | 714 | File::Find::Rule also gives you a procedural interface. This is 715 | documented in L<File::Find::Rule::Procedural> 716 | 717 | =head1 EXPORTS 718 | 719 | L</find>, L</rule> 720 | 721 | =head1 BUGS 722 | 723 | The code relies on qr// compiled regexes, therefore this module 724 | requires perl version 5.005_03 or newer. 725 | 726 | Currently it isn't possible to remove a clause from a rule object. If 727 | this becomes a significant issue it will be addressed. 728 | 729 | =head1 AUTHOR 730 | 731 | Richard Clamp <richardc@unixbeard.net> with input gained from this 732 | use.perl discussion: http://use.perl.org/~richardc/journal/6467 733 | 734 | Additional proofreading and input provided by Kake, Greg McCarroll, 735 | and Andy Lester andy@petdance.com. 736 | 737 | =head1 COPYRIGHT 738 | 739 | Copyright (C) 2002, 2003, 2004, 2006 Richard Clamp. All Rights Reserved. 740 | 741 | This module is free software; you can redistribute it and/or modify it 742 | under the same terms as Perl itself. 743 | 744 | =head1 SEE ALSO 745 | 746 | L<File::Find>, L<Text::Glob>, L<Number::Compare>, find(1) 747 | 748 | If you want to know about the procedural interface, see 749 | L<File::Find::Rule::Procedural>, and if you have an idea for a neat 750 | extension L<File::Find::Rule::Extending> 751 | 752 | =cut 753 | 754 | Implementation notes: 755 | 756 | [0] Currently we use an array of anonymous subs, and call those 757 | repeatedly from match. It'll probably be way more effecient to 758 | instead eval-string compile a dedicated matching sub, and call that to 759 | avoid the repeated sub dispatch. 760 | 761 | [1] Though [0] isn't as true as it once was, I'm not sure that the 762 | subs stack is exposed in quite the right way. Maybe it'd be better as 763 | a private global hash. Something like $subs{$self} = []; and in 764 | C<DESTROY>, delete $subs{$self}. 765 | 766 | That'd make compiling subrules really much easier (no need to pass 767 | @subs in for context), and things that work via a mix of callbacks and 768 | code fragments are possible (you'd probably want this for the stat 769 | tests). 770 | 771 | Need to check this currently working version in before I play with 772 | that though. 773 | 774 | [*] There's probably a win to be made with the current model in making 775 | stat calls use C<_>. For 776 | 777 | find( file => size => "> 20M" => size => "< 400M" ); 778 | 779 | up to 3 stats will happen for each candidate. Adding a priming _ 780 | would be a bit blind if the first operation was C< name => 'foo' >, 781 | since that can be tested by a single regex. Simply checking what the 782 | next type of operation doesn't work since any arbritary exec sub may 783 | or may not stat. Potentially worse, they could stat something else 784 | like so: 785 | 786 | # extract from the worlds stupidest make(1) 787 | find( exec => sub { my $f = $_; $f =~ s/\.c$/.o/ && !-e $f } ); 788 | 789 | Maybe the best way is to treat C<_> as invalid after calling an exec, 790 | and doc that C<_> will only be meaningful after stat and -X tests if 791 | they're wanted in exec blocks. 792 | -------------------------------------------------------------------------------- /lib/FreezeThaw.pm: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | FreezeThaw - converting Perl structures to strings and back. 4 | 5 | =head1 SYNOPSIS 6 | 7 | use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard); 8 | $string = freeze $data1, $data2, $data3; 9 | ... 10 | ($olddata1, $olddata2, $olddata3) = thaw $string; 11 | if (cmpStr($olddata2,$data2) == 0) {print "OK!"} 12 | 13 | =head1 DESCRIPTION 14 | 15 | Converts data to/from stringified form, appropriate for 16 | saving-to/reading-from permanent storage. 17 | 18 | Deals with objects, circular lists, repeated appearence of the same 19 | refence. Does not deal with overloaded I<stringify> operator yet. 20 | 21 | =head1 EXPORT 22 | 23 | =over 12 24 | 25 | =item Default 26 | 27 | None. 28 | 29 | =item Exportable 30 | 31 | C<freeze thaw cmpStr cmpStrHard safeFreeze>. 32 | 33 | =back 34 | 35 | =head1 User API 36 | 37 | =over 12 38 | 39 | =item C<cmpStr> 40 | 41 | analogue of C<cmp> for data. Takes two arguments and compares them as 42 | separate entities. 43 | 44 | =item C<cmpStrHard> 45 | 46 | analogue of C<cmp> for data. Takes two arguments and compares them 47 | considered as a group. 48 | 49 | =item C<freeze> 50 | 51 | returns a string that encupsulates its arguments (considered as a 52 | group). C<thaw>ing this string leads to a fatal error if arguments to 53 | C<freeze> contained references to C<GLOB>s and C<CODE>s. 54 | 55 | =item C<safeFreeze> 56 | 57 | returns a string that encupsulates its arguments (considered as a 58 | group). The result is C<thaw>able in the same process. C<thaw>ing the 59 | result in a different process should result in a fatal error if 60 | arguments to C<safeFreeze> contained references to C<GLOB>s and 61 | C<CODE>s. 62 | 63 | =item C<thaw> 64 | 65 | takes one string argument and returns an array. The elements of the 66 | array are "equivalent" to arguments of the C<freeze> command that 67 | created the string. Can result in a fatal error (see above). 68 | 69 | =back 70 | 71 | =head1 Developer API 72 | 73 | C<FreezeThaw> C<freeze>s and C<thaw>s data blessed in some package by 74 | calling methods C<Freeze> and C<Thaw> in the package. The fallback 75 | methods are provided by the C<FreezeThaw> itself. The fallback 76 | C<Freeze> freezes the "content" of blessed object (from Perl point of 77 | view). The fallback C<Thaw> blesses the C<thaw>ed data back into the package. 78 | 79 | So the package needs to define its own methods only if the fallback 80 | methods will fail (for example, for a lot of data the "content" of an 81 | object is an address of some B<C> data). The methods are called like 82 | 83 | $newcooky = $obj->Freeze($cooky); 84 | $obj = Package->Thaw($content,$cooky); 85 | 86 | To save and restore the data the following method are applicable: 87 | 88 | $cooky->FreezeScalar($data,$ignorePackage,$noduplicate); 89 | 90 | during Freeze()ing, and 91 | 92 | $data = $cooky->ThawScalar; 93 | 94 | Two optional arguments $ignorePackage and $noduplicate regulate 95 | whether the freezing should not call the methods even if $data is a 96 | reference to a blessed object, and whether the data should not be 97 | marked as seen already even if it was seen before. The default methods 98 | 99 | sub UNIVERSAL::Freeze { 100 | my ($obj, $cooky) = (shift, shift); 101 | $cooky->FreezeScalar($obj,1,1); 102 | } 103 | 104 | sub UNIVERSAL::Thaw { 105 | my ($package, $cooky) = (shift, shift); 106 | my $obj = $cooky->ThawScalar; 107 | bless $obj, $package; 108 | } 109 | 110 | call the C<FreezeScalar> method of the $cooky since the freezing 111 | engine will see the data the second time during this call. Indeed, it 112 | is the freezing engine who calls UNIVERSAL::Freeze(), and it calls it 113 | because it needs to freeze $obj. The above call to 114 | $cooky->FreezeScalar() handles the same data back to engine, but 115 | because flags are different, the code does not cycle. 116 | 117 | Freezing and thawing $cooky also allows the following additional methods: 118 | 119 | $cooky->isSafe; 120 | 121 | to find out whether the current freeze was initiated by C<freeze> or 122 | C<safeFreeze> command. Analogous method for thaw $cooky returns 123 | whether the current thaw operation is considered safe (i.e., either 124 | does not contain cached elsewhere data, or comes from the same 125 | application). You can use 126 | 127 | $cooky->makeSafe; 128 | 129 | to prohibit cached data for the duration of the rest of freezing or 130 | thawing of current object. 131 | 132 | Two methods 133 | 134 | $value = $cooky->repeatedOK; 135 | $cooky->noRepeated; # Now repeated are prohibited 136 | 137 | allow to find out/change the current setting for allowing repeated 138 | references. 139 | 140 | If you want to flush the cache of saved objects you can use 141 | 142 | FreezeThaw->flushCache; 143 | 144 | this can invalidate some frozen string, so that thawing them will 145 | result in fatal error. 146 | 147 | =head2 Instantiating 148 | 149 | Sometimes, when an object from a package is recreated in presense of 150 | repeated references, it is not safe to recreate the internal structure 151 | of an object in one step. In such a situation recreation of an object 152 | is carried out in two steps: in the first the object is C<allocate>d, 153 | in the second it is C<instantiate>d. 154 | 155 | The restriction is that during the I<allocation> step you cannot use any 156 | reference to any Perl object that can be referenced from any other 157 | place. This restriction is applied since that object may not exist yet. 158 | 159 | Correspondingly, during I<instantiation> step the previosly I<allocated> 160 | object should be C<filled>, i.e., it can be changed in any way such 161 | that the references to this object remain valid. 162 | 163 | The methods are called like this: 164 | 165 | $pre_object_ref = Package->Allocate($pre_pre_object_ref); 166 | # Returns reference 167 | Package->Instantiate($pre_object_ref,$cooky); 168 | # Converts into reference to blessed object 169 | 170 | The reverse operations are 171 | 172 | $object_ref->FreezeEmpty($cooky); 173 | $object_ref->FreezeInstance($cooky); 174 | 175 | during these calls object can C<freezeScalar> some information (in a 176 | usual way) that will be used during C<Allocate> and C<Instantiate> 177 | calls (via C<thawScalar>). Note that the return value of 178 | C<FreezeEmpty> is cached during the phase of creation of uninialized 179 | objects. This B<must> be used like this: the return value is the 180 | reference to the created object, so it is not destructed until other 181 | objects are created, thus the frozen values of the different objects 182 | will not share the same references. Example of bad result: 183 | 184 | $o1->FreezeEmpty($cooky) 185 | 186 | freezes C<{}>, and C<$o2-E<gt>FreezeEmpty($cooky)> makes the same. Now 187 | nobody guaranties that that these two copies of C<{}> are different, 188 | unless a reference to the first one is preserved during the call to 189 | C<$o2-E<gt>FreezeEmpty($cooky)>. If C<$o1-E<gt>FreezeEmpty($cooky)> 190 | returns the value of C<{}> it uses, it will be preserved by the 191 | engine. 192 | 193 | The helper function C<FreezeThaw::copyContents> is provided for 194 | simplification of instantiation. The syntax is 195 | 196 | FreezeThaw::copyContents $to, $from; 197 | 198 | The function copies contents the object $from point to into what the 199 | object $to points to (including package for blessed references). Both 200 | arguments should be references. 201 | 202 | The default methods are provided. They do the following: 203 | 204 | =over 12 205 | 206 | =item C<FreezeEmpty> 207 | 208 | Freezes an I<empty> object of underlying type. 209 | 210 | =item C<FreezeInstance> 211 | 212 | Calls C<Freeze>. 213 | 214 | =item C<Allocate> 215 | 216 | Thaws what was frozen by C<FreezeEmpty>. 217 | 218 | =item C<Instantiate> 219 | 220 | Thaws what was frozen by C<FreezeInstance>, uses C<copyContents> to 221 | transfer this to the $pre_object. 222 | 223 | =back 224 | 225 | =head1 BUGS and LIMITATIONS 226 | 227 | A lot of objects are blessed in some obscure packages by XSUB 228 | typemaps. It is not clear how to (automatically) prevent the 229 | C<UNIVERSAL> methods to be called for objects in these packages. 230 | 231 | The objects which can survive freeze()/thaw() cycle must also survive a 232 | change of a "member" to an equal member. Say, after 233 | 234 | $a = [a => 3]; 235 | $a->{b} = \ $a->{a}; 236 | 237 | $a satisfies 238 | 239 | $a->{b} == \ $a->{a} 240 | 241 | This property will be broken by freeze()/thaw(), but it is also broken by 242 | 243 | $a->{a} = delete $a->{a}; 244 | 245 | =cut 246 | 247 | require 5.002; # defined ref stuff... 248 | 249 | # Different line noise chars: 250 | # 251 | # $567| next 567 chars form a scalar 252 | # 253 | # @34| next 34 scalars form an array 254 | # 255 | # %34| next 34 scalars form a hash 256 | # 257 | # ? next scalar is a safe-stamp at beginning 258 | # 259 | # ? next scalar is a stringified data 260 | # 261 | # ! repeated array follows (after a scalar denoting array $#), 262 | # (possibly?) followed by instantiation array. At beginning 263 | # 264 | # <45| ordinal of element in repeated array 265 | # 266 | # * stringified glob follows 267 | # 268 | # & stringified coderef follows 269 | # 270 | # \\ stringified defererenced data follows 271 | # 272 | # / stringified REx follows 273 | # 274 | # > stringified package name follows, then frozen data 275 | # 276 | # { stringified package name follows, then allocation data 277 | # 278 | # } stringified package name follows, then instantiation data 279 | # 280 | # _ frozen form of undef 281 | 282 | 283 | package FreezeThaw; 284 | 285 | use Exporter; 286 | 287 | @ISA = qw(Exporter); 288 | $VERSION = '0.5001'; 289 | @EXPORT_OK = qw(freeze thaw cmpStr cmpStrHard safeFreeze); 290 | 291 | use strict; 292 | use Carp; 293 | 294 | my $lock = (reverse time) ^ $$ ^ \&freezeString; # To distingush processes 295 | 296 | use vars qw( @multiple 297 | %seen_packages 298 | $seen_packages 299 | %seen_packages 300 | %count 301 | %address 302 | $string 303 | $unsafe 304 | $noCache 305 | $cooky 306 | $secondpass 307 | ), # Localized in freeze() 308 | qw( $norepeated ), # Localized in freezeScalar() 309 | qw( $uninitOK ), # Localized in thawScalar() 310 | qw( @uninit ), # Localized in thaw() 311 | qw($safe); # Localized in safeFreeze() 312 | 313 | BEGIN { # allow optimization away 314 | my $haveIsRex = defined &re::is_regexp; 315 | my $RexIsREGEXP = ($haveIsRex and # 'REGEXP' eq ref qr/1/); # First-class REX 316 | $] >= 5.011); # Code like above requires Scalar::Utils::reftype 317 | eval <<EOE or die; 318 | sub haveIsRex () {$haveIsRex} 319 | sub RexIsREGEXP () {$RexIsREGEXP} 320 | 1 321 | EOE 322 | } 323 | 324 | my (%saved); 325 | 326 | my %Empty = ( ARRAY => sub {[]}, HASH => sub {{}}, 327 | SCALAR => sub {my $undef; \$undef}, 328 | REF => sub {my $undef; \$undef}, 329 | CODE => 1, # 1 means atomic 330 | GLOB => 1, 331 | (RexIsREGEXP 332 | ? (Regexp => sub {my $qr = qr//}) 333 | : (Regexp => 0)), 334 | ); 335 | 336 | # This should better be done via pos() and \G, but apparently \G is not 337 | # optimized (bug in the REx optimizer???) 338 | BEGIN { 339 | my $pointer_size = length pack 'p', 0; 340 | #my $max_dig0 = 3*$pointer_size; # 8bits take less than 3 decimals 341 | # Now calculate the exact value: 342 | #my $max_pointer = sprintf "%.${max_dig0}g", 0x100**$pointer_size; 343 | my $max_pointer = sprintf "%.0f", 0x100**$pointer_size; 344 | die "Panic" if $max_pointer =~ /\D/; 345 | my $max_pointer_l = length $max_pointer; 346 | warn "Max pointer_l=$max_pointer_l" if $ENV{FREEZE_THAW_WARN}; 347 | eval "sub max_strlen_l () {$max_pointer_l}; 1" or die; 348 | } 349 | 350 | sub flushCache {$lock ^= rand; undef %saved;} 351 | 352 | sub getref ($) { 353 | my $ref = ref $_[0]; 354 | return $ref if not $ref or defined $Empty{$ref}; # Optimization _and_ Regexp 355 | my $str; 356 | if (defined &overload::StrVal) { 357 | $str = overload::StrVal($_[0]); 358 | } else { 359 | $str = "$_[0]"; 360 | } 361 | $ref = $1 if $str =~ /=(\w+)/; 362 | $ref; 363 | } 364 | 365 | sub freezeString {$string .= "\$" . length($_[0]) . '|' . $_[0]} 366 | 367 | sub freezeNumber {$string .= $_[0] . '|'} 368 | 369 | sub freezeREx {$string .= '/' . length($_[0]) . '|' . $_[0]} 370 | 371 | sub thawString { # Returns list: a string and offset of rest 372 | substr($string, $_[0], 2+max_strlen_l) =~ /^\$(\d+)\|/ 373 | or confess "Wrong format of frozen string: " . substr($string, $_[0]); 374 | length($string) - $_[0] > length($1) + 1 + $1 375 | or confess "Frozen string too short: `" . 376 | substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1); 377 | (substr($string, $_[0] + length($1) + 2, $1), $_[0] + length($1) + 2 + $1); 378 | } 379 | 380 | sub thawNumber { # Returns list: a number and offset of rest 381 | substr($string, $_[0], 1+max_strlen_l) =~ /^(\d+)\|/ 382 | or confess "Wrong format of frozen string: " . substr($string, $_[0]); 383 | ($1, $_[0] + length($1) + 1); 384 | } 385 | 386 | sub _2rex ($); 387 | if (eval 'ref qr/1/') { 388 | eval 'sub _2rex ($) {my $r = shift; qr/$r/} 1' or die; 389 | } else { 390 | eval 'sub _2rex ($) { shift } 1' or die; 391 | } 392 | 393 | sub thawREx { # Returns list: a REx and offset of rest 394 | substr($string, $_[0], 2+max_strlen_l) =~ m,^/(\d+)\|, 395 | or confess "Wrong format of frozen REx: " . substr($string, $_[0]); 396 | length($string) - $_[0] > length($1) + 1 + $1 397 | or confess "Frozen string too short: `" . 398 | substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1); 399 | (_2rex substr($string, $_[0] + length($1) + 2, $1), 400 | $_[0] + length($1) + 2 + $1); 401 | } 402 | 403 | sub freezeArray { 404 | $string .= '@' . @{$_[0]} . '|'; 405 | for (@{$_[0]}) { 406 | freezeScalar($_); 407 | } 408 | } 409 | 410 | sub thawArray { 411 | substr($string, $_[0], 2+max_strlen_l) =~ /^[\@%](\d+)\|/ # % To make it possible thaw hashes 412 | or confess "Wrong format of frozen array: \n$_[0]"; 413 | my $count = $1; 414 | my $off = $_[0] + 2 + length $count; 415 | my (@res, $res); 416 | while ($count and length $string > $off) { 417 | ($res,$off) = thawScalar($off); 418 | push(@res,$res); 419 | --$count; 420 | } 421 | confess "Wrong length of data in thawing Array: $count left" if $count; 422 | (\@res, $off); 423 | } 424 | 425 | sub freezeHash { 426 | my @arr = sort keys %{$_[0]}; 427 | $string .= '%' . (2*@arr) . '|'; 428 | for (@arr, @{$_[0]}{@arr}) { 429 | freezeScalar($_); 430 | } 431 | } 432 | 433 | sub thawHash { 434 | my ($arr, $rest) = &thawArray; 435 | my %hash; 436 | my $l = @$arr/2; 437 | foreach (0 .. $l - 1) { 438 | $hash{$arr->[$_]} = $arr->[$l + $_]; 439 | } 440 | (\%hash,$rest); 441 | } 442 | 443 | # Second optional argument: ignore the package 444 | # Third optional one: do not check for duplicates on outer level 445 | 446 | sub freezeScalar { 447 | $string .= '_', return unless defined $_[0]; 448 | return &freezeString unless ref $_[0]; 449 | my $ref = ref $_[0]; 450 | my $str; 451 | if ($_[1] and $ref) { # Similar to getref() 452 | if (defined &overload::StrVal) { 453 | $str = overload::StrVal($_[0]); 454 | } else { 455 | $str = "$_[0]"; 456 | } 457 | $ref = $1 if $str =~ /=(\w+)/; 458 | } else { 459 | $str = "$_[0]"; 460 | } 461 | # Die if a) repeated prohibited, b) met, c) not explicitely requested to ingore. 462 | confess "Repeated reference met when prohibited" 463 | if $norepeated && !$_[2] && defined $count{$str}; 464 | if ($secondpass and !$_[2]) { 465 | $string .= "<$address{$str}|", return 466 | if defined $count{$str} and $count{$str} > 1; 467 | } elsif (!$_[2]) { 468 | # $count{$str} is defined if we have seen it on this pass. 469 | $address{$str} = @multiple, push(@multiple, $_[0]) 470 | if defined $count{$str} and not exists $address{$str}; 471 | # This is for debugging and shortening thrown-away output (also 472 | # internal data in arrays and hashes is not duplicated). 473 | $string .= "<$address{$str}|", ++$count{$str}, return 474 | if defined $count{$str}; 475 | ++$count{$str}; 476 | } 477 | return &freezeArray if $ref eq 'ARRAY'; 478 | return &freezeHash if $ref eq 'HASH'; 479 | return &freezeREx if haveIsRex ? re::is_regexp($_[0]) 480 | : ($ref eq 'Regexp' and not defined ${$_[0]}); 481 | $string .= "*", return &freezeString 482 | if $ref eq 'GLOB' and !$safe; 483 | $string .= "&", return &freezeString 484 | if $ref eq 'CODE' and !$safe; 485 | $string .= '\\', return &freezeScalar( $ {shift()} ) 486 | if $ref eq 'REF' or $ref eq 'SCALAR'; 487 | if ($noCache and (($ref eq 'CODE') or $ref eq 'GLOB')) { 488 | confess "CODE and GLOB references prohibited now"; 489 | } 490 | if ($safe and (($ref eq 'CODE') or $ref eq 'GLOB')) { 491 | $unsafe = 1; 492 | $saved{$str} = $_[0] unless defined $saved{$str}; 493 | $string .= "?"; 494 | return &freezeString; 495 | } 496 | $string .= '>'; 497 | local $norepeated = $norepeated; 498 | local $noCache = $noCache; 499 | freezePackage(ref $_[0]); 500 | $_[0]->Freeze($cooky); 501 | } 502 | 503 | sub freezePackage { 504 | my $packageid = $seen_packages{$_[0]}; 505 | if (defined $packageid) { 506 | $string .= ')'; 507 | &freezeNumber( $packageid ); 508 | } else { 509 | $string .= '>'; 510 | &freezeNumber( $seen_packages ); 511 | &freezeScalar( $_[0] ); 512 | $seen_packages{ $_[0] } = $seen_packages++; 513 | } 514 | } 515 | 516 | sub thawPackage { # First argument: offset 517 | my $key = substr($string,$_[0],1); 518 | my ($get, $rest, $id); 519 | ($id, $rest) = &thawNumber($_[0] + 1); 520 | if ($key eq ')') { 521 | $get = $seen_packages{$id}; 522 | } else { 523 | ($get, $rest) = &thawString($rest); 524 | $seen_packages{$id} = $get; 525 | } 526 | ($get, $rest); 527 | } 528 | 529 | # First argument: offset; Optional other: index in the @uninit array 530 | 531 | sub thawScalar { 532 | my $key = substr($string,$_[0],1); 533 | if ($key eq "\$") {&thawString} 534 | elsif ($key eq '@') {&thawArray} 535 | elsif ($key eq '%') {&thawHash} 536 | elsif ($key eq '/') {&thawREx} 537 | elsif ($key eq '\\') { 538 | my ($out,$rest) = &thawScalar( $_[0]+1 ) ; 539 | (\$out,$rest); 540 | } 541 | elsif ($key eq '_') { (undef, $_[0]+1) } 542 | elsif ($key eq '&') {confess "Do not know how to thaw CODE"} 543 | elsif ($key eq '*') {confess "Do not know how to thaw GLOB"} 544 | elsif ($key eq '?') { 545 | my ($address,$rest) = &thawScalar( $_[0]+1 ) ; 546 | confess "The saved data accessed in unprotected thaw" unless $unsafe; 547 | confess "The saved data disappeared somewhere" 548 | unless defined $saved{$address}; 549 | ($saved{$address},$rest); 550 | } elsif ($key eq '<') { 551 | confess "Repeated data prohibited at this moment" unless $uninitOK; 552 | my ($off,$end) = &thawNumber ($_[0]+1); 553 | ($uninit[$off],$end); 554 | } elsif ($key eq '>' or $key eq '{' or $key eq '}') { 555 | my ($package,$rest) = &thawPackage( $_[0]+1 ); 556 | my $cooky = bless \$rest, 'FreezeThaw::TCooky'; 557 | local $uninitOK = $uninitOK; 558 | local $unsafe = $unsafe; 559 | if ($key eq '{') { 560 | my $res = $package->Allocate($cooky); 561 | ($res, $rest); 562 | } elsif ($key eq '}') { 563 | warn "Here it is undef!" unless defined $_[1]; 564 | $package->Instantiate($uninit[$_[1]],$cooky); 565 | (undef, $rest); 566 | } else { 567 | ($package->Thaw($cooky),$rest); 568 | } 569 | } else { 570 | confess "Do not know how to thaw data with code `$key'"; 571 | } 572 | } 573 | 574 | sub freezeEmpty { # Takes a type, freezes ref to empty object 575 | my $e = $Empty{ref $_[0]}; 576 | if (ref $e) { 577 | my $cache = &$e; 578 | freezeScalar $cache; 579 | $cache; 580 | } elsif ($e) { 581 | my $cache = shift; 582 | freezeScalar($cache,1,1); # Atomic 583 | $cache; 584 | } else { 585 | $string .= "{"; 586 | freezePackage ref $_[0]; 587 | $_[0]->FreezeEmpty($cooky); 588 | } 589 | } 590 | 591 | sub freeze { 592 | local @multiple; 593 | local %seen_packages; 594 | local $seen_packages = 0; 595 | local %seen_packages; 596 | # local @seentypes; 597 | local %count; 598 | local %address; 599 | local $string = 'FrT;'; 600 | local $unsafe; 601 | local $noCache; 602 | local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake 603 | local $secondpass; 604 | freezeScalar(\@_); 605 | if (@multiple) { 606 | # Now repeated structures are enumerated with order of *second* time 607 | # they appear in the what we freeze. 608 | # What we want is to have them enumerated with respect to the first time 609 | #### $string = ''; # Start again 610 | #### @multiple = (); 611 | #### %address = (); 612 | #### for (keys %count) { 613 | #### $count{$_} = undef if $count{$_} <= 1; # As at start 614 | #### $count{$_} = 0 if $count{$_}; # As at start 615 | #### } 616 | #### $seen_packages = 0; 617 | #### %seen_packages = (); 618 | #### freezeScalar(\@_); 619 | # Now repeated structures are enumerated with order of first time 620 | # they appear in the what we freeze 621 | #### my $oldstring = substr $string, 4; 622 | $string = 'FrT;!'; # Start again 623 | $seen_packages = 0; 624 | %seen_packages = (); # XXXX We reshuffle parts of the 625 | # string, so the order of packages may 626 | # be wrong... 627 | freezeNumber($#multiple); 628 | { 629 | my @cache; # Force different values for different 630 | # empty objects. 631 | foreach (@multiple) { 632 | push @cache, freezeEmpty $_; 633 | } 634 | } 635 | # for (keys %count) { 636 | # $count{$_} = undef 637 | # if !(defined $count{$_}) or $count{$_} <= 1; # As at start 638 | # } 639 | # $string .= '@' . @multiple . '|'; 640 | $secondpass = 1; 641 | for (@multiple) { 642 | freezeScalar($_,0,1,1), next if $Empty{ref $_}; 643 | $string .= "}"; 644 | freezePackage ref $_; 645 | $_->FreezeInstance($cooky); 646 | } 647 | #### $string .= $oldstring; 648 | freezeScalar(\@_); 649 | } 650 | return "FrT;?\$" . length($lock) . "|" . $lock . substr $string, 4 651 | if $unsafe; 652 | $string; 653 | } 654 | 655 | sub safeFreeze { 656 | local $safe = 1; 657 | &freeze; 658 | } 659 | 660 | sub copyContents { # Given two references, copies contents of the 661 | # second one to the first one, provided they have 662 | # the same basic type. The package is copied too. 663 | my($first,$second) = @_; 664 | my $ref = getref $second; 665 | if ($ref eq 'SCALAR' or $ref eq 'REF') { 666 | $$first = $$second; 667 | } elsif ($ref eq 'ARRAY') { 668 | @$first = @$second; 669 | } elsif ($ref eq 'HASH') { 670 | %$first = %$second; 671 | } elsif (haveIsRex ? re::is_regexp($second) 672 | : ($ref eq 'Regexp' and not defined $$second)) { 673 | $first = qr/$second/; 674 | } else { 675 | croak "Don't know how to copyContents of type `$ref'"; 676 | } 677 | if (ref $second ne ref $first) { # Rebless 678 | # SvAMAGIC() is a property of a reference, not of a referent! 679 | # Thus we cannot use $first here if $second was overloaded... 680 | bless $_[0], ref $second; 681 | } 682 | $first; 683 | } 684 | 685 | sub thaw { 686 | confess "thaw requires one argument" unless @_ ==1; 687 | local $string = shift; 688 | local %seen_packages; 689 | my $initoff = 0; 690 | #print STDERR "Thawing `$string'", substr ($string, 0, 4), "\n"; 691 | if (substr($string, 0, 4) ne 'FrT;') { 692 | warn "Signature not present, continuing anyway" if $^W; 693 | } else { 694 | $initoff = 4; 695 | } 696 | local $unsafe = $initoff + (substr($string, $initoff, 1) eq "?" ? 1 : 0); 697 | if ($unsafe != $initoff) { 698 | my $key; 699 | ($key,$unsafe) = thawScalar($unsafe); 700 | confess "The lock in frozen data does not match the key" 701 | unless $key eq $lock; 702 | } 703 | local @multiple; 704 | local $uninitOK = 1; # The methods can change it. 705 | my $repeated = substr($string,$unsafe,1) eq '!' ? 1 : 0; 706 | my ($res, $off); 707 | if ($repeated) { 708 | ($res, $off) = thawNumber($repeated + $unsafe); 709 | } else { 710 | ($res, $off) = thawScalar($repeated + $unsafe); 711 | } 712 | my $cooky = bless \$off, 'FreezeThaw::TCooky'; 713 | if ($repeated) { 714 | local @uninit; 715 | my $lst = $res; 716 | foreach (0..$lst) { 717 | ($res, $off) = thawScalar($off, $_); 718 | push(@uninit, $res); 719 | } 720 | my @init; 721 | foreach (0..$lst) { 722 | ($res, $off) = thawScalar($off, $_); 723 | push(@init, $res); 724 | } 725 | #($init, $off) = thawScalar($off); 726 | #print "Instantiating...\n"; 727 | #my $ref; 728 | for (0..$#uninit) { 729 | copyContents $uninit[$_], $init[$_] if ref $init[$_]; 730 | } 731 | ($res, $off) = thawScalar($off); 732 | } 733 | croak "Extra elements in frozen structure: `" . substr($string,$off) . "'" 734 | if $off != length $string; 735 | return @$res; 736 | } 737 | 738 | sub cmpStr { 739 | confess "Compare requires two arguments" unless @_ == 2; 740 | freeze(shift) cmp freeze(shift); 741 | } 742 | 743 | sub cmpStrHard { 744 | confess "Compare requires two arguments" unless @_ == 2; 745 | local @multiple; 746 | # local @seentypes; 747 | local %count; 748 | local %address; 749 | local $string = 'FrT;'; 750 | local $unsafe; 751 | local $noCache; 752 | local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake 753 | freezeScalar($_[0]); 754 | my %cnt1 = %count; 755 | freezeScalar($_[1]); 756 | my %cnt2 = %count; 757 | %count = (); 758 | # Now all the caches are filled, delete the entries for guys which 759 | # are in one argument only. 760 | my ($elt, $val); 761 | while (($elt, $val) = each %cnt1) { 762 | $count{$elt}++ if $cnt2{$elt} > $cnt1{$elt}; 763 | } 764 | $string = ''; 765 | freezeScalar($_[0]); 766 | my $str1 = $string; 767 | $string = ''; 768 | freezeScalar($_[1]); 769 | $str1 cmp $string; 770 | } 771 | 772 | # local $string = freeze(shift,shift); 773 | # local $uninitOK = 1; 774 | # #print "$string\n"; 775 | # my $off = 7; # Hardwired offset after @2| 776 | # if (substr($string,4,1) eq '!') { 777 | # $off = 5; # Hardwired offset after ! 778 | # my ($uninit, $len); 779 | # ($len,$off) = thawScalar $off; 780 | # local @uninit; 781 | # foreach (0..$len) { 782 | # ($uninit,$off) = thawScalar $off, $_; 783 | # } 784 | # $off += 3; # Hardwired offset after @2| 785 | # } 786 | # croak "Unknown format of frozen array: " . substr($string,$off-3) 787 | # unless substr($string,$off-3,1) eq '@'; 788 | # my ($first,$off2) = thawScalar $off; 789 | # my $off3; 790 | # ($first,$off3) = thawScalar $off2; 791 | # substr($string, $off, $off2-$off) cmp substr($string,$off2,$off3-$off2); 792 | # } 793 | 794 | sub FreezeThaw::FCooky::FreezeScalar { 795 | shift; 796 | &freezeScalar; 797 | } 798 | 799 | sub FreezeThaw::FCooky::isSafe { 800 | $safe || $noCache; 801 | } 802 | 803 | sub FreezeThaw::FCooky::makeSafe { 804 | $noCache = 1; 805 | } 806 | 807 | sub FreezeThaw::FCooky::repeatedOK { 808 | !$norepeated; 809 | } 810 | 811 | sub FreezeThaw::FCooky::noRepeated { 812 | $norepeated = 1; 813 | } 814 | 815 | sub FreezeThaw::TCooky::repeatedOK { 816 | $uninitOK; 817 | } 818 | 819 | sub FreezeThaw::TCooky::noRepeated { 820 | undef $uninitOK; 821 | } 822 | 823 | sub FreezeThaw::TCooky::isSafe { 824 | !$unsafe; 825 | } 826 | 827 | sub FreezeThaw::TCooky::makeSafe { 828 | undef $unsafe; 829 | } 830 | 831 | sub FreezeThaw::TCooky::ThawScalar { 832 | my $self = shift; 833 | my ($res,$off) = &thawScalar($$self); 834 | $$self = $off; 835 | $res; 836 | } 837 | 838 | sub UNIVERSAL::Freeze { 839 | my ($obj, $cooky) = (shift, shift); 840 | $cooky->FreezeScalar($obj,1,1); 841 | } 842 | 843 | sub UNIVERSAL::Thaw { 844 | my ($package, $cooky) = (shift, shift); 845 | my $obj = $cooky->ThawScalar; 846 | bless $obj, $package; 847 | } 848 | 849 | sub UNIVERSAL::FreezeInstance { 850 | my($obj,$cooky) = @_; 851 | return if !RexIsREGEXP # Special-case non-1st-class RExes 852 | and ref $obj and (haveIsRex ? re::is_regexp($obj) 853 | : (ref $obj eq 'Regexp' and not defined $$obj)); # Regexp 854 | $obj->Freeze($cooky); 855 | } 856 | 857 | sub UNIVERSAL::Instantiate { 858 | my($package,$pre,$cooky) = @_; 859 | return if !RexIsREGEXP and $package eq 'Regexp'; 860 | my $obj = $package->Thaw($cooky); 861 | # SvAMAGIC() is a property of a reference, not of a referent! 862 | # Thus we cannot use $pre here if $obj was overloaded... 863 | copyContents $_[1], $obj; 864 | } 865 | 866 | sub UNIVERSAL::Allocate { 867 | my($package,$cooky) = @_; 868 | $cooky->ThawScalar; 869 | } 870 | 871 | sub UNIVERSAL::FreezeEmpty { 872 | my $obj = shift; 873 | my $type = getref $obj; 874 | my $e = $Empty{$type}; 875 | if (ref $e) { 876 | my $ref = &$e; 877 | freezeScalar $ref; 878 | $ref; # Put into cache. 879 | } elsif ($e) { 880 | freezeScalar($obj,1,1); # Atomic 881 | undef; 882 | } elsif (!RexIsREGEXP and defined $e and not defined $$obj) { # REx pre-5.11 883 | freezeREx($obj); 884 | undef; 885 | } else { 886 | die "Do not know how to FreezeEmpty $type"; 887 | } 888 | } 889 | 890 | 1; 891 | -------------------------------------------------------------------------------- /flac2mp3.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # $Id$ 4 | # 5 | # Converts a directory full of flac files into a corresponding 6 | # directory of mp3 files 7 | # 8 | # Robin Bowes <robin@robinbowes.com> 9 | # 10 | # Release History: 11 | # - See changelog.txt 12 | 13 | use warnings; 14 | use strict; 15 | use Carp; 16 | 17 | use FindBin; 18 | use lib "$FindBin::RealBin/lib"; 19 | 20 | use version; our $VERSION = qv("v1.0.0"); 21 | 22 | use Audio::FLAC::Header; 23 | use Data::Dumper; 24 | use Encode; 25 | use File::Basename; 26 | use File::Copy; 27 | use File::Find::Rule; 28 | use File::Path; 29 | use File::Spec; 30 | use File::Temp qw/ cleanup /; 31 | use File::Which; 32 | use Getopt::Long; 33 | use MP3::Tag; 34 | use Parallel::ForkManager; 35 | use Scalar::Util qw/ looks_like_number /; 36 | use FreezeThaw qw/ cmpStr /; 37 | use Digest::MD5; 38 | 39 | # ------- User-config options start here -------- 40 | # Assume flac and lame programs are in the path. 41 | # If not, put full path to programs here. 42 | # 43 | # On Windows: 44 | # * If you specify a path, you must include the ".exe" extension 45 | # * Long filenames are OK, e.g. c:/Program Files/flac/flac.exe 46 | # * You can use "/" or "\\" or even "\" as path separator, e.g.: 47 | # c:\windows\system32\flac.exe 48 | # or 49 | # c:/windows/system32/flac.exe 50 | # or 51 | # c:\\windows\\system32\\flac.exe 52 | my $flaccmd = 'flac'; 53 | my $lamecmd = 'lame'; 54 | 55 | # Modify presets if required 56 | my %presets = ( 57 | 'V2' => [ 58 | '--noreplaygain', 59 | '--vbr-new', 60 | '-V 2', 61 | '-h', 62 | '--nohist', 63 | '--quiet' 64 | ], 65 | 'V0' => [ 66 | '--noreplaygain', 67 | '--vbr-new', 68 | '-V 0', 69 | '-h', 70 | '--nohist', 71 | '--quiet' 72 | ], 73 | '320' => [ 74 | '--noreplaygain', 75 | '-b 320', 76 | '-h', 77 | '--nohist', 78 | '--quiet' 79 | ], 80 | ); 81 | 82 | # Use V2 preset by default 83 | my $PRESET_DEFAULT = 'V2'; 84 | 85 | # Use one process by default 86 | my $NUM_PROCESSES_DEFAULT = 1; 87 | 88 | # -------- User-config options end here --------- 89 | 90 | my @lameargs = @{$presets{$PRESET_DEFAULT}}; 91 | 92 | # use Id3 v2.3.0 tag separator by default 93 | my $TAG_SEPARATOR_DEFAULT = '/'; 94 | 95 | my @flacargs = qw ( 96 | --decode 97 | --stdout 98 | --silent 99 | ); 100 | 101 | # hash mapping FLAC tag names to MP3 frames 102 | my %MP3frames = ( 103 | 'ALBUM' => 'TALB', 104 | 'ALBUMARTIST' => 'TPE2', 105 | 'ARTIST' => 'TPE1', 106 | 'BAND' => 'TPE2', 107 | 'BPM' => 'TBPM', 108 | 'COMMENT' => 'COMM', 109 | 'COMPILATION' => 'TCMP', 110 | 'COMPOSER' => 'TCOM', 111 | 'CONDUCTOR' => 'TPE3', 112 | 'DATE' => 'TYER', 113 | 'DISCNUMBER' => 'TPOS', 114 | 'GENRE' => 'TCON', 115 | 'ISRC' => 'TSRC', 116 | 'LYRICIST' => 'TEXT', 117 | 'PUBLISHER' => 'TPUB', 118 | 'TITLE' => 'TIT2', 119 | 'TRACKNUMBER' => 'TRCK', 120 | 'MUSICBRAINZ_ALBUMID' => 'TXXX', 121 | 'MUSICBRAINZ_ALBUMSTATUS' => 'TXXX', 122 | 'MUSICBRAINZ_ALBUMTYPE' => 'TXXX', 123 | 'MUSICBRAINZ_ARTISTID' => 'TXXX', 124 | 'MUSICBRAINZ_SORTNAME' => 'TXXX', 125 | 'MUSICBRAINZ_TRACKID' => 'UFID', 126 | 'MUSICBRAINZ_TRMID' => 'TXXX', 127 | 'MD5' => 'TXXX', 128 | 'PIC' => 'APIC', 129 | 130 | 'REPLAYGAIN_TRACK_PEAK' => 'TXXX', 131 | 'REPLAYGAIN_TRACK_GAIN' => 'TXXX', 132 | 'REPLAYGAIN_ALBUM_PEAK' => 'TXXX', 133 | 'REPLAYGAIN_ALBUM_GAIN' => 'TXXX', 134 | ); 135 | 136 | my %MP3frametexts = ( 137 | 'COMMENT' => '', 138 | 'MD5' => 'MD5', 139 | 'MUSICBRAINZ_ALBUMARTISTID' => 'MusicBrainz Album Artist Id', 140 | 'MUSICBRAINZ_ALBUMID' => 'MusicBrainz Album Id', 141 | 'MUSICBRAINZ_ALBUMSTATUS' => 'MusicBrainz Album Status', 142 | 'MUSICBRAINZ_ALBUMTYPE' => 'MusicBrainz Album Type', 143 | 'MUSICBRAINZ_ARTISTID' => 'MusicBrainz Artist Id', 144 | 'MUSICBRAINZ_SORTNAME' => 'MusicBrainz Sortname', 145 | 'MUSICBRAINZ_TRACKID' => 'MusicBrainz Trackid', 146 | 'MUSICBRAINZ_TRMID' => 'MusicBrainz TRM Id', 147 | 'REPLAYGAIN_TRACK_PEAK' => 'REPLAYGAIN_TRACK_PEAK', 148 | 'REPLAYGAIN_TRACK_GAIN' => 'REPLAYGAIN_TRACK_GAIN', 149 | 'REPLAYGAIN_ALBUM_PEAK' => 'REPLAYGAIN_ALBUM_PEAK', 150 | 'REPLAYGAIN_ALBUM_GAIN' => 'REPLAYGAIN_ALBUM_GAIN', 151 | ); 152 | 153 | # Hash telling us which key to use if a complex frame hash is encountered 154 | # For example, the COMM frame is complex and returns a hash with the 155 | # following keys (with example values): 156 | # 'Language' => 'ENG' 157 | # 'Description' => 'Short Text' 158 | # 'Text' => 'This is the actual comment field' 159 | # 160 | # In this case, we want to use the "Description" to check if this is the 161 | # correct frame. 162 | # We always grab the "Text" for the frame data. 163 | my %Complex_Frame_Keys = 164 | ( 'COMM' => 'Description', 'TXXX' => 'Description', 'UFID' => '_Data' ); 165 | 166 | # Catch interupts (SIGINT) 167 | $SIG{INT} = \&INT_Handler; 168 | 169 | # Set default options 170 | my %Options = ( 171 | skipfilename => 'flac2mp3.ignore', 172 | skipfile => 1, 173 | processes => $NUM_PROCESSES_DEFAULT, 174 | tagseparator => $TAG_SEPARATOR_DEFAULT 175 | ); 176 | 177 | GetOptions( 178 | \%Options, "quiet!", "tagdiff", "debug!", 179 | "tagsonly!", "force!", "usage", "help", 180 | "version", "pretend", "skipfile!", "skipfilename=s", 181 | "processes=i", "tagseparator=s", "preset=s", "lameargs=s", 182 | "copyfiles" 183 | ); 184 | 185 | # info flag is the inverse of --quiet 186 | $Options{info} = !$Options{quiet}; 187 | 188 | # Turn off output buffering (makes debugging easier) 189 | $| = 1; 190 | 191 | my ( $source_root, $target_root ) = @ARGV; 192 | 193 | showversion() if ( $Options{version} ); 194 | showusage() 195 | if ( !defined $source_root 196 | or !defined $target_root 197 | or $Options{processes} < 1 198 | or $Options{usage} 199 | or $Options{help} ); 200 | 201 | croak "--lameargs and --preset are mutually exclusive options" 202 | if $Options{lameargs} && $Options{preset}; 203 | 204 | croak "Chosen preset does not exist" 205 | if $Options{preset} && !defined $presets{$Options{preset}}; 206 | 207 | @lameargs = @{$presets{$Options{preset}}} 208 | if $Options{preset}; 209 | 210 | @lameargs = $Options{lameargs} 211 | if $Options{lameargs}; 212 | 213 | my $pretendString = ''; 214 | $pretendString = '** Pretending ** ' 215 | if $Options{pretend}; 216 | 217 | # Check flac and lame are found 218 | # First see if the specified command is executable. 219 | # If not, look in path 220 | foreach my $cmd ( $flaccmd, $lamecmd ) { 221 | my $cmdpath; 222 | if ( -x $cmd ) { 223 | $cmdpath = $cmd; 224 | } 225 | else { 226 | $cmdpath = which($cmd); 227 | } 228 | croak "$cmd not found" unless $cmdpath; 229 | $Options{info} && msg("Using $cmd from: $cmdpath"); 230 | } 231 | 232 | # Convert directories to absolute paths 233 | $source_root = File::Spec->rel2abs($source_root); 234 | $target_root = File::Spec->rel2abs($target_root); 235 | 236 | die "Source directory not found: $source_root\n" 237 | unless -d $source_root; 238 | 239 | # count all flac files in source_dir 240 | # Display a progress report after each file, e.g. Processed 367/4394 files 241 | # Possibly do some timing and add a Estimated Time Remaining 242 | # Will need to only count files that are going to be processed. 243 | # Hmmm could get complicated. 244 | 245 | $Options{info} 246 | && msg( $pretendString . "Processing directory: $source_root" ); 247 | 248 | # Now look for files in the source dir 249 | # (following symlinks) 250 | 251 | my @flac_files = @{ find_files( $source_root, qr/\.flac$/i ) }; 252 | 253 | # Get directories from target_dir and put in an array 254 | my ( $target_root_volume, $target_root_path, $target_root_file ) = 255 | File::Spec->splitpath( $target_root, 1 ); 256 | my @target_root_elements = File::Spec->splitdir($target_root_path); 257 | 258 | # use parallel processing to launch multiple transcoding processes 259 | msg("Using $Options{processes} transcoding processes.\n"); 260 | my $pm = new Parallel::ForkManager( $Options{processes} ); 261 | foreach my $src_file (@flac_files) { 262 | $pm->start and next; # Forks and returns the pid for the child 263 | path_and_conversion($src_file); 264 | $pm->finish; # Terminates the child process 265 | } 266 | $pm->wait_all_children; 267 | 268 | if ( $Options{copyfiles} ) { 269 | my @non_flac_files = 270 | sort File::Find::Rule->file()->extras( { follow => 1 } ) 271 | ->not_name(qr/\.flac$/i)->in($source_root); 272 | my $non_flac_file_count = scalar @non_flac_files; 273 | $Options{info} 274 | && msg( "Found $non_flac_file_count non-flac file" 275 | . ( $non_flac_file_count != 1 ? 's' : '' . "\n" ) ); 276 | 277 | # Copy non-flac files from source to dest directories 278 | my $t0 = time; 279 | my $cntr_all = 0; 280 | my $cntr_copied = 0; 281 | foreach my $src_file (@non_flac_files) { 282 | my ( $dst_dir, $dst_file ) = get_dest_file_path_non_flac($src_file); 283 | 284 | # Flag which determines if file should be copied: 285 | my $do_copy = 1; 286 | 287 | # Don't copy file if it already exists in dest directory and 288 | # has identical md5 to the source file 289 | if ( -e $dst_file ) { 290 | my $src_md5 = get_md5_of_non_flac_file($src_file); 291 | my $dst_md5 = get_md5_of_non_flac_file($dst_file); 292 | if ( $src_md5 eq $dst_md5 ) { 293 | $do_copy = 0; # Don't copy if equal md5 294 | } 295 | } 296 | else { 297 | # Create the destination directory if it 298 | # doesn't already exist 299 | mkpath($dst_dir) 300 | or die "Can't create directory $dst_dir\n" 301 | unless -d $dst_dir; 302 | } 303 | if ($do_copy) { 304 | unless ( $Options{pretend} ) { 305 | copy( $src_file, $dst_file ) 306 | || die("Can't copy this FILE: $src_file !"); 307 | } 308 | $cntr_copied++; 309 | } 310 | $cntr_all++; 311 | 312 | # Show the progress every second 313 | if ( ( ( time - $t0 ) >= 1 ) || ( $cntr_all == $non_flac_file_count ) ) { 314 | $t0 = time; 315 | print("\r" 316 | . $pretendString 317 | . $cntr_copied 318 | . " non-flac files of " 319 | . $cntr_all 320 | . " were copied to dest directories." ); 321 | } 322 | } 323 | msg("\n"); # double line feed 324 | } 325 | 326 | sub get_dest_file_path_non_flac { 327 | my $source = shift; 328 | 329 | # remove $source_dir from front of $src_file 330 | my $target = $source; 331 | $target =~ s{\Q$source_root/\E}{}xms; 332 | 333 | # Get directories in target and put in an array 334 | # Note: the filename is the source file name 335 | my ( $target_volume, $target_path, $source_file ) = 336 | File::Spec->splitpath($target); 337 | my @target_path_elements = File::Spec->splitdir($target_path); 338 | 339 | # Add the dst_dirs to the dst root and join back together 340 | $target_path = 341 | File::Spec->catdir( @target_root_elements, @target_path_elements ); 342 | 343 | # Now join it all together to get the complete path of the dest_file 344 | $target = 345 | File::Spec->catpath( $target_root_volume, $target_path, $source_file ); 346 | my $target_dir = 347 | File::Spec->catpath( $target_root_volume, $target_path, '' ); 348 | 349 | return $target_dir, $target; 350 | } 351 | 352 | sub get_md5_of_non_flac_file { 353 | my $file = shift; 354 | open( FILE, $file ) or die "Can't open '$file': $!"; 355 | binmode(FILE); 356 | my $md5_code = Digest::MD5->new->addfile(*FILE)->hexdigest; 357 | close FILE; 358 | return $md5_code; 359 | } 360 | 361 | # use parallel processing to launch multiple transcoding processes 362 | sub path_and_conversion { 363 | my $source = shift; 364 | 365 | # remove $source_dir from front of $src_file 366 | my $target = $source; 367 | $target =~ s{\Q$source_root/\E}{}xms; 368 | 369 | # Get directories in target and put in an array 370 | # Note: the filename is the source file name 371 | my ( $target_volume, $target_path, $source_file ) = 372 | File::Spec->splitpath($target); 373 | my @target_path_elements = File::Spec->splitdir($target_path); 374 | 375 | # Add the dst_dirs to the dst root and join back together 376 | $target_path = 377 | File::Spec->catdir( @target_root_elements, @target_path_elements ); 378 | 379 | # Add volume for OSes that require it (MSWin etc.) 380 | $target_path = File::Spec->catpath( $target_root_volume, $target_path, '' ); 381 | 382 | # Get the basename of the dst file 383 | my ( $target_base, $target_dir, $source_ext ) = 384 | fileparse( $source_file, qr{\Q.flac\E$}xmsi ); 385 | 386 | # Now join it all together to get the complete path of the dest_file 387 | $target = File::Spec->catpath( $target_volume, $target_path, 388 | $target_base . '.mp3' ); 389 | 390 | convert_file( $source, $target ); 391 | } 392 | 393 | 1; 394 | 395 | sub find_files { 396 | my $path = shift; 397 | my $regex = shift; 398 | 399 | my @found_files; 400 | 401 | my $rule = File::Find::Rule->extras( { follow => 1 } ); 402 | if ( $Options{skipfile} ) { 403 | @found_files = sort $rule->any( 404 | $rule->new->directory->exec( 405 | sub { 406 | my ( $fname, $fpath, $frpath ) = @_; 407 | -f File::Spec->catdir( $frpath, $Options{skipfilename} ); 408 | } 409 | )->prune->discard, 410 | $rule->new->file->name($regex) 411 | )->in($path); 412 | } 413 | else { 414 | @found_files = sort $rule->in($path); 415 | } 416 | 417 | $Options{debug} && msg( Dumper(@found_files) ); 418 | 419 | if ( $Options{info} ) { 420 | my $file_count = scalar @found_files; 421 | msg( 422 | "Found $file_count flac file" . ( $file_count > 1 ? 's' : '' . "\n" ) ); 423 | } 424 | 425 | return \@found_files; 426 | } 427 | 428 | sub showusage { 429 | print <<"EOT"; 430 | Usage: $0 <options> <flacdir> <mp3dir> 431 | 432 | Options: 433 | --pretend Don't actually do anything 434 | --quiet Disable informational output to stdout 435 | --debug Enable debugging output. For developers only! 436 | --tagsonly Don't do any transcoding - just update tags 437 | --force Force transcoding and tag update even if not required 438 | --tagdiff Print source/dest tag values if different 439 | --preset='s' Select a popular parameter set for the LAME encoder 440 | Valid: "V0", "V2", "320" 441 | Default: "V2" 442 | --lameargs='s' specify parameter(string) to be passed to the LAME Encoder 443 | Default: "--noreplaygain --vbr-new -V 2 -h --nohist --quiet" 444 | --noskipfile Ignore any skip files 445 | --skipfilename Specify the name of the skip file. 446 | Default: flac2mp3.ignore 447 | --processes=n Launch n parallel transcoding processes (does not work on Windows platform) 448 | Use with multi-core CPUs. 449 | Default: 1 450 | --tagseparator=s Use "s" as the separator to join multiple instances of the 451 | same tag. 452 | Default: "/" 453 | --copyfiles Copy non-flac files to dest directories 454 | EOT 455 | exit 0; 456 | } 457 | 458 | sub showversion{ 459 | msg($VERSION); 460 | exit 0; 461 | } 462 | 463 | sub msg { 464 | my $msg = shift; 465 | print "$msg\n"; 466 | } 467 | 468 | sub convert_file { 469 | my ( $source, $target ) = @_; 470 | 471 | $Options{debug} && msg("source: '$source'"); 472 | $Options{debug} && msg("target: '$target'"); 473 | 474 | # get tags from flac file 475 | my $source_tags = read_flac_tags($source); 476 | 477 | # hash to hold tags that will be updated 478 | my $tags_to_update = preprocess_flac_tags($source_tags); 479 | 480 | # Initialise file processing flags 481 | my $pflags = examine_destfile_tags( $target, $tags_to_update ); 482 | 483 | # Transcode the file based on the processing flags 484 | transcode_file( $source, $target, $pflags ); 485 | 486 | # Write the tags based on the processing flags 487 | write_tags( $target, $tags_to_update, $pflags ); 488 | } 489 | 490 | sub read_flac_tags { 491 | my $source = shift; 492 | 493 | # create object to access flac tags 494 | my $source_header = Audio::FLAC::Header->new($source); 495 | 496 | # get tags from flac file 497 | my $source_tags = $source_header->tags(); 498 | 499 | # convert all tagnames to upper case 500 | %$source_tags = map { uc $_ => $source_tags->{$_} } keys %$source_tags; 501 | $Options{debug} && msg "Tags from source file:\n" . Dumper $source_tags; 502 | 503 | # get MD5 checksdum from flac file and add to srcframes hash 504 | $source_tags->{'MD5'} = $source_header->info('MD5CHECKSUM'); 505 | 506 | # if present, add album art to srcframes hash: 507 | # get picture data from flac file and 508 | # proceed if a picture metadata block is found (i.e. a valid ref was returned) 509 | if ( ref( my $allsrcpictures = $source_header->picture('all') ) ) { 510 | $source_tags->{'PIC'} = $allsrcpictures; 511 | } 512 | 513 | return $source_tags; 514 | } 515 | 516 | sub preprocess_flac_tags { 517 | my $source_tags = shift; 518 | my %tags_to_update; 519 | 520 | # weed out tags not valid in destfile 521 | foreach my $frame ( keys %$source_tags ) { 522 | if ( $MP3frames{$frame} ) { 523 | 524 | # Multiple comments with the same name are returned as an array 525 | # Check for that here and convert the array to a null-separated 526 | # list to be compatible with mp3 tags 527 | my $src_tag_type = ref( $source_tags->{$frame} ); 528 | 529 | # Check for normal string 530 | if ( !$src_tag_type ) { 531 | $tags_to_update{$frame} = fixUpFrame( $source_tags->{$frame} ); 532 | } 533 | else { 534 | if ( $frame eq 'PIC' ) { 535 | foreach my $pic ( @{ $source_tags->{'PIC'} } ) { 536 | $$pic{'description'} = fixUpFrame( $$pic{'description'} ) 537 | ; # convert from UTF-8 to latin1 538 | } 539 | $tags_to_update{$frame} = $source_tags->{$frame}; 540 | } 541 | elsif ( $src_tag_type eq 'ARRAY' ) { 542 | 543 | # Fixup each value individually 544 | map { $_ = fixUpFrame($_) } @{ $source_tags->{$frame} }; 545 | 546 | # join all values, separated by the tagseparator string 547 | $tags_to_update{$frame} = 548 | join( $Options{tagseparator}, @{ $source_tags->{$frame} } ); 549 | } 550 | else { 551 | carp "Unexpected source frame data type returned"; 552 | } 553 | } 554 | } 555 | } 556 | 557 | # Fix up TRACKNUMBER 558 | if ( $tags_to_update{'TRACKNUMBER'} ) { 559 | my $fixeduptracknumber = 560 | fixUpTrackNumber( $tags_to_update{'TRACKNUMBER'} ); 561 | if ( $fixeduptracknumber ne $tags_to_update{'TRACKNUMBER'} ) { 562 | $tags_to_update{'TRACKNUMBER'} = $fixeduptracknumber; 563 | } 564 | } 565 | 566 | if ( $Options{debug} ) { 567 | msg("Tags we know how to deal with from source file:"); 568 | msg( Dumper \%tags_to_update ); 569 | 570 | } 571 | 572 | return \%tags_to_update; 573 | } 574 | 575 | sub examine_destfile_tags { 576 | my $destfilename = shift; 577 | my $frames_ref = shift; 578 | my %frames_to_update = %$frames_ref; # this is only to minimize changes 579 | 580 | # Initialise file processing flags 581 | my %pflags = ( 582 | exists => 0, # assume file doesn't exist 583 | md5 => 1, # and the md5 checksum doesn't match 584 | tags => 0, # and the tags match (this will be set if tags 585 | # don't match 586 | ); 587 | 588 | # if destfile already exists 589 | if ( -e $destfilename ) { 590 | 591 | $pflags{exists} = 1; 592 | $Options{debug} && msg("destfile exists: '$destfilename'"); 593 | 594 | # General approach: 595 | # Transcode the file if destfile md5 tag is different than the srcfile md5 596 | # Update the tags if tags are different 597 | 598 | # Get tags from dst file and compare 599 | $Options{debug} && msg("Comparing tags"); 600 | 601 | # Compare tags; build hash of changed tags; 602 | 603 | my $mp3 = MP3::Tag->new($destfilename); 604 | my @tags = $mp3->get_tags; 605 | $Options{debug} && msg( Dumper @tags ); 606 | my $ID3v2 = $mp3->{"ID3v2"}; 607 | 608 | # If an ID3v2 tag is found 609 | if ( defined $ID3v2 ) { 610 | 611 | $Options{debug} && msg("ID3v2 tag found"); 612 | 613 | # loop over all valid destfile frames 614 | foreach my $frame ( keys %MP3frames ) { 615 | 616 | $Options{debug} && msg("frame is '$frame'"); 617 | 618 | # To do: Check the frame is valid 619 | # Specifically, make sure the GENRE is one of the standard ID3 tags 620 | my $method = $MP3frames{$frame}; 621 | 622 | $Options{debug} && msg("method is '$method'"); 623 | 624 | # Check for tag in destfile 625 | # 'intact' option makes sure that any embedded '\0' are not mangled 626 | # This is needed now we can handle multiple tags of the same type 627 | my ( $tagname, @info ) = $ID3v2->get_frames( $method, 'intact' ); 628 | 629 | $Options{debug} 630 | && msg( "values from id3v2 tags:\n" . Dumper \$tagname, \@info ); 631 | 632 | # Compare album art 633 | if ( $frame eq 'PIC' ) { 634 | $pflags{tags} = 635 | compare_src_dest_picture_data( $frames_to_update{'PIC'}, 636 | \@info, $destfilename ); 637 | next; # don't do any more processing on the picture frame 638 | } 639 | 640 | my $dest_text = ''; 641 | 642 | # check for complex frame (e.g. Comments) 643 | TAGLOOP: 644 | foreach my $tag_info (@info) { 645 | if ( ref($tag_info) ) { 646 | my $cfname = 647 | $MP3frametexts{$frame} || ''; # we may not know $frame 648 | my $cfkey = $Complex_Frame_Keys{$method}; 649 | 650 | if ( $$tag_info{$cfkey} eq $cfname ) { 651 | $dest_text = $$tag_info{'Text'}; 652 | if ( $frame eq 'MD5' ) { 653 | $pflags{md5} = ( $frames_to_update{'MD5'} ne $dest_text ); 654 | 655 | if ( $Options{debug} ) { 656 | msg( "\$pflags{md5} is " 657 | . ( $pflags{md5} ? 'set' : 'not set' ) ); 658 | 659 | } 660 | } 661 | last TAGLOOP; 662 | } 663 | } 664 | else { 665 | $dest_text = $tag_info; 666 | } 667 | } 668 | 669 | $Options{debug} 670 | && msg( "\$dest_text: " . Dumper $dest_text ); 671 | 672 | # Fix up TRACKNUMBER 673 | if ( $frame eq 'TRACKNUMBER' ) { 674 | my $fixeduptracknumber = fixUpTrackNumber($dest_text); 675 | if ( $fixeduptracknumber ne $dest_text ) { 676 | $dest_text = $fixeduptracknumber; 677 | } 678 | } 679 | 680 | # get tag from srcfile 681 | my $srcframe = $frames_to_update{$frame}; 682 | $srcframe = '' if ( !defined $srcframe ); 683 | 684 | # Strip trailing spaces from src frame value 685 | # $srcframe =~ s/ *$//; 686 | 687 | # If set the flag if any frame is different 688 | if ( $dest_text ne $srcframe ) { 689 | $pflags{tags} = 1; 690 | if ( $Options{tagdiff} ) { 691 | msg("frame: '$frame'"); 692 | msg("srcframe value: '$srcframe'"); 693 | msg("destframe value: '$dest_text'"); 694 | } 695 | 696 | } 697 | } 698 | } 699 | else { 700 | 701 | # no ID2V2 object found so set the flag so the tags get written 702 | $pflags{tags} = 1; 703 | } 704 | } 705 | 706 | if ( $Options{debug} ) { 707 | msg("pf_exists: $pflags{exists}"); 708 | msg("pf_tags: $pflags{tags}"); 709 | msg("pf_md5: $pflags{md5}\n"); 710 | } 711 | 712 | if ( $Options{debug} ) { 713 | msg("Tags to be written if tags need updating\n"); 714 | msg( Dumper \%frames_to_update ); 715 | } 716 | 717 | return \%pflags; 718 | } 719 | 720 | sub transcode_file { 721 | my $source = shift; 722 | my $target = shift; 723 | my $pflags_ref = shift; 724 | my %pflags = %$pflags_ref; # this is only to minimize changes 725 | 726 | my ( $target_volume, $target_dir, $target_filename ) = 727 | File::Spec->splitpath($target); 728 | my $dst_dir = File::Spec->catpath( $target_volume, $target_dir, '' ); 729 | 730 | if ( ( !$pflags{exists} || $pflags{md5} || $Options{force} ) 731 | && !$Options{tagsonly} ) 732 | { 733 | 734 | # Transcode to a temp file in the destdir. 735 | # Rename the file if the conversion completes sucessfully 736 | # This avoids leaving incomplete files in the destdir 737 | # If we're "pretending", don't create a File::Temp object 738 | my $tmpfilename; 739 | my $tmpfh; 740 | if ( $Options{pretend} ) { 741 | $tmpfilename = $target; 742 | } 743 | else { 744 | 745 | # Create the destination directory if it 746 | # doesn't already exist 747 | unless ( -d $dst_dir ) { 748 | 749 | # If necessary, allow a second check. Don't die just because the 750 | # dir was created by another child (race condition): 751 | mkpath($dst_dir) 752 | or ( -d $dst_dir ) 753 | or die "Can't create directory $dst_dir\n"; 754 | } 755 | $tmpfh = new File::Temp( 756 | UNLINK => 1, 757 | DIR => $dst_dir, 758 | SUFFIX => '.tmp' 759 | ); 760 | $tmpfilename = $tmpfh->filename; 761 | } 762 | $Options{info} 763 | && msg( $pretendString . "Transcoding \"$source\"" ); 764 | 765 | my $convert_command = 766 | "\"$flaccmd\" @flacargs " 767 | . quotemeta($source) 768 | . "| \"$lamecmd\" @lameargs - " 769 | . quotemeta($tmpfilename); 770 | 771 | $Options{debug} && msg("transcode: $convert_command"); 772 | 773 | # Convert the file (unless we're pretending} 774 | my $exit_value; 775 | if ( !$Options{pretend} ) { 776 | $exit_value = system($convert_command); 777 | } 778 | else { 779 | $exit_value = 0; 780 | } 781 | 782 | $Options{debug} 783 | && msg("Exit value from convert command: $exit_value"); 784 | 785 | if ($exit_value) { 786 | msg("$convert_command failed with exit code $exit_value"); 787 | 788 | # delete the destfile if it exists 789 | unlink $tmpfilename; 790 | 791 | # should check exit status of this command 792 | 793 | exit($exit_value); 794 | } 795 | 796 | if ( !$Options{pretend} ) { 797 | 798 | # If we get here, assume the conversion has succeeded 799 | $tmpfh->unlink_on_destroy(0); 800 | $tmpfh->close; 801 | croak "Failed to rename '$tmpfilename' to '$target' $!" 802 | unless rename( $tmpfilename, $target ); 803 | 804 | # the destfile now exists! 805 | $pflags{exists} = 1; 806 | 807 | # and the tags need writing 808 | $pflags{tags} = 1; 809 | } 810 | } 811 | 812 | if ( $Options{debug} ) { 813 | msg("pf_exists: $pflags{exists}"); 814 | msg("pf_tags: $pflags{tags}"); 815 | msg( 816 | "\$Options{pretend}: " . ( $Options{pretend} ? 'set' : 'not set' ) ); 817 | } 818 | 819 | %$pflags_ref = %pflags; # this is only to minimize changes 820 | } 821 | 822 | sub write_tags { 823 | my $destfilename = shift; 824 | my $frames_ref = shift; 825 | my $pflags_ref = shift; 826 | my %frames_to_update = %$frames_ref; # this is only to minimize changes 827 | my %pflags = %$pflags_ref; # this is only to minimize changes 828 | 829 | # Write the tags 830 | if ( 831 | $pflags{exists} 832 | && ( $pflags{tags} 833 | || $Options{force} ) 834 | ) 835 | { 836 | 837 | $Options{info} 838 | && msg( $pretendString . "Writing tags to \"$destfilename\"" ); 839 | 840 | if ( !$Options{pretend} ) { 841 | my $mp3 = MP3::Tag->new($destfilename); 842 | 843 | # Remove any existing tags 844 | $mp3->{ID3v2}->remove_tag if exists $mp3->{ID3v2}; 845 | 846 | # Create a new tag 847 | $mp3->new_tag("ID3v2"); 848 | 849 | foreach my $frame ( keys %frames_to_update ) { 850 | 851 | $Options{debug} 852 | && msg("changedframe is '$frame'"); 853 | 854 | # To do: Check the frame is valid 855 | # Specifically, make sure the GENRE is one of the standard ID3 tags 856 | my $method = $MP3frames{$frame}; 857 | 858 | $Options{debug} && msg("method is $method"); 859 | 860 | if ( $method eq "APIC" ) { 861 | 862 | # Add the source picture data to APIC frames in the dest file 863 | $mp3 = picsToAPICframes( $mp3, $frames_to_update{$frame} ); 864 | next; # avoid more processing of this complex tag, jump to next 865 | } 866 | 867 | my $framestring = $frames_to_update{$frame}; 868 | 869 | # Only add the frame if framestring is not empty 870 | if ( $framestring ne '' ) { 871 | $Options{debug} 872 | && msg("Setting $frame = '$framestring'"); 873 | 874 | # COMM, TXX, and UFID are Complex frames that must be 875 | # treated differently. 876 | my $frametext = $MP3frametexts{$frame}; 877 | if ( $method eq "COMM" ) { 878 | $mp3->{"ID3v2"} 879 | ->add_frame( $method, 'ENG', $frametext, $framestring ); 880 | } 881 | elsif ( $method eq "TXXX" ) { 882 | $frametext = $frame 883 | if ( !( defined($frametext) ) ); 884 | $mp3->{"ID3v2"} 885 | ->add_frame( $method, 0, $frametext, $framestring ); 886 | } 887 | elsif ( $method eq 'UFID' ) { 888 | $mp3->{'ID3v2'}->add_frame( $method, $framestring, $frametext ); 889 | } 890 | else { 891 | $mp3->{"ID3v2"}->add_frame( $method, $framestring ); 892 | } 893 | } 894 | } 895 | 896 | $mp3->{ID3v2}->write_tag 897 | or die("Couldn't write the ID3v2 tag to $destfilename!\n"); 898 | 899 | $mp3->close(); 900 | 901 | # should we optionally reset the destfile timestamp to the same as the srcfile 902 | # utime $srcstat->mtime, $srcstat->mtime, $destfilename; 903 | } 904 | } 905 | } 906 | 907 | sub INT_Handler { 908 | my $signame = shift; 909 | die "Exited with SIG$signame\n"; 910 | } 911 | 912 | sub fixUpFrame { 913 | my ($frameValue) = @_; 914 | $frameValue = decode( "utf8", $frameValue ); 915 | $frameValue =~ s/ +$//; 916 | return $frameValue; 917 | } 918 | 919 | sub fixUpTrackNumber { 920 | my $trackNum = shift; 921 | 922 | # Check TRACKNUMBER tag is not empty 923 | if ($trackNum) { 924 | 925 | # Check TRACKNUMBER tag is numeric 926 | if ( looks_like_number($trackNum) ) { 927 | $trackNum = sprintf( "%02u", $trackNum ); 928 | } 929 | else { 930 | $Options{info} 931 | && msg('TRACKNUMBER not numeric'); 932 | } 933 | } 934 | return $trackNum; 935 | } 936 | 937 | sub compare_src_dest_picture_data { 938 | my ( $allsrcpictures, $alldestpictures, $destfilename ) = @_; 939 | 940 | # Create temporary MP3 id3v2 tag 941 | my $mp3_tmp_pic = MP3::Tag->new($destfilename); 942 | $mp3_tmp_pic->new_tag("ID3v2"); 943 | 944 | # Write APIC frames to temporary tag 945 | $mp3_tmp_pic = picsToAPICframes( $mp3_tmp_pic, $allsrcpictures ); 946 | 947 | # Read back the APIC frames in a format which allows direct 948 | # comparison with destination file data 949 | ( my $tagname, my @alltmppictures ) = 950 | $mp3_tmp_pic->{"ID3v2"}->get_frames( "APIC", 'intact' ); 951 | 952 | # Set 'tags don't match' flag to 1 if embedded picture data differs 953 | # between source and destination files. Use cmpStr from FreezeThaw for this: 954 | my $pics_dont_match = cmpStr( [@alltmppictures], [@$alldestpictures] ); 955 | ( $Options{debug} || $Options{tagdiff} ) 956 | && ($pics_dont_match) 957 | && msg( "Source and destination picture data NOT equal, " 958 | . "will rewrite destination APIC frames." ); 959 | 960 | return $pics_dont_match; 961 | } 962 | 963 | sub picsToAPICframes { 964 | 965 | # Write pictures to supplied mp3 tag 966 | my ( $mp3_object, $allpics ) = @_; 967 | if ($allpics) { 968 | foreach my $thisPic (@$allpics) { 969 | my $imdata = $thisPic->{imageData}; 970 | my $pictype = $thisPic->{pictureType}; 971 | my @APICheader = 972 | ( 0, $$thisPic{mimeType}, chr($pictype), $$thisPic{description} ); 973 | $mp3_object->{"ID3v2"}->add_frame( "APIC", @APICheader, $imdata ); 974 | } 975 | } 976 | return $mp3_object; 977 | } 978 | 979 | # vim:set softtabstop=4: 980 | # vim:set shiftwidth=4: 981 | 982 | __END__ 983 | -------------------------------------------------------------------------------- /lib/Audio/FLAC/Header.pm: -------------------------------------------------------------------------------- 1 | package Audio::FLAC::Header; 2 | 3 | # $Id: Header.pm 26 2008-11-08 23:37:45Z dsully $ 4 | 5 | use strict; 6 | use File::Basename; 7 | 8 | our $VERSION = '2.3'; 9 | our $HAVE_XS = 0; 10 | 11 | # First four bytes of stream are always fLaC 12 | my $FLACHEADERFLAG = 'fLaC'; 13 | my $ID3HEADERFLAG = 'ID3'; 14 | 15 | # Masks for METADATA_BLOCK_HEADER 16 | my $LASTBLOCKFLAG = 0x80000000; 17 | my $BLOCKTYPEFLAG = 0x7F000000; 18 | my $BLOCKLENFLAG = 0x00FFFFFF; 19 | 20 | # Enumerated Block Types 21 | my $BT_STREAMINFO = 0; 22 | my $BT_PADDING = 1; 23 | my $BT_APPLICATION = 2; 24 | my $BT_SEEKTABLE = 3; 25 | my $BT_VORBIS_COMMENT = 4; 26 | my $BT_CUESHEET = 5; 27 | my $BT_PICTURE = 6; 28 | 29 | my %BLOCK_TYPES = ( 30 | $BT_STREAMINFO => '_parseStreamInfo', 31 | $BT_APPLICATION => '_parseAppBlock', 32 | # The seektable isn't actually useful yet, and is a big performance hit. 33 | # $BT_SEEKTABLE => '_parseSeekTable', 34 | $BT_VORBIS_COMMENT => '_parseVorbisComments', 35 | $BT_CUESHEET => '_parseCueSheet', 36 | $BT_PICTURE => '_parsePicture', 37 | ); 38 | 39 | XS_BOOT: { 40 | # If I inherit DynaLoader then I inherit AutoLoader 41 | require DynaLoader; 42 | 43 | # DynaLoader calls dl_load_flags as a static method. 44 | *dl_load_flags = DynaLoader->can('dl_load_flags'); 45 | 46 | $HAVE_XS = eval { 47 | 48 | do {__PACKAGE__->can('bootstrap') || \&DynaLoader::bootstrap}->(__PACKAGE__, $VERSION); 49 | 50 | return 1; 51 | }; 52 | 53 | # Try to use the faster code first. 54 | if ($HAVE_XS) { 55 | *new = \&_new_XS; 56 | *write = \&_write_XS; 57 | } else { 58 | *new = \&_new_PP; 59 | *write = \&_write_PP; 60 | } 61 | } 62 | 63 | sub _new_PP { 64 | my ($class, $file) = @_; 65 | 66 | # open up the file 67 | open(my $fh, $file) or die "[$file] does not exist or cannot be read: $!"; 68 | 69 | # make sure dos-type systems can handle it... 70 | binmode($fh); 71 | 72 | my $self = { 73 | 'fileSize' => -s $file, 74 | 'filename' => $file, 75 | }; 76 | 77 | bless $self, $class; 78 | 79 | # check the header to make sure this is actually a FLAC file 80 | my $byteCount = $self->_checkHeader($fh) || 0; 81 | 82 | if ($byteCount <= 0) { 83 | 84 | close($fh); 85 | die "[$file] does not appear to be a FLAC file!"; 86 | } 87 | 88 | $self->{'startMetadataBlocks'} = $byteCount; 89 | 90 | # Grab the metadata blocks from the FLAC file 91 | if (!$self->_getMetadataBlocks($fh)) { 92 | 93 | close($fh); 94 | die "[$file] Unable to read metadata from FLAC!"; 95 | }; 96 | 97 | # Always set to empty hash in the case of no comments. 98 | $self->{'tags'} = {}; 99 | 100 | for my $block (@{$self->{'metadataBlocks'}}) { 101 | 102 | my $method = $BLOCK_TYPES{ $block->{'blockType'} } || next; 103 | 104 | $self->$method($block); 105 | } 106 | 107 | close($fh); 108 | 109 | return $self; 110 | } 111 | 112 | sub info { 113 | my $self = shift; 114 | my $key = shift; 115 | 116 | # if the user did not supply a key, return a hashref 117 | return $self->{'info'} unless $key; 118 | 119 | # otherwise, return the value for the given key 120 | return $self->{'info'}->{$key}; 121 | } 122 | 123 | sub tags { 124 | my $self = shift; 125 | my $key = shift; 126 | 127 | # if the user did not supply a key, return a hashref 128 | return $self->{'tags'} unless $key; 129 | 130 | # otherwise, return the value for the given key 131 | return $self->{'tags'}->{$key}; 132 | } 133 | 134 | sub cuesheet { 135 | my $self = shift; 136 | 137 | # if the cuesheet block exists, return it as an arrayref 138 | return $self->{'cuesheet'} if exists($self->{'cuesheet'}); 139 | 140 | # otherwise, return an empty arrayref 141 | return []; 142 | } 143 | 144 | sub seektable { 145 | my $self = shift; 146 | 147 | # if the seekpoint table block exists, return it as an arrayref 148 | return $self->{'seektable'} if exists($self->{'seektable'}); 149 | 150 | # otherwise, return an empty arrayref 151 | return []; 152 | } 153 | 154 | sub application { 155 | my $self = shift; 156 | my $appID = shift || "default"; 157 | 158 | # if the application block exists, return it's content 159 | return $self->{'application'}->{$appID} if exists($self->{'application'}->{$appID}); 160 | 161 | # otherwise, return nothing 162 | return undef; 163 | } 164 | 165 | sub picture { 166 | my $self = shift; 167 | my $type = shift; 168 | $type = 3 unless defined ($type); # defaults to front cover 169 | 170 | if ($type eq 'all') { 171 | return $self->{'allpictures'} if exists($self->{'allpictures'}); 172 | } 173 | 174 | # Also look for other types of images 175 | # http://flac.sourceforge.net/format.html#metadata_block_picture 176 | my @types = ($type, 4, 0, 5..20); 177 | 178 | # if the picture block exists, return it's content 179 | for (@types) { 180 | return $self->{'picture'}->{$_} if exists $self->{'picture'}->{$_}; 181 | } 182 | 183 | # otherwise, return nothing 184 | return undef; 185 | } 186 | 187 | sub vendor_string { 188 | my $self = shift; 189 | 190 | return $self->{'vendor'} || ''; 191 | } 192 | 193 | sub set_separator { 194 | my $self = shift; 195 | 196 | $self->{'separator'} = shift; 197 | } 198 | 199 | sub _write_PP { 200 | my $self = shift; 201 | 202 | my @tagString = (); 203 | my $numTags = 0; 204 | 205 | my ($idxVorbis,$idxPadding); 206 | my $totalAvail = 0; 207 | my $metadataBlocks = $FLACHEADERFLAG; 208 | my $tmpnum; 209 | 210 | # Make a list of the tags and lengths for packing into the vorbis metadata block 211 | foreach (keys %{$self->{'tags'}}) { 212 | 213 | unless (/^VENDOR$/) { 214 | push @tagString, $_ . "=" . $self->{'tags'}{$_}; 215 | $numTags++; 216 | } 217 | } 218 | 219 | # Create the contents of the vorbis comment metablock with the number of tags 220 | my $vorbisComment .= _packInt32($numTags); 221 | 222 | # Finally, each tag string (with length) 223 | foreach (@tagString) { 224 | _addStringToComment(\$vorbisComment, $_); 225 | } 226 | 227 | # Is there enough space for this new header? 228 | # Determine the length of the old comment block and the length of the padding available 229 | $idxVorbis = $self->_findMetadataIndex($BT_VORBIS_COMMENT); 230 | $idxPadding = $self->_findMetadataIndex($BT_PADDING); 231 | 232 | if ($idxVorbis >= 0) { 233 | # Add the length of the block 234 | $totalAvail += $self->{'metadataBlocks'}[$idxVorbis]->{'blockSize'}; 235 | } else { 236 | # Subtract 4 (min size of block when added) 237 | $totalAvail -= 4; 238 | } 239 | 240 | if ($idxPadding >= 0) { 241 | # Add the length of the block 242 | $totalAvail += $self->{'metadataBlocks'}[$idxPadding]->{'blockSize'}; 243 | } else { 244 | # Subtract 4 (min size of block when added) 245 | $totalAvail -= 4; 246 | } 247 | 248 | # Check for not enough space to write tag without 249 | # re-writing entire file (not within scope) 250 | if ($totalAvail - length($vorbisComment) < 0) { 251 | warn "Unable to write Vorbis tags - not enough header space!"; 252 | return 0; 253 | } 254 | 255 | # Modify the metadata blocks to reflect new header sizes 256 | 257 | # Is there a Vorbis metadata block? 258 | if ($idxVorbis < 0) { 259 | # no vorbis block, so add one 260 | _addNewMetadataBlock($self, $BT_VORBIS_COMMENT, $vorbisComment); 261 | } else { 262 | # update the vorbis block 263 | _updateMetadataBlock($self, $idxVorbis , $vorbisComment); 264 | } 265 | 266 | # Is there a Padding block? 267 | # Change the padding to reflect the new vorbis comment size 268 | if ($idxPadding < 0) { 269 | # no padding block 270 | _addNewMetadataBlock($self, $BT_PADDING , "\0" x ($totalAvail - length($vorbisComment))); 271 | } else { 272 | # update the padding block 273 | _updateMetadataBlock($self, $idxPadding, "\0" x ($totalAvail - length($vorbisComment))); 274 | } 275 | 276 | # Create the metadata block structure for the FLAC file 277 | foreach (@{$self->{'metadataBlocks'}}) { 278 | $tmpnum = $_->{'lastBlockFlag'} << 31; 279 | $tmpnum |= $_->{'blockType'} << 24; 280 | $tmpnum |= $_->{'blockSize'}; 281 | $metadataBlocks .= pack "N", $tmpnum; 282 | $metadataBlocks .= $_->{'contents'}; 283 | } 284 | 285 | # open FLAC file and write new metadata blocks 286 | open FLACFILE, "+<$self->{'filename'}" or return 0; 287 | binmode FLACFILE; 288 | 289 | # overwrite the existing metadata blocks 290 | print FLACFILE $metadataBlocks or return 0; 291 | 292 | close FLACFILE; 293 | 294 | return 1; 295 | } 296 | 297 | # private methods to this class 298 | sub _checkHeader { 299 | my ($self, $fh) = @_; 300 | 301 | # check that the first four bytes are 'fLaC' 302 | read($fh, my $buffer, 4) or return -1; 303 | 304 | if (substr($buffer,0,3) eq $ID3HEADERFLAG) { 305 | 306 | $self->{'ID3V2Tag'} = 1; 307 | 308 | my $id3size = ''; 309 | 310 | # How big is the ID3 header? 311 | # Skip the next two bytes - major & minor version number. 312 | read($fh, $buffer, 2) or return -1; 313 | 314 | # The size of the ID3 tag is a 'synchsafe' 4-byte uint 315 | # Read the next 4 bytes one at a time, unpack each one B7, 316 | # and concatenate. When complete, do a bin2dec to determine size 317 | for (my $c = 0; $c < 4; $c++) { 318 | read($fh, $buffer, 1) or return -1; 319 | $id3size .= substr(unpack ("B8", $buffer), 1); 320 | } 321 | 322 | seek $fh, _bin2dec($id3size) + 10, 0; 323 | read($fh, $buffer, 4) or return -1; 324 | } 325 | 326 | if ($buffer ne $FLACHEADERFLAG) { 327 | warn "Unable to identify $self->{'filename'} as a FLAC bitstream!\n"; 328 | return -2; 329 | } 330 | 331 | # at this point, we assume the bitstream is valid 332 | return tell($fh); 333 | } 334 | 335 | sub _getMetadataBlocks { 336 | my ($self, $fh) = @_; 337 | 338 | my $metadataBlockList = []; 339 | my $numBlocks = 0; 340 | my $lastBlockFlag = 0; 341 | my $buffer; 342 | 343 | # Loop through all of the metadata blocks 344 | while ($lastBlockFlag == 0) { 345 | 346 | # Read the next metadata_block_header 347 | read($fh, $buffer, 4) or return 0; 348 | 349 | my $metadataBlockHeader = unpack('N', $buffer); 350 | 351 | # Break out the contents of the metadata_block_header 352 | my $metadataBlockType = ($BLOCKTYPEFLAG & $metadataBlockHeader)>>24; 353 | my $metadataBlockLength = ($BLOCKLENFLAG & $metadataBlockHeader); 354 | $lastBlockFlag = ($LASTBLOCKFLAG & $metadataBlockHeader)>>31; 355 | 356 | # If the block size is zero go to the next block 357 | next unless $metadataBlockLength; 358 | 359 | # Read the contents of the metadata_block 360 | read($fh, my $metadataBlockData, $metadataBlockLength) or return 0; 361 | 362 | # Store the parts in the list 363 | $metadataBlockList->[$numBlocks++] = { 364 | 'lastBlockFlag' => $lastBlockFlag, 365 | 'blockType' => $metadataBlockType, 366 | 'blockSize' => $metadataBlockLength, 367 | 'contents' => $metadataBlockData 368 | }; 369 | } 370 | 371 | # Store the metadata blocks in the hash 372 | $self->{'metadataBlocks'} = $metadataBlockList; 373 | $self->{'startAudioData'} = tell $fh; 374 | 375 | return 1; 376 | } 377 | 378 | sub _parseStreamInfo { 379 | my ($self, $block) = @_; 380 | 381 | my $info = {}; 382 | 383 | # Convert to binary string, since there's some unfriendly lengths ahead 384 | my $metaBinString = unpack('B144', $block->{'contents'}); 385 | 386 | my $x32 = 0 x 32; 387 | 388 | $info->{'MINIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 0, 16), -32))); 389 | $info->{'MAXIMUMBLOCKSIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 16, 32), -32))); 390 | $info->{'MINIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 32, 24), -32))); 391 | $info->{'MINIMUMFRAMESIZE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 56, 24), -32))); 392 | 393 | $info->{'SAMPLERATE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 80, 20), -32))); 394 | $info->{'NUMCHANNELS'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 100, 3), -32))) + 1; 395 | $info->{'BITSPERSAMPLE'} = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 100, 5), -32))) + 1; 396 | 397 | # Calculate total samples in two parts 398 | my $highBits = unpack('N', pack('B32', substr($x32 . substr($metaBinString, 108, 4), -32))); 399 | 400 | $info->{'TOTALSAMPLES'} = $highBits * 2 ** 32 + 401 | unpack('N', pack('B32', substr($x32 . substr($metaBinString, 112, 32), -32))); 402 | 403 | # Return the MD5 as a 32-character hexadecimal string 404 | #$info->{'MD5CHECKSUM'} = unpack('H32',substr($self->{'metadataBlocks'}[$idx]->{'contents'},18,16)); 405 | $info->{'MD5CHECKSUM'} = unpack('H32',substr($block->{'contents'}, 18, 16)); 406 | 407 | # Store in the data hash 408 | $self->{'info'} = $info; 409 | 410 | # Calculate the track times 411 | my $totalSeconds = $info->{'TOTALSAMPLES'} / $info->{'SAMPLERATE'}; 412 | 413 | if ($totalSeconds == 0) { 414 | warn "totalSeconds is 0 - we couldn't find either TOTALSAMPLES or SAMPLERATE!\n" . 415 | "setting totalSeconds to 1 to avoid divide by zero error!\n"; 416 | 417 | $totalSeconds = 1; 418 | } 419 | 420 | $self->{'trackTotalLengthSeconds'} = $totalSeconds; 421 | 422 | $self->{'trackLengthMinutes'} = int(int($totalSeconds) / 60); 423 | $self->{'trackLengthSeconds'} = int($totalSeconds) % 60; 424 | $self->{'trackLengthFrames'} = ($totalSeconds - int($totalSeconds)) * 75; 425 | $self->{'bitRate'} = 8 * ($self->{'fileSize'} - $self->{'startAudioData'}) / $totalSeconds; 426 | 427 | return 1; 428 | } 429 | 430 | sub _parseVorbisComments { 431 | my ($self, $block) = @_; 432 | 433 | my $tags = {}; 434 | my $rawTags = []; 435 | 436 | # Parse out the tags from the metadata block 437 | my $tmpBlock = $block->{'contents'}; 438 | my $offset = 0; 439 | 440 | # First tag in block is the Vendor String 441 | my $tagLen = unpack('V', substr($tmpBlock, $offset, 4)); 442 | $tags->{'VENDOR'} = substr($tmpBlock, ($offset += 4), $tagLen); 443 | 444 | # Now, how many additional tags are there? 445 | my $numTags = unpack('V', substr($tmpBlock, ($offset += $tagLen), 4)); 446 | 447 | $offset += 4; 448 | 449 | for (my $tagi = 0; $tagi < $numTags; $tagi++) { 450 | 451 | # Read the tag string 452 | my $tagLen = unpack('V', substr($tmpBlock, $offset, 4)); 453 | my $tagStr = substr($tmpBlock, ($offset += 4), $tagLen); 454 | 455 | # Save the raw tag 456 | push(@$rawTags, $tagStr); 457 | 458 | # Match the key and value 459 | if ($tagStr =~ /^(.*?)=(.*?)[\r\n]*$/s) { 460 | 461 | my $tkey = $1; 462 | 463 | # Stick it in the tag hash - and handle multiple tags 464 | # of the same name. 465 | if (exists $tags->{$tkey} && ref($tags->{$tkey}) ne 'ARRAY') { 466 | 467 | my $oldValue = $tags->{$tkey}; 468 | 469 | $tags->{$tkey} = [ $oldValue, $2 ]; 470 | 471 | } elsif (ref($tags->{$tkey}) eq 'ARRAY') { 472 | 473 | push @{$tags->{$tkey}}, $2; 474 | 475 | } else { 476 | 477 | $tags->{$tkey} = $2; 478 | } 479 | } 480 | 481 | $offset += $tagLen; 482 | } 483 | 484 | $self->{'tags'} = $tags; 485 | $self->{'rawTags'} = $rawTags; 486 | 487 | return 1; 488 | } 489 | 490 | sub _parseCueSheet { 491 | my ($self, $block) = @_; 492 | 493 | my $cuesheet = []; 494 | 495 | # Parse out the tags from the metadata block 496 | my $tmpBlock = $block->{'contents'}; 497 | 498 | # First field in block is the Media Catalog Number 499 | my $catalog = substr($tmpBlock,0,128); 500 | $catalog =~ s/\x00+.*$//gs; # trim nulls off of the end 501 | 502 | push (@$cuesheet, "CATALOG $catalog\n") if length($catalog) > 0; 503 | $tmpBlock = substr($tmpBlock,128); 504 | 505 | # metaflac uses "dummy.wav" but we're going to use the actual filename 506 | # this will help external parsers that have to associate the resulting 507 | # cuesheet with this flac file. 508 | push (@$cuesheet, "FILE \"" . basename("$self->{'filename'}") ."\" FLAC\n"); 509 | 510 | # Next field is the number of lead-in samples for CD-DA 511 | my $highbits = unpack('N', substr($tmpBlock,0,4)); 512 | my $leadin = $highbits * 2 ** 32 + unpack('N', (substr($tmpBlock,4,4))); 513 | $tmpBlock = substr($tmpBlock,8); 514 | 515 | # Flag to determine if this represents a CD 516 | my $bits = unpack('B8', substr($tmpBlock, 0, 1)); 517 | my $isCD = substr($bits, 0, 1); 518 | 519 | # Some sanity checking related to the CD flag 520 | if ($isCD && length($catalog) != 13 && length($catalog) != 0) { 521 | warn "Invalid Catalog entry\n"; 522 | return -1; 523 | } 524 | 525 | if (!$isCD && $leadin > 0) { 526 | warn "Lead-in detected for non-CD cue sheet.\n"; 527 | return -1; 528 | } 529 | 530 | # The next few bits should be zero. 531 | my $reserved = _bin2dec(substr($bits, 1, 7)); 532 | $reserved += unpack('B*', substr($tmpBlock, 1, 258)); 533 | 534 | if ($reserved != 0) { 535 | warn "Either the cue sheet is corrupt, or it's a newer revision than I can parse\n"; 536 | #return -1; # ?? may be harmless to continue ... 537 | } 538 | 539 | $tmpBlock = substr($tmpBlock,259); 540 | 541 | # Number of tracks 542 | my $numTracks = _bin2dec(unpack('B8',substr($tmpBlock,0,1))); 543 | $tmpBlock = substr($tmpBlock,1); 544 | 545 | if ($numTracks < 1 || ($isCD && $numTracks > 100)) { 546 | warn "Invalid number of tracks $numTracks\n"; 547 | return -1; 548 | } 549 | 550 | # Parse individual tracks now 551 | my %seenTracknumber = (); 552 | my $leadout = 0; 553 | my $leadouttracknum = 0; 554 | 555 | for (my $i = 1; $i <= $numTracks; $i++) { 556 | 557 | $highbits = unpack('N', substr($tmpBlock,0,4)); 558 | 559 | my $trackOffset = $highbits * 2 ** 32 + unpack('N', (substr($tmpBlock,4,4))); 560 | 561 | if ($isCD && $trackOffset % 588) { 562 | warn "Invalid track offset $trackOffset\n"; 563 | return -1; 564 | } 565 | 566 | my $tracknum = _bin2dec(unpack('B8',substr($tmpBlock,8,1))) || do { 567 | 568 | warn "Invalid track numbered \"0\" detected\n"; 569 | return -1; 570 | }; 571 | 572 | if ($isCD && $tracknum > 99 && $tracknum != 170) { 573 | warn "Invalid track number for a CD $tracknum\n"; 574 | return -1; 575 | } 576 | 577 | if (defined $seenTracknumber{$tracknum}) { 578 | warn "Invalid duplicate track number $tracknum\n"; 579 | return -1; 580 | } 581 | 582 | $seenTracknumber{$tracknum} = 1; 583 | 584 | my $isrc = substr($tmpBlock,9,12); 585 | $isrc =~ s/\x00+.*$//; 586 | 587 | if ((length($isrc) != 0) && (length($isrc) != 12)) { 588 | warn "Invalid ISRC code $isrc\n"; 589 | return -1; 590 | } 591 | 592 | $bits = unpack('B8', substr($tmpBlock, 21, 1)); 593 | my $isAudio = !substr($bits, 0, 1); 594 | my $preemphasis = substr($bits, 1, 1); 595 | 596 | # The next few bits should be zero. 597 | $reserved = _bin2dec(substr($bits, 2, 6)); 598 | $reserved += unpack('B*', substr($tmpBlock, 22, 13)); 599 | 600 | if ($reserved != 0) { 601 | warn "Either the cue sheet is corrupt, " . 602 | "or it's a newer revision than I can parse\n"; 603 | #return -1; # ?? may be harmless to continue ... 604 | } 605 | 606 | my $numIndexes = _bin2dec(unpack('B8',substr($tmpBlock,35,1))); 607 | 608 | $tmpBlock = substr($tmpBlock,36); 609 | 610 | # If we're on the lead-out track, stop before pushing TRACK info 611 | if ($i == $numTracks) { 612 | $leadout = $trackOffset; 613 | 614 | if ($isCD && $tracknum != 170) { 615 | warn "Incorrect lead-out track number $tracknum for CD\n"; 616 | return -1; 617 | } 618 | 619 | $leadouttracknum = $tracknum; 620 | next; 621 | } 622 | 623 | # Add TRACK info to cuesheet 624 | my $trackline = sprintf(" TRACK %02d %s\n", $tracknum, $isAudio ? "AUDIO" : "DATA"); 625 | 626 | push (@$cuesheet, $trackline); 627 | push (@$cuesheet, " FLAGS PRE\n") if ($preemphasis); 628 | push (@$cuesheet, " ISRC " . $isrc . "\n") if ($isrc); 629 | 630 | if ($numIndexes < 1 || ($isCD && $numIndexes > 100)) { 631 | warn "Invalid number of Indexes $numIndexes for track $tracknum\n"; 632 | return -1; 633 | } 634 | 635 | # Itterate through the indexes for this track 636 | for (my $j = 0; $j < $numIndexes; $j++) { 637 | 638 | $highbits = unpack('N', substr($tmpBlock,0,4)); 639 | 640 | my $indexOffset = $highbits * 2 ** 32 + unpack('N', (substr($tmpBlock,4,4))); 641 | 642 | if ($isCD && $indexOffset % 588) { 643 | warn "Invalid index offset $indexOffset\n"; 644 | return -1; 645 | } 646 | 647 | my $indexnum = _bin2dec(unpack('B8',substr($tmpBlock,8,1))); 648 | #TODO: enforce sequential indexes 649 | 650 | $reserved = 0; 651 | $reserved += unpack('B*', substr($tmpBlock, 9, 3)); 652 | 653 | if ($reserved != 0) { 654 | warn "Either the cue sheet is corrupt, " . 655 | "or it's a newer revision than I can parse\n"; 656 | #return -1; # ?? may be harmless to continue ... 657 | } 658 | 659 | my $timeoffset = _samplesToTime(($trackOffset + $indexOffset), $self->{'info'}->{'SAMPLERATE'}); 660 | 661 | return -1 unless defined ($timeoffset); 662 | 663 | my $indexline = sprintf (" INDEX %02d %s\n", $indexnum, $timeoffset); 664 | 665 | push (@$cuesheet, $indexline); 666 | 667 | $tmpBlock = substr($tmpBlock,12); 668 | } 669 | } 670 | 671 | # Add final comments just like metaflac would 672 | push (@$cuesheet, "REM FLAC__lead-in " . $leadin . "\n"); 673 | push (@$cuesheet, "REM FLAC__lead-out " . $leadouttracknum . " " . $leadout . "\n"); 674 | 675 | $self->{'cuesheet'} = $cuesheet; 676 | 677 | return 1; 678 | } 679 | 680 | sub _parsePicture { 681 | my ($self, $block) = @_; 682 | 683 | # Parse out the tags from the metadata block 684 | my $tmpBlock = $block->{'contents'}; 685 | my $offset = 0; 686 | 687 | my $pictureType = unpack('N', substr($tmpBlock, $offset, 4)); 688 | my $mimeLength = unpack('N', substr($tmpBlock, ($offset += 4), 4)); 689 | my $mimeType = substr($tmpBlock, ($offset += 4), $mimeLength); 690 | my $descLength = unpack('N', substr($tmpBlock, ($offset += $mimeLength), 4)); 691 | my $description = substr($tmpBlock, ($offset += 4), $descLength); 692 | my $width = unpack('N', substr($tmpBlock, ($offset += $descLength), 4)); 693 | my $height = unpack('N', substr($tmpBlock, ($offset += 4), 4)); 694 | my $depth = unpack('N', substr($tmpBlock, ($offset += 4), 4)); 695 | my $colorIndex = unpack('N', substr($tmpBlock, ($offset += 4), 4)); 696 | my $imageLength = unpack('N', substr($tmpBlock, ($offset += 4), 4)); 697 | my $imageData = substr($tmpBlock, ($offset += 4), $imageLength); 698 | 699 | $self->{'picture'}->{$pictureType}->{'mimeType'} = $mimeType; 700 | $self->{'picture'}->{$pictureType}->{'description'} = $description; 701 | $self->{'picture'}->{$pictureType}->{'width'} = $width; 702 | $self->{'picture'}->{$pictureType}->{'height'} = $height; 703 | $self->{'picture'}->{$pictureType}->{'depth'} = $depth; 704 | $self->{'picture'}->{$pictureType}->{'colorIndex'} = $colorIndex; 705 | $self->{'picture'}->{$pictureType}->{'imageData'} = $imageData; 706 | $self->{'picture'}->{$pictureType}->{'pictureType'} = $pictureType; 707 | 708 | # Create array of hashes with picture data from all the picture metadata blocks 709 | push ( @{$self->{'allpictures'}}, {%{$self->{'picture'}->{$pictureType}}} ); 710 | 711 | return 1; 712 | } 713 | 714 | sub _parseSeekTable { 715 | my ($self, $block) = @_; 716 | 717 | my $seektable = []; 718 | 719 | # grab the seekpoint table 720 | my $tmpBlock = $block->{'contents'}; 721 | my $offset = 0; 722 | 723 | # parse out the seekpoints 724 | while (my $seekpoint = substr($tmpBlock, $offset, 18)) { 725 | 726 | # Sample number of first sample in the target frame 727 | my $highbits = unpack('N', substr($seekpoint,0,4)); 728 | my $sampleNumber = $highbits * 2 ** 32 + unpack('N', (substr($seekpoint,4,4))); 729 | 730 | # Detect placeholder seekpoint 731 | # since the table is sorted, a placeholder means were finished 732 | last if ($sampleNumber == (0xFFFFFFFF * 2 ** 32 + 0xFFFFFFFF)); 733 | 734 | # Offset (in bytes) from the first byte of the first frame header 735 | # to the first byte of the target frame's header. 736 | $highbits = unpack('N', substr($seekpoint,8,4)); 737 | my $streamOffset = $highbits * 2 ** 32 + unpack('N', (substr($seekpoint,12,4))); 738 | 739 | # Number of samples in the target frame 740 | my $frameSamples = unpack('n', (substr($seekpoint,16,2))); 741 | 742 | # add this point to our copy of the table 743 | push (@$seektable, { 744 | 'sampleNumber' => $sampleNumber, 745 | 'streamOffset' => $streamOffset, 746 | 'frameSamples' => $frameSamples, 747 | }); 748 | 749 | $offset += 18; 750 | } 751 | 752 | $self->{'seektable'} = $seektable; 753 | 754 | return 1; 755 | } 756 | 757 | sub _parseAppBlock { 758 | my ($self, $block) = @_; 759 | 760 | # Parse out the tags from the metadata block 761 | my $appID = unpack('N', substr($block->{'contents'}, 0, 4, '')); 762 | 763 | $self->{'application'}->{$appID} = $block->{'contents'}; 764 | 765 | return 1; 766 | } 767 | 768 | # Take an offset as number of flac samples 769 | # and return CD-DA style mm:ss:ff 770 | sub _samplesToTime { 771 | my $samples = shift; 772 | my $samplerate = shift; 773 | 774 | if ($samplerate == 0) { 775 | warn "Couldn't find SAMPLERATE for time calculation!\n"; 776 | return; 777 | } 778 | 779 | my $totalSeconds = $samples / $samplerate; 780 | 781 | if ($totalSeconds == 0) { 782 | # handled specially to avoid division by zero errors 783 | return "00:00:00"; 784 | } 785 | 786 | my $trackMinutes = int(int($totalSeconds) / 60); 787 | my $trackSeconds = int($totalSeconds % 60); 788 | my $trackFrames = ($totalSeconds - int($totalSeconds)) * 75; 789 | 790 | # Poor man's rounding. Needed to match the output of metaflac. 791 | $trackFrames = int($trackFrames + 0.5); 792 | 793 | my $formattedTime = sprintf("%02d:%02d:%02d", $trackMinutes, $trackSeconds, $trackFrames); 794 | 795 | return $formattedTime; 796 | } 797 | 798 | sub _bin2dec { 799 | # Freely swiped from Perl Cookbook p. 48 (May 1999) 800 | return unpack ('N', pack ('B32', substr(0 x 32 . shift, -32))); 801 | } 802 | 803 | sub _packInt32 { 804 | # Packs an integer into a little-endian 32-bit unsigned int 805 | return pack('V', shift) 806 | } 807 | 808 | sub _findMetadataIndex { 809 | my $self = shift; 810 | my $htype = shift; 811 | my $idx = shift || 0; 812 | 813 | my $found = 0; 814 | 815 | # Loop through the metadata_blocks until one of $htype is found 816 | while ($idx < @{$self->{'metadataBlocks'}}) { 817 | 818 | # Check the type to see if it's a $htype block 819 | if ($self->{'metadataBlocks'}[$idx]->{'blockType'} == $htype) { 820 | $found++; 821 | last; 822 | } 823 | 824 | $idx++; 825 | } 826 | 827 | # No streaminfo found. Error. 828 | return -1 if $found == 0; 829 | return $idx; 830 | } 831 | 832 | sub _addStringToComment { 833 | my $self = shift; 834 | my $addString = shift; 835 | 836 | $$self .= _packInt32(length($addString)); 837 | $$self .= $addString; 838 | } 839 | 840 | sub _addNewMetadataBlock { 841 | my $self = shift; 842 | my $htype = shift; 843 | my $contents = shift; 844 | 845 | my $numBlocks = @{$self->{'metadataBlocks'}}; 846 | 847 | $self->{'metadataBlocks'}->[$numBlocks-1]->{'lastBlockFlag'}= 0; 848 | 849 | # create a new block 850 | $self->{'metadataBlocks'}->[$numBlocks]->{'lastBlockFlag'} = 1; 851 | $self->{'metadataBlocks'}->[$numBlocks]->{'blockType'} = $htype; 852 | $self->{'metadataBlocks'}->[$numBlocks]->{'blockSize'} = length($contents); 853 | $self->{'metadataBlocks'}->[$numBlocks]->{'contents'} = $contents; 854 | } 855 | 856 | sub _updateMetadataBlock { 857 | my $self = shift; 858 | my $blockIdx = shift; 859 | my $contents = shift; 860 | 861 | # Update the block 862 | $self->{'metadataBlocks'}->[$blockIdx]->{'blockSize'} = length($contents); 863 | $self->{'metadataBlocks'}->[$blockIdx]->{'contents'} = $contents; 864 | } 865 | 866 | 1; 867 | 868 | __END__ 869 | 870 | =head1 NAME 871 | 872 | Audio::FLAC::Header - interface to FLAC header metadata. 873 | 874 | =head1 SYNOPSIS 875 | 876 | use Audio::FLAC::Header; 877 | my $flac = Audio::FLAC::Header->new("song.flac"); 878 | 879 | my $info = $flac->info(); 880 | 881 | foreach (keys %$info) { 882 | print "$_: $info->{$_}\n"; 883 | } 884 | 885 | my $tags = $flac->tags(); 886 | 887 | foreach (keys %$tags) { 888 | print "$_: $tags->{$_}\n"; 889 | } 890 | 891 | =head1 DESCRIPTION 892 | 893 | This module returns a hash containing basic information about a FLAC file, 894 | a representation of the embedded cue sheet if one exists, as well as tag 895 | information contained in the FLAC file's Vorbis tags. 896 | There is no complete list of tag keys for Vorbis tags, as they can be 897 | defined by the user; the basic set of tags used for FLAC files include: 898 | 899 | ALBUM 900 | ARTIST 901 | TITLE 902 | DATE 903 | GENRE 904 | TRACKNUMBER 905 | COMMENT 906 | 907 | The information returned by Audio::FLAC::info is keyed by: 908 | 909 | MINIMUMBLOCKSIZE 910 | MAXIMUMBLOCKSIZE 911 | MINIMUMFRAMESIZE 912 | MAXIMUMFRAMESIZE 913 | TOTALSAMPLES 914 | SAMPLERATE 915 | NUMCHANNELS 916 | BITSPERSAMPLE 917 | MD5CHECKSUM 918 | 919 | Information stored in the main hash that relates to the file itself or is 920 | calculated from some of the information fields is keyed by: 921 | 922 | trackLengthMinutes : minutes field of track length 923 | trackLengthSeconds : seconds field of track length 924 | trackLengthFrames : frames field of track length (base 75) 925 | trackTotalLengthSeconds : total length of track in fractional seconds 926 | bitRate : average bits per second of file 927 | fileSize : file size, in bytes 928 | 929 | =head1 CONSTRUCTORS 930 | 931 | =head2 C<new ($filename)> 932 | 933 | Opens a FLAC file, ensuring that it exists and is actually an 934 | FLAC stream, then loads the information and comment fields. 935 | 936 | =head1 INSTANCE METHODS 937 | 938 | =over 4 939 | 940 | =item * info( [$key] ) 941 | 942 | Returns a hashref containing information about the FLAC file from 943 | the file's information header. 944 | 945 | The optional parameter, key, allows you to retrieve a single value from 946 | the info hash. Returns C<undef> if the key is not found. 947 | 948 | =item * tags( [$key] ) 949 | 950 | Returns a hashref containing tag keys and values of the FLAC file from 951 | the file's Vorbis Comment header. 952 | 953 | The optional parameter, key, allows you to retrieve a single value from 954 | the tag hash. Returns C<undef> if the key is not found. 955 | 956 | =item * cuesheet( ) 957 | 958 | Returns an arrayref which contains a textual representation of the 959 | cuesheet metada block. Each element in the array corresponds to one 960 | line in a .cue file. If there is no cuesheet block in this FLAC file 961 | the array will be empty. The resulting cuesheet should match the 962 | output of metaflac's --export-cuesheet-to option, with the exception 963 | of the FILE line, which includes the actual file name instead of 964 | "dummy.wav". 965 | 966 | =item * seektable( ) 967 | 968 | Returns the seektable. Currently disabled for performance. 969 | 970 | =item * application( $appId ) 971 | 972 | Returns the application block for the passed id. 973 | 974 | =item * picture( [$type ] ) 975 | 976 | Returns a hash containing data from a PICTURE block if found. 977 | 978 | Defaults to type 3 - "Front Cover" 979 | 980 | When the passed variable is 'all', an array of hashes containing 981 | picture data from all PICTURE blocks is returned. Allows for multiple instances 982 | of the same picture type. 983 | 984 | =item * set_separator( ) 985 | 986 | For multi-value ID3 tags, set the separator string. Defaults to '/' 987 | 988 | =item * vendor_string( ) 989 | 990 | Returns the vendor string. 991 | 992 | =item * write( ) 993 | 994 | Writes the current contents of the tag hash to the FLAC file, given that 995 | there's enough space in the header to do so. If there's insufficient 996 | space available (using pre-existing padding), the file will remain 997 | unchanged, and the function will return a zero value. 998 | 999 | =back 1000 | 1001 | =head1 SEE ALSO 1002 | 1003 | L<http://flac.sourceforge.net/format.html> 1004 | 1005 | =head1 AUTHORS 1006 | 1007 | Dan Sully, E<lt>daniel@cpan.orgE<gt> 1008 | 1009 | =head1 COPYRIGHT 1010 | 1011 | Pure perl code Copyright (c) 2003-2004, Erik Reckase. 1012 | 1013 | Pure perl code Copyright (c) 2003-2007, Dan Sully & Slim Devices. 1014 | 1015 | XS code Copyright (c) 2004-2007, Dan Sully & Slim Devices. 1016 | 1017 | This library is free software; you can redistribute it and/or modify 1018 | it under the same terms as Perl itself, either Perl version 5.8.2 or, 1019 | at your option, any later version of Perl 5 you may have available. 1020 | 1021 | =cut 1022 | --------------------------------------------------------------------------------