File Coverage

blib/lib/MPEG/ID3v2Tag.pm

Criterion	Covered	Total	%
statement	321	523	61.3
branch	77	170	45.2
condition	20	66	30.3
subroutine	65	109	59.6
pod	11	18	61.1
total	494	886	55.7

use strict;

# This module may be copied under the same terms as perl itself.

# This is a module for reading and writing ID3v2 tags.
#
# see the pod documentation at the bottom for details.

package MPEG::ID3v2Tag;

use vars qw($VERSION);
$VERSION = "0.39";

use Carp;

# Constructor.
sub new {
    my ($package) = @_;

    my $self = {
        FRAMES   => [],
        MAJORVER => 3,
        MINORVER => 0,
    };

    bless $self, $package;
}

####
# Return all the frame objects from the tag.  Either an array or arrayref,
# depending on call context.
#
# If an arrayref is passed in, it will replace the current frame list.
####
sub frames {
    my ( $self, $newframes ) = @_;

    if ($newframes) {
        croak "must pass an arrayref to frames" if ref($newframes) !~ 'ARRAY';
        $self->{FRAMES} = $newframes;
    }

    if (wantarray) {
        return @{ $self->{FRAMES} };
    }
    else {
        return $self->{FRAMES};
    }
}

####
# Delete frame by frame id.
# If n is provided,     deletes frame[n] of that particular frameid
# If n is not provided, deletes all frames with that frame id
####
sub del_frame {
    my ( $self, $frameid, $frameocc ) = @_;

    my $i = 0;
    my @newframes;

    if ( defined $frameocc ) {
        @newframes = grep {
            $_->frameid() ne $frameid
            or (
                $_->frameid() eq $frameid
                and $i++ != $frameocc
            )
        } $self->frames();
    }
    else {
        @newframes = grep { $_->frameid() ne $frameid }
                     $self->frames();
    }

    $self->frames( \@newframes );
}

sub set_frame {
    my $self    = shift;
    my $frameid = shift;

    $self->del_frame($frameid);
    $self->add_frame($frameid, @_);
}

####
# Return the entire tag as a binary string.
####
sub as_string {
    my ($self) = @_;

    my $body = $self->data_as_string();

    if ( $self->flag_unsynchronization && $body =~ /\xff$/ ) {
        $self->set_padding_size(256) if !$self->{PADDING_SIZE};
    }

    if ( $self->flag_extended_header() ) {
        $body = pack(
            "NCCN", 6,    # ext-header-size
            0,            # no flags (I don't support CRC)
            $self->{PADDING_SIZE}
        ) . $body;
    }

    if ( $self->flag_unsynchronization ) {
        $body = unsynchronize($body);
    }

    if (exists($self->{ORIGINAL_SIZE}) && $self->{PADDING_SIZE} && !$self->{MANUAL_PADDING}) {
        # attempt to preserve the original size of the tag by
        # adjusting the padding size.
        my $padlen = $self->{ORIGINAL_SIZE} - length($body);

        if ( $padlen >= 0 ) {
            $self->set_padding_size($padlen);
        }
    }

    if ( $self->{PADDING_SIZE} ) {
        $body .= "\0" x $self->{PADDING_SIZE};
    }

    my $size = length($body);

    my $flags = ( ( !!$self->flag_unsynchronization() ) << 7 )
              | ( ( !!$self->flag_extended_header()   ) << 6 )
              | ( ( !!$self->flag_experimental()      ) << 5 );

    return "ID3" . pack( "CCCN", 3, 0, $flags, MungeSize($size) ) . $body;
}

####
# Set the amount of nul-padding to add at the end of the tag, in bytes.
####
sub set_padding_size {
    my ( $self, $size ) = @_;

    $self->{PADDING_SIZE} = $size;
    $self->flag_extended_header(1) if ($size);

    # remember that the user set the padding, so we don't try to maintain
    # the same tag size in as_string()
    $self->{MANUAL_PADDING} = 1;
}

####
# Perform "unsynchronization" on the data.  This takes things that
# look like mpeg syncs, 11111111 111xxxxx, and stuffs a zero
# in between the bytes.  In addition, it stuffs a zero after every
# ff 00 combination.
#
# Note that this is A.F.U., because the standard doesn't say to stuff
# an extra zero in 11111111 00000000 111xxxxx.  It says to stuff it
# after 11111111 00000000.  That's broken.  Seems to be what id3lib
# does also, though.
#
####
sub unsynchronize {
    my ($data) = @_;

    # zero stuff after ff 00
    $data =~ s/\xff\0/\xff\0\0/g;

    # zero stuff between 11111111 111xxxxx
    $data =~ s/\xff(?=[\xe0-\xff])/\xff\x00/g;

    return $data;
}

####
# Reverse the unsyncrhonization process.
####
sub un_unsynchronize {
    my ($data) = @_;

    $data =~ s/\xff\x00([\xe0-\xff])/\xff$1/g;
    $data =~ s/\xff\x00\x00/\xff\x00/g;

    return $data;
}

####
# Return all the formatted frames as a big binary string.
####
sub data_as_string {
    my $self = shift;

    my $data = "";

    for my $frame (@{ $self->frames() }) {
        $data .= $frame->as_string();
    }

    return $data;
}

####
# Add a new frame's data to the id3 tag.
#  You can either call this with an MPEG::ID3Frame object, or you can
# call it with a four-letter frame ID code plus arguments.
# If you send the frame code, add_frame will go looking for
# a new() method in the package MPEG::ID3Frame:: and call
# it with the specified arguments.
#
# Returns the frame that was added.
####
sub add_frame {
    my ( $self, $frame, @args ) = @_;

    if ( length($frame) == 4 && @args ) {
        # they passed us a frame id and constructor arguments.
        # Construct an object of the appropriate type and make it format
        # its data.

        my $frameid = $frame;
        my $package = "MPEG::ID3Frame::$frameid";

        if ( !$package->can("new") ) {
            croak "Frame type $frameid is not implemented";
        }

        eval { $frame = $package->new(@args) };
        if ($@) {
            chomp $@;    # trailing newline.
            $@ =~ s/ at.*$//;    # at file line#
            croak $@ ;
        }
    }

    if ( !$frame->isa("MPEG::ID3Frame") ) {
        croak "strange arguments to append_frame()";
    }

    push @{ $self->{FRAMES} }, $frame;

    return $frame;
}

####
# Find a frame by frame id.
# In list context, returns all the matching frames.
# In scalar context, returns just the first match.
####
sub get_frame {
    my ( $self, $frameid ) = @_;

    my @frames = grep { $_->frameid() eq $frameid } $self->frames();

    if (wantarray) {
        return @frames;
    }
    else {
        return $frames[0];
    }
}

# create a bunch of flag routines
for my $flag (qw(unsynchronization extended_header experimental)) {
    eval <
  sub flag_$flag
  {
    my \$self = shift ;
    if (\@_) {
      # there was a parameter
      \$self->{FLAGS}{"$flag"} = \$_[0] ;
    }

    return \$self->{FLAGS}{"$flag"} ;
  }
EOT
    die $@ if $@;
}

####
# Given an open filehandle, parse out the ID3 tag, if any.
# Constructs a new tag object (it's a static method).
####
sub parse {
    my ( $package, $fh ) = @_;

    my $tag = {};
    my $str;

    my ( $header, $data, $place );

    if ( ( ref $fh ) eq 'GLOB' ) {
        my $readlen = read( $fh, $header, 10 );
        croak "$!"   if !defined $readlen;
        if ($readlen < 10) {
            carp "Read less than 10 bytes";
            return undef;
        }
    }
    else {    ##not a filehandle. asume its a scalar
        $place = index( $fh, "ID3" );    ##the real start of the ID3 Tag!!
        if ($place < 0) {
            carp "'ID3' not found in header";
            return undef;
        }
        $header = substr( $fh, $place, 10 );
    }

    my ( $id3, $flags, $totalsize );

    ( $id3, $tag->{MAJORVER}, $tag->{MINORVER}, $flags, $totalsize )
        = unpack( "a3CCCN", $header );

    $totalsize = UnMungeSize($totalsize);
    $tag->{ORIGINAL_SIZE} = $totalsize;

    if ($id3 ne 'ID3') {
        carp "Header does not begin with 'ID3'";
        return undef;
    }
    if ($tag->{MAJORVER} < 3) {
        carp "ID3 tag version is 2.$tag->{MAJORVER}.$tag->{MINORVER}, less than 2.3.0";
        return undef;
    }

    bless $tag, $package;

    $tag->flag_unsynchronization( ( $flags >> 7 ) & 1 );
    $tag->flag_extended_header(   ( $flags >> 6 ) & 1 );
    $tag->flag_experimental(      ( $flags >> 5 ) & 1 );

    if ( ( ref $fh ) eq 'GLOB' ) {
        my $len = 0;

        while ( $len < $totalsize ) {
            my $readlen = read( $fh, $data, $totalsize - $len, $len );
            croak "$!" if !defined $readlen;
            last       if $readlen == 0;
            $len += $readlen;
        }
    }
    else {
        # easier if not a filehandle
        $data = substr( $fh, $place + 10, $totalsize );
    }

    # now we have all the tag data, minus the main header, in $data.
    $data = un_unsynchronize($data) if $tag->flag_unsynchronization();

    # if there's an extended header, peel it off the front of the data
    # and parse it.
    if ( $tag->flag_extended_header() ) {
        # peel off the header size
        $str = substr( $data, 0, 4, "" );
        my $extheader_size = unpack( "N", $str );

        # peel the header
        my $extheader = substr( $data, 0, $extheader_size, "" );
        $str = substr( $extheader, 0, 6, "" );

        # two bytes of flags, then four byte padding size.
        ( $flags, undef, $tag->{PADDING_SIZE} ) = unpack( "CCN", $str );

        # at this point, anything left in the extended header is stuff
        # I don't know what to do with, including maybe a CRC value that I'm
        # ignoring.

        # If there is any padding, strip it off the end of the data
        # and throw it away (it's supposed to be all nuls).

        if ( $tag->{PADDING_SIZE} ) {
            substr( $data, -$tag->{PADDING_SIZE}, $tag->{PADDING_SIZE}, "" );
        }
    }

    # Now data contains just the frames.  If it's id3v2.3 it won't have
    # padding, but if it's id3v2.4, it might.  Parse until the data is
    # empty or all padding.

    while ( $data ne '' and $data !~ /^\0+$/ ) {
        my $frame = MPEG::ID3Frame->parse( \$data, $tag );
        $tag->add_frame($frame);
    }

    # done!

    return $tag;
}

sub UnMungeSize {
    my ($size) = @_;
    my $newsize = 0;

    my $pos;

    for ( $pos = 0; $pos < 4; $pos++ ) {
        my $mask = 0xff << ( $pos * 8 );

        my $val = ( $size & $mask ) >> ( $pos * 8 );

        $newsize |= $val << ( $pos * 7 );
    }

    return $newsize;
}

# Takes an integer and returns an ID3 size field
sub MungeSize {
    my ($size) = @_;

    my $newsize = 0;
    my $pos;

    for ( $pos = 0; $pos < 4; $pos++ ) {
        my $val = ( $size >> ( $pos * 7 ) ) & 0x7f;
        $newsize |= $val << ( $pos * 8 );
    }

    return $newsize;
}

sub dump {
    my $self = shift;

    print "----Frames:\n";

    for my $frame ( $self->frames() ) {
        $frame->dump();
    }
}

###############################################################################
#  MPEG::ID3Frame
#
#  This is a base class from which other classes need to be derived.
# To implement a particular frame type, such as UFID, create a new
# class MPEG::ID3Frame::UFID (or whatever), and follow the directions
# in the pod.
#
# See the pod for what this class can do.
#
##############################################################################
package MPEG::ID3Frame;
use Carp;

# DO NOT WRITE A new() METHOD FOR THIS CLASS!

####
# This is just a placeholder.  In derived classes this would return
# the four-letter id code for the frame type.
####
sub frameid {
    my $self = shift;
    return $self->{FRAMEID} if ( $self->{FROM_PARSER} );
    confess "Must get frameid() from a derived class";
}

####
# Format the entire frame as a string ready for output to the file.
####
sub as_string {
    my $self = shift;
    my $data = $self->data_as_string();

    if ( $self->flag_encryption || $self->flag_grouping_identity ) {
        # these extend the headers.
        carp "unsupported flag used, header will be wrong.";
    }

    # The musicmatch id3lib doesn't munge frame header sizes.
    # That seems to be correct.
    # Only the ID3 header itself needs to take care to avoid false
    # syncs, because the body is handled by the unsync. scheme.

    if ( $self->flag_compression && !exists $self->{UNSUPPORTED_BODY} ) {
        # require Compress::Zlib here so the module stays functional
        # without it.

        require Compress::Zlib;
        Compress::Zlib->import( "compress", "uncompress" );

        my $compressed_data = compress($data);

        croak "Error in Compress::Zlib::compress"
            if !defined $compressed_data;

        return $self->frameid()
            . pack( "N", 4 + length($compressed_data) ) # 4 is for "N" length $data
            . $self->flags_as_string()
            . pack( "N", length($data) )
            . $compressed_data;
    }
    else {
        return $self->frameid()
            . pack( "N", length($data) )
            . $self->flags_as_string
            . $data;
    }
}

####
# Return the data as a binary string.
# This private method must be overridden in a derived class.
####
sub data_as_string {
    my $self = shift;

    if ( $self->{FROM_PARSER} && exists $self->{UNSUPPORTED_BODY} ) {
        return $self->{UNSUPPORTED_BODY};
    }

    confess "Must get data_as_string from a derived class";
}

####
#  Return true iff the parsing module was able to fully parse this
# object so the data is useful.
#
# It could return false for any number of reasons, generally either
# an unsupported frame or an unsupported feature like compression
# or encryption.
####
sub fully_parsed {
    my $self = shift;
    return !exists( $self->{UNSUPPORTED_BODY} );
}

# create flag get/set subroutines for supported frame flags.
my @flags = qw(
    tag_alter file_alter read_only compression encryption
    grouping_identity
);

for my $flag (@flags) {
    eval <<"EOT" ;
    sub flag_$flag {
      my (\$self, \$value) = \@_ ;
      if (defined \$value) {
	\$self->{FLAGS}{"$flag"} = \$value ;
      } else {
	return \$self->{FLAGS}{"$flag"} ;
      }
    }
EOT
    die $@ if $@;
}

####
# Some tags require a default of 1 for the file_alter flag.
# This function gets exported as flag_file_alter to those packages in
# the for loop below this.
####
sub flag_file_alter_default_1 {
    my ( $self, $value ) = @_;

    if ( defined $value ) {
        $self->{FLAGS}{"flag_file_alter"} = $value;
    }
    else {
        if ( exists $self->{FLAGS}{"flag_file_alter"} ) {
            return $self->{FLAGS}{"flag_file_alter"};
        }
        else {
            return 1;
        }
    }
}

# According to section 3.3.2 of the informal v2.3.0 spec, these frames
# need to default to discarded-if-file-altered = 1, so override the
# flag_file_alter method for those frames to the right default.
my @frameids = qw(
    AENC ETCO EQUA MLLT POSS SYLT SYTC RVAD TENC TLEN TSIZ
);

for my $frameid (@frameids) {
    # perl magic to stick a reference to a subroutine into a package's
    # symbol table as a different subroutine name.  Scary stuff, but
    # better than evaling in 11 new copies of the same function,
    # and safer than another layer of inheritance.
    no strict 'refs';

    *{"MPEG::ID3Frame::${frameid}::flag_file_alter"}
        = \&flag_file_alter_default_1;
}

####
# Return the header flags as a binary string.
# Private method.
####
sub flags_as_string {
    my $self = shift;

    my ( $byte0, $byte1 );

    $byte0 = ( $self->flag_tag_alter()  << 7 )
           | ( $self->flag_file_alter() << 6 )
           | ( $self->flag_read_only()  << 5 );
    $byte1 = ( $self->flag_compression()       << 7 )
           | ( $self->flag_encryption()        << 6 )
           | ( $self->flag_grouping_identity() << 5 );
    return pack( "CC", $byte0, $byte1 );
}

####
# Static method/ctor to parse the frame from the front of a string
# and return an appropriate MPEG::ID3Frame::* object.
# A reference to the binary string is passed in, and the data
# is peeled from the front of that string.
#
# Actually calls MPEG::ID3Frame::::parse_data to do the
# frame data parsing.  Headers here, data there.
####
sub parse {
    my ( $package, $dataref, $tag ) = @_;
    my $self = { FROM_PARSER => 1 };
    my ( $body, $original_body );
    my $tmp;
    bless $self, $package;

    my $header = substr( $$dataref, 0, 10, "" );
    my ( $frameid, $size, $flags0, $flags1 ) = unpack( "a4NCC", $header );
    $self->{FRAMEID} = $frameid;

    if ( defined $tag and $tag->{MAJORVER} == 4 ) {
        $size = MPEG::ID3v2Tag::UnMungeSize($size);
    }

    $self->flag_tag_alter(  ( $flags0 >> 7 ) & 1 );
    $self->flag_file_alter( ( $flags0 >> 6 ) & 1 );
    $self->flag_read_only(  ( $flags0 >> 5 ) & 1 );

    $self->flag_compression(       ( $flags1 >> 7 ) & 1 );
    $self->flag_encryption(        ( $flags1 >> 6 ) & 1 );
    $self->flag_grouping_identity( ( $flags1 >> 5 ) & 1 );

    $original_body = $body = substr( $$dataref, 0, $size, "" );

    if ( $self->flag_encryption() || $self->flag_grouping_identity() ) {
        # we don't know how to parse this field because we don't support
        # encryption.  We will still return the frame, and
        # it will still be output ok.  We just can't do anything with the
        # data contained.

        $self->{UNSUPPORTED_BODY}   = $original_body;
        $self->{UNSUPPORTED_REASON} = "Unsupported flag";
        return $self;
    }

    if ( $self->flag_compression() ) {
        eval {
            require Compress::Zlib;
            Compress::Zlib->import( "compress", "uncompress" );
        };
        if ($@) {
            $self->{UNSUPPORTED_BODY}   = $original_body;
            $self->{UNSUPPORTED_REASON} = $@;
            return $self;
        }

        # four bytes after header are actually uncompressed data size.
        $tmp = substr( $body, 0, 4, "" );
        my $uc_size = unpack( "N", $tmp );

        $body = uncompress($body);
        if ( !defined $body || length($body) != $uc_size ) {
            $self->{UNSUPPORTED_BODY} = $original_body;
            if ( defined $body ) {
                $self->{UNSUPPORTED_REASON} = "compress size mismatch";
            }
            else {
                $self->{UNSUPPORTED_REASON} = "zlib compress error";
            }
            return $self;
        }
    }

    # now we've stripped away all the headers and we can attempt to
    # parse the body.

    # Look in MPEG::ID3Frame:: for a parse_data method.
    # if there is one, rebless this frame object into that package
    # and call the method.

    my $frame_package = "MPEG::ID3Frame::$frameid";
    if ( $frame_package->can("parse_data") ) {
        bless $self, $frame_package;
        $self->parse_data($body);

        if ( $self->{UNSUPPORTED_BODY} ) {
            # the frame's parse_data set up an UNSUPPORTED_BODY,
            # which means they got some kind of error and they couldn't
            # complete the parse.

            # That means they really aren't a MPEG::ID3Frame::$frameid,
            # they're a generic frame, so re-rebless them back to
            # the generic frame package.
            bless $self, $package;

            # and they wouldn't know if we had passed them something
            # that was originally compressed, so we'll use the body
            # we started with rather than the one they gave us back.
            # so it'll still be compressed on output.
            $self->{UNSUPPORTED_BODY} = $original_body;

            # but we'll keep their reason, whatever that was.
        }

    }
    else {
        $self->{UNSUPPORTED_BODY} = $original_body;
        $self->{UNSUPPORTED_REASON} = "No MPEG::ID3Frame::$frameid parse_data method";
    }

    return $self;
}

sub dump {
    my $self = shift;

    if ( $self->{UNSUPPORTED_BODY} ) {
        my $reason = $self->{UNSUPPORTED_REASON};
        print $self->frameid(), " (unparsed: $reason)\n";
    }
    else {
        print $self->frameid(), " (no dump method)\n";
    }
}

###############################################################################
# MPEG::ID3Frame::Text
#    MPEG::ID3Frame::TALB
#    MPEG::ID3Frame::TBPM
#    MPEG::ID3Frame::TCOM
#                ... and so on for all T??? frame types.
#
#  This class is derived from MPEG::ID3Frame, and from this is derived all the
# MPEG::ID3Frame::T??? fields.   It is not useful on its own.
#
# This section of the file will also create derived classes for all the
# Text types (TALB, TBPM, etc).  Note that TEXT is not the same as Text.
###############################################################################
package MPEG::ID3Frame::Text;
use Carp;

use vars '@ISA';

@ISA = qw(MPEG::ID3Frame);

sub new {
    my $package = shift;
    my $self;
    if ( @_ == 1 ) {
        $self = {
            ENCODING => 0,
            DATA     => $_[0]
        };
    }
    elsif ( @_ == 2 ) {
        $self = {
            ENCODING => $_[0],
            DATA     => $_[1]
        };
    }
    else {
        croak "Wrong # arguments to MPEG::ID3Frame::Text::new\n";
    }
    bless $self, $package;
}

####
# Given the body portion of a text-type tag, parse out the encoding and data
# portions.
####
sub parse_data {
    my ( $self, $data ) = @_;

    #  ($self->{ENCODING}, $self->{DATA}) = unpack("CZ*", $data) ;
    $self->{ENCODING} = unpack( "C", substr( $data, 0, 1 ) );

    if ( $self->{ENCODING} == 0 ) {
        $self->{DATA} = unpack( "Z*", substr( $data, 1 ) );
    }
    elsif ( $self->{ENCODING} == 1 ) {    ##with BOM
        ######## a really dirty hack to change the UNICODE to normal ISO-8859-1  this will of course
        ######## destroy the real unicode. so no need to write a UNICODE back to file
        my @text_as_list;
        $self->{BOM} = unpack( "n", substr( $data, 1, 2 ) );
        if ( $self->{BOM} == 0xfeff ) {
            @text_as_list = unpack( "n*", substr( $data, 3 ) );
        }
        else {
            @text_as_list = unpack( "v*", substr( $data, 3 ) );
        }
        $self->{DATA} = pack( "C*", @text_as_list );
        $self->{ENCODING} = 0;    ## now
    }
    elsif ( $self->{ENCODING} == 2 ) {    #no BOM here   ##never tested
        ######## a really dirty hack to change the UNICODE to normal ISO-8859-1  this will of course
        ######## destroy the real unicode. so no need to write a UNICODE back to file

        ## I hope this n is working for ENCODING type 2. else change to back to v like type 1
        my @text_as_list;
        @text_as_list = unpack( "v*", substr( $data, 1 ) );
        $self->{DATA} = pack( "C*", @text_as_list );
        $self->{ENCODING} = 0;    ## now
    }
    elsif ( $self->{ENCODING} == 3 ) {    ##never tested
        my @text_as_list;
        @text_as_list = unpack( "U*", substr( $data, 1 ) );
        $self->{DATA} = pack( "C*", @text_as_list );
        $self->{ENCODING} = 0;    ## now
    }
}

sub encoding { return $_[0]->{ENCODING} }
sub text     { return $_[0]->{DATA} }

####
# Override for MPEG::ID3Frame::frameid().  returns the frame id, the
# four-letter word identifying the frame type.
####
sub frameid {
    my ($self) = @_;
    my $frameid = ref $self;
    $frameid =~ s/^.*:://;
    if ( $frameid eq 'Text' || $frameid eq 'Url' ) {
        confess "Must get frameid() from a derived class";
    }
    return $frameid;
}

####
# Return the data portion of this frame, formatted as a binary string.
####
sub data_as_string {
    my ($self) = @_;

    # zero for encoding=latin-1, and the rest is just the text, nul-terminated.
    return pack( "CZ*", $self->{ENCODING}, $self->{DATA} );
}

sub dump {
    my $self = shift;
    print $self->frameid(), " (enc=", $self->encoding, ") ", $self->text, "\n";
}

# automatically derive a ton of classes from this one.
my @derived_frameids = qw(
    TALB TBPM TCOM TCON TCOP TDAT TDLY TENC TEXT TFLT TIME TIT1 TIT2
    TIT3 TKEY TLAN TLEN TMED TOAL TOFN TOLY TOPE TORY TOWN TPE1 TPE2
    TPE3 TPE4 TPOS TPUB TRCK TRDA TRSN TRSO TSIZ TSRC TSSE TYER
);

my $evalstr;
for my $frameid (@derived_frameids) {
    $evalstr .= <
    \@MPEG::ID3Frame\::$frameid\::ISA = qw(MPEG::ID3Frame::Text) ;
EOT
}

eval $evalstr;
die $@ if $@;
undef $evalstr;

###############################################################################
# MPEG::ID3Frame::Url
#    MPEG::ID3Frame::WCOM
#    MPEG::ID3Frame::WCOP
#    MPEG::ID3Frame::WOAF
#                ... and so on for all W??? frame types.
#
#  This class is derived from MPEG::ID3Frame, and from this is derived all the
# MPEG::ID3Frame::W??? fields.   It is not useful on its own.
#
# It steals its new and frameid() methods from ::Text.  That's kinda
# sloppy; they should both derive from some class.
#
# This section of the file will also create derived classes for all the
# URL types (WCOM, WCOP, etc).
###############################################################################
package MPEG::ID3Frame::Url;
use Carp;

use vars '@ISA';

@ISA = qw(MPEG::ID3Frame::Text);

####
# Return the data portion of this frame, formatted as a binary string.
####
sub data_as_string {
    my ($self) = @_;

    return $self->{DATA} . "\0";
}

####
# Given the body portion of a text-type tag, parse out the encoding and data
# portions.
####
sub parse_data {
    my ( $self, $data ) = @_;

    ( $self->{DATA} ) = unpack( "Z*", $data );
}

sub url { return $_[0]->{DATA} }

sub dump {
    my $self = shift;
    print $self->frameid(), " ", $self->url(), "\n";
}

# automatically derive a bunch of classes from this one.
for my $frameid (qw(WCOM WCOP WOAF WOAR WOAS WORS WPAY WPUB)) {
    $evalstr .= <
    \@MPEG::ID3Frame\::$frameid\::ISA = qw(MPEG::ID3Frame::Url) ;
EOT
}

#print $evalstr ;
eval $evalstr;
die $@ if $@;
undef $evalstr;

##############################################################################
# MPEG::ID3Frame::UFID
#  Unique file Identifier frame type.
##############################################################################
package MPEG::ID3Frame::UFID;
use vars '@ISA';
@ISA = qw(MPEG::ID3Frame);
use Carp;

sub frameid () { return "UFID" }

sub new {
    my ( $package, $owner_id, $id ) = @_;
    my $self = {
        OWNER_ID => $owner_id,
        ID       => $id
    };
    bless $self, $package;
}

sub data_as_string {
    my $self = shift;

    return $self->{OWNER_ID} . "\0" . $self->{ID};
}

##############################################################################
# MPEG::ID3Frame::USLT
#  Unsynchronized lyrics/text transcription frame.
##############################################################################
package MPEG::ID3Frame::USLT;
use Carp;
use vars '@ISA';
@ISA = qw(MPEG::ID3Frame);
use Carp;

sub frameid () { return "USLT" }

sub new {
    my ( $package, $encoding, $language, $content_descriptor, $lyrics ) = @_;
    croak "language must be a three letter code" if length($language) != 3;
    my $self = {
        ENCODING     => $encoding,
        LANGUAGE     => $language,
        CONTENT_DESC => $content_descriptor,
        LYRICS       => $lyrics
    };
    bless $self, $package;
}

sub encoding           { return $_[0]->{ENCODING} }
sub language           { return $_[0]->{LANGUAGE} }
sub content_descriptor { return $_[0]->{CONTENT_DESC} }
sub lyrics             { return $_[0]->{LYRICS} }

sub data_as_string {
    my $self = shift;

    return pack( "Ca3Z*", $self->{ENCODING}, $self->{LANGUAGE}, $self->{CONTENT_DESC} . "\0" )
        . $self->{LYRICS} . "\0";
}

sub parse_data {
    my ( $self, $data ) = @_;

    my $tmp = substr( $data, 0, 4, "" );
    ( $self->{ENCODING}, $self->{LANGUAGE} ) = unpack( "Ca3", $tmp );
    ( $self->{CONTENT_DESC}, $self->{LYRICS} ) = ( $data =~ /^(.*?)\x00(.*)\x00/s );
}

sub dump {
    my $self = shift;
    printf "%s (enc=%d lang=%s desc=%s)\n", $self->frameid(),
        $self->encoding(), $self->language(), $self->content_descriptor();
    my $lyrics = $self->lyrics;
    $lyrics =~ s/^/  | /mg;
    print $lyrics ;
}

##############################################################################
# MPEG::ID3Frame::APIC
#  attached picture.
##############################################################################
package MPEG::ID3Frame::APIC;
use Carp;
use IO::File;
use vars '@ISA';
@ISA = qw(MPEG::ID3Frame);
use Carp;

sub frameid () { return "APIC" }

sub new {
    my $package = shift;
    my $self    = {
        PICTURETYPE => 0,
        ENCODING    => 0,
        DESCRIPTION => " "
    };
    my $fh;
    my $fname;

    while ( @_ && $_[0] =~ /^-/ ) {
        my $arg = shift;
        if ( $arg =~ /^-encoding/ ) {
            $self->{ENCODING} = shift(@_);
        }
        elsif ( $arg =~ /^-mime/ ) {
            $self->{MIMETYPE} = shift(@_)
                || croak "bad argument to -mimetype";
        }
        elsif ( $arg =~ /^-picture_type/ || $arg =~ /-type/ ) {
            $self->{PICTURETYPE} = shift(@_);
        }
        elsif ( $arg =~ /^-desc/ ) {
            $self->{DESCRIPTION} = shift(@_);
        }
        elsif ( $arg =~ /^-fh/ ) {
            $fh = shift(@_) || croak "bad argument to -fh";
        }
        elsif ( $arg =~ /^-fn/ || $arg =~ /^-file/ ) {
            $fname = shift(@_) || croak "bad argument to $arg";
        }
        elsif ( $arg =~ /^-data/ || $arg =~ /^-data/ ) {
            $self->{DATA} = shift(@_) || croak "bad argument to $arg";
        }
        else {
            croak "unknown switch $arg";
        }
    }
    croak "bad arguments to APIC" if @_;

    if ( !exists $self->{MIMETYPE} ) {
        if ($fname) {
            if ( $fname =~ /\.gif$/i ) {
                $self->{MIMETYPE} = "image/gif";
            }
            elsif ( $fname =~ /\.jpg/ ) {
                $self->{MIMETYPE} = "image/jpeg";
            }
        }
    }
    if ( !exists $self->{MIMETYPE} ) {
        croak "must specify a -mimetype";
    }

    if ( !exists $self->{DATA} ) {
        if ( !defined $fh ) {
            croak "must specify -data, -file, or -fh" if ( !defined $fname );
            $fh = IO::File->new("<$fname") || croak "$fname: $!\n";
        }
        local $/ = undef;    # file slurp mode
        $self->{DATA} = <$fh>;
    }

    bless $self, $package;
}

sub data_as_string {
    my $self = shift;

    my $data = pack( "CZ*", $self->{ENCODING}, $self->{MIMETYPE} )
        . pack( "CZ*", $self->{PICTURETYPE}, $self->{DESCRIPTION} )
        . $self->{DATA};

    return $data;
}

##############################################################################
# MPEG::ID3Frame::USER
#  terms of use frame.
##############################################################################
package MPEG::ID3Frame::USER;
use Carp;
use vars '@ISA';
@ISA = qw(MPEG::ID3Frame);
use Carp;

sub frameid () { return "USER" }

sub new {
    my ( $package, $encoding, $language, $text ) = @_;
    croak "language must be a three letter code" if length($language) != 3;
    my $self = {
        ENCODING => $encoding,
        LANGUAGE => $language,
        TEXT     => $text
    };
    bless $self, $package;
}

sub data_as_string {
    my $self = shift;

    return pack( "Ca3a*", $self->{ENCODING}, $self->{LANGUAGE}, $self->{TEXT} );
}

##############################################################################
# MPEG::ID3Frame::COMM
#  comment frame.
##############################################################################
package MPEG::ID3Frame::COMM;
use Carp;
use vars '@ISA';
@ISA = qw(MPEG::ID3Frame);
use Carp;

sub frameid () { return "COMM" }

sub new {
    my ( $package, $encoding, $language, $description, $text ) = @_;
    croak "language must be a three letter code" if length($language) != 3;
    my $self = {
        ENCODING    => $encoding,
        LANGUAGE    => $language,
        DESCRIPTION => $description,
        TEXT        => $text
    };
    bless $self, $package;
}

sub parse_data {
    my ( $self, $data ) = @_;

    ( $self->{ENCODING}, $self->{LANGUAGE} ) = unpack( "Ca3", substr( $data, 0, 4 ) );

    my $textpos = index( $data, "\0", 4 ) + 1;
    my $desc = substr( $data, 4, $textpos - 5 );
    my $text = substr( $data, $textpos );

    if ( $self->{ENCODING} == 0 ) {
        $self->{DESCRIPTION} = $desc;
        $self->{TEXT}        = $text;
    }
    elsif ( $self->{ENCODING} == 1 ) {    ##with BOM
        ######## a really dirty hack to change the UNICODE to normal ISO-8859-1  this will of course
        ######## destroy the real unicode. so no need to write a UNICODE back to file
        my @text_as_list_t;
        my @text_as_list_d;

        $self->{BOM} = unpack( "n", substr( $data, 1, 2 ) );
        if ( $self->{BOM} == 0xfeff ) {
            @text_as_list_t = unpack( "n*", substr( $text, 2 ) );
            @text_as_list_d = unpack( "n*", substr( $desc, 2 ) );
        }
        else {
            @text_as_list_t = unpack( "v*", $text );
            @text_as_list_d = unpack( "v*", $desc );
        }
        $self->{DESCRIPTION} = pack( "C*", @text_as_list_d );
        $self->{TEXT}        = pack( "C*", @text_as_list_t );
        $self->{ENCODING} = 0;    ## now
    }

}

sub data_as_string {
    my $self = shift;

    return pack( "Ca3a*", $self->{ENCODING}, $self->{LANGUAGE}, $self->{DESCRIPTION} . "\0" . $self->{TEXT} );
}

##############################################################################
# MPEG::ID3Frame::WXXX
#  User defined URL link frame
##############################################################################
package MPEG::ID3Frame::WXXX;
use Carp;
use vars '@ISA';
@ISA = qw(MPEG::ID3Frame);
use Carp;

sub frameid () { return "WXXX" }

sub new {
    my ( $package, $encoding, $description, $url ) = @_;
    my $self = {
        ENCODING    => $encoding,
        DESCRIPTION => $description,
        URL         => $url
    };
    bless $self, $package;
}

sub parse_data {
    my ( $self, $data ) = @_;
    my $desc_url;

    ( $self->{ENCODING}, $desc_url ) = unpack( "Ca*", $data );
    ( $self->{DESCRIPTION}, $self->{URL} ) = split( "\0", $desc_url );
}

sub encoding    { return $_[0]->{ENCODING} }
sub description { return $_[0]->{DESCRIPTION} }
sub url         { return $_[0]->{URL} }

sub data_as_string {
    my $self = shift;

    return pack( "Ca*", $self->{ENCODING}, $self->{DESCRIPTION} . "\0" . $self->{URL} );
}

##############################################################################
# MPEG::ID3Frame::TXXX
#  User defined text frame
##############################################################################
package MPEG::ID3Frame::TXXX;
use Carp;
use vars '@ISA';
@ISA = qw(MPEG::ID3Frame);
use Carp;

sub frameid () { return "TXXX" }

sub new {
    my ( $package, $encoding, $description, $data ) = @_;
    my $self = {
        ENCODING    => $encoding,
        DESCRIPTION => $description,
        DATA        => $data
    };
    bless $self, $package;
}

sub parse_data {
    my ( $self, $data ) = @_;
    my $desc_data;

    ( $self->{ENCODING}, $desc_data ) = unpack( "Ca*", $data );
    ( $self->{DESCRIPTION}, $self->{DATA} ) = split( "\0", $desc_data );
}

sub encoding    { return $_[0]->{ENCODING} }
sub description { return $_[0]->{DESCRIPTION} }
sub text        { return $_[0]->{DATA} }

sub data_as_string {
    my $self = shift;

    return pack( "Ca*", $self->{ENCODING}, $self->{DESCRIPTION} . "\0" . $self->{DATA} );
}

1;

__END__