1#------------------------------------------------------------------------------
2# File:         GIF.pm
3#
4# Description:  Read and write GIF meta information
5#
6# Revisions:    10/18/2005 - P. Harvey Separated from ExifTool.pm
7#               05/23/2008 - P. Harvey Added ability to read/write XMP
8#               10/28/2011 - P. Harvey Added ability to read/write ICC_Profile
9#
10# References:   1) http://www.w3.org/Graphics/GIF/spec-gif89a.txt
11#               2) http://www.adobe.com/devnet/xmp/
12#               3) http://graphcomp.com/info/specs/ani_gif.html
13#               4) http://www.color.org/icc_specs2.html
14#               5) http://www.midiox.com/mmgif.htm
15#------------------------------------------------------------------------------
16
17package Image::ExifTool::GIF;
18
19use strict;
20use vars qw($VERSION);
21use Image::ExifTool qw(:DataAccess :Utils);
22
23$VERSION = '1.18';
24
25# road map of directory locations in GIF images
26my %gifMap = (
27    XMP         => 'GIF',
28    ICC_Profile => 'GIF',
29);
30
31%Image::ExifTool::GIF::Main = (
32    GROUPS => { 2 => 'Image' },
33    VARS => { NO_ID => 1 },
34    NOTES => q{
35        This table lists information extracted from GIF images. See
36        L<http://www.w3.org/Graphics/GIF/spec-gif89a.txt> for the official GIF89a
37        specification.
38    },
39    GIFVersion => { },
40    FrameCount => { Notes => 'number of animated images' },
41    Text       => { Notes => 'text displayed in image' },
42    Comment    => {
43        # for documentation only -- flag as writable for the docs, but
44        # it won't appear in the TagLookup because there is no WRITE_PROC
45        Writable => 2,
46    },
47    Duration   => {
48        Notes => 'duration of a single animation iteration',
49        PrintConv => 'sprintf("%.2f s",$val)',
50    },
51    ScreenDescriptor => {
52        SubDirectory => { TagTable => 'Image::ExifTool::GIF::Screen' },
53    },
54    Extensions => { # (for documentation only)
55        SubDirectory => { TagTable => 'Image::ExifTool::GIF::Extensions' },
56    },
57);
58
59# GIF89a application extensions:
60%Image::ExifTool::GIF::Extensions = (
61    GROUPS => { 2 => 'Image' },
62    NOTES => 'Tags extracted from GIF89a application extensions.',
63    'NETSCAPE/2.0' => { #3
64        Name => 'Animation',
65        SubDirectory => { TagTable => 'Image::ExifTool::GIF::Animation' },
66    },
67    'XMP Data/XMP' => { #2
68        Name => 'XMP',
69        IncludeLengthBytes => 1, # length bytes are included in the data
70        Writable => 2,
71        SubDirectory => { TagTable => 'Image::ExifTool::XMP::Main' },
72    },
73    'ICCRGBG1/012' => { #4
74        Name => 'ICC_Profile',
75        Writable => 2,
76        SubDirectory => { TagTable => 'Image::ExifTool::ICC_Profile::Main' },
77    },
78    'MIDICTRL/Jon' => { #5
79        Name => 'MIDIControl',
80        SubDirectory => { TagTable => 'Image::ExifTool::GIF::MIDIControl' },
81    },
82    'MIDISONG/Dm7' => { #5
83        Name => 'MIDISong',
84        Groups => { 2 => 'Audio' },
85        Binary => 1,
86    },
87);
88
89# GIF locical screen descriptor
90%Image::ExifTool::GIF::Screen = (
91    PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
92    GROUPS => { 2 => 'Image' },
93    NOTES => 'Information extracted from the GIF logical screen descriptor.',
94    0 => {
95        Name => 'ImageWidth',
96        Format => 'int16u',
97    },
98    2 => {
99        Name => 'ImageHeight',
100        Format => 'int16u',
101    },
102    4.1 => {
103        Name => 'HasColorMap',
104        Mask => 0x80,
105        PrintConv => { 0 => 'No', 1 => 'Yes' },
106    },
107    4.2 => {
108        Name => 'ColorResolutionDepth',
109        Mask => 0x70,
110        ValueConv => '$val + 1',
111    },
112    4.3 => {
113        Name => 'BitsPerPixel',
114        Mask => 0x07,
115        ValueConv => '$val + 1',
116    },
117    5 => 'BackgroundColor',
118    6 => {
119        Name => 'PixelAspectRatio',
120        RawConv => '$val ? $val : undef',
121        ValueConv => '($val + 15) / 64',
122    },
123);
124
125# GIF Netscape 2.0 animation extension (ref 3)
126%Image::ExifTool::GIF::Animation = (
127    PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
128    GROUPS => { 2 => 'Image' },
129    NOTES => 'Information extracted from the "NETSCAPE2.0" animation extension.',
130    1 => {
131        Name => 'AnimationIterations',
132        Format => 'int16u',
133        PrintConv => '$val ? $val : "Infinite"',
134    },
135);
136
137# GIF MIDICTRL extension (ref 5)
138%Image::ExifTool::GIF::MIDIControl = (
139    PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
140    GROUPS => { 2 => 'Audio' },
141    NOTES => 'Information extracted from the MIDI control block extension.',
142    0 => 'MIDIControlVersion',
143    1 => 'SequenceNumber',
144    2 => 'MelodicPolyphony',
145    3 => 'PercussivePolyphony',
146    4 => {
147        Name => 'ChannelUsage',
148        Format => 'int16u',
149        PrintConv => 'sprintf("0x%.4x", $val)',
150    },
151    6 => {
152        Name => 'DelayTime',
153        Format => 'int16u',
154        ValueConv => '$val / 100',
155        PrintConv => '$val . " s"',
156    },
157);
158
159#------------------------------------------------------------------------------
160# Process meta information in GIF image
161# Inputs: 0) ExifTool object reference, 1) Directory information ref
162# Returns: 1 on success, 0 if this wasn't a valid GIF file, or -1 if
163#          an output file was specified and a write error occurred
164sub ProcessGIF($$)
165{
166    my ($et, $dirInfo) = @_;
167    my $outfile = $$dirInfo{OutFile};
168    my $raf = $$dirInfo{RAF};
169    my $verbose = $et->Options('Verbose');
170    my $out = $et->Options('TextOut');
171    my ($a, $s, $ch, $length, $buff);
172    my ($err, $newComment, $setComment, $nvComment);
173    my ($addDirs, %doneDir);
174    my ($frameCount, $delayTime) = (0, 0);
175
176    # verify this is a valid GIF file
177    return 0 unless $raf->Read($buff, 6) == 6
178        and $buff =~ /^GIF(8[79]a)$/
179        and $raf->Read($s, 7) == 7;
180
181    my $ver = $1;
182    my $rtnVal = 0;
183    my $tagTablePtr = GetTagTable('Image::ExifTool::GIF::Main');
184    SetByteOrder('II');
185
186    if ($outfile) {
187        $et->InitWriteDirs(\%gifMap, 'XMP'); # make XMP the preferred group for GIF
188        $addDirs = $$et{ADD_DIRS};
189        # determine if we are editing the File:Comment tag
190        my $delGroup = $$et{DEL_GROUP};
191        $newComment = $et->GetNewValue('Comment', \$nvComment);
192        $setComment = 1 if $nvComment or $$delGroup{File};
193        # change to GIF 89a if adding comment, XMP or ICC_Profile
194        $buff = 'GIF89a' if $$addDirs{XMP} or $$addDirs{ICC_Profile} or defined $newComment;
195        Write($outfile, $buff, $s) or $err = 1;
196    } else {
197        $et->SetFileType();   # set file type
198        $et->HandleTag($tagTablePtr, 'GIFVersion', $ver);
199        $et->HandleTag($tagTablePtr, 'ScreenDescriptor', $s);
200    }
201    my $flags = Get8u(\$s, 4);
202    if ($flags & 0x80) { # does this image contain a color table?
203        # calculate color table size
204        $length = 3 * (2 << ($flags & 0x07));
205        $raf->Read($buff, $length) == $length or return 0; # skip color table
206        Write($outfile, $buff) or $err = 1 if $outfile;
207    }
208#
209# loop through GIF blocks
210#
211Block:
212    for (;;) {
213        last unless $raf->Read($ch, 1);
214        # write out any new metadata now if this isn't an extension block
215        if ($outfile and ord($ch) != 0x21) {
216            # write the comment first if necessary
217            if (defined $newComment and $$nvComment{IsCreating}) {
218                # write comment marker
219                Write($outfile, "\x21\xfe") or $err = 1;
220                $verbose and print $out "  + Comment = $newComment\n";
221                my $len = length($newComment);
222                # write out the comment in 255-byte chunks, each
223                # chunk beginning with a length byte
224                my $n;
225                for ($n=0; $n<$len; $n+=255) {
226                    my $size = $len - $n;
227                    $size > 255 and $size = 255;
228                    my $str = substr($newComment,$n,$size);
229                    Write($outfile, pack('C',$size), $str) or $err = 1;
230                }
231                Write($outfile, "\0") or $err = 1;  # empty chunk as terminator
232                undef $newComment;
233                undef $nvComment;   # delete any other extraneous comments
234                ++$$et{CHANGED};    # increment file changed flag
235            }
236            # add application extension containing XMP block if necessary
237            # (this will place XMP before the first non-extension block)
238            if (exists $$addDirs{XMP} and not defined $doneDir{XMP}) {
239                $doneDir{XMP} = 1;
240                # write new XMP data
241                my $xmpTable = GetTagTable('Image::ExifTool::XMP::Main');
242                my %dirInfo = ( Parent => 'GIF' );
243                $verbose and print $out "Creating XMP application extension block:\n";
244                $buff = $et->WriteDirectory(\%dirInfo, $xmpTable);
245                if (defined $buff and length $buff) {
246                    my $lz = pack('C*',1,reverse(0..255),0);
247                    Write($outfile, "\x21\xff\x0bXMP DataXMP", $buff, $lz) or $err = 1;
248                    ++$doneDir{XMP};    # set to 2 to indicate we added XMP
249                } else {
250                    $verbose and print $out "  -> no XMP to add\n";
251                }
252            }
253            # add application extension containing ICC_Profile if necessary
254            if (exists $$addDirs{ICC_Profile} and not defined $doneDir{ICC_Profile}) {
255                $doneDir{ICC_Profile} = 1;
256                # write new ICC_Profile
257                my $iccTable = GetTagTable('Image::ExifTool::ICC_Profile::Main');
258                my %dirInfo = ( Parent => 'GIF' );
259                $verbose and print $out "Creating ICC_Profile application extension block:\n";
260                $buff = $et->WriteDirectory(\%dirInfo, $iccTable);
261                if (defined $buff and length $buff) {
262                    my $pos = 0;
263                    Write($outfile, "\x21\xff\x0bICCRGBG1012") or $err = 1;
264                    my $len = length $buff;
265                    while ($pos < $len) {
266                        my $n = $len - $pos;
267                        $n = 255 if $n > 255;
268                        Write($outfile, chr($n), substr($buff, $pos, $n)) or $err = 1;
269                        $pos += $n;
270                    }
271                    Write($outfile, "\0") or $err = 1;  # write null terminator
272                    ++$doneDir{ICC_Profile};    # set to 2 to indicate we added a new profile
273                } else {
274                    $verbose and print $out "  -> no ICC_Profile to add\n";
275                }
276            }
277        }
278        if (ord($ch) == 0x2c) {
279            ++$frameCount;
280            Write($outfile, $ch) or $err = 1 if $outfile;
281            # image descriptor
282            last unless $raf->Read($buff, 8) == 8 and $raf->Read($ch, 1);
283            Write($outfile, $buff, $ch) or $err = 1 if $outfile;
284            if ($verbose) {
285                my ($left, $top, $w, $h) = unpack('v*', $buff);
286                print $out "Image: left=$left top=$top width=$w height=$h\n";
287            }
288            if (ord($ch) & 0x80) { # does color table exist?
289                $length = 3 * (2 << (ord($ch) & 0x07));
290                # skip the color table
291                last unless $raf->Read($buff, $length) == $length;
292                Write($outfile, $buff) or $err = 1 if $outfile;
293            }
294            # skip "LZW Minimum Code Size" byte
295            last unless $raf->Read($buff, 1);
296            Write($outfile,$buff) or $err = 1 if $outfile;
297            # skip image blocks
298            for (;;) {
299                last unless $raf->Read($ch, 1);
300                Write($outfile, $ch) or $err = 1 if $outfile;
301                last unless ord($ch);
302                last unless $raf->Read($buff, ord($ch));
303                Write($outfile,$buff) or $err = 1 if $outfile;
304            }
305            next;  # continue with next field
306        }
307#               last if ord($ch) == 0x3b;  # normal end of GIF marker
308        unless (ord($ch) == 0x21) {
309            if ($outfile) {
310                Write($outfile, $ch) or $err = 1;
311                # copy the rest of the file
312                while ($raf->Read($buff, 65536)) {
313                    Write($outfile, $buff) or $err = 1;
314                }
315            }
316            $rtnVal = 1;
317            last;
318        }
319        # get extension block type/size
320        last unless $raf->Read($s, 2) == 2;
321        # get marker and block size
322        ($a,$length) = unpack("C"x2, $s);
323
324        if ($a == 0xfe) {                           # comment extension
325
326            my $comment = '';
327            while ($length) {
328                last unless $raf->Read($buff, $length) == $length;
329                $et->VerboseDump(\$buff) unless $outfile;
330                # add buffer to comment string
331                $comment .= $buff;
332                last unless $raf->Read($ch, 1);  # read next block header
333                $length = ord($ch);  # get next block size
334            }
335            last if $length;    # was a read error if length isn't zero
336            if ($outfile) {
337                my $isOverwriting;
338                if ($setComment) {
339                    if ($nvComment) {
340                        $isOverwriting = $et->IsOverwriting($nvComment,$comment);
341                        # get new comment again (may have been shifted)
342                        $newComment = $et->GetNewValue($nvComment) if defined $newComment;
343                    } else {
344                        # group delete, or deleting additional comments after writing one
345                        $isOverwriting = 1;
346                    }
347                }
348                if ($isOverwriting) {
349                    ++$$et{CHANGED};     # increment file changed flag
350                    $et->VerboseValue('- Comment', $comment);
351                    $comment = $newComment;
352                    $et->VerboseValue('+ Comment', $comment) if defined $comment;
353                    undef $nvComment;   # just delete remaining comments
354                } else {
355                    undef $setComment;  # leave remaining comments alone
356                }
357                if (defined $comment) {
358                    # write comment marker
359                    Write($outfile, "\x21\xfe") or $err = 1;
360                    my $len = length($comment);
361                    # write out the comment in 255-byte chunks, each
362                    # chunk beginning with a length byte
363                    my $n;
364                    for ($n=0; $n<$len; $n+=255) {
365                        my $size = $len - $n;
366                        $size > 255 and $size = 255;
367                        my $str = substr($comment,$n,$size);
368                        Write($outfile, pack('C',$size), $str) or $err = 1;
369                    }
370                    Write($outfile, "\0") or $err = 1;  # empty chunk as terminator
371                }
372                undef $newComment;  # don't write the new comment again
373            } else {
374                $rtnVal = 1;
375                $et->FoundTag('Comment', $comment) if $comment;
376                undef $comment;
377                # assume no more than one comment in FastScan mode
378                last if $et->Options('FastScan');
379            }
380            next;
381
382        } elsif ($a == 0xff and $length == 0x0b) {  # application extension
383
384            last unless $raf->Read($buff, $length) == $length;
385            my $hdr = "$ch$s$buff";
386            # add "/" for readability
387            my $tag = substr($buff, 0, 8) . '/' . substr($buff, 8);
388            $tag =~ tr/\0-\x1f//d;   # remove nulls and control characters
389            $verbose and print $out "Application Extension: $tag\n";
390
391            my $extTable = GetTagTable('Image::ExifTool::GIF::Extensions');
392            my $extInfo = $$extTable{$tag};
393            my ($subdir, $inclLen, $justCopy);
394            if ($extInfo) {
395                $subdir = $$extInfo{SubDirectory};
396                $inclLen = $$extInfo{IncludeLengthBytes};
397                # rewrite as-is unless this is a writable subdirectory
398                $justCopy = 1 if $outfile and (not $subdir or not $$extInfo{Writable});
399            } else {
400                $justCopy = 1 if $outfile;
401            }
402            Write($outfile, $hdr) or $err = 1 if $justCopy;
403
404            # read the extension data
405            my $dat = '';
406            for (;;) {
407                $raf->Read($ch, 1) or last Block;   # read next block header
408                $length = ord($ch) or last;         # get next block size
409                $raf->Read($buff, $length) == $length or last Block;
410                Write($outfile, $ch, $buff) or $err = 1 if $justCopy;
411                $dat .= $inclLen ? $ch . $buff : $buff;
412            }
413            Write($outfile, "\0") if $justCopy;
414
415            if ($subdir) {
416                my $dirLen = length $dat;
417                my $name = $$extInfo{Name};
418                if ($name eq 'XMP') {
419                    # get length of XMP without landing zone data
420                    # (note that LZ data may not be exactly the same as what we use)
421                    $dirLen = pos($dat) if $dat =~ /<\?xpacket end=['"][wr]['"]\?>/g;
422                }
423                my %dirInfo = (
424                    DataPt  => \$dat,
425                    DataLen => length $dat,
426                    DirLen  => $dirLen,
427                    DirName => $name,
428                    Parent  => 'GIF',
429                );
430                my $subTable = GetTagTable($$subdir{TagTable});
431                if (not $outfile) {
432                    $et->ProcessDirectory(\%dirInfo, $subTable);
433                } elsif ($$extInfo{Writable}) {
434                    if ($doneDir{$name} and $doneDir{$name} > 1) {
435                        $et->Warn("Duplicate $name block created");
436                    }
437                    $buff = $et->WriteDirectory(\%dirInfo, $subTable);
438                    if (defined $buff) {
439                        next unless length $buff;   # delete this extension if length is zero
440                        # check for null just to be safe
441                        $et->Error("$name contained NULL character") if $buff =~ /\0/;
442                        $dat = $buff;
443                        # add landing zone (without terminator, which will be added later)
444                        $dat .= pack('C*',1,reverse(0..255)) if $$extInfo{IncludeLengthBytes};
445                    } # (else rewrite original data)
446
447                    $doneDir{$name} = 1;
448
449                    if ($$extInfo{IncludeLengthBytes}) {
450                        # write data and landing zone
451                        Write($outfile, $hdr, $dat) or $err = 1;
452                    } else {
453                        # write as sub-blocks
454                        Write($outfile, $hdr) or $err = 1;
455                        my $pos = 0;
456                        my $len = length $dat;
457                        while ($pos < $len) {
458                            my $n = $len - $pos;
459                            $n = 255 if $n > 255;
460                            Write($outfile, chr($n), substr($dat, $pos, $n)) or $err = 1;
461                            $pos += $n;
462                        }
463                    }
464                    Write($outfile, "\0") or $err = 1;  # write null terminator
465                }
466            } elsif (not $outfile) {
467                $et->HandleTag($extTable, $tag, $dat);
468            }
469            next;
470
471        } elsif ($a == 0xf9 and $length == 4) {     # graphic control extension
472
473            last unless $raf->Read($buff, $length) == $length;
474            # sum the individual delay times
475            my $delay = Get16u(\$buff, 1);
476            $delayTime += $delay;
477            $verbose and printf $out "Graphic Control: delay=%.2f\n", $delay / 100;
478            $raf->Seek(-$length, 1) or last;
479
480        } elsif ($a == 0x01 and $length == 12) {    # plain text extension
481
482            last unless $raf->Read($buff, $length) == $length;
483            Write($outfile, $ch, $s, $buff) or $err = 1 if $outfile;
484            if ($verbose) {
485                my ($left, $top, $w, $h) = unpack('v4', $buff);
486                print $out "Text: left=$left top=$top width=$w height=$h\n";
487            }
488            my $text = '';
489            for (;;) {
490                last unless $raf->Read($ch, 1);
491                $length = ord($ch) or last;
492                last unless $raf->Read($buff, $length) == $length;
493                Write($outfile, $ch, $buff) or $err = 1 if $outfile; # write block
494                $text .= $buff;
495            }
496            Write($outfile, "\0") or $err = 1 if $outfile;  # write terminator block
497            $et->HandleTag($tagTablePtr, 'Text', $text);
498            next;
499        }
500        Write($outfile, $ch, $s) or $err = 1 if $outfile;
501        # skip the block
502        while ($length) {
503            last unless $raf->Read($buff, $length) == $length;
504            Write($outfile, $buff) or $err = 1 if $outfile;
505            last unless $raf->Read($ch, 1);  # read next block header
506            Write($outfile, $ch) or $err = 1 if $outfile;
507            $length = ord($ch);  # get next block size
508        }
509    }
510    unless ($outfile) {
511        $et->HandleTag($tagTablePtr, 'FrameCount', $frameCount) if $frameCount > 1;
512        $et->HandleTag($tagTablePtr, 'Duration', $delayTime/100) if $delayTime;
513    }
514
515    # set return value to -1 if we only had a write error
516    $rtnVal = -1 if $rtnVal and $err;
517    return $rtnVal;
518}
519
520
5211;  #end
522
523__END__
524
525=head1 NAME
526
527Image::ExifTool::GIF - Read and write GIF meta information
528
529=head1 SYNOPSIS
530
531This module is loaded automatically by Image::ExifTool when required.
532
533=head1 DESCRIPTION
534
535This module contains definitions required by Image::ExifTool to read and
536write GIF meta information.
537
538=head1 AUTHOR
539
540Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com)
541
542This library is free software; you can redistribute it and/or modify it
543under the same terms as Perl itself.
544
545=head1 REFERENCES
546
547=over 4
548
549=item L<http://www.w3.org/Graphics/GIF/spec-gif89a.txt>
550
551=item L<http://www.adobe.com/devnet/xmp/>
552
553=item L<http://graphcomp.com/info/specs/ani_gif.html>
554
555=item L<http://www.color.org/icc_specs2.html>
556
557=item L<http://www.midiox.com/mmgif.htm>
558
559=back
560
561=head1 SEE ALSO
562
563L<Image::ExifTool(3pm)|Image::ExifTool>
564
565=cut
566