File Coverage

blib/lib/MP3/Tag/ID3v2.pm
Criterion Covered Total %
statement 723 1069 67.6
branch 409 726 56.3
condition 184 398 46.2
subroutine 53 86 61.6
pod 35 68 51.4
total 1404 2347 59.8


line stmt bran cond sub pod time code
1             package MP3::Tag::ID3v2;
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 6     6   40 use strict;
  6         7  
  6         148  
10 6     6   19 use File::Basename;
  6         7  
  6         455  
11             # use Compress::Zlib;
12              
13 6         60073 use vars qw /%format %long_names %res_inp @supported_majors %v2names_to_v3
14             $VERSION @ISA %field_map %field_map_back %is_small_int
15             %back_splt %embedded_Descr
16 6     6   44 /;
  6         6  
17              
18             $VERSION = "1.14";
19             @ISA = 'MP3::Tag::__hasparent';
20              
21             my $trustencoding = $ENV{MP3TAG_DECODE_UNICODE};
22             $trustencoding = 1 unless defined $trustencoding;
23              
24             my $decode_utf8 = $ENV{MP3TAG_DECODE_UTF8};
25             $decode_utf8 = 1 unless defined $decode_utf8;
26             my $encode_utf8 = $decode_utf8;
27              
28             =pod
29              
30             =head1 NAME
31              
32             MP3::Tag::ID3v2 - Read / Write ID3v2.x.y tags from mp3 audio files
33              
34             =head1 SYNOPSIS
35              
36             MP3::Tag::ID3v2 supports
37             * Reading of ID3v2.2.0 and ID3v2.3.0 tags (some ID3v2.4.0 frames too)
38             * Writing of ID3v2.3.0 tags
39              
40             MP3::Tag::ID3v2 is designed to be called from the MP3::Tag module. If
41             you want to make calls from user code, please consider using
42             highest-level wrapper code in MP3::Tag, such as update_tags() and
43             select_id3v2_frame_by_descr().
44              
45             Low-level creation code:
46              
47             use MP3::Tag;
48             $mp3 = MP3::Tag->new($filename);
49              
50             # read an existing tag
51             $mp3->get_tags();
52             $id3v2 = $mp3->{ID3v2} if exists $mp3->{ID3v2};
53              
54             # or create a new tag
55             $id3v2 = $mp3->new_tag("ID3v2");
56              
57             See L for information on the above used functions.
58              
59             * Reading a tag, very low-level:
60              
61             $frameIDs_hash = $id3v2->get_frame_ids('truename');
62              
63             foreach my $frame (keys %$frameIDs_hash) {
64             my ($name, @info) = $id3v2->get_frames($frame);
65             for my $info (@info) {
66             if (ref $info) {
67             print "$name ($frame):\n";
68             while(my ($key,$val)=each %$info) {
69             print " * $key => $val\n";
70             }
71             } else {
72             print "$name: $info\n";
73             }
74             }
75             }
76              
77             * Adding / Changing / Removing a frame in memory (higher-level)
78              
79             $t = $id3v2->frame_select("TIT2", undef, undef); # Very flexible
80              
81             $c = $id3v2->frame_select_by_descr("COMM(fre,fra,eng,#0)[]");
82             $t = $id3v2->frame_select_by_descr("TIT2");
83             $id3v2->frame_select_by_descr("TIT2", "MyT"); # Set/Change
84             $id3v2->frame_select_by_descr("RBUF", $n1, $n2, $n3); # Set/Change
85             $id3v2->frame_select_by_descr("RBUF", "$n1;$n2;$n3"); # Set/Change
86             $id3v2->frame_select_by_descr("TIT2", undef); # Remove
87              
88             * Adding / Changing / Removing a frame in memory (low-level)
89              
90             $id3v2->add_frame("TIT2", "Title of the audio");
91             $id3v2->change_frame("TALB","Greatest Album");
92             $id3v2->remove_frame("TLAN");
93              
94             * Output the modified-in-memory version of the tag:
95              
96             $id3v2->write_tag();
97              
98             * Removing the whole tag from the file
99              
100             $id3v2->remove_tag();
101              
102             * Get information about supported frames
103              
104             %tags = $id3v2->supported_frames();
105             while (($fname, $longname) = each %tags) {
106             print "$fname $longname: ",
107             join(", ", @{$id3v2->what_data($fname)}), "\n";
108             }
109              
110             =head1 AUTHOR
111              
112             Thomas Geffert, thg@users.sourceforge.net
113             Ilya Zakharevich, ilyaz@cpan.org
114              
115             =head1 DESCRIPTION
116              
117             =over 4
118              
119             =item get_frame_ids()
120              
121             $frameIDs = $tag->get_frame_ids;
122             $frameIDs = $tag->get_frame_ids('truename');
123              
124             [old name: getFrameIDs() . The old name is still available, but you should use the new name]
125              
126             get_frame_ids loops through all frames, which exist in the tag. It
127             returns a hash reference with a list of all available Frame IDs. The
128             keys of the returned hash are 4-character-codes (short names), the
129             internal names of the frames, the according value is the english
130             (long) name of the frame.
131              
132             You can use this list to iterate over all frames to get their data, or to
133             check if a specific frame is included in the tag.
134              
135             If there are multiple occurences of a frame in one tag, the first frame is
136             returned with its normal short name, following frames of this type get a
137             '01', '02', '03', ... appended to this name. These names can then
138             used with C to get the information of these frames. These
139             fake frames are not returned if C<'truename'> argument is set; one
140             can still use C to extract the info for all of the frames with
141             the given short name.
142              
143             =cut
144              
145             ###### structure of a tag frame
146             #
147             # major=> Identifies format of frame, normally set to major version of the whole
148             # tag, but many ID3v2.2 frames are converted automatically to ID3v2.3 frames
149             # flags=> Frame flags, depend on major version
150             # data => Data of frame, including gid
151             # gid => group id, if any (created by get_frame())
152             #
153              
154             sub un_syncsafe_4bytes ($) {
155 44     44 0 91 my ($rawsize,$size) = (shift, 0);
156 44         83 foreach my $b (unpack("C4", $rawsize)) {
157 176         153 $size = ($size << 7) + $b;
158             }
159 44         71 return $size;
160             }
161              
162             sub get_frame_ids {
163 131     131 1 109 my $self = shift; # Tag
164 131         85 my $basic = shift;
165              
166             # frame headers format for the different majors
167 131         160 my $headersize = (0,0,6,10,10)[$self->{major}];
168 131         141 my $headerformat=("","","a3a3","a4Nn","a4a4n")[$self->{major}];
169              
170 131 100       188 if (exists $self->{frameIDs}) {
171 72 100       143 return unless defined wantarray;
172 6         6 my %return;
173 6         3 foreach (keys %{$self->{frames}}) {
  6         19  
174 22 50 33     31 next if $basic and length > 4; # ignore frames with 01 etc. at end
175 22         38 $return{$_}=$long_names{substr($_,0,4)};
176             }
177 6         11 return \%return;
178             }
179              
180 59         60 my $pos = $self->{frame_start};
181             # if ($self->{flags}->{extheader}) {
182             # warn "get_frame_ids: possible wrong IDs because of unsupported extended header\n";
183             # }
184 59         43 my $buf;
185 59         118 while ($pos + $headersize < $self->{data_size}) {
186 144         170 $buf = substr ($self->{tag_data}, $pos, $headersize);
187 144         297 my ($ID, $size, $flags) = unpack($headerformat, $buf);
188             # tag size is handled differently for all majors
189 144 50 33     609 if ($self->{major} == 2) {
    50          
    50          
190             # flags don't exist in id3v2.2
191 0         0 $flags=0;
192 0         0 my $rawsize=$size;
193 0         0 $size=0;
194 0         0 foreach (unpack("C3", $rawsize)) {
195 0         0 $size = ($size << 8) + $_;
196             }
197             } elsif ($self->{major} == 4) {
198 0         0 $size = un_syncsafe_4bytes $size;
199             } elsif ($self->{major}==3 and $size>255) {
200             # Size>255 means at least 2 bytes are used for size.
201             # Some programs use (incorectly) for the frame size
202             # the format of the tag size (snchsafe). Trying do detect that here
203 0 0 0     0 if ($pos + $headersize + $size > $self->{data_size} ||
204             !exists $long_names{substr ($self->{tag_data}, $pos+$size,4)}) {
205             # wrong size or last frame
206 0         0 my $fsize = un_syncsafe_4bytes substr $buf, 4, 4;
207 0 0 0     0 if ($pos + 20 + $fsize < $self->{data_size} &&
208             exists $long_names{substr ($self->{tag_data}, $pos+10+$fsize,4)}) {
209 0         0 warn "Probably wrong size format found in frame $ID. Trying to correct it\n";
210             #probably false size format detected, using corrected size
211 0         0 $size = $fsize;
212             }
213             }
214             }
215              
216 144 100       251 if ($ID !~ "\000\000\000") {
217 101         86 my $major = $self->{major};
218 101 50       138 if ($major == 2) {
219             # most frame IDs can be converted directly to id3v2.3 IDs
220 0 0       0 if (exists $v2names_to_v3{$ID}) {
221             # frame is direct convertable to major 3
222 0         0 $ID = $v2names_to_v3{$ID};
223 0         0 $major=3;
224             }
225             }
226 101 100       224 if (exists $self->{frames}->{$ID}) {
227 17         23 ++$self->{extra_frames}->{$ID};
228 17         17 $ID .= '01';
229 17         33 while (exists $self->{frames}->{$ID}) {
230 4         9 $ID++;
231             }
232             }
233              
234             $self->{frames}->{$ID} = {flags=>$self->check_flags($flags),
235             major=>$major,
236 101         156 data=>substr($self->{tag_data}, $pos+$headersize, $size)};
237 101         199 $pos += $size+$headersize;
238             } else { # Padding reached, cut tag data here
239 43         55 last;
240             }
241             }
242 59         63 $self->{endpos} = $pos;
243             # Since tag_data is de-synced, this doesn't count the forced final "\0"
244 59         86 $self->{padding} = length($self->{tag_data}) - $pos;
245             # tag is seperated into frames, tagdata not more needed
246 59         55 $self->{tag_data}="";
247              
248 59         52 $self->{frameIDs} =1;
249 59         52 my %return;
250 59         49 foreach (keys %{$self->{frames}}) {
  59         181  
251 101 50 33     150 next if $basic and length > 4; # ignore frames with 01 etc. at end
252 101         180 $return{$_}=$long_names{substr($_,0,4)};
253             }
254 59         94 return \%return;
255             }
256              
257             *getFrameIDs = \&get_frame_ids;
258              
259             =pod
260              
261             =item get_frame()
262              
263             ($info, $name, @rest) = $tag->get_frame($ID);
264             ($info, $name, @rest) = $tag->get_frame($ID, 'raw');
265              
266             [old name: getFrame() . The old name is still available, but you should use the new name]
267              
268             get_frame gets the contents of a specific frame, which must be specified by the
269             4-character-ID (aka short name). You can use C to get the IDs of
270             the tag, or use IDs which you hope to find in the tag. If the ID is not found,
271             C returns empty list, so $info and $name become undefined.
272              
273             Otherwise it extracts the contents of the frame. Frames in ID3v2 tags can be
274             very small, or complex and huge. That is the reason, that C returns
275             the frame data in two ways, depending on the tag.
276              
277             If it is a simple tag, with only one piece of data, these data is returned
278             directly as ($info, $name), where $info is the text string, and $name is the
279             long (english) name of the frame.
280              
281             If the frame consist of different pieces of data, $info is a hash reference,
282             $name is again the long name of the frame.
283              
284             The hash, to which $info points, contains key/value pairs, where the key is
285             always the name of the data, and the value is the data itself.
286              
287             If the name starts with a underscore (as eg '_code'), the data is probably
288             binary data and not printable. If the name starts without an underscore,
289             it should be a text string and printable.
290              
291             If the second parameter is given as C<'raw'>, the whole frame data is returned,
292             but not the frame header. If the second parameter is C<'intact'>, no mangling
293             of embedded C<"\0"> and trailing spaces is performed. If the second parameter
294             is C<'hash'>, then, additionally, the result is always in the hash format;
295             likewise, if it is C<'array'>, the result is an array reference (with C
296             =E value> pairs same as with C<'hash'>, but ordered as in the frame).
297             If it is C<'array_nokey'>, only the "value" parts are returned (in particular,
298             the result is suitable to give to add_frame(), change_frame()); in addition,
299             if it is C<'array_nodecode'>, then keys are not returned, and the setting of
300             C is ignored. (The "return array" flavors don't massage
301             the fields for better consumption by humans, so the fields should be in format
302             suitable for frame_add().)
303              
304             If the data was stored compressed, it is
305             uncompressed before it is returned (even in raw mode). Then $info contains a string
306             with all data (which might be binary), and $name the long frame name.
307              
308             See also L for a list of all supported frames, and
309             some other explanations of the returned data structure.
310              
311             If more than one frame with name $ID is present, @rest contains $info
312             fields for all consequent frames with the same name. Note that after
313             removal of frames there may be holes in the list of frame names (as in
314             C) in the case when multiple frames of the given
315             type were present; the removed frames are returned as C.
316              
317             ! Encrypted frames are not supported yet !
318              
319             ! Some frames are not supported yet, but the most common ones are supported !
320              
321             =cut
322              
323             sub get_frame {
324 727     727 1 675 my ($self, $fname, $raw) = @_;
325 727 100       1090 $self->get_frame_ids() unless exists $self->{frameIDs};
326 727         696 my ($e, @extra) = 0; # More frames follow?
327             $e = $self->{extra_frames}->{$fname} || 0
328 727 100 100     2037 if wantarray and $self->{extra_frames} and length $fname == 4;
      66        
      100        
329 727         1005 @extra = map scalar $self->get_frame((sprintf "%s%02d", $fname, $_), $raw),
330             1..$e;
331 727         665 $e = grep defined, @extra;
332 727         782 my $frame = $self->{frames}->{$fname};
333 727 100 100     2325 return unless defined $frame or $e;
334 341         442 $fname = substr ($fname, 0, 4);
335 341 100       468 return (undef, $long_names{$fname}, @extra) unless defined $frame;
336 337         234 my $start_offset=0;
337 337 50       541 if ($frame->{flags}->{encryption}) {
338 0         0 warn "Frame $fname: encryption not supported yet\n" ;
339 0         0 return;
340             }
341              
342 337         571 my $result = $frame->{data};
343              
344             # Some frame format flags indicate that additional information fields
345             # are added to the frame. This information is added after the frame
346             # header and before the frame data in the same order as the flags that
347             # indicates them. I.e. the four bytes of decompressed size will precede
348             # the encryption method byte. These additions affects the 'frame size'
349             # field, but are not subject to encryption or compression.
350 337 50       422 if ($frame->{flags}->{groupid}) {
351 0         0 $frame->{gid} = substring $result, 0, 1;
352 0         0 $result = substring $result, 1;
353             }
354              
355 337 50       456 if ($frame->{flags}->{compression}) {
356 0         0 my $usize=unpack("N", $result);
357 0         0 require Compress::Zlib;
358 0         0 $result = Compress::Zlib::uncompress(substr ($result, 4));
359 0 0       0 warn "$fname: Wrong size of uncompressed data\n" if $usize=!length($result);
360             }
361              
362 337 100 100     1057 if (($raw ||= 0) eq 'raw') {
363 2 50       16 return ($result, $long_names{$fname}, @extra) if wantarray;
364 0         0 return $result;
365             }
366              
367 335         453 my $format = get_format($fname);
368 335 50       458 if (defined $format) {
369 335         236 my($as_arr, $nodecode);
370 335 50       416 $as_arr = 2 if $raw eq 'array';
371 335 100 66     883 $as_arr = 1 if $raw eq 'array_nokey' or $raw eq 'array_nodecode';
372 335 50       397 $nodecode = 1 if $raw eq 'array_nodecode';
373 335 100 66     1392 $format = [map +{%$_}, @$format], $format->[-1]{data} = 1
      100        
374             if $raw eq 'intact' or $raw eq 'hash' or $as_arr;
375 335         439 $result = extract_data($self, $result, $format, $nodecode, $as_arr);
376 335 100 66     1139 unless ($as_arr or $raw eq 'hash') {
377 330         479 my $k = scalar keys %$result;
378 330 100       469 $k-- if exists $result->{encoding};
379 330 100       514 if ($k == 1) {
380 129 50       140 if (exists $result->{Text}) {
    0          
    0          
381 129         161 $result = $result->{Text};
382             } elsif (exists $result->{URL}) {
383 0         0 $result = $result->{URL};
384             } elsif ($fname =~ /^MCDI/) { # Per ID3v2_Data.pod
385 0         0 $result = $result->{_Data};
386             } # In fact, no other known frame has one element
387             }
388             }
389             }
390 335 100       456 if (wantarray) {
391 224         722 return ($result, $long_names{$fname}, @extra);
392             } else {
393 111         320 return $result;
394             }
395             }
396              
397             *getFrame= \&get_frame;
398              
399             =item get_frame_descr()
400              
401             $long_name = $self->get_frame_descr($fname);
402              
403             returns a "long name" for the frame (such as C),
404             appropriate for interpolation, or for frame_select_by_descr().
405              
406             =item get_frame_descriptors()
407              
408             @long_names = $self->get_frame_descriptors();
409              
410             return "long names" for the frames in the tag (see C).
411              
412             =cut
413              
414             sub get_frame_descr {
415 26     26 1 29 my ($self, $fname)=@_;
416 26         33 (undef, my $frame) = $self->get_frames($fname); # Ignore the rest
417 26 50       51 return unless defined $frame;
418 26 100       79 return $fname unless ref $frame;
419 11         12 my $k = scalar keys %$frame;
420 11 50 33     44 if ($k == 5 and substr($fname, 0, 4) eq 'APIC') {
421             return $fname unless
422 11 50       22 $frame->{'MIME type'} eq $self->_Data_to_MIME($frame->{_Data});
423 11         15 delete $frame->{'MIME type'};
424 11         8 $k--;
425 11         17 $frame->{Language} = delete $frame->{'Picture Type'};
426             }
427 11 50       18 return $fname unless $k <= 4; # encoding, Language, Description + 1
428 11 50       17 $k-- if exists $frame->{encoding};
429 11 50       14 return $fname unless $k <= 3;
430 11         15 my $l = delete $frame->{Language};
431 11 50       15 $k-- if defined $l;
432 11 50       14 return $fname unless $k <= 2;
433 11         10 my $d = delete $frame->{Description};
434 11 50       14 $k-- if defined $d;
435 11 50       16 return $fname unless $k <= 1;
436 11         29 $fname =~ s/^(\w{4})\d{2}/$1/;
437 11 50       20 $l = "($l)" if defined $l;
438 11 50       15 $d = "[$d]" if defined $d;
439 11   50     16 $l ||= '';
440 11   50     12 $d ||= '';
441 11         39 return "$fname$l$d";
442             }
443              
444             sub get_frame_descriptors {
445 7     7 1 6 my $self = shift;
446 7         10 my $h = $self->get_frame_ids();
447 7         35 map $self->get_frame_descr($_), sort keys %$h;
448             }
449              
450             # I'm not yet ready to freeze these APIs
451             sub __frame_as_printable {
452 0     0   0 my ($self,$descr,$pre,$post,$fsep,$pre_mult,$val_sep, $bin) = (shift, shift, shift, shift, shift, shift, shift, shift);
453 0         0 my $val = $self->frame_select_by_descr($descr);
454             # Simple binary frames:
455 0         0 my $l = length $val;
456 0 0 0     0 return '__binary_DATA__ [len='.length($val).']'
      0        
457             if not $bin and not ref $val and $descr =~ /^(MCDI|APIC)/;
458 0 0       0 return "$pre$val$post" unless ref $val;
459 0         0 my $format = get_format(substr $descr, 0, 4);
460 0         0 my %optnl = map(($_->{name},$_->{optional}), @$format);
461 0         0 my @keys = map $_->{name}, @$format; # In order...
462 0         0 s/^_(?=encoding$)// for @keys; # Reverse mangling by extract_data()...
463 0         0 my %keys = map(($_,1), @keys);
464 0         0 my @ekeys = grep !exists $keys{$_}, keys %$val; # Just in case...
465 0         0 my @miss = grep(!exists $val->{$_}, @keys);
466 0 0       0 @miss = map "$_".($optnl{$_} ? ' [optional]' : ''), @miss;
467 0 0       0 my $miss = @miss ? "${fsep}missing fields: ".(join ', ', @miss)."." : '';
468 0         0 @keys = ( grep(exists $val->{$_}, @keys), sort @ekeys ); # grep: just in case
469 0         0 my %ekeys = map(($_,''), @keys);
470 0         0 @ekeys{@ekeys} = ('?') x @ekeys;
471              
472 0 0       0 return $pre_mult . (join $fsep,
473             map "$ekeys{$_}".sprintf('%-14s',$_)."$val_sep$pre$val->{$_}$post", @keys) . $miss if $bin;
474             $pre_mult . (join $fsep, map "$ekeys{$_}".sprintf('%-14s',$_)."$val_sep"
475 0 0       0 . ( $_ =~ /^_(?!encoding)/ ? '__binary_DATA__ [len='.length($val->{$_}).']'
476             : "$pre$val->{$_}$post" ), @keys) . $miss;
477             }
478              
479             sub __f_long_name ($$) {
480 0     0   0 my ($self,$fr) = (shift, shift);
481 0         0 (my $short = $fr) =~ s/^(\w{4})\d{2,}/$1/;
482 0 0       0 $long_names{$short} || '???';
483             }
484              
485             sub __frames_as_printable {
486 0     0   0 my ($self,$fr_sep,$fn_sep) = (shift, shift, shift);
487 0         0 my $h = $self->get_frame_ids();
488 0         0 join $fr_sep, map sprintf('%-40s',
489             $self->get_frame_descr($_)
490             . " (" . $self->__f_long_name($_) . ")")
491             . $fn_sep . $self->__frame_as_printable($_,@_), sort keys %$h;
492             }
493              
494              
495             =pod
496              
497             =item get_frame_option()
498              
499             $options = get_frame_option($ID);
500              
501             Option is a hash reference, the hash contains all possible options.
502             The value for each option is 0 or 1.
503              
504             groupid -- not supported yet
505             encryption -- not supported yet
506             compression -- Compresses frame before writing tag;
507             compression/uncompression is done automatically
508             read_only -- Ignored by this library, should be obeyed by application
509             file_preserv -- Ignored by this library, should be obeyed by application
510             tag_preserv -- Ignored by this library, should be obeyed by application
511              
512             =cut
513              
514             sub get_frame_option {
515 0     0 1 0 my ($self, $fname)=@_;
516 0 0       0 $self->get_frame_ids() unless exists $self->{frameIDs};
517 0 0       0 return undef unless exists $self->{frames}->{$fname};
518 0         0 return $self->{frames}->{$fname}->{flags};
519             }
520              
521             =pod
522              
523             =item set_frame_option()
524              
525             $options = set_frame_option($ID, $option, $value);
526              
527             Set $option to $value (0 or 1). If successfull the new set of
528             options is returned, undef otherwise.
529              
530             groupid -- not supported yet
531             encryption -- not supported yet
532             compression -- Compresses frame before writing tag;
533             compression/uncompression is done automatically
534             read_only -- Ignored by this library, should be obeyed by application
535             file_preserv -- Ignored by this library, should be obeyed by application
536             tag_preserv -- Ignored by this library, should be obeyed by application
537              
538              
539             =cut
540              
541             sub set_frame_option {
542 0     0 1 0 my ($self, $fname,$option,$value)=@_;
543 0 0       0 $self->get_frame_ids() unless exists $self->{frameIDs};
544 0 0       0 return undef unless exists $self->{frames}->{$fname};
545 0 0       0 if (exists $self->{frames}->{$fname}->{flags}->{$option}) {
546 0 0       0 $self->{frames}->{$fname}->{flags}->{$option}=$value?1:0;
547             } else {
548 0         0 warn "Unknown option $option\n";
549 0         0 return undef;
550             }
551 0         0 return $self->{frames}->{$fname}->{flags};
552             }
553              
554             sub sort_with_apic {
555 72     72 0 155 my ($a_APIC, $b_APIC) = map scalar(/^APIC/), $a, $b;
556 72 100       226 $a_APIC cmp $b_APIC or $a cmp $b;
557             }
558              
559             # build_tag()
560             # create a string with the complete tag data
561             sub build_tag {
562 33     33 0 36 my ($self, $ignore_error) = @_;
563 33         22 my $tag_data;
564              
565             # in which order should the frames be sorted?
566             # with a simple sort the order of frames of one type is the order of adding them
567 33         31 my @frames = sort sort_with_apic keys %{$self->{frames}};
  33         151  
568              
569 33         60 for my $frameid (@frames) {
570 78         80 my $frame = $self->{frames}->{$frameid};
571              
572 78 50       120 if ($frame->{major} < 3) {
573             #try to convert to ID3v2.3 or
574 0         0 warn "Can't convert $frameid to ID3v2.3\n";
575 0 0       0 next if ($ignore_error);
576 0         0 return undef;
577             }
578 78         87 my $data = $frame->{data};
579 78         81 my %flags = ();
580             #compress data if this is wanted
581 78 50 33     241 if ($frame->{flags}->{compression} || $self->{flags}->{compress_all}) {
582 0         0 $flags{compression} = 1;
583 0 0       0 $data = pack("N", length($data)) . compress $data unless $frame->{flags}->{unchanged};
584             }
585              
586             #encrypt data if this is wanted
587 78 50 33     177 if ($frame->{flags}->{encryption} || $self->{flags}->{encrypt_all}) {
588 0 0       0 if ($frame->{flags}->{unchanged}) {
589 0         0 $flags{encryption} = 1;
590             } else {
591             # ... not supported yet
592 0 0       0 return undef unless $ignore_error;
593 0         0 warn "Encryption not supported yet\n";
594             }
595             }
596              
597             # set groupid
598 78 50       98 if ($frame->{flags}->{group_id}) {
599 0 0       0 return undef unless $ignore_error;
600 0         0 warn "Group ids are not supported in writing\n";
601             }
602              
603             # unsync
604 78         58 my $extra = 0;
605 78 50 33     133 if ( ($self->get_config('id3v23_unsync'))->[0]
      33        
606             and ($self->{version} == 3
607             and ($self->get_config('id3v23_unsync_size_w'))->[0]
608             or $self->{version} >= 4) ) {
609 0         0 $extra++ while $data =~ /\xFF(?=[\x00\xE0-\xFF])/g;
610             }
611              
612             #prepare header
613 78         193 my $header = substr($frameid,0,4) . pack("Nn", $extra + length ($data), build_flags(%flags));
614              
615 78         145 $tag_data .= $header . $data;
616             }
617 33         57 return $tag_data;
618             }
619              
620             # insert_space() copies a mp3-file and can insert one or several areas
621             # of free space for a tag. These areas are defined as
622             # ($pos, $old_size, $new_size)
623             # $pos says at which position of the mp3-file the space should be inserted
624             # new_size gives the size of the space to insert and old_size can be used
625             # to skip this size in the mp3-file (e.g if
626             sub insert_space {
627 16     16 0 21 my ($self, $insert) = @_;
628 16         17 my $mp3obj = $self->{mp3};
629             # !! use a specific tmp-dir here
630 16         352 my $tempfile = dirname($mp3obj->{filename}) . "/TMPxx";
631 16         20 my $count = 0;
632 16         225 while (-e $tempfile . $count . ".tmp") {
633 0 0       0 if ($count++ > 999) {
634 0         0 warn "Problems with tempfile\n";
635 0         0 return undef;
636             }
637             }
638 16         25 $tempfile .= $count . ".tmp";
639 16 50       682 unless (open (NEW, ">$tempfile")) {
640 0         0 warn "Can't open '$tempfile' to insert tag\n";
641 0         0 return -1;
642             }
643 16         24 my ($buf, $pos_old);
644 16         23 binmode NEW;
645 16         26 $pos_old=0;
646 16         58 $mp3obj->seek(0,0);
647 16         55 local $\ = '';
648              
649 16         33 foreach my $ins (@$insert) {
650 16 50       33 if ($pos_old < $ins->[0]) {
651 0         0 $pos_old += $ins->[0];
652 0 0       0 while ($mp3obj->read(\$buf,$ins->[0]<16384?$ins->[0]:16384)) {
653 0         0 print NEW $buf;
654 0 0       0 $ins->[0] = $ins->[0]<16384?0:$ins->[0]-16384;
655             }
656             }
657 16         49 for (my $i = 0; $i<$ins->[2]; $i++) {
658 6576         7991 print NEW chr(0);
659             }
660 16 100       46 if ($ins->[1]) {
661 1         2 $pos_old += $ins->[1];
662 1         3 $mp3obj->seek($pos_old,0);
663             }
664             }
665              
666 16         60 while ($mp3obj->read(\$buf,16384)) {
667 16         46 print NEW $buf;
668             }
669 16         369 close NEW;
670 16         39 $mp3obj->close;
671              
672             # rename tmp-file to orig file
673 16 50 33     1749450 unless (( rename $tempfile, $mp3obj->{filename})||
674             (system("mv",$tempfile,$mp3obj->{filename})==0)) {
675 0         0 unlink($tempfile);
676 0         0 warn "Couldn't rename temporary file $tempfile to $mp3obj->{filename}\n";
677 0         0 return -1;
678             }
679 16         92 return 0;
680             }
681              
682             =pod
683              
684             =item get_frames()
685              
686             ($name, @info) = get_frames($ID);
687             ($name, @info) = get_frames($ID, 'raw');
688              
689             Same as get_frame() with different order of the returned values.
690             $name and elements of the array @info have the same semantic as for
691             get_frame(); each frame with id $ID produces one elements of array @info.
692              
693             =cut
694              
695             sub get_frames {
696 303     303 1 902 my ($self, $fname, $raw) = @_;
697 303 100       500 my ($info, $name, @rest) = $self->get_frame($fname, $raw) or return;
698 224         413 return ($name, $info, @rest);
699             }
700              
701              
702             =item as_bin()
703              
704             $tag2 = $id3v2->as_bin($ignore_error, $update_file, $raw_ok);
705              
706             Returns the the current content of the ID3v2 tag as a string good to
707             write to a file; it contains all the necessary footers and headers.
708              
709             If $ignore_error is TRUE, the frames the module does not know how to
710             write are skipped; otherwise it is an error to have such a frame.
711             Returns undef on error.
712              
713             If the optional argument $update_file is TRUE, an additional action is
714             performed: if the audio file does not contain an ID3v2 tag, or the tag
715             in the file is smaller than the built ID3v2 tag, the necessary
716             0-padding is inserted before the audio content of the file so that it
717             is able to accommodate the build tag (and the C field of
718             $id3v2 is updated correspondingly); in any case the header length of
719             $tag2 is set to reflect the space in the beginning of the audio file.
720              
721             Unless $update_file has C<'padding'> as a substring, the actual length of
722             the string $tag2 is not modified, so if it is smaller than the reserved
723             space in the file, one needs to add some 0 padding at the end. Note that
724             if the size of reserved space can shrink (as with C configuration
725             option), then without this option it would be hard to calculate necessary
726             padding by hand.
727              
728             If $raw_ok option is given, but not $update_file, the original contents
729             is returned for unmodified tags.
730              
731             =item as_bin_raw()
732              
733             $tag2 = $id3v2->as_bin_raw($ignore_error, $update_file);
734              
735             same as as_bin() with $raw_ok flag.
736              
737             =item write_tag()
738              
739             $id3v2->write_tag($ignore_error);
740              
741             Saves all frames to the file. It tries to update the file in place,
742             when the space of the old tag is big enough for the new tag.
743             Otherwise it creates a temp file with a new tag (i.e. copies the whole
744             mp3 file) and renames/moves it to the original file name.
745              
746             An extended header with CRC checksum is not supported yet.
747              
748             Encryption of frames and group ids are not supported. If $ignore_error
749             is set, these options are ignored and the frames are saved without these options.
750             If $ignore_error is not set and a tag with an unsupported option should be save, the
751             tag is not written and a 0 is returned.
752              
753             If a tag with an encrypted frame is read, and the frame is not changed
754             it can be saved encrypted again.
755              
756             ID3v2.2 tags are converted automatically to ID3v2.3 tags during
757             writing. If a frame cannot be converted automatically (PIC; CMR),
758             writing aborts and returns a 0. If $ignore_error is true, only not
759             convertable frames are ignored and not written, but the rest of the
760             tag is saved as ID3v2.3.
761              
762             At the moment the tag is automatically unsynchronized.
763              
764             If the tag is written successfully, 1 is returned.
765              
766             =cut
767              
768             sub as_bin_raw ($;$$) {
769 0     0 1 0 my ($self, $ignore_error, $update_file) = @_;
770 0         0 $self->as_bin($ignore_error, $update_file, 1);
771             }
772              
773             sub as_bin ($;$$$) {
774 33     33 1 46 my ($self, $ignore_error, $update_file, $raw_ok) = @_;
775              
776             return $self->{raw_data}
777 33 0 33     57 if $raw_ok and $self->{raw_data} and not $self->{modified} and not $update_file;
      0        
      0        
778              
779             die "Writing of ID3v2.4 is not fully supported (prohibited now via `write_v24').\n"
780 33 50 33     72 if $self->{major} == 4 and not $self->get_config1('write_v24');
781 33 50       56 if ($self->{major} > 4) {
782             warn "Only writing of ID3v2.3 (and some tags of v2.4) is supported. Cannot convert ID3v".
783 0         0 $self->{version}." to ID3v2.3 yet.\n";
784 0         0 return undef;
785             }
786              
787             # which order should tags have?
788              
789 33         51 $self->get_frame_ids;
790 33         61 my $tag_data = $self->build_tag($ignore_error);
791 33 50       59 return unless defined $tag_data;
792              
793             # printing this will ruin flags if they are \x80 or above.
794 33 50       103 die "panic: prepared raw tag contains wide characters"
795             if $tag_data =~ /[^\x00-\xFF]/;
796             # perhaps search for first mp3 data frame to check if tag size is not
797             # too big and will override the mp3 data
798              
799             #ext header are not supported yet
800 33         32 my $flags = chr(0);
801 33 50 33     58 $flags = chr(128) if ($self->get_config('id3v23_unsync'))->[0]
802             and $tag_data =~ s/\xFF(?=[\x00\xE0-\xFF])/\xFF\x00/g; # sync flag
803 33 50 33     127 $tag_data .= "\0" # Terminated by 0xFF?
804             if length $tag_data and chr(0xFF) eq substr $tag_data, -1, 1;
805 33         38 my $n_tsize = length $tag_data;
806              
807 33         31 my $header = 'ID3' . chr(3) . chr(0);
808              
809 33 50       53 if ($update_file) {
810 33         37 my $o_tsize = $self->{buggy_padding_size} + $self->{tagsize};
811 33         26 my $add_padding = 0;
812 33 100 66     98 if ( $o_tsize < $n_tsize
813             or ($self->get_config('id3v2_shrink'))->[0] ) {
814             # if creating new tag / increasing size add at least 128b padding
815             # add additional bytes to make new filesize multiple of 512b
816 19         28 my $mp3obj = $self->{mp3};
817 19         167 my $filesize = (stat($mp3obj->{filename}))[7];
818 19         45 my $extra = ($self->get_config('id3v2_minpadding'))->[0];
819 19         28 my $n_filesize = ($filesize + $n_tsize - $o_tsize + $extra);
820 19         37 my $round = ($self->get_config('id3v2_sizemult'))->[0];
821 19         32 $n_filesize = (($n_filesize + $round - 1) & ~($round - 1));
822 19         20 my $n_padding = $n_filesize - $filesize - ($n_tsize - $o_tsize);
823 19         15 $n_tsize += $n_padding;
824 19 100       38 if ($o_tsize != $n_tsize) {
825 16         37 my @insert = [0, $o_tsize+10, $n_tsize + 10];
826 16 50       35 return undef unless insert_space($self, \@insert) == 0;
827             } else { # Slot is not filled by 0; fill it manually
828 3         4 $add_padding = $n_padding - $self->{buggy_padding_size};
829             }
830 19         47 $self->{tagsize} = $n_tsize;
831             } else { # Include current "padding" into n_tsize
832 14         20 $add_padding = $self->{tagsize} - $n_tsize;
833 14         17 $n_tsize = $self->{tagsize} = $o_tsize;
834             }
835 33 50       61 $add_padding = 0 if $add_padding < 0;
836 33 50       135 $tag_data .= "\0" x $add_padding if $update_file =~ /padding/;
837             }
838              
839             #convert size to header format specific size
840 33         111 my $size = unpack('B32', pack ('N', $n_tsize));
841 33         148 substr ($size, -$_, 0) = '0' for (qw/28 21 14 7/);
842 33         102 $size= pack('B32', substr ($size, -32));
843              
844 33         83 return "$header$flags$size$tag_data";
845             }
846              
847             sub write_tag {
848 33     33 1 300 my ($self,$ignore_error) = @_;
849 33 50       65 $self->fix_frames_encoding()
850             if $self->get_config1('id3v2_fix_encoding_on_write');
851              
852 33         57 $self->get_frame_ids; # Ensure all the reading is done...
853             # Need to do early, otherwise file size for calculation of "best" padding
854             # may not take into account the added ID3v1 tag
855 33         36 my $mp3obj = $self->{mp3};
856 33         69 $mp3obj->close;
857 33 50       67 unless ($mp3obj->open("write")) {
858 0         0 warn "Couldn't open file `",$mp3obj->filename(),"' to write tag!";
859 0         0 return undef;
860             }
861              
862 33         78 my $tag = $self->as_bin($ignore_error, 'update_file, with_padding');
863 33 50       55 return 0 unless defined $tag;
864              
865 33         83 $mp3obj->close;
866 33 50       65 unless ($mp3obj->open("write")) { # insert_space() could've closed the file
867 0         0 warn "Couldn't open file `",$mp3obj->filename(),"' to write tag!";
868 0         0 return undef;
869             }
870              
871             # actually write the tag
872 33         87 $mp3obj->seek(0,0);
873 33         64 $mp3obj->write($tag);
874 33         70 $mp3obj->close;
875 33         78 return 1;
876             }
877              
878             =pod
879              
880             =item remove_tag()
881              
882             $id3v2->remove_tag();
883              
884             Removes the whole tag from the file by copying the whole
885             mp3-file to a temp-file and renaming/moving that to the
886             original filename.
887              
888             Do not use remove_tag() if you only want to change a header,
889             as otherwise the file is copied unnecessarily. Use write_tag()
890             directly, which will override an old tag.
891              
892             =cut
893              
894             sub remove_tag {
895 0     0 1 0 my $self = shift;
896 0         0 my $mp3obj = $self->{mp3};
897 0         0 my $tempfile = dirname($mp3obj->{filename}) . "/TMPxx";
898 0         0 my $count = 0;
899 0         0 local $\ = '';
900 0         0 while (-e $tempfile . $count . ".tmp") {
901 0 0       0 if ($count++ > 999) {
902 0         0 warn "Problems with tempfile\n";
903 0         0 return undef;
904             }
905             }
906 0         0 $tempfile .= $count . ".tmp";
907 0 0       0 if (open (NEW, ">$tempfile")) {
908 0         0 my $buf;
909 0         0 binmode NEW;
910 0         0 $mp3obj->seek($self->{tagsize}+10,0);
911 0         0 while ($mp3obj->read(\$buf,16384)) {
912 0         0 print NEW $buf;
913             }
914 0         0 close NEW;
915 0         0 $mp3obj->close;
916 0 0 0     0 unless (( rename $tempfile, $mp3obj->{filename})||
917             (system("mv",$tempfile,$mp3obj->{filename})==0)) {
918 0         0 warn "Couldn't rename temporary file $tempfile\n";
919             }
920             } else {
921 0         0 warn "Couldn't write temp file\n";
922 0         0 return undef;
923             }
924 0         0 return 1;
925             }
926              
927             =pod
928              
929             =item add_frame()
930              
931             $fn = $id3v2->add_frame($fname, @data);
932              
933             Add a new frame, identified by the short name $fname. The number of
934             elements of array @data should be as described in the ID3v2.3
935             standard. (See also L.) There are two
936             exceptions: if @data is empty, it is filled with necessary number of
937             C<"">); if one of required elements is C, it may be omitted
938             or be C, meaning the arguments are in "Plain Perl (=ISOLatin-1
939             or Unicode) encoding".
940              
941             It returns the the short name $fn (which can differ from
942             $fname, when an $fname frame already exists). If no
943             other frame of this kind is allowed, an empty string is
944             returned. Otherwise the name of the newly created frame
945             is returned (which can have a 01 or 02 or ... appended).
946              
947             You have to call write_tag() to save the changes to the file.
948              
949             Examples (with C<$id3v2-E> omitted):
950              
951             $f = add_frame('TIT2', 0, 'Abba'); # $f='TIT2'
952             $f = add_frame('TIT2', 'Abba'); # $f='TIT201', encoding=0 implicit
953              
954             $f = add_frame('COMM', 'ENG', 'Short text', 'This is a comment');
955              
956             $f = add_frame('COMM'); # creates an empty frame
957              
958             $f = add_frame('COMM', 'ENG'); # ! wrong ! $f=undef, becaues number
959             # of arguments is wrong
960              
961             $f = add_frame('RBUF', $n1, $n2, $n3);
962             $f = add_frame('RBUF', $n1, $n2); # last field of RBUF is optional
963              
964             If a frame has optional fields I C (only C frame
965             as of ID3v2.4), there may be an ambiguity which fields are omitted.
966             It is resolved this way: the C field can be omitted only if
967             all other optional frames are omitted too (set it to C
968             instead).
969              
970             =item add_frame_split()
971              
972             The same as add_frame(), but if the number of arguments is
973             unsufficient, would split() the last argument on C<;> to obtain the
974             needed number of arguments. Should be avoided unless it is known that
975             the fields do not contain C<;> (except for C,
976             where splitting may be done non-ambiguously).
977              
978             # No ambiguity, since numbers do not contain ";":
979             $f = add_frame_split('RBUF', "$n1;$n2;$n3");
980              
981             For C frame, in case when the fields are Ced by C<';'>,
982             C field may be present only if all the other fields are
983             present.
984              
985             =cut
986              
987             # 0 = latin1 (effectively: unknown)
988             # 1 = UTF-16 with BOM (we always write UTF-16le to cowtow to M$'s bugs)
989             # 2 = UTF-16be, no BOM
990             # 3 = UTF-8
991             my @dec_types = qw( iso-8859-1 UTF-16 UTF-16BE utf8 );
992             my @enc_types = qw( iso-8859-1 UTF-16LE UTF-16BE utf8 );
993             my @tail_rex;
994              
995             # Actually, disable this code: it always triggers unsync...
996             my $use_utf16le = $ENV{MP3TAG_USE_UTF_16LE};
997             @enc_types = @dec_types unless $use_utf16le;
998              
999             sub _add_frame {
1000 68     68   130 my ($self, $split, $fname, @data) = @_;
1001 68 100       106 $self->get_frame_ids() unless exists $self->{frameIDs};
1002 68         86 my $format = get_format($fname);
1003 68 50       109 return undef unless defined $format;
1004              
1005             #prepare the data
1006 68         58 my $args = @$format; my $opt = 0;
  68         55  
1007              
1008 68 50       96 unless (@data) {
1009 0         0 @data = map {''} @$format;
  0         0  
1010             }
1011              
1012 68         77 my($encoding, $calc_enc, $e, $e_add) = (0,0); # Need to calculate encoding?
1013             # @data may be smaller than @args due to missing encoding, or due
1014             # to optional arguments. Both may be applicable for COMR frames.
1015 68 100       96 if (@data < $args) {
1016 67   66     280 $_->{optional} and $opt++ for @$format;
1017             $e_add++, unshift @data, undef # Encoding skipped
1018             if (@data == $args - 1 - $opt or $split and @data <= $args - 1 - $opt)
1019 67 100 66     377 and $format->[0]->{name} eq '_encoding';
      66        
1020 67 100       112 if ($opt) { # encoding is present only for COMR, require it
1021             die "Data for `encoding' should be between 0 and 3"
1022 3 50 66     13 if $format->[0]->{name} eq "_encoding"
      33        
1023             and defined $data[0] and not $data[0] =~ /^[0-3]?$/;
1024             }
1025             }
1026 68 100 100     177 if ($split and @data < $args) {
1027 3 100       8 if ($back_splt{$fname}) {
1028 1         3 my $c = $args - @data;
1029 1         2 my $last = pop @data;
1030 1   33     36 my $rx = ($tail_rex[$c] ||= qr/((?:;[^;]*){0,$c})\z/);
1031 1         9 my($tail) = ($last =~ /$rx/); # Will always match
1032 1         2 push @data, substr $last, 0, length($last)-length($tail);
1033 1 50       5 if ($tail =~ s/^;//) { # matched >= 1 times
1034 1         3 push @data, split ';', $tail;
1035             }
1036             } else {
1037 2         3 my $last = pop @data;
1038 2         6 push @data, split /;/, $last, $args - @data;
1039             }
1040             # Allow for explicit specification of encoding
1041             shift @data if @data == $args + 1 and not defined $data[0]
1042 3 0 33     11 and $format->[0]->{name} eq '_encoding'; # Was auto-put there
      33        
1043             }
1044 68 50 33     206 die "Unexpected number of fields: ".@data.", expect $args, optional=$opt"
1045             unless @data <= $args and @data >= $args - $opt;
1046 68 100 66     228 if ($format->[0]->{name} eq "_encoding" and not defined $data[0]) {
1047 65         70 $calc_enc = 1;
1048 65         141 shift @data;
1049             }
1050              
1051 68         69 my ($datastring, $have_high) = "";
1052 68 100       95 if ($calc_enc) {
1053 65         88 my @d = @data;
1054 65         69 foreach my $fs (@$format) {
1055 187 50 66     560 $have_high = 1 if $fs->{encoded} and $d[0] and $d[0] =~ /[^\x00-\xff]/;
      66        
1056 187 100       329 shift @d unless $fs->{name} eq "_encoding";
1057             }
1058             }
1059 68         76 foreach my $fs (@$format) {
1060 196 100 100     341 next if $fs->{optional} and not @data;
1061 193 100       246 if ($fs->{name} eq "_encoding") {
1062 65 50       91 if ($calc_enc) {
1063 65 50       93 $encoding = ($have_high ? 1 : 0); # v2.3 only has 0, 1
1064             } else {
1065 0         0 $encoding = shift @data;
1066             }
1067 65         127 $datastring .= chr($encoding);
1068 65         66 next;
1069             }
1070 128         128 my $d = shift @data;
1071 128 100 66     459 if ($fs->{isnum}) {
    100 33        
    50          
1072             ## store data as number
1073 7         17 my $num = int($d);
1074 7         6 $d="";
1075 7         11 while ($num) { $d=pack("C",$num % 256) . $d; $num = int($num/256);}
  7         14  
  7         15  
1076 7 100 66     25 if ( exists $fs->{len} and $fs->{len}>0 ) {
1077 6         9 $d = substr $d, -$fs->{len};
1078 6 100       14 $d = ("\x00" x ($fs->{len}-length($d))) . $d if length($d) < $fs->{len};
1079             }
1080 7 100 66     15 if ( exists $fs->{mlen} and $fs->{mlen}>0 ) {
1081 1 50       4 $d = ("\x00" x ($fs->{mlen}-length($d))) . $d if length($d) < $fs->{mlen};
1082             }
1083             } elsif ( exists $fs->{len} and not exists $fs->{func}) {
1084 100 100       197 if ($fs->{len}>0) {
    100          
1085 14         23 $d = substr $d, 0, $fs->{len};
1086 14 100       29 $d .= " " x ($fs->{len}-length($d)) if length($d) < $fs->{len};
1087             } elsif ($fs->{len}==0) {
1088 35         44 $d .= chr(0);
1089             }
1090             } elsif (exists $fs->{mlen} and $fs->{mlen}>0) {
1091 0 0       0 $d .= " " x ($fs->{mlen}-length($d)) if length($d) < $fs->{mlen};
1092             }
1093 128 100       165 if (exists $fs->{re2b}) {
1094 1         2 while (my ($pat, $rep) = each %{$fs->{re2b}}) {
  2         8  
1095 1         23 $d =~ s/$pat/$rep/gis;
1096             }
1097             }
1098 128 100       220 if (exists $fs->{func_back}) {
    100          
1099 12         24 $d = $fs->{func_back}->($d);
1100             } elsif (exists $fs->{func}) {
1101 9 100       22 if ($fs->{small_max}) { # Allow the old way (byte) and a number
1102             # No conflict possible: byte is always smaller than ord '0'
1103 8 100       30 $d = pack 'C', $d if $d =~ /^\d+$/;
1104             }
1105 9         29 $d = $self->__format_field($fname, $fs->{name}, $d)
1106             }
1107 128 100       210 if ($fs->{encoded}) {
1108 82 50 33     297 if ($encoding) {
    50 33        
      33        
1109             # 0 = latin1 (effectively: unknown)
1110             # 1 = UTF-16 with BOM (we write UTF-16le to cowtow to M$'s bugs)
1111             # 2 = UTF-16be, no BOM
1112             # 3 = UTF-8
1113 0         0 require Encode;
1114 0 0 0     0 if ($calc_enc or $encode_utf8) { # e_u8==1 by default
    0          
1115 0         0 $d = Encode::encode($enc_types[$encoding], $d);
1116             } elsif ($encoding < 3) {
1117             # Reencode from UTF-8
1118 0         0 $d = Encode::decode('UTF-8', $d);
1119 0         0 $d = Encode::encode($enc_types[$encoding], $d);
1120             }
1121 0 0 0     0 $d = "\xFF\xFE$d" if $use_utf16le and $encoding == 1;
1122             } elsif (not $self->{fixed_encoding} # Now $encoding == 0...
1123             and $self->get_config1('id3v2_fix_encoding_on_edit')
1124             and $e = $self->botched_encoding()
1125 0         0 and do { require Encode; Encode::decode($e, $d) ne $d }) {
  0         0  
1126             # If the current string is interpreted differently
1127             # with botched_encoding, need to unbotch...
1128 0         0 $self->fix_frames_encoding();
1129             }
1130             }
1131 128         174 $datastring .= $d;
1132             }
1133              
1134 68         118 return add_raw_frame($self, $fname, $datastring);
1135             }
1136              
1137             sub add_frame {
1138 44     44 1 156 my $self = shift;
1139 44         87 _add_frame($self, 0, @_)
1140             }
1141              
1142             sub add_frame_split {
1143 24     24 1 21 my $self = shift;
1144 24         45 _add_frame($self, 1, @_)
1145             }
1146              
1147             sub add_raw_frame ($$$$) {
1148 68     68 0 90 my($self, $fname, $datastring, $flags) = (shift,shift,shift,shift);
1149              
1150             #add frame to tag
1151 68 100       120 if (exists $self->{frames}->{$fname}) {
1152 6         12 my ($c, $ID) = (1, $fname);
1153 6         9 $fname .= '01';
1154 6         22 while (exists $self->{frames}->{$fname}) {
1155 1         2 $fname++, $c++;
1156             }
1157             ++$self->{extra_frames}->{$ID}
1158 6 50 100     34 if $c > ($self->{extra_frames}->{$ID} || 0);
1159             }
1160             $self->{frames}->{$fname} = {flags => ($flags || $self->check_flags(0)),
1161             major => $self->{frame_major},
1162 68   33     163 data => $datastring };
1163 68         76 $self->{modified}++;
1164 68         425 return $fname;
1165             }
1166              
1167             =pod
1168              
1169             =item change_frame()
1170              
1171             $id3v2->change_frame($fname, @data);
1172              
1173             Change an existing frame, which is identified by its
1174             short name $fname eg as returned by get_frame_ids().
1175             @data must be same as in add_frame().
1176              
1177             If the frame $fname does not exist, undef is returned.
1178              
1179             You have to call write_tag() to save the changes to the file.
1180              
1181             =cut
1182              
1183             sub change_frame {
1184 0     0 1 0 my ($self, $fname, @data) = @_;
1185 0 0       0 $self->get_frame_ids() unless exists $self->{frameIDs};
1186 0 0       0 return undef unless exists $self->{frames}->{$fname};
1187              
1188 0         0 $self->remove_frame($fname);
1189 0         0 $self->add_frame($fname, @data);
1190              
1191 0         0 return 1;
1192             }
1193              
1194             =pod
1195              
1196             =item remove_frame()
1197              
1198             $id3v2->remove_frame($fname);
1199              
1200             Remove an existing frame. $fname is the short name of a frame,
1201             eg as returned by get_frame_ids().
1202              
1203             You have to call write_tag() to save the changes to the file.
1204              
1205             =cut
1206              
1207             sub remove_frame {
1208 43     43 1 42 my ($self, $fname) = @_;
1209 43 100       74 $self->get_frame_ids() unless exists $self->{frameIDs};
1210 43 100       73 return undef unless exists $self->{frames}->{$fname};
1211 32         111 delete $self->{frames}->{$fname};
1212 32         36 $self->{modified}++;
1213 32         43 return 1;
1214             }
1215              
1216             =item copy_frames($from, $to, $overwrite, [$keep_flags, $f_ids])
1217              
1218             Copies specified frames between C objects $from, $to. Unless
1219             $keep_flags, the copied frames have their flags cleared.
1220             If the array reference $f_ids is not specified, all the frames (but C
1221             and C) are considered (subject to $overwrite), otherwise $f_ids should
1222             contain short frame ids to consider. Group ID flag is always cleared.
1223              
1224             If $overwrite is C<'delete'>, frames with the same descriptors (as
1225             returned by get_frame_descr()) in $to are deleted first, then all the
1226             specified frames are copied. If $overwrite is FALSE, only frames with
1227             descriptors not present in $to are copied. (If one of these two
1228             conditions is not met, the result may be not conformant to standards.)
1229              
1230             Returns count of copied frames.
1231              
1232             =cut
1233              
1234             sub copy_frames {
1235 0     0 1 0 my ($from, $to, $overwrite, $keep_flags, $f_ids) = @_;
1236             # return 0 unless $from->{ID3v2}; # No need to create it...
1237 0         0 my($cp, $expl) = (0, $f_ids);
1238 0   0     0 $f_ids ||= [keys %{$from->get_frame_ids}];
  0         0  
1239 0         0 for my $fn (@$f_ids) {
1240 0 0 0     0 next if not $expl and $fn =~ /^(GRID|TLEN)/;
1241 0 0 0     0 if (($overwrite || 0) eq 'delete') {
    0          
1242 0         0 $to->frame_select_by_descr($from->get_frame_descr($fn), undef); # delete
1243             } elsif (not $overwrite) {
1244 0 0       0 next if $to->frame_have($from->get_frame_descr($fn));
1245             }
1246 0         0 my $f = $from->{frames}->{$fn};
1247 0         0 $fn =~ s/^(\w{4})\d+$/$1/;
1248 0         0 my $d = $f->{data};
1249 0         0 my %fl = %{$f->{flags}};
  0         0  
1250 0 0       0 (substr $d, 0, 1) = '' if delete $fl{groupid};
1251 0 0       0 $to->add_raw_frame($fn, $d, $keep_flags ? \%fl : undef);
1252 0         0 $cp++;
1253             }
1254 0         0 return $cp
1255             }
1256              
1257             =item is_modified()
1258              
1259             $id3v2->is_modified;
1260              
1261             Returns true if the tag was modified after it was created.
1262              
1263             =cut
1264              
1265             sub is_modified {
1266             shift->{modified}
1267 0     0 1 0 }
1268              
1269             =pod
1270              
1271             =item supported_frames()
1272              
1273             $frames = $id3v2->supported_frames();
1274              
1275             Returns a hash reference with all supported frames. The keys of the
1276             hash are the short names of the supported frames, the
1277             according values are the long (english) names of the frames.
1278              
1279             =cut
1280              
1281             sub supported_frames {
1282 0     0 1 0 my $self = shift;
1283              
1284 0         0 my (%tags, $fname, $lname);
1285 0         0 while ( ($fname, $lname) = each %long_names) {
1286 0 0       0 $tags{$fname} = $lname if get_format($fname, "quiet");
1287             }
1288              
1289 0         0 return \%tags;
1290             }
1291              
1292             =pod
1293              
1294             =item what_data()
1295              
1296             ($data, $res_inp, $data_map) = $id3v2->what_data($fname);
1297              
1298             Returns an array reference with the needed data fields for a
1299             given frame.
1300             At this moment only the internal field names are returned,
1301             without any additional information about the data format of
1302             this field. Names beginning with an underscore (normally '_data')
1303             can contain binary data. (The C<_encoding> field is skipped in this list,
1304             since it is usually auto-deduced by this module.)
1305              
1306             $resp_inp is a reference to a hash (keyed by the field name) describing
1307             restrictions for the content of the data field.
1308             If the entry is undef, no restriction exists. Otherwise it is a hash.
1309             The keys of the hash are the allowed input, the correspodending value
1310             is the value which is actually stored in this field. If the value
1311             is undef then the key itself is valid for saving.
1312             If the hash contains an entry with "_FREE", the hash contains
1313             only suggestions for the input, but other input is also allowed.
1314              
1315             $data_map contains values of $resp_inp in the order of fields of a frame
1316             (including C<_encoding>).
1317              
1318             Example for picture types of the APIC frame:
1319              
1320             {"Other" => "\x00",
1321             "32x32 pixels 'file icon' (PNG only)" => "\x01",
1322             "Other file icon" => "\x02",
1323             ...}
1324              
1325             =cut
1326              
1327             sub what_data {
1328 0     0 1 0 my ($self, $fname) = @_;
1329 0         0 $fname = substr $fname, 0, 4; # delete 01 etc. at end
1330 0 0       0 return if length($fname)==3; #id3v2.2 tags are read-only and should never be written
1331 0         0 my $reswanted = wantarray;
1332 0         0 my $format = get_format($fname, "quiet");
1333 0 0       0 return unless defined $format;
1334 0         0 my (@data, %res, @datares);
1335              
1336 0         0 foreach (@$format) {
1337 0 0       0 next unless exists $_->{name};
1338 0 0       0 push @data, $_->{name} unless $_->{name} eq "_encoding";
1339 0 0       0 next unless $reswanted;
1340 0         0 my $key = $fname . $_->{name};
1341 0 0       0 $res{$_->{name}} = $field_map{$key} if exists $field_map{$key};
1342 0         0 push @datares, $field_map{$key};
1343             }
1344              
1345 0 0       0 return(\@data, \%res, \@datares) if $reswanted;
1346 0         0 return \@data;
1347             }
1348              
1349             sub __format_field {
1350 9     9   13 my ($self, $fname, $nfield, $v) = @_;
1351             # $v =~ s/^(\d+)$/chr $1/e if $is_small_int{"$fname$nfield"}; # Already done by caller
1352              
1353 9 50       29 my $m = $field_map_back{my $t = "$fname$nfield"} or return $v; # packed ==> Human
1354 9 100       28 return $v if exists $m->{$v}; # Already of a correct form
1355              
1356 2 50       6 my $m1 = $field_map{$t} or die; # Human ==> packed
1357 2 50       7 return $m1->{$v} if exists $m1->{$v}; # translate
1358 0 0       0 return $v if $m->{_FREE}; # Free-form allowed
1359              
1360 0         0 die "Unsupported value `$v' for field `$nfield' of frame `$fname'";
1361             }
1362              
1363             =item title( [@new_title] )
1364              
1365             Returns the title composed of the tags configured via Cconfig('v2title')>
1366             call (with default 'Title/Songname/Content description' (TIT2)) from the tag.
1367             (For backward compatibility may be called by deprecated name song() as well.)
1368              
1369             Sets TIT2 frame if given the optional arguments @new_title. If this is an
1370             empty string, the frame is removed.
1371              
1372             =cut
1373              
1374             *song = \&title;
1375              
1376             sub v2title_order {
1377 66     66 0 50 my $self = shift;
1378 66         44 @{ $self->get_config('v2title') };
  66         106  
1379             }
1380              
1381             sub title {
1382 44     44 1 39 my $self = shift;
1383 44 100       63 if (@_) {
1384 11         17 $self->remove_frame('TIT2'); # NOP if it is not there
1385 11 50 33     38 return if @_ == 1 and $_[0] eq '';
1386 11         22 return $self->add_frame('TIT2', @_);
1387             }
1388 33   66     52 my @parts = grep defined && length,
1389             map scalar $self->get_frame($_), $self->v2title_order;
1390 33 100       92 return unless @parts;
1391 18         20 my $last = pop @parts;
1392 18         19 my $part;
1393 18         26 for $part (@parts) {
1394 0         0 $part =~ s(\0)(///)g; # Multiple strings
1395 0 0       0 $part .= ',' unless $part =~ /[.,;:\n\t]\s*$/;
1396 0 0       0 $part .= ' ' unless $part =~ /\s$/;
1397             }
1398 18         62 return join '', @parts, $last;
1399             }
1400              
1401             sub have_one_of_frames {
1402 0     0 0 0 my $self = shift;
1403 0         0 return grep $self->frame_have($_), @_;
1404             }
1405              
1406             sub title_have {
1407 0     0 0 0 my $self = shift;
1408 0         0 $self->have_one_of_frames($self->v2title_order)
1409             }
1410              
1411             =item _comment([$language])
1412              
1413             Returns the file comment (COMM with an empty 'Description') from the tag, or
1414             "Subtitle/Description refinement" (TIT3) frame (unless it is considered a part
1415             of the title).
1416              
1417             =cut
1418              
1419             sub __comment {
1420 22     22   30 my($self, $check_have) = (shift, shift);
1421 22         18 my $language;
1422 22 100       37 $language = lc shift if @_;
1423 22         35 my @info = get_frames($self, "COMM");
1424 22         24 shift @info;
1425 22         28 for my $comment (@info) {
1426 16 50       31 next unless defined $comment; # Removed frames
1427 16 100 66     56 next unless exists $comment->{Description} and not length $comment->{Description};
1428             next if defined $language and (not exists $comment->{Language}
1429 5 100 66     18 or lc $comment->{Language} ne $language);
      66        
1430 4 50       20 return $check_have ? 1 : $comment->{Text} ;
1431             }
1432 18 50       32 return if grep $_ eq 'TIT3', $self->v2title_order;
1433 0 0       0 return $check_have ? $self->frame_have("TIT3") : scalar $self->get_frame("TIT3");
1434             }
1435              
1436             sub _comment {
1437 22     22   19 my $self = shift;
1438 22         39 $self->__comment(!'only_check', @_);
1439             }
1440              
1441             sub comment_have {
1442 0     0 0 0 my $self = shift;
1443 0         0 $self->__comment('only_check', @_);
1444             }
1445              
1446             =item comment()
1447              
1448             $val = $id3v2->comment();
1449             $newframe = $id3v2->comment('Just a comment for freddy', 'personal', 'eng');
1450              
1451             Returns the file comment (COMM frame with the 'Description' field in
1452             C configuration variable, defalting to C<''>) from
1453             the tag, or "Subtitle/Description refinement" (TIT3) frame (unless it
1454             is considered a part of the title).
1455              
1456             If optional arguments ($comment, $short, $language) are present, sets
1457             the comment frame. If $language is omited, uses the
1458             C configuration variable (default is C). If not
1459             C, this should be lowercase 3-letter abbreviation according to
1460             ISO-639-2).
1461              
1462             If $short is not defined, uses the C configuration
1463             variable. If $comment is an empty string, the frame is removed.
1464              
1465             =cut
1466              
1467             sub comment {
1468 21     21 1 140 my $self = shift;
1469 21 100       65 my ($comment, $short, $language) = @_ or return $self->_comment();
1470 1         4 my @info = get_frames($self, "COMM");
1471 1         3 my $desc = ($self->get_config('default_descr_c'))->[0];
1472 1         1 shift @info;
1473 1         2 my $c = -1;
1474 1         2 for my $comment (@info) {
1475 1         1 ++$c;
1476 1 50       3 next unless defined $comment; # Removed frames
1477             next unless exists $comment->{Description}
1478 1 50 33     6 and $comment->{Description} eq $desc;
1479             next if defined $language and (not exists $comment->{Language}
1480 1 50 33     8 or lc $comment->{Language} ne lc $language);
      33        
1481 1 50       4 $self->remove_frame($c ? sprintf 'COMM%02d', $c : 'COMM');
1482             # $c--; # Not needed if only one frame is removed
1483 1         1 last;
1484             }
1485 1 50 33     4 return if @_ == 1 and $_[0] eq '';
1486 1 50       2 $language = ($self->get_config('default_language'))->[0]
1487             unless defined $language;
1488 1 50       6 $short = $desc unless defined $short;
1489 1         3 $self->add_frame('COMM', $language, $short, $comment);
1490             }
1491              
1492             =item frame_select($fname, $descrs, $languages [, $newval1, ...])
1493              
1494             Used to get/set/delete frames which may be not necessarily unique in a tag.
1495              
1496             # Select short-description='', prefere language 'eng', then 'rus', then
1497             # the third COMM frame, then any (in this case, the first or the second)
1498             # COMM frame
1499             $val = $id3v2->frame_select('COMM', '', ['eng', 'rus', '#2', '']); # Read
1500             $new = $id3v2->frame_select('COMM', '', ['eng', 'rus', '#2'], # Write
1501             'Comment with empty "Description" and "eng"');
1502             $new = $id3v2->frame_select('COMM', '', ['eng', 'rus', '#2'], # Delete
1503             undef);
1504              
1505             Returns the contents of the first frame named $fname with a
1506             'Description' field in the specified array reference $descrs and the
1507             language in the list of specified languages $languages; empty return
1508             otherwise. If the frame is a "simple frame", the frame is returned as
1509             a string, otherwise as a hash reference; a "simple frame" should
1510             consist of one of Text/URL/_Data fields, with possible addition of
1511             Language and Description fields (if the corresponding arguments were
1512             defined).
1513              
1514             The lists $descrs and $languages of one element can be flattened to
1515             become this element (as with C<''> above). If the lists are not
1516             defined, no restriction is applied; to get the same effect with
1517             defined arguments, use $languages of C<''>, and/or $descrs a hash
1518             reference. Language of the form C<'#NUMBER'> selects the NUMBER's
1519             (0-based) frame with frame name $fname.
1520              
1521             If optional arguments C<$newval1...> are given, B the found frames are
1522             removed; if only one such argument C is given, this is the only action.
1523             Otherwise, a new frame is created afterwards (the first
1524             elements of $descrs and $languages are used as the short description
1525             and the language, defaulting to C<''> and the C
1526             configuration variable (which, in turn, defaults to C; if not C,
1527             this should be lowercase 3-letter abbreviation according to ISO-639-2).
1528             If new frame is created, the frame's name is returned; otherwise the count of
1529             removed frames is returned.
1530              
1531             As a generalization, APIC frames are handled too, using C
1532             Type> instead of C, and auto-calculating C for
1533             (currently) TIFF/JPEG/GIF/PNG/BMP and octet-stream. Only frames with
1534             C coinciding with the auto-calculated value are considered
1535             as "simple frames". One can use both the 1-byte format for C
1536             Type>, and the long names used in the ID3v2 documentation; the default
1537             value is C<'Cover (front)'>.
1538              
1539             # Choose APIC with empty description, picture_type='Leaflet page'
1540             my $data = $id3v2->frame_select('APIC', '', 'Leaflet page')
1541             or die "no expected APIC frame found";
1542             my $format = ( ref $data ? $data->{'MIME type'}
1543             : $id3v2->_Data_to_MIME($data) );
1544             # I know what to do with application/pdf only (sp?) and 'image/gif'
1545             die "Do not know what to do with this APIC format: `$format'"
1546             unless $format eq 'application/pdf' or $format eq 'image/gif';
1547             $data = $data->{_Data} if ref $data; # handle non-simple frame
1548              
1549             # Set APIC frame with empty description (front cover if no other present)
1550             # from content of file.gif
1551             my $data = do { open my $f, '<', 'file.gif' and binmode $f or die;
1552             undef $/; <$f>};
1553             my $new_frame = $id3v2->frame_select('APIC', '', undef, $data);
1554              
1555             Frames with multiple "content" fields may be set by providing multiple
1556             values to set. Alternatively, one can also C the values with
1557             C<';'> if the splitting is not ambiguous, e.g., for C
1558             SYTC>. (For frames C and C, which have a C
1559             field, it should be specified among these values.)
1560              
1561             $id3v2->frame_select("RBUF", undef, undef, $n1, $n2, $n3);
1562             $id3v2->frame_select("RBUF", undef, undef, "$n1;$n2;$n3");
1563              
1564             (By the way: consider using the method select_id3v2_frame() on the
1565             "parent" MP3::Tag object instead [see L],
1566             or L.)
1567              
1568             =item _Data_to_MIME
1569              
1570             Internal method to extract MIME type from a string the image file
1571             content. Returns C for unrecognized data
1572             (unless extra TRUE argument is given).
1573              
1574             $format = $id3v2->_Data_to_MIME($data);
1575              
1576             Currently, only the first 4 bytes of the string are inspected.
1577              
1578             =cut
1579              
1580 332 100 100 332   290 sub __to_lang($$) {my $l = shift; return $l if shift or $l eq 'XXX'; lc $l}
  332         1019  
  286         819  
1581              
1582             my %as_lang = ('APIC', ['Picture Type', chr 3, 'small_int']); # "Cover (front)"
1583             my %MT = ("\xff\xd8\xff\xe0" => 'image/jpeg', "MM\0*" => 'image/tiff',
1584             "II*\0" => 'image/tiff', "\x89PNG",
1585             qw(image/png GIF8 image/gif BM image/bmp));
1586              
1587             sub _Data_to_MIME ($$;$) {
1588 37     37   45 my($self, $data, $force) = (shift, shift, shift); # Fname, field name remain
1589 37   33     85 my $res = $MT{substr $data, 0, 4} || $MT{substr $data, 0, 2};
1590 37 50       123 return $res if $res;
1591 0 0       0 return 'audio/mpeg' if $data =~ /^\xff[\xe0-\xff]/; # 11 bits are 1
1592 0 0       0 return 'application/octet-stream' unless $force;
1593 0         0 return;
1594             }
1595              
1596             sub _frame_select { # if $extract_content false, return all found
1597             # "Quadratic" in number of comment frames and select-short/lang specifiers
1598 245     245   301 my ($self, $extract_content, $fname) = (shift, shift, shift);
1599 245         223 my ($descr, $languages) = (shift, shift);
1600             # or ($fname eq 'COMM' and return $self->_comment()); # ???
1601 245         178 my $any_descr;
1602 245 100 66     761 if (ref $descr eq 'HASH') { # Special case
    100          
1603 32         24 $any_descr = 1;
1604 32         34 undef $descr;
1605             } elsif (defined $descr and not ref $descr) {
1606 124         186 $descr = [$descr];
1607             }
1608 245         265 my $lang_special = $as_lang{$fname};
1609 245 100       293 my $lang_field = ($lang_special ? $lang_special->[0] : 'Language');
1610 245         173 my $languages_mangled;
1611              
1612 245 100       304 if (defined $languages) {
1613 169 100       322 $languages = [$languages] unless ref $languages;
1614 169         226 $languages = [@$languages]; # Make a copy: we edit the entries...
1615 169 100       213 if ($lang_special) {
1616 37         59 my $m = $field_map{"$fname$lang_field"};
1617 37 50       62 if ($m) { # Below we assume that mapped values are not ''...
1618             # Need to duplicate the logic in add_frame() here, since
1619             # we need a normalized form to compare frames-to-select with...
1620 37 50       61 if ($lang_special->[2]) { # small_int
1621 37         114 s/^(\d+)$/chr $1/e for @$languages;
  3         14  
1622             }
1623 37 100       159 @$languages_mangled = map( (exists $m->{$_} ? $m->{$_} : $_), @$languages);
1624 37 50       81 my $m1 = $field_map_back{"$fname$lang_field"} or die;
1625 37         37 my $loose = $m->{_FREE};
1626 37 100       124 @$languages = map( (exists $m1->{$_} ? $m1->{$_} : $_), @$languages_mangled);
1627             $_ eq '' or exists $m1->{$_} or $loose or not /\D/
1628             or die "Unknown value `$_' for field `$lang_field' of frame $fname"
1629 37   66     182 for @$languages_mangled;
      33        
      33        
      0        
1630             }
1631             } else {
1632 132         217 @$languages = map __to_lang($_, 0), @$languages;
1633             }
1634             }
1635 245         360 my @found_frames = get_frames($self, $fname);
1636 245         237 shift @found_frames;
1637 245         348 my(@by_lang) = (0..$#found_frames);
1638             # Do it the slow way...
1639 245 100       346 if (defined $languages) {
1640 169         145 @by_lang = ();
1641 169         127 my %seen;
1642 169         191 for my $l (@$languages) {
1643 266 100 66     690 if ($l =~ /^#(\d+)$/) {
    50          
1644 28 100 66     170 push @by_lang, $1 if not $seen{$1}++ and $1 < @found_frames;
1645             } elsif (length $l > 3 and not $lang_special) {
1646 0         0 die "Language `$l' should not be more than 3-chars long";
1647             } else {
1648 238         426 for my $c (0..$#found_frames) {
1649 209 100       323 my $f = $found_frames[$c] or next; # XXXX Needed?
1650             push @by_lang, $c
1651             if ($l eq ''
1652             or ref $f and defined $f->{$lang_field}
1653             and $l eq __to_lang $f->{$lang_field}, $lang_special)
1654 206 100 66     1099 and not $seen{$c}++;
      66        
1655             }
1656             }
1657             }
1658             }
1659 245         221 my @select;
1660 245         297 for my $c (@by_lang) {
1661 204         167 my $f = $found_frames[$c];
1662 204         252 my $cc = [$c, $f];
1663 204 100       324 push(@select, $cc), next unless defined $descr;
1664             push @select, $cc
1665             if defined $f and ref $f and defined $f->{Description}
1666 137 100 66     920 and grep $_ eq $f->{Description}, @$descr;
      66        
      66        
1667             }
1668 245 100       391 return @select unless $extract_content;
1669 218 100       312 unless (@_) { # Read-only access
1670 179 100       463 return unless @select;
1671 116         104 my $res = $select[0][1]; # Only defined frames here...
1672 116 100       278 return $res unless ref $res; # TLEN
1673 84         86 my $ic = my $c = keys %$res;
1674 84 100 100     256 $c-- if exists $res->{Description} and (defined $descr or $any_descr);
      33        
1675 84 100 100     226 $c-- if exists $res->{$lang_field} and defined $languages;
1676 84 50       104 $c-- if exists $res->{encoding};
1677             $c-- if $c == 2 and $ic == 5 and exists $res->{'MIME type'}
1678             and exists $res->{_Data}
1679 84 50 100     246 and $res->{'MIME type'} eq $self->_Data_to_MIME($res->{_Data});
      66        
      33        
      33        
1680 84 100       118 if ($c <= 1) {
1681 74 100       322 return $res->{Text} if exists $res->{Text};
1682 22 50       27 return $res->{URL} if exists $res->{URL};
1683 22 50       133 return $res->{_Data} if exists $res->{_Data};
1684             }
1685 10         55 return $res;
1686             }
1687             # Write or delete
1688 39         42 for my $f (reverse @select) { # Removal may break the numeration???
1689 23         29 my ($c, $frame) = @$f;
1690 23 100       71 $self->remove_frame($c ? sprintf('%s%02d', $fname, $c) : $fname);
1691             }
1692 39 100 100     226 return scalar @select unless @_ > 1 or defined $_[0]; # Delete
1693 24 100       33 if (defined $languages) {
    100          
1694 6 100       12 $languages = $languages_mangled if defined $languages_mangled;
1695             } elsif ($lang_special) {
1696 1         2 $languages = [$lang_special->[1]];
1697             } else {
1698 17         13 $languages = [@{$self->get_config('default_language')}]; # Copy to modify
  17         34  
1699             }
1700 24         37 my $format = get_format($fname);
1701 24         71 my $have_lang = grep $_->{name} eq $lang_field, @$format;
1702 24         55 $#$languages = $have_lang - 1; # Truncate
1703 24 100 66     61 unshift @$languages, $self->_Data_to_MIME($_[0])
1704             if $lang_special and @_ == 1; # "MIME type" field
1705 24 100       47 $descr = [''] unless defined $descr;
1706 24         49 my $have_descr = grep $_->{name} eq 'Description', @$format;
1707 24 100       40 $have_descr = 0 if $embedded_Descr{$fname}; # Must be explicitly provided
1708 24         52 $#$descr = $have_descr - 1; # Truncate
1709 24 50       57 $self->add_frame_split($fname, @$languages, @$descr, @_) or die;
1710             }
1711              
1712             sub frame_select {
1713 49     49 1 39 my $self = shift;
1714 49         75 $self->_frame_select(1, @_);
1715             }
1716              
1717             =item frame_list()
1718              
1719             Same as frame_select(), but returns the list of found frames, each an
1720             array reference C<[$N, $f]> with $N the 0-based ordinal (among frames
1721             with the given short name), and $f the contents of a frame.
1722              
1723             =item frame_have()
1724              
1725             Same as frame_select(), but returns the count of found frames.
1726              
1727             =item frame_select_by_descr()
1728              
1729             =item frame_have_by_descr()
1730              
1731             =item frame_list_by_descr()
1732              
1733             $c = $id3v2->frame_select_by_descr("COMM(fre,fra,eng,#0)[]");
1734             $t = $id3v2->frame_select_by_descr("TIT2");
1735             $id3v2->frame_select_by_descr("TIT2", "MyT"); # Set/Change
1736             $id3v2->frame_select_by_descr("RBUF", $n1, $n2, $n3); # Set/Change
1737             $id3v2->frame_select_by_descr("RBUF", "$n1;$n2;$n3"); # Set/Change
1738             $id3v2->frame_select_by_descr("TIT2", undef); # Remove
1739              
1740             Same as frame_select(), frame_have(), frame_list(), but take one string
1741             argument instead of $fname, $descrs, $languages. The argument should
1742             be of the form
1743              
1744             NAME(langs)[descr]
1745              
1746             Both C<(langs)> and C<[descr]> parts may be omitted; I should
1747             contain comma-separated list of needed languages; no protection by
1748             backslashes is needed in I. frame_select_by_descr() will
1749             return a hash if C<(lang)> is omited, but the frame has a language
1750             field; likewise for C<[descr]>; see below for alternatives.
1751              
1752             Remember that when frame_select_by_descr() is used for modification,
1753             B found frames are deleted before a new one is added.
1754              
1755             (By the way: consider using the method select_id3v2_frame_by_descr() on the
1756             "parent" MP3::Tag object instead; see L.)
1757              
1758             =item frame_select_by_descr_simple()
1759              
1760             Same as frame_select_by_descr(), but if no language is given, will not
1761             consider the frame as "complicated" frame even if it contains a
1762             language field.
1763              
1764             =item frame_select_by_descr_simpler()
1765              
1766             Same as frame_select_by_descr_simple(), but if no C is
1767             given, will not consider the frame as "complicated" frame even if it
1768             contains a C field.
1769              
1770             =cut
1771              
1772             sub frame_have {
1773 0     0 1 0 my $self = shift;
1774 0         0 scalar $self->_frame_select(0, @_);
1775             }
1776              
1777             sub frames_list {
1778 0     0 0 0 my $self = shift;
1779 0         0 $self->_frame_select(0, @_);
1780             }
1781              
1782             sub _frame_select_by_descr {
1783 196     196   209 my ($self, $what, $d) = (shift, shift, shift);
1784 196         156 my($l, $descr) = ('');
1785 196 100       941 if ( $d =~ s/^(\w{4})(?:\(([^()]*(?:\([^()]+\)[^()]*)*)\))?(?:\[(.*)\])?$/$1/ ) {
1786 152 100 100     547 $l = defined $2 ? [split /,/, $2, -1] : ($what > 1 && !@_ ? '' : undef);
    100          
1787             # Use special case in _frame_select:
1788 152 100 100     406 $descr = defined $3 ? $3 : ($what > 2 && !@_ ? {} : undef);
    100          
1789             # $descr =~ s/\\([\\\[\]])/$1/g if defined $descr;
1790             }
1791 196         318 return $self->_frame_select($what, $d, $descr, $l, @_);
1792             }
1793              
1794             sub frame_have_by_descr {
1795 27     27 1 20 my $self = shift;
1796 27         44 scalar $self->_frame_select_by_descr(0, @_);
1797             }
1798              
1799             sub frame_list_by_descr {
1800 0     0 1 0 my $self = shift;
1801 0         0 $self->_frame_select_by_descr(0, @_);
1802             }
1803              
1804             sub frame_select_by_descr {
1805 0     0 1 0 my $self = shift;
1806 0         0 $self->_frame_select_by_descr(1, @_);
1807             }
1808              
1809             sub frame_select_by_descr_simple {
1810 0     0 1 0 my $self = shift;
1811 0         0 $self->_frame_select_by_descr(2, @_); # 2 ==> prefer $languages eq ''...
1812             }
1813              
1814             sub frame_select_by_descr_simpler {
1815 169     169 1 133 my $self = shift;
1816 169         237 $self->_frame_select_by_descr(3, @_); # 2 ==> prefer $languages eq ''...
1817             }
1818              
1819             =item year( [@new_year] )
1820              
1821             Returns the year (TYER/TDRC) from the tag.
1822              
1823             Sets TYER and TDRC frames if given the optional arguments @new_year. If this
1824             is an empty string, the frame is removed.
1825              
1826             The format is similar to timestamps of IDv2.4.0, but ranges can be separated
1827             by C<-> or C<-->, and non-contiguous dates are separated by C<,> (comma). If
1828             periods need to be specified via duration, then one needs to use the ISO 8601
1829             C-notation (e.g., see
1830              
1831             http://www.mcs.vuw.ac.nz/technical/software/SGML/doc/iso8601/ISO8601.html
1832              
1833             ); the C is not supported.
1834              
1835             On output, ranges of timestamps are converted to C<-> or C<--> separated
1836             format depending on whether the timestamps are years, or have additional
1837             fields.
1838              
1839             If configuration variable C is false, the return value
1840             is always the year only (of the first timestamp of a composite timestamp).
1841              
1842             Recall that ID3v2.4.0 timestamp has format yyyy-MM-ddTHH:mm:ss (year, "-",
1843             month, "-", day, "T", hour (out of
1844             24), ":", minutes, ":", seconds), but the precision may be reduced by
1845             removing as many time indicators as wanted. Hence valid timestamps
1846             are
1847             yyyy, yyyy-MM, yyyy-MM-dd, yyyy-MM-ddTHH, yyyy-MM-ddTHH:mm and
1848             yyyy-MM-ddTHH:mm:ss. All time stamps are UTC. For durations, use
1849             the slash character as described in 8601, and for multiple noncontiguous
1850             dates, use multiple strings, if allowed by the frame definition.
1851              
1852             =cut
1853              
1854             sub year {
1855 23     23 1 136 my $self = shift;
1856 23 100       46 if (@_) {
1857 2 50       6 $self->remove_frame('TYER') if defined $self->get_frame( "TYER");
1858 2 50       5 $self->remove_frame('TDRC') if defined $self->get_frame( "TDRC");
1859 2 50 33     12 return if @_ == 1 and $_[0] eq '';
1860 2         3 my @args = @_;
1861 2         12 $args[-1] =~ s/^(\d{4}\b).*/$1/;
1862 2         5 $self->add_frame('TYER', @args); # Obsolete
1863 2         4 @args = @_;
1864 2         9 $args[-1] =~ s/-(-|(?=\d{4}\b))/\//g; # ranges are /-separated
1865 2         5 $args[-1] =~ s/,(?=\d{4}\b)/\0/g; # dates are \0-separated
1866 2         9 $args[-1] =~ s#([-/T:])(?=\d(\b|T))#${1}0#g; # %02d-format
1867 2         5 return $self->add_frame('TDRC', @args); # new; allows YYYY-MM-etc as well
1868             }
1869 21         17 my $y;
1870 21 100 66     38 ($y) = $self->get_frame( "TDRC", 'intact')
1871             or ($y) = $self->get_frame( "TYER") or return;
1872 3 50       7 return substr $y, 0, 4 unless ($self->get_config('year_is_timestamp'))->[0];
1873             # Convert to human-readable form
1874 3         7 $y =~ s/\0/,/g;
1875 3 100       23 my $sep = ($y =~ /-/) ? '--' : '-';
1876 3         8 $y =~ s#/(?=\d)#$sep#g;
1877 3         8 return $y;
1878             }
1879              
1880             sub year_have {
1881 0     0 0 0 my $self = shift;
1882 0         0 $self->have_one_of_frames(qw( TDRC TYER ))
1883             }
1884              
1885             =pod
1886              
1887             =item track( [$new_track] )
1888              
1889             Returns the track number (TRCK) from the tag.
1890              
1891             Sets TRCK frame if given the optional arguments @new_track. If this is an
1892             empty string or 0, the frame is removed.
1893              
1894             =cut
1895              
1896             sub track {
1897 54     54 1 47 my $self = shift;
1898 54 100       74 if (@_) {
1899 14 50       21 $self->remove_frame('TRCK') if defined $self->get_frame("TRCK");
1900 14 100 66     59 return if @_ == 1 and not $_[0];
1901 1         4 return $self->add_frame('TRCK', @_);
1902             }
1903 40         55 return scalar $self->get_frame("TRCK");
1904             }
1905              
1906             sub track_have {
1907 0     0 0 0 my $self = shift;
1908 0         0 $self->frame_have('TRCK')
1909             }
1910              
1911             =pod
1912              
1913             =item artist( [ $new_artist ] )
1914              
1915             Returns the artist name; it is the first existing frame from the list of
1916              
1917             TPE1 Lead artist/Lead performer/Soloist/Performing group
1918             TPE2 Band/Orchestra/Accompaniment
1919             TCOM Composer
1920             TPE3 Conductor
1921             TEXT Lyricist/Text writer
1922              
1923             Sets TPE1 frame if given the optional arguments @new_artist. If this is an
1924             empty string, the frame is removed.
1925              
1926             =cut
1927              
1928             sub artist {
1929 27     27 1 26 my $self = shift;
1930 27 100       48 if (@_) {
1931 12 50       22 $self->remove_frame('TPE1') if defined $self->get_frame( "TPE1");
1932 12 100 66     53 return if @_ == 1 and $_[0] eq '';
1933 3         7 return $self->add_frame('TPE1', @_);
1934             }
1935 15         15 my $a;
1936 15 100       28 ($a) = $self->get_frame("TPE1") and return $a;
1937 13 50       19 ($a) = $self->get_frame("TPE2") and return $a;
1938 13 50       17 ($a) = $self->get_frame("TCOM") and return $a;
1939 13 50       20 ($a) = $self->get_frame("TPE3") and return $a;
1940 13 50       19 ($a) = $self->get_frame("TEXT") and return $a;
1941 13         35 return;
1942             }
1943              
1944             sub artist_have {
1945 0     0 0 0 my $self = shift;
1946 0         0 $self->have_one_of_frames(qw( TPE1 TPE2 TCOM TPE3 TEXT ))
1947             }
1948              
1949             =pod
1950              
1951             =item album( [ $new_album ] )
1952              
1953             Returns the album name (TALB) from the tag. If none is found, returns
1954             the "Content group description" (TIT1) frame (unless it is considered a part
1955             of the title).
1956              
1957             Sets TALB frame if given the optional arguments @new_album. If this is an
1958             empty string, the frame is removed.
1959              
1960             =cut
1961              
1962             sub album {
1963 29     29 1 26 my $self = shift;
1964 29 100       53 if (@_) {
1965 14 50       23 $self->remove_frame('TALB') if defined $self->get_frame( "TALB");
1966 14 50 33     61 return if @_ == 1 and $_[0] eq '';
1967 0         0 return $self->add_frame('TALB', @_);
1968             }
1969 15         15 my $a;
1970 15 50       26 ($a) = $self->get_frame("TALB") and return $a;
1971 15 50       29 return if grep $_ eq 'TIT1', $self->v2title_order;
1972 0         0 return scalar $self->get_frame("TIT1");
1973             }
1974              
1975             sub album_have {
1976 0     0 0 0 my $self = shift;
1977 0 0       0 return 1 if $self->frame_have('TALB');
1978 0 0       0 return if grep $_ eq 'TIT1', $self->v2title_order;
1979 0         0 return $self->frame_have('TIT1');
1980             }
1981              
1982             =item genre( [ $new_genre ] )
1983              
1984             Returns the genre string from TCON frame of the tag.
1985              
1986             Sets TCON frame if given the optional arguments @new_genre. If this is an
1987             empty string, the frame is removed.
1988              
1989             =cut
1990              
1991             sub genre {
1992 38     38 1 44 my $self = shift;
1993 38 100       57 if (@_) {
1994 11 100       26 $self->remove_frame('TCON') if defined $self->get_frame( "TCON");
1995 11 50 33     46 return if @_ == 1 and $_[0] eq '';
1996 11         25 return $self->add_frame('TCON', @_); # XXX add genreID 0x00 ?
1997             }
1998 27         73 my $g = $self->get_frame('TCON');
1999 27 100       75 return unless defined $g;
2000 11         12 $g =~ s/^\d+\0(?:.)//s; # XXX Shouldn't this be done in TCON()?
2001 11         28 $g;
2002             }
2003              
2004             sub genre_have {
2005 0     0 0 0 my $self = shift;
2006 0         0 $self->frame_have('TCON')
2007             }
2008              
2009             =item version()
2010              
2011             $version = $id3v2->version();
2012             ($major, $revision) = $id3v2->version();
2013              
2014             Returns the version of the ID3v2 tag. It returns a formatted string
2015             like "3.0" or an array containing the major part (eg. 3) and revision
2016             part (eg. 0) of the version number.
2017              
2018             =cut
2019              
2020             sub version {
2021 0     0 1 0 my ($self) = @_;
2022 0 0       0 if (wantarray) {
2023 0         0 return ($self->{major}, $self->{revision});
2024             } else {
2025 0         0 return $self->{version};
2026             }
2027             }
2028              
2029             =item new()
2030              
2031             $tag = new($mp3fileobj);
2032              
2033             C needs as parameter a mp3fileobj, as created by C.
2034             C tries to find a ID3v2 tag in the mp3fileobj. If it does not find a
2035             tag it returns undef. Otherwise it reads the tag header, as well as an
2036             extended header, if available. It reads the rest of the tag in a
2037             buffer, does unsynchronizing if necessary, and returns a
2038             ID3v2-object. At this moment only ID3v2.3 is supported. Any extended
2039             header with CRC data is ignored, so no CRC check is done at the
2040             moment. The ID3v2-object can be used to extract information from
2041             the tag.
2042              
2043             Please use
2044              
2045             $mp3 = MP3::Tag->new($filename);
2046             $mp3->get_tags(); ## to find an existing tag, or
2047             $id3v2 = $mp3->new_tag("ID3v2"); ## to create a new tag
2048              
2049             instead of using this function directly
2050              
2051             =cut
2052              
2053             sub new {
2054 101     101 1 115 my ($class, $mp3obj, $create, $r_header) = @_;
2055 101         145 my $self={mp3=>$mp3obj};
2056 101         88 my $header=0;
2057 101         94 bless $self, $class;
2058              
2059 101 100       162 if (defined $mp3obj) { # Not fake
2060 100 100 50     197 $mp3obj->open or return unless $mp3obj->is_open;
2061 100         424 $mp3obj->seek(0,0);
2062 100         209 $mp3obj->read(\$header, 10);
2063 100 100 100     468 $$r_header = $header if $r_header and 10 == length $header;
2064             }
2065 101         163 $self->{frame_start}=0;
2066             # default ID3v2 version
2067 101         154 $self->{major}=3;
2068 101         117 $self->{frame_major}=3; # major for new frames
2069 101         105 $self->{revision}=0;
2070 101         249 $self->{version}= "$self->{major}.$self->{revision}";
2071              
2072 101 100 100     282 if (defined $mp3obj and $self->read_header($header)) {
2073 44 50       57 if ($create) {
2074 0         0 $self->{tag_data} = '';
2075 0         0 $self->{data_size} = 0;
2076             } else {
2077             # sanity check:
2078 44         107 my $s = $mp3obj->size;
2079 44         63 my $s1 = $self->{tagsize} + $self->{footer_size};
2080 44 50 33     186 if (defined $s and $s - 10 < $s1) {
2081 0         0 warn "Ridiculously large tag size: $s1; file size $s";
2082 0         0 return;
2083             }
2084 44         108 $mp3obj->read(\$self->{tag_data}, $s1);
2085 44         70 $self->{data_size} = $self->{tagsize};
2086 44         80 $self->{raw_data} = $header . $self->{tag_data};
2087             # un-unsynchronize comes in all versions first
2088 44 100       85 if ($self->{flags}->{unsync}) {
2089 1         4 my $hits = $self->{tag_data} =~ s/\xFF\x00/\xFF/gs;
2090 1         2 $self->{data_size} -= $hits;
2091             }
2092             # in v2.2.x complete tag may be compressed, but compression isn't
2093             # described in tag specification, so get out if compression is found
2094 44 50       63 if ($self->{flags}->{compress_all}) {
2095             # can we test if it is simple zlib compression and use this?
2096 0         0 warn "ID3v".$self->{version}." [whole tag] compression isn't supported. Cannot read tag\n";
2097 0         0 return undef;
2098             }
2099             # read the ext header if it exists
2100 44 50       66 if ($self->{flags}->{extheader}) {
2101 0         0 $self->{extheader} = substr ($self->{tag_data}, 0, 14);
2102 0 0       0 unless ($self->read_ext_header()) {
2103 0         0 return undef; # ext header not supported
2104             }
2105             }
2106             $self->{footer} = substr $self->{tag_data}, -$self->{footer_size}
2107 44 50       71 if $self->{footer_size};
2108             # Treat (illegal) padding after the tag
2109 44         101 my($merge, $d, $z, $r) = ($mp3obj->get_config('id3v2_mergepadding'))->[0];
2110 44 100       67 my $max0s = $merge ? 1e100 : 16*1024;
2111 44   33     142 while ($max0s and $mp3obj->read(\$d, 1024)) {
2112 45         68 $max0s -= length $d;
2113 45         141 ($z) = ($d =~ /^(\0*)/);
2114 45 100       84 $self->{buggy_padding_size} += length $z if $merge;
2115 45 100       134 ($r = substr $d, length $z), last unless length($z) == length($d);
2116             }
2117 44         109 $self->{tagend_offset} = $mp3obj->tell() - length $r;
2118 44 100 33     160 $mp3obj->read(\$d, 10 - length $r) and $r .= $d if defined $r and length $r < 10;
      66        
2119 44 100 66     172 $$r_header = $d if $r_header and 10 <= length $d;
2120             }
2121 44         80 $mp3obj->close;
2122 44         76 return $self;
2123             } else {
2124 57 100       155 $mp3obj->close if defined $mp3obj;
2125 57 100 66     163 if (defined $create && $create) {
2126 16         25 $self->{tag_data}='';
2127 16         35 $self->{tagsize} = -10;
2128 16         20 $self->{data_size} = 0;
2129 16         18 $self->{buggy_padding_size} = 0;
2130 16         43 return $self;
2131             }
2132             }
2133 41         108 return undef;
2134             }
2135              
2136             sub new_with_parent {
2137 85     85 0 90 my ($class, $filename, $parent) = @_;
2138 85         78 my $header;
2139 85         169 my $new = $class->new($filename, undef, \$header);
2140 85 100 66     278 $parent->[0]{header} = $header if $header and $parent;
2141 85 100       173 return unless $new;
2142 44         46 $new->{parent} = $parent;
2143 44         79 $new;
2144             }
2145              
2146             ##################
2147             ##
2148             ## internal subs
2149             ##
2150              
2151             # This sub tries to read the header of an ID3v2 tag and checks for the right header
2152             # identification for the tag. It reads the version number of the tag, the tag size
2153             # and the flags.
2154             # Returns true if it finds a known ID3v2.x header, false otherwise.
2155              
2156             sub read_header {
2157 100     100 0 112 my ($self, $header) = @_;
2158 100         84 my %params;
2159              
2160 100 100       207 if (substr ($header,0,3) eq "ID3") {
2161             # flag meaning for all supported ID3v2.x versions
2162 44         202 my @flag_meaning=([],[], # v2.0 and v2.1 aren't supported yet
2163             # 2.2
2164             ["unknown","unknown","unknown","unknown","unknown","unknown","compress_all","unsync"],
2165             # 2.3
2166             ["unknown","unknown","unknown","unknown","unknown","experimental","extheader","unsync"],
2167             # 2.4
2168             ["unknown","unknown","unknown","unknown","footer","experimental","extheader","unsync"],
2169             # ????
2170             #["unknown","unknown","unknown","unknown","footer","experimental","extheader","unsync"],
2171             );
2172              
2173             # extract the header data
2174 44         118 my ($major, $revision, $pflags) = unpack ("x3CCC", $header);
2175             # check the version
2176 44 50 33     192 if ($major > $#supported_majors or $supported_majors[$major] == 0) {
2177 0         0 my $warn = "Unknown ID3v2-Tag version: v2.$major.$revision\n";
2178 0         0 $warn .= "| $major > ".($#supported_majors)." || $supported_majors[$major] == 0\n";
2179              
2180 0 0       0 if($major > $#supported_majors) {
2181 0         0 $warn .= "| major $major > ".($#supported_majors)."\n";
2182             } else {
2183 0         0 $warn .= "| \$supported_majors[major=$major] == 0\n";
2184             }
2185             $warn .= "$_: \$supported_majors[$_] = $supported_majors[$_]\n"
2186 0         0 for (0..$#supported_majors);
2187 0         0 warn $warn;
2188 0         0 return 0;
2189             }
2190 44 50 33     87 if ($major == 4 and $self->get_config1('prohibit_v24')) {
2191 0         0 warn "Reading ID3v2-Tag version: v2.$major.$revision is prohibited via setting `prohibit_v24'\n";
2192 0         0 return 0;
2193             }
2194 44 50       71 if ($revision != 0) {
2195 0         0 warn "Unknown ID3v2-Tag revision: v2.$major.$revision\nTrying to read tag\n";
2196             }
2197             # check the flags
2198 44         45 my $flags={};
2199 44         41 my $unknownFlag=0;
2200 44         41 my $i=0;
2201 44         205 foreach (split (//, unpack('b8',pack('v',$pflags)))) {
2202 352 100       378 $flags->{$flag_meaning[$major][$i]}=1 if $_;
2203 352         253 $i++;
2204             }
2205 44         104 $self->{version} = "$major.$revision";
2206 44         46 $self->{major} = $major;
2207 44         36 $self->{revision} = $revision;
2208             # 2.3: includes extHeader, frames (as written), and the padding
2209             # excludes the header size (10)
2210             # 2.4: also excludes the footer (10 if present)
2211 44         110 $self->{tagsize} = un_syncsafe_4bytes substr $header, 6, 4;
2212 44         102 $self->{buggy_padding_size} = 0; # Fake so far
2213 44         51 $self->{flags} = $flags;
2214 44 50       85 $self->{footer_size} = ($self->{flags}->{footer} ? 10 : 0);
2215 44         212 return 1;
2216             }
2217 56         173 return 0; # no ID3v2-Tag found
2218             }
2219              
2220             # Reads the extended header and adapts the internal counter for the start of the
2221             # frame data. Ignores the rest of the ext. header (as CRC data).
2222              
2223             # v2.3:
2224             # Total size - 4 (4bytes, 6 or 10), flags (2bytes), padding size (4bytes),
2225             # OptionalCRC.
2226             # Flags: (subject to unsyncronization)
2227             # %x0000000 00000000
2228             # x - CRC data present
2229              
2230             #If this flag is set four bytes of CRC-32 data is appended to the extended header. The CRC
2231             #should be calculated before unsynchronisation on the data between the extended header and
2232             #the padding, i.e. the frames and only the frames.
2233             # Total frame CRC $xx xx xx xx
2234              
2235             # v2.4: Total size (4bytes, unsync), length of flags (=1), flags, Optional part.
2236             # 2.4 flags (with the corresponding "Optional part" format):
2237             # %0bcd0000
2238             # b - Tag is an update
2239             # Flag data length $00
2240             # c - CRC data present
2241             # Flag data length $05
2242             # Total frame CRC 5 * %0xxxxxxx
2243             # d - Tag restrictions
2244             # Flag data length $01
2245             # Restrictions %ppqrrstt
2246              
2247             sub read_ext_header { # XXXX in 2.3, it should be unsyncronized
2248 0     0 0 0 my $self = shift;
2249 0         0 my $ext_header = $self->{extheader};
2250             # flags, padding and crc ignored at this time
2251 0         0 my $size;
2252 0 0       0 if ($self->{major}==4) {
2253 0         0 $size = un_syncsafe_4bytes substr $ext_header, 0, 4;
2254             } else { # 4 bytes extra for the size field itself
2255 0         0 $size = 4 + unpack("N", $ext_header);
2256             }
2257 0         0 $self->{frame_start} += $size;
2258 0         0 return 1;
2259             }
2260              
2261             sub extract_data { # Main sub for getting data from a frame
2262 335     335 0 350 my ($self, $data, $format, $noDecode, $arr) = @_;
2263 335         247 my ($rule, $found,$encoding, @result, $e);
2264              
2265 335         233 $encoding=0;
2266 335   100     703 $arr ||= 0; # 1: values only; 2: return array
2267 335         363 foreach $rule (@$format) {
2268 1105 50       1353 next if exists $rule->{v3name};
2269 1105 100 100     1534 last if $rule->{optional} and not length $data;
2270             # get the data
2271 1103 100       1989 if ( exists $rule->{mlen} ) { # minlength, data is string
    100          
    100          
2272 1         3 ($found, $data) = ($data, ""); # Never with encoding
2273             } elsif ( $rule->{len} == 0 ) { # Till \0
2274 257 50 66     792 if (exists $rule->{encoded} && ($encoding =~ /^[12]$/)) {
2275 0         0 ($found, $data) = ($data =~ /^((?:..)*?)(?:\0\0(.*)|\z)/s);
2276             } else {
2277 257         629 ($found, $data) = split /\x00/, $data, 2;
2278             }
2279             } elsif ($rule->{len} == -1) { # Till end
2280 330         473 ($found, $data) = ($data, "");
2281             } else {
2282 515         554 $found = substr $data, 0,$rule->{len};
2283 515         550 substr ($data, 0,$rule->{len}) = '';
2284             }
2285              
2286             # was data found?
2287 1103 100 66     3292 unless (defined $found && $found ne "") {
2288 6         6 $found = "";
2289 6 50       11 $found = $rule->{default} if exists $rule->{default};
2290             }
2291              
2292             # work with data
2293 1103 100       1262 if ($rule->{name} eq "_encoding") {
2294 331         515 $encoding=unpack ("C", $found);
2295 331 100       587 push @result, 'encoding' unless $arr == 1;
2296 331         389 push @result, $encoding;
2297             } else {
2298 772 100       935 if (exists $rule->{encoded}) { # decode data
2299 480 50 33     1864 if ( $encoding > 3 ) {
    50 33        
    50          
    50          
2300 0         0 warn "Encoding type '$encoding' not supported: found in $rule->{name}\n";
2301 0         0 next;
2302             } elsif ($encoding and not $trustencoding) {
2303 0         0 warn "UTF encoding types disabled via MP3TAG_DECODE_UNICODE): found in $rule->{name}\n";
2304 0         0 next;
2305             } elsif ($encoding) {
2306             # 0 = latin1 (effectively: unknown)
2307             # 1 = UTF-16 with BOM
2308             # 2 = UTF-16be, no BOM
2309             # 3 = UTF-8
2310 0         0 require Encode;
2311 0 0       0 if ($decode_utf8) {
    0          
2312 0         0 $found = Encode::decode($dec_types[$encoding],
2313             $found);
2314             } elsif ($encoding < 3) {
2315             # Reencode in UTF-8
2316 0         0 $found = Encode::decode($dec_types[$encoding],
2317             $found);
2318 0         0 $found = Encode::encode('UTF-8', $found);
2319             }
2320             } elsif (not $noDecode and $e = $self->botched_encoding) {
2321 0         0 require Encode;
2322 0         0 $found = Encode::decode( $e, $found );
2323             }
2324             }
2325              
2326 772 100       973 $found = toNumber($found) if $rule->{isnum};
2327              
2328 772 100       971 unless ($arr) {
2329 757 100       955 $found = $rule->{func}->($found) if exists $rule->{func};
2330              
2331 757 100 66     2014 unless (exists $rule->{data} || !defined $found) {
2332 701         673 $found =~ s/[\x00]+$//; # some progs pad text fields with \x00
2333 701         549 $found =~ s![\x00]! / !g; # some progs use \x00 inside a text string to seperate text strings
2334 701         628 $found =~ s/ +$//; # no trailing spaces after the text
2335             }
2336              
2337 757 100       922 if (exists $rule->{re2}) {
2338 21         17 while (my ($pat, $rep) = each %{$rule->{re2}}) {
  61         158  
2339 40         263 $found =~ s/$pat/$rep/gis;
2340             }
2341             }
2342             }
2343             # store data
2344 772 100       1226 push @result, $rule->{name} unless $arr == 1;
2345 772         907 push @result, $found;
2346             }
2347             }
2348 335 100       1359 return {@result} unless $arr;
2349 5         11 return \@result;
2350             }
2351              
2352             sub botched_encoding ($) {
2353 562     562 0 465 my($self) = @_;
2354 562 50       762 return if $self->{fixed_encoding};
2355 562 50       1008 return unless my $enc = $self->get_config1('decode_encoding_v2');
2356             # Don't recourse into TXXX[*] (inside-[] is encoded,
2357             # and frame_select() reads ALL TXXX frames...)
2358 0         0 local $self->{fixed_encoding} = 1;
2359 0 0 0     0 return unless $self->get_config1('ignore_trusted_encoding0_v2')
2360             or not $self->frame_select('TXXX', 'trusted_encoding0_v2');
2361 0         0 $enc;
2362             }
2363              
2364             # Make editing in presence of decode_encoding_v2 more predictable:
2365             sub frames_need_fix_encoding ($) {
2366 0     0 0 0 my($self) = @_;
2367 0 0       0 return unless $self->botched_encoding;
2368 0         0 my($fname, $rule, %fix);
2369 0         0 for $fname (keys %{$self->{frames}}) {
  0         0  
2370 0         0 my $frame = $self->{frames}->{$fname};
2371 0 0       0 next unless defined $frame; # XXXX Needed?
2372 0         0 my $fname4 = substr ($fname, 0, 4);
2373 0         0 my($result, $e) = $frame->{data};
2374 0         0 my $format = get_format($fname4);
2375 0 0       0 next unless defined $format;
2376 0         0 foreach $rule (@$format) {
2377 0 0       0 next if exists $rule->{v3name};
2378             # Otherwise _encoding is the first entry
2379 0 0       0 last if $rule->{name} ne '_encoding';
2380 0         0 $e = unpack ("C", $result);
2381             }
2382 0 0 0     0 next unless defined $e and not $e; # The unfortunate "latin1"
2383 0         0 my $txts = $self->get_frame($fname, 'array_nokey');
2384 0         0 my $raw_txts = $self->get_frame($fname, 'array_nodecode');
2385 0 0       0 $fix{$fname} = $txts # Really need to fix:
2386             if join("\0\0\0", @$txts) ne join("\0\0\0", @$raw_txts);
2387             }
2388 0 0       0 return unless %fix;
2389 0         0 \%fix;
2390             }
2391              
2392             sub fix_frames_encoding ($) { # do not touch frames unless absolutely needed
2393 0     0 0 0 my($self) = @_;
2394 0         0 my($fix, $fname, $txt) = $self->frames_need_fix_encoding;
2395 0 0       0 while (($fname, $txt) = each %{$fix || {}}) {
  0         0  
2396 0         0 shift @$txt; # The 1st field is always _encoding; recalculate it
2397 0 0       0 $self->change_frame($fname, @$txt) or die;
2398             }
2399 0         0 $self->{fixed_encoding} = 1;
2400 0 0       0 $self->frame_select('TXXX', 'trusted_encoding0_v2', undef, 1)
2401             if $self->get_config1('id3v2_set_trusted_encoding0');
2402 0   0     0 return($fix and keys %$fix); # Better be scalar context...
2403             }
2404              
2405             #Searches for a format string for a specified frame. format strings exist for
2406             #specific frames, or also for a group of frames. Specific format strings have
2407             #precedence over general ones.
2408              
2409             sub get_format {
2410 427     427 0 373 my $fname = shift;
2411             # to be quiet if called from supported_frames or what_data
2412 427         285 my $quiet = shift;
2413 427         307 my $fnamecopy = $fname;
2414 427         630 while ($fname ne "") {
2415 841 100       1362 return $format{$fname} if exists $format{$fname};
2416 414         515 substr ($fname, -1) =""; #delete last char
2417             }
2418 0 0       0 warn "Unknown Frame-Format found: $fnamecopy\n" unless defined $quiet;
2419 0         0 return undef;
2420             }
2421              
2422             #Reads the flags of a frame, and returns a hash with all flags as keys, and
2423             #0/1 as value for unset/set.
2424             sub check_flags {
2425             # how to detect unknown flags?
2426 169     169 0 152 my ($self, $flags)=@_;
2427             # %0abc0000 %0h00kmnp (this is byte1 byte2)
2428 169         404 my @flagmap4 = qw/data_length unsync encryption compression unknown_j unknown_i groupid 0
2429             unknown_g unknown_f unknown_e unknown_d read_only file_preserv tag_preserv 0/;
2430             # %abc00000 %ijk00000
2431 169         333 my @flagmap3 = qw/unknown_o unknown_n unknown_l unknown_m unknown_l groupid encryption compression
2432             unknown_h unknown_g unknown_f unknown_e unknown_d read_only file_preserv tag_preserv/;
2433             # flags were unpacked with 'n', so pack('v') gives byte2 byte1
2434             # unpack('b16') puts more significant bits to the right, separately for
2435             # each byte; so the order is as specified above
2436             # 2.4:
2437             # %0abc0000 %0h00kmnp (this is byte1 byte2)
2438             # a - Tag alter preservation
2439             # b - File alter preservation
2440             # c - Read only
2441             # h - Grouping identity
2442             # k - Compression
2443             # m - Encryption
2444             # n - Unsynchronisation
2445             # p - Data length indicator
2446             # 2.3:
2447             # %abc00000 %ijk00000
2448             # a - Tag alter preservation
2449             # b - File alter preservation
2450             # c - Read only
2451             # i - Compression
2452             # j - Encryption
2453             # k - Grouping identity
2454 169 50       417 my @flagmap = $self->{major} == 4 ? @flagmap4 : @flagmap3;
2455 169         826 my %flags = map { (shift @flagmap) => $_ } split (//, unpack('b16',pack('v',$flags)));
  2704         3223  
2456 169         526 $flags{unchanged}=1;
2457 169         766 return \%flags;
2458             }
2459              
2460             sub build_flags {
2461 78     78 0 88 my %flags=@_;
2462 78         50 my $flags=0;
2463 78         181 my %flagmap=(groupid=>32, encryption=>64, compression=>128,
2464             read_only=>8192, file_preserv=>16384, tag_preserv=>32768);
2465 78         152 while (my($flag,$set)=each %flags) {
2466 0 0 0     0 if ($set and exists $flagmap{$flag}) {
    0          
2467 0         0 $flags += $flagmap{$flag};
2468             } elsif (not exists $flagmap{$flag}) {
2469 0         0 warn "Unknown flag during tag write: $flag\n";
2470             }
2471             }
2472 78         205 return $flags;
2473             }
2474              
2475       0     sub DESTROY {
2476             }
2477              
2478              
2479             ##################################
2480             #
2481             # How to store frame formats?
2482             #
2483             # format{fname}=[{xxx},{xxx},...]
2484             #
2485             # array containing descriptions of the different parts of a frame. Each description
2486             # is a hash, which contains information, how to read the part.
2487             #
2488             # As Example: TCON
2489             # Text encoding $xx
2490             # Information
2491             #
2492             # TCON consist of two parts, so a array with two hashes is needed to describe this frame.
2493             #
2494             # A hash may contain the following keys.
2495             #
2496             # * len - says how many bytes to read for this part. 0 means read until \x00, -1 means
2497             # read until end of frame, any value > 0 specifies an exact length
2498             # * mlen - specifies a minimum length for the data, real length is until end of frame
2499             # (we assume it is not paired with encoding)
2500             # * name - the user sees this part of the frame under this name. If this part contains
2501             # binary data, the name should start with a _
2502             # The name "_encoding" is reserved for the encoding part of a frame, which
2503             # is handled specifically to support encoding of text strings
2504             # (Is assumed to be the first entry, unless v3name)
2505             # * encoded - this part has to be encoded following to the encoding information
2506             # * func - a reference to a sub, which is called after the data is extracted. It gets
2507             # this data as argument and has to return some data, which is then returned
2508             # a result of this part
2509             # * isnum=1 - indicator that field stores a number as binary number
2510             # * re2 - hash with information for a replace: s/key/value/
2511             # This is used after a call of `func' when reading a frame
2512             # * re2b - hash with information for a replace: s/key/value/
2513             # This is used when adding a frame
2514             # * func_back - Translator function for add_frame (after re2b).
2515             # * data=1 - indicator that this part contains binary data
2516             # * default - default value, if data contains no information
2517             #
2518             # Name and exactly one of len or mlen are mandatory.
2519             #
2520             # TCON example:
2521             #
2522             # $format{TCON}=[{len=> 1, name=>"encoding", data=>1},
2523             # {len=>-1, name=>"text", func=>\&TCON, re2=>{'\(RX\)'=>'Remix', '\(CR\)'=>'Cover'}]
2524             #
2525             ############################
2526              
2527             sub toNumber {
2528 10     10 0 8 my $num = 0;
2529 10         33 $num = (256*$num)+unpack("C",$_) for split("",shift);
2530              
2531 10         13 return $num;
2532             }
2533              
2534             sub APIC { # MAX about 20
2535 58     58 0 47 my $byte = shift;
2536 58         78 my $index = unpack ("C", $byte);
2537 58         162 my @pictypes = ("Other", "32x32 pixels 'file icon' (PNG only)", "Other file icon",
2538             "Cover (front)", "Cover (back)", "Leaflet page",
2539             "Media (e.g. label side of CD)", "Lead artist/lead performer/soloist",
2540             "Artist/performer", "Conductor", "Band/Orchestra", "Composer",
2541             "Lyricist/text writer", "Recording Location", "During recording",
2542             "During performance", "Movie/video screen capture",
2543             "A bright coloured fish", "Illustration", "Band/artist logotype",
2544             "Publisher/Studio logotype");
2545 58         45 my $how = shift;
2546 58 100       84 if (defined $how) { # called by what_data
2547 6 50 33     33 die unless $how eq 1 and $byte eq 1;
2548 6         3 my $c=0;
2549 6         20 my %ret = map {$_, chr($c++)} @pictypes;
  126         172  
2550 6         68 return \%ret;
2551             }
2552             # called by extract_data
2553 52 50       77 return "Unknown... Error?" if $index > $#pictypes;
2554 52         98 return $pictypes[$index];
2555             }
2556              
2557             sub COMR { # MAX about 9
2558 6     6 0 5 my $data = shift;
2559 6         18 my $number = unpack ("C", $data);
2560 6         12 my @receivedas = ("Other","Standard CD album with other songs",
2561             "Compressed audio on CD","File over the Internet",
2562             "Stream over the Internet","As note sheets",
2563             "As note sheets in a book with other sheets",
2564             "Music on other media","Non-musical merchandise");
2565 6         5 my $how = shift;
2566 6 50       15 if (defined $how) {
2567 6 50 33     32 die unless $how eq 1 and $data eq 1;
2568 6         9 my $c=0;
2569 6         30 my %ret = map {$_, chr($c++)} @receivedas;
  54         87  
2570 6         47 return \%ret;
2571             }
2572 0 0       0 return $number if ($number>8);
2573 0         0 return $receivedas[$number];
2574             }
2575              
2576             sub PIC {
2577             # ID3v2.2 stores only 3 character Image format for pictures
2578             # and not mime type: Convert image format to mime type
2579 0     0 0 0 my $data = shift;
2580              
2581 0         0 my $how = shift;
2582 0 0       0 if (defined $how) { # called by what_data
2583 0 0 0     0 die unless $how eq 1 and $data eq 1;
2584 0         0 my %ret={};
2585 0         0 return \%ret;
2586             }
2587             # called by extract_data
2588 0 0       0 if ($data eq "-->") {
2589 0         0 warn "ID3v2.2 PIC frame with link not supported\n";
2590 0         0 $data = "text/plain";
2591             } else {
2592 0         0 $data = "image/".(lc $data);
2593             }
2594 0         0 return $data;
2595             }
2596              
2597             sub TCON {
2598 25     25 0 27 my $data = shift;
2599 25         19 my $how = shift;
2600 25 100       46 if (defined $how) { # called by what_data
2601 6 50 33     39 die unless $how eq 1 and $data eq 1;
2602 6         7 my $c=0;
2603 6         6 my %ret = map {$_, "(".$c++.")"} @{MP3::Tag::ID3v1::genres()};
  888         4401  
  6         22  
2604 6         42 $ret{"_FREE"}=1;
2605 6         14 $ret{Remix}='(RX)';
2606 6         6 $ret{Cover}="(CR)";
2607 6         256 return \%ret;
2608             } # called by extract_data
2609 19         34 join ' / ', MP3::Tag::Implemenation::_massage_genres($data);
2610             }
2611              
2612             sub TCON_back {
2613 12     12 0 14 my $data = shift;
2614 12         46 $data = join ' / ', map MP3::Tag::Implemenation::_massage_genres($_, 'prefer_num'),
2615             split ' / ', $data;
2616 12         27 $data =~ s[(?:(?<=\(\d\))|(?<=\(\d\d\d\))|(?<=\((?:RX|CV|\d\d)\))) / ][]ig;
2617 12         14 $data =~ s[ / (?=\((?:RX|CV|\d{1,3})\))][]ig;
2618 12         17 $data;
2619             }
2620              
2621             sub TFLT {
2622 7     7 0 9 my $text = shift;
2623 7         7 my $how = shift;
2624 7 100       17 if (defined $how) { # called by what_data
2625 6 50 33     46 die unless $how eq 1 and $text eq 1;
2626 6         30 my %ret=("MPEG Audio"=>"MPG",
2627             "MPEG Audio MPEG 1/2 layer I"=>"MPG /1",
2628             "MPEG Audio MPEG 1/2 layer II"=>"MPG /2",
2629             "MPEG Audio MPEG 1/2 layer III"=>"MPG /3",
2630             "MPEG Audio MPEG 2.5"=>"MPG /2.5",
2631             "Transform-domain Weighted Interleave Vector Quantization"=>"VQF",
2632             "Pulse Code Modulated Audio"=>"PCM",
2633             "Advanced audio compression"=>"AAC",
2634             "_FREE"=>1,
2635             );
2636 6         33 return \%ret;
2637             }
2638             #called by extract_data
2639 1 50       4 return "" if $text eq "";
2640 1         4 $text =~ s/MPG/MPEG Audio/;
2641 1         2 $text =~ s/VQF/Transform-domain Weighted Interleave Vector Quantization/;
2642 1         1 $text =~ s/PCM/Pulse Code Modulated Audio/;
2643 1         3 $text =~ s/AAC/Advanced audio compression/;
2644 1 50       3 unless ($text =~ s!/1!MPEG 1/2 layer I!) {
2645 1 50       3 unless ($text =~ s!/2!MPEG 1/2 layer II!) {
2646 1 50       4 unless ($text =~ s!/3!MPEG 1/2 layer III!) {
2647 0         0 $text =~ s!/2\.5!MPEG 2.5!;
2648             }
2649             }
2650             }
2651 1         2 return $text;
2652             }
2653              
2654             sub TMED {
2655             #called by extract_data
2656 0     0 0   my $text = shift;
2657 0 0         return "" if $text eq "";
2658 0 0         if ($text =~ /(?
2659 0           my $found = $1;
2660 0 0 0       if ($found =~ s!DIG!Other digital Media! ||
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
      0        
2661             $found =~ /DAT/ ||
2662             $found =~ /DCC/ ||
2663             $found =~ /DVD/ ||
2664             $found =~ s!MD!MiniDisc! ||
2665             $found =~ s!LD!Laserdisc!) {
2666 0           $found =~ s!/A!, Analog Transfer from Audio!;
2667             }
2668             elsif ($found =~ /CD/) {
2669 0           $found =~ s!/DD!, DDD!;
2670 0           $found =~ s!/AD!, ADD!;
2671 0           $found =~ s!/AA!, AAD!;
2672             }
2673             elsif ($found =~ s!ANA!Other analog Media!) {
2674 0           $found =~ s!/WAC!, Wax cylinder!;
2675 0           $found =~ s!/8CA!, 8-track tape cassette!;
2676             }
2677             elsif ($found =~ s!TT!Turntable records!) {
2678 0           $found =~ s!/33!, 33.33 rpm!;
2679 0           $found =~ s!/45!, 45 rpm!;
2680 0           $found =~ s!/71!, 71.29 rpm!;
2681 0           $found =~ s!/76!, 76.59 rpm!;
2682 0           $found =~ s!/78!, 78.26 rpm!;
2683 0           $found =~ s!/80!, 80 rpm!;
2684             }
2685             elsif ($found =~ s!TV!Television! ||
2686             $found =~ s!VID!Video! ||
2687             $found =~ s!RAD!Radio!) {
2688 0           $found =~ s!/!, !;
2689             }
2690             elsif ($found =~ s!TEL!Telephone!) {
2691 0           $found =~ s!/I!, ISDN!;
2692             }
2693             elsif ($found =~ s!REE!Reel! ||
2694             $found =~ s!MC!MC (normal cassette)!) {
2695 0           $found =~ s!/4!, 4.75 cm/s (normal speed for a two sided cassette)!;
2696 0           $found =~ s!/9!, 9.5 cm/s!;
2697 0           $found =~ s!/19!, 19 cm/s!;
2698 0           $found =~ s!/38!, 38 cm/s!;
2699 0           $found =~ s!/76!, 76 cm/s!;
2700 0           $found =~ s!/I!, Type I cassette (ferric/normal)!;
2701 0           $found =~ s!/II!, Type II cassette (chrome)!;
2702 0           $found =~ s!/III!, Type III cassette (ferric chrome)!;
2703 0           $found =~ s!/IV!, Type IV cassette (metal)!;
2704             }
2705 0           $text =~ s/(?
2706             }
2707 0           $text =~ s/\(\(/\(/g;
2708 0           $text =~ s/ / /g;
2709              
2710 0           return $text;
2711             }
2712              
2713             for my $elt ( qw( cddb_id cdindex_id ) ) {
2714 6     6   39 no strict 'refs';
  6         8  
  6         4177  
2715             *$elt = sub (;$) {
2716 0     0     my $self = shift;
2717 0           $self->frame_select('TXXX', $elt);
2718             }
2719             }
2720              
2721             BEGIN {
2722             # ID3v2.2, v2.3 are supported, v2.4 is very compatible...
2723 6     6   15 @supported_majors=(0,0,1,1,1);
2724              
2725 6         16 my $encoding ={len=>1, name=>"_encoding", data=>1};
2726 6         14 my $text_enc ={len=>-1, name=>"Text", encoded=>1};
2727 6         14 my $text ={len=>-1, name=>"Text"};
2728 6         9 my $description ={len=>0, name=>"Description", encoded=>1};
2729 6         8 my $url ={len=>-1, name=>"URL"};
2730 6         24 my $url0 ={len=>0, name=>"URL"};
2731 6         12 my $data ={len=>-1, name=>"_Data", data=>1};
2732 6         16 my $language ={len=>3, name=>"Language"};
2733              
2734             # this list contains all id3v2.2 frame names which can be matched directly to a id3v2.3 frame
2735 6         170 %v2names_to_v3 = (
2736             BUF => "RBUF",
2737             CNT => "PCNT",
2738             COM => "COMM",
2739             CRA => "AENC",
2740             EQU => "EQUA",
2741             ETC => "ETCO",
2742             GEO => "GEOB",
2743             IPL => "IPLS",
2744             MCI => "MDCI",
2745             MLL => "MLLT",
2746             POP => "POPM",
2747             REV => "RVRB",
2748             RVA => "RVAD",
2749             SLT => "SYLT",
2750             STC => "SYTC",
2751             TFT => "TFLT",
2752             TMT => "TMED",
2753             UFI => "UFID",
2754             ULT => "USLT",
2755             TAL => "TALB",
2756             TBP => "TBPM",
2757             TCM => "TCOM",
2758             TCO => "TCON",
2759             TCR => "TCOP",
2760             TDA => "TDAT",
2761             TDY => "TDLY",
2762             TEN => "TENC",
2763             TIM => "TIME",
2764             TKE => "TKEY",
2765             TLA => "TLAN",
2766             TLE => "TLEN",
2767             TOA => "TOPE",
2768             TOF => "TOFN",
2769             TOL => "TOLY",
2770             TOR => "TORY",
2771             TOT => "TOAL",
2772             TP1 => "TPE1",
2773             TP2 => "TPE2",
2774             TP3 => "TPE3",
2775             TP4 => "TPE4",
2776             TPA => "TPOS",
2777             TPB => "TPUB",
2778             TRC => "TSRC",
2779             TRD => "TRDA",
2780             TRK => "TRCK",
2781             TSI => "TSIZ",
2782             TSS => "TSSE",
2783             TT1 => "TIT1",
2784             TT2 => "TIT2",
2785             TT3 => "TIT3",
2786             TXT => "TEXT",
2787             TXX => "TXXX",
2788             TYE => "TYER",
2789             WAF => "WOAF",
2790             WAR => "WOAR",
2791             WAS => "WOAS",
2792             WCM => "WCOM",
2793             WCP => "WCOP",
2794             WPB => "WPUB",
2795             WXX => "WXXX",
2796             );
2797              
2798 6         451 %format = (
2799             AENC => [$url0, {len=>2, name=>"Preview start", isnum=>1},
2800             {len=>2, name=>"Preview length", isnum=>1}, $data],
2801             APIC => [$encoding, {len=>0, name=>"MIME type"},
2802             {len=>1, name=>"Picture Type", small_max=>1, func=>\&APIC},
2803             $description, $data],
2804             COMM => [$encoding, $language, $description, $text_enc],
2805             COMR => [$encoding, {len=>0, name=>"Price"},
2806             {len=>8, name=>"Valid until"}, $url0,
2807             {len=>1, name=>"Received as", small_max=>1, func=>\&COMR},
2808             {len=>0, name=>"Name of Seller", encoded=>1},
2809             $description, {len=>0, name=>"MIME type", optional=>1},
2810             {len=>-1, name=>"_Logo", data=>1, optional => 1}],
2811             CRM => [{v3name=>""},{len=>0, name=>"Owner ID"}, {len=>0, name=>"Content/explanation"}, $data], #v2.2
2812             ENCR => [{len=>0, name=>"Owner ID"}, {len=>0, name=>"Method symbol"}, $data],
2813             #EQUA => [],
2814             #ETCO => [],
2815             GEOB => [$encoding, {len=>0, name=>"MIME type"},
2816             {len=>0, name=>"Filename"}, $description, $data],
2817             GRID => [{len=>0, name=>"Owner"}, {len=>1, name=>"Symbol", isnum=>1},
2818             $data],
2819             IPLS => [$encoding, $text_enc], # in 2.4 split into TMCL, TIPL
2820             LNK => [{len=>4, name=>"ID", func=>\&LNK}, {len=>0, name=>"URL"}, $text],
2821             LINK => [{len=>4, name=>"ID"}, {len=>0, name=>"URL"}, $text],
2822             MCDI => [$data],
2823             #MLLT => [],
2824             OWNE => [$encoding, {len=>0, name=>"Price payed"},
2825             {len=>0, name=>"Date of purchase"}, $text_enc],
2826             PCNT => [{mlen=>4, name=>"Text", isnum=>1}],
2827             PIC => [{v3name => "APIC"}, $encoding, {len=>3, name=>"Image Format", func=>\&PIC},
2828             {len=>1, name=>"Picture Type", func=>\&APIC}, $description, $data], #v2.2
2829             POPM => [{len=>0, name=>"URL"},{len=>1, name=>"Rating", isnum=>1},
2830             {mlen=>4, name=>"Counter", isnum=>1, optional=>1}],
2831             #POSS => [],
2832             PRIV => [{len=>0, name=>"Text"}, $data],
2833             RBUF => [{len=>3, name=>"Buffer size", isnum=>1},
2834             {len=>1, name=>"Embedded info flag", isnum=>1},
2835             {len=>4, name=>"Offset to next tag", isnum=>1, optional=>1}],
2836             #RVAD => [],
2837             RVRB => [{len=>2, name=>"Reverb left (ms)", isnum=>1},
2838             {len=>2, name=>"Reverb right (ms)", isnum=>1},
2839             {len=>1, name=>"Reverb bounces (left)", isnum=>1},
2840             {len=>1, name=>"Reverb bounces (right)", isnum=>1},
2841             {len=>1, name=>"Reverb feedback (left to left)", isnum=>1},
2842             {len=>1, name=>"Reverb feedback (left to right)", isnum=>1},
2843             {len=>1, name=>"Reverb feedback (right to right)", isnum=>1},
2844             {len=>1, name=>"Reverb feedback (right to left)", isnum=>1},
2845             {len=>1, name=>"Premix left to right", isnum=>1},
2846             {len=>1, name=>"Premix right to left", isnum=>1},],
2847             SYTC => [{len=>1, name=>"Time Stamp Format", isnum=>1}, $data],
2848             #SYLT => [],
2849             T => [$encoding, $text_enc],
2850             TCON => [$encoding,
2851             {%$text_enc, func=>\&TCON, func_back => \&TCON_back,
2852             re2=>{'\(RX\)'=>'Remix', '\(CR\)'=>'Cover'},
2853             # re2b=>{'\bRemix\b'=>'(RX)', '\bCover\b'=>'(CR)'}
2854             }],
2855             TCOP => [$encoding,
2856             {%$text_enc, re2 => {'^(?!\Z)'=>'(C) '},
2857             re2b => {'^(Copyright\b)?\s*(\(C\)\s*)?' => ''}}],
2858             # TDRC => [$encoding, $text_enc, data => 1],
2859             TFLT => [$encoding, {%$text_enc, func=>\&TFLT}],
2860             TIPL => [{v3name => "IPLS"}, $encoding, $text_enc],
2861             TMCL => [{v3name => "IPLS"}, $encoding, $text_enc],
2862             TMED => [$encoding, {%$text_enc, func=>\&TMED}], # no what_data support
2863             TXXX => [$encoding, $description, $text_enc],
2864             UFID => [{%$description, name=>"Text"}, $data],
2865             USER => [$encoding, $language, $text_enc],
2866             USLT => [$encoding, $language, $description, $text_enc],
2867             W => [$url],
2868             WXXX => [$encoding, $description, $url],
2869             );
2870              
2871 6         194 %long_names = (
2872             AENC => "Audio encryption",
2873             APIC => "Attached picture",
2874             COMM => "Comments",
2875             COMR => "Commercial frame",
2876             ENCR => "Encryption method registration",
2877             EQUA => "Equalization",
2878             ETCO => "Event timing codes",
2879             GEOB => "General encapsulated object",
2880             GRID => "Group identification registration",
2881             IPLS => "Involved people list",
2882             LINK => "Linked information",
2883             MCDI => "Music CD identifier",
2884             MLLT => "MPEG location lookup table",
2885             OWNE => "Ownership frame",
2886             PRIV => "Private frame",
2887             PCNT => "Play counter",
2888             POPM => "Popularimeter",
2889             POSS => "Position synchronisation frame",
2890             RBUF => "Recommended buffer size",
2891             RVAD => "Relative volume adjustment",
2892             RVRB => "Reverb",
2893             SYLT => "Synchronized lyric/text",
2894             SYTC => "Synchronized tempo codes",
2895             TALB => "Album/Movie/Show title",
2896             TBPM => "BPM (beats per minute)",
2897             TCOM => "Composer",
2898             TCON => "Content type",
2899             TCOP => "Copyright message",
2900             TDAT => "Date",
2901             TDLY => "Playlist delay",
2902             TDRC => "Recording time",
2903             TENC => "Encoded by",
2904             TEXT => "Lyricist/Text writer",
2905             TFLT => "File type",
2906             TIME => "Time",
2907             TIPL => "Involved people list",
2908             TIT1 => "Content group description",
2909             TIT2 => "Title/songname/content description",
2910             TIT3 => "Subtitle/Description refinement",
2911             TKEY => "Initial key",
2912             TLAN => "Language(s)",
2913             TLEN => "Length",
2914             TMCL => "Musician credits list",
2915             TMED => "Media type",
2916             TOAL => "Original album/movie/show title",
2917             TOFN => "Original filename",
2918             TOLY => "Original lyricist(s)/text writer(s)",
2919             TOPE => "Original artist(s)/performer(s)",
2920             TORY => "Original release year",
2921             TOWN => "File owner/licensee",
2922             TPE1 => "Lead performer(s)/Soloist(s)",
2923             TPE2 => "Band/orchestra/accompaniment",
2924             TPE3 => "Conductor/performer refinement",
2925             TPE4 => "Interpreted, remixed, or otherwise modified by",
2926             TPOS => "Part of a set",
2927             TPUB => "Publisher",
2928             TRCK => "Track number/Position in set",
2929             TRDA => "Recording dates",
2930             TRSN => "Internet radio station name",
2931             TRSO => "Internet radio station owner",
2932             TSIZ => "Size",
2933             TSRC => "ISRC (international standard recording code)",
2934             TSSE => "Software/Hardware and settings used for encoding",
2935             TYER => "Year",
2936             TXXX => "User defined text information frame",
2937             UFID => "Unique file identifier",
2938             USER => "Terms of use",
2939             USLT => "Unsychronized lyric/text transcription",
2940             WCOM => "Commercial information",
2941             WCOP => "Copyright/Legal information",
2942             WOAF => "Official audio file webpage",
2943             WOAR => "Official artist/performer webpage",
2944             WOAS => "Official audio source webpage",
2945             WORS => "Official internet radio station homepage",
2946             WPAY => "Payment",
2947             WPUB => "Publishers official webpage",
2948             WXXX => "User defined URL link frame",
2949              
2950             # ID3v2.2 frames which cannot linked directly to a ID3v2.3 frame
2951             CRM => "Encrypted meta frame",
2952             PIC => "Attached picture",
2953             LNK => "Linked information",
2954             );
2955              
2956             # these fields have restricted input (FRAMEfield)
2957 6         17 %res_inp=( "APICPicture Type" => \&APIC,
2958             "TCONText" => \&TCON, # Actually, has func_back()...
2959             "TFLTText" => \&TFLT,
2960             "COMRReceived as" => \&COMR,
2961             );
2962             # have small_max
2963 6         31 %is_small_int = ("APICPicture Type" => 1, "COMRReceived as" => 1);
2964              
2965 6         18 for my $k (keys %res_inp) {
2966 24         18 my %h = %{ $field_map{$k} = $res_inp{$k}->(1,1) }; # Assign+make copy
  24         42  
2967 24         56 delete $h{_FREE};
2968 24         1327 %h = reverse %h;
2969 24         128 $field_map_back{$k} = \%h;
2970             }
2971             # Watch for 'lable':
2972             $field_map{'APICPicture Type'}{'Media (e.g. lable side of CD)'} =
2973 6         15 $field_map{'APICPicture Type'}{'Media (e.g. label side of CD)'};
2974 6         10 %back_splt = qw(POPM 1); # Have numbers at end
2975 6         281 %embedded_Descr = qw(GEOD 1 COMR 1); # Have descr which is not leading
2976             }
2977              
2978             =pod
2979              
2980             =back
2981              
2982             =head1 BUGS
2983              
2984             Writing C-layout tags is not supported.
2985              
2986             Additionally, one should keep in mind that C and C have differences
2987             in two areas:
2988              
2989             =over 4
2990              
2991             =item *
2992              
2993             layout of information in the byte stream (in other words, in a file
2994             considered as a string) is different;
2995              
2996             =item *
2997              
2998             semantic of frames is extended in C - more frames are defined, and
2999             more frame flags are defined too.
3000              
3001             =back
3002              
3003             MP3::Tag does not even try to I frames in C-layout. However,
3004             when I the frames, MP3::Tag does not assume any restriction on
3005             the semantic of frames - it allows all the semantical extensions
3006             defined in C even for C (and, probably, for C) layout.
3007              
3008             C<[*]> (I expect, any sane program would do the same...)
3009              
3010             Likewise, when writing frames, there is no restriction imposed on semantic.
3011             If user specifies a frame the meaning of which is defined only in C,
3012             we would happily write it even when we use C layout. Same for frame
3013             flags. (And given the assumption C<[*]>, this is a correct thing to do...)
3014              
3015             =head1 SEE ALSO
3016              
3017             L, L, L
3018              
3019             ID3v2 standard - http://www.id3.org
3020             L, L,
3021             L,
3022             L,
3023             L.
3024              
3025             =head1 COPYRIGHT
3026              
3027             Copyright (c) 2000-2008 Thomas Geffert, Ilya Zakharevich. All rights reserved.
3028              
3029             This program is free software; you can redistribute it and/or
3030             modify it under the terms of the Artistic License, distributed
3031             with Perl.
3032              
3033             =cut
3034              
3035              
3036             1;