PC Professionell 2004 December/PCpro_2004_12.ISO/files/webserver/tsw/TSW_3.4.0.exe/Apache2/perl/TIFF.pm

Perl POD Document | 2004-01-07 | 4.8 KB | 200 lines

package Image::Info::TIFF;

=begin register

MAGIC: /^MM\x00\x2a/
MAGIC: /^II\x2a\x00/

The C<TIFF> spec can be found at:
http://partners.adobe.com/asn/developer/PDFS/TN/TIFF6.pdf

Also good writeup on exif spec at:
http://www.ba.wakwak.com/~tsuruzoh/Computer/Digicams/exif-e.html

=end register

=cut

use strict;
use Config;
use Image::TIFF;

sub my_read
{
    my($source, $len) = @_;
    my $buf;
    my $n = read($source, $buf, $len);
    die "read failed: $!" unless defined $n;
    die "short read ($len/$n)" unless $n == $len;
    $buf;
}
sub my_readbytes
{
    my ($fh,$offset,$len) = @_;
    my $curoffset = tell($fh);
    my $buf;
    seek($fh,$offset,0);
    my $n = read($fh,$buf,$len);
    die "short read($len/$n)" unless $n == $len;
    # back to before.
    seek($fh,$curoffset,0);
    return $buf;
}

sub my_readrational
{
    my ($fh,$offset,$byteorder,$count,$ar,$signed) = @_;
    my $curoffset = tell($fh);
    my $buf;
    seek($fh,$offset,0);
    while ($count > 0) {
    my $num;
    my $denom;
    if ($signed) {
        $num = unpack("l",my_read_order($fh,4,$byteorder));
        $denom = unpack("l",my_read_order($fh,4,$byteorder));
    } else {
        $num = unpack("L",my_read_order($fh,4,$byteorder));
        $denom = unpack("L",my_read_order($fh,4,$byteorder));
    }
    push(@{$ar},new Image::TIFF::Rational($num,$denom));
    $count--;
    }
    # back to before.
    seek($fh,$curoffset,0);
}

sub my_read_order
{
    my($source, $len,$byteorder) = @_;
    my $buf;
    my $n = read($source, $buf, $len);
    # maybe reverse
    if ($byteorder ne $Config{byteorder}) {
    my @bytes = unpack("C$len",$buf);
    my @newbytes;
    # swap bytes
    for (my $i = $len-1; $i >= 0; $i--) {
        push(@newbytes,$bytes[$i]);
    }
    $buf = pack("C$len",@newbytes);
    }
    die "read failed: $!" unless defined $n;
    die "short read ($len/$n)" unless $n == $len;
    $buf;
}

my %order = (
         "MM\x00\x2a" => '4321',
         "II\x2a\x00" => '1234',
         );

sub process_file
{
    my($info, $fh) = @_;

    my $soi = my_read($fh, 4);
    die "SOI missing" unless (defined($order{$soi}));
    # XXX: should put this info in all pages?
    $info->push_info(0, "file_media_type" => "image/tiff");
    $info->push_info(0, "file_ext" => "tif");

    my $byteorder = $order{$soi};
    #print "TIFF byte order $byteorder, our byte order: $Config{byteorder}\n";
    my $ifdoff = unpack("L",my_read_order($fh,4,$byteorder));
    #print "first dir at $ifdoff\n";
    &process_ifds($info,$fh,0,0,$byteorder,$ifdoff);
}

sub process_ifds {
    my($info, $fh,$page, $tagsseen, $byteorder,$offset) = @_;
    my $curpos = tell($fh);
    seek($fh,$offset,0);

    my $n = unpack("S",my_read_order($fh, 2, $byteorder));
    my $i = 1;
    while ($n > 0) {
    # process one IFD entry
    my $tag = unpack("S",my_read_order($fh,2,$byteorder));
    my $fieldtype = unpack("S",my_read_order($fh,2,$byteorder));
    my $count = unpack("L",my_read_order($fh,4,$byteorder));
    my $offset;
    if ($fieldtype == 3 && $count <= 1) {
        $offset = unpack("S",my_read_order($fh,2,$byteorder));
        # skip rest
        my_read_order($fh,2,$byteorder);
    } else {        # fieldtype == 4
        $offset = unpack("L",my_read_order($fh,4,$byteorder));
    }
    my $val = "";
    if ($fieldtype == 2) {
        $val = my_readbytes($fh,$offset,$count);
    } elsif (($fieldtype == 3 || $fieldtype == 4) &&
        $count == 1) {
        $val = $offset;
    } elsif ($fieldtype == 3 && $count == 2) {
        # array
        $val = [];
        push(@$val,$offset & 0xffff);
        push(@$val,$offset >> 16);
    } elsif ($fieldtype == 4 && $count > 1) {
        $val = [];
        my $n = $count;
        my $curoffset = tell($fh);
        seek($fh,$offset,0);
        while ($n > 0) {
        $offset = unpack("L",my_read_order($fh,4,$byteorder));
        push(@$val,$offset);
        $n--;
        }
        seek($fh,$curoffset,0);
    } elsif ($fieldtype == 5 || $fieldtype == 10) {
        # rational
        my $num;
        my $denom;
        $val = [];
        if ($fieldtype == 5) {
        my_readrational($fh,$offset,$byteorder,$count,$val,0);
        } else {
        #signed rational
        my_readrational($fh,$offset,$byteorder,$count,$val,1);
        }
        # get rid of singleton array.
        if ($#{$val} == 0) {
        $val = $$val[0];
        }
    }
    #look up tag
    my $tn =  Image::TIFF->exif_tagname($tag);
    if (ref($tn)) {
        $val = $$tn{$offset};
        $tn = $$tn{__TAG__};
    }
    if ($tn eq "NewSubfileType") {
        # start new page if necessary
        if ($tagsseen) {
        $page++;
        $tagsseen = 0;
        }
    } else {
        $tagsseen = 1;
    }
    #print "$i/$page: tag: $tag ($tn), fieldtype: $fieldtype, count: $count, offset: $offset ($val)\n";
    if ($tn eq "ExifOffset") {
        # parse ExifSubIFD
        &process_ifds($info,$fh,$byteorder,$offset);
    }
    $info->push_info($page, $tn => $val);
    $n--;
    $i++;
    }
    my $ifdoff = unpack("L",my_read_order($fh,4,$byteorder));
    #print "next dir at $ifdoff\n";
    if ($ifdoff) {
    &process_ifds($info,$fh,$page, $tagsseen, $byteorder,$ifdoff);
    }
    # back to before
    seek($fh,$curpos,0);
}
1;