pjs/webtools/tinderbox/fixupimages.pl

#!/usr/bin/perl --
# -*- Mode: perl; indent-tabs-mode: nil -*-
#
# The contents of this file are subject to the Netscape Public
# License Version 1.1 (the "License"); you may not use this file
# except in compliance with the License. You may obtain a copy of
# the License at http://www.mozilla.org/NPL/
#
# Software distributed under the License is distributed on an "AS
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
# implied. See the License for the specific language governing
# rights and limitations under the License.
#
# The Original Code is the Tinderbox build tool.
#
# The Initial Developer of the Original Code is Netscape Communications
# Corporation. Portions created by Netscape are
# Copyright (C) 1998 Netscape Communications Corporation. All
# Rights Reserved.
#
# Contributor(s): 

use strict;
use Socket;

require 'tbglobals.pl';
require 'imagelog.pl';

# Set up an alarm handler for URLs that take too long.
$SIG{ALRM} = sub { die "timeout" };

# Move an old imagelog to a new one

open( IMAGELOG, "<", "$::data_dir/imagelog.txt" ) || die "can't open file";
open (OUT, ">", "$::data_dir/newimagelog.txt") || die "can't open output file";
select(OUT); $| = 1; select(STDOUT);

my ($size, $height, $width);
while( <IMAGELOG> ){
    chop;
    my ($url,$quote)  = split(/\`/);
    print "$url\n";

    eval {
      # Only wait 8 seconds for images to load.
      alarm(8);
      $size = &URLsize($url);
      alarm(0);
    };
    # Check if the eval block died.
    if ($@) {
      if ($@ =~ /timeout/) {
        # URL took to long skip it.
        warn "URL took too long. Skip it.\n";
        next;
      } else {
        # Some other error (e.g. no host)
        warn "$@\n";
        alarm(0);
        next;
      }
    }

    $width = "";
    $height = "";
    if ($size =~ /WIDTH=([0-9]*)/) {
        $width = $1;
    }
    if ($size =~ /HEIGHT=([0-9]*)/) {
        $height = $1;
    }
    if ($width eq "" || $height eq "") {
        print "Couldn't get image size; skipping.\n";
    } else {
        print OUT "$url`$width`$height`$quote\n";
    }
}



sub imgsize {
    my ($file)= @_;
    my ($size, $s, $newwidth, $newheight);
    my $STREAM = new IO::Handle;

    #first try to open the file
    if( !open($STREAM, "<", $file) ){
        print "Can't open IMG $file"; 
        $size="";
    } else {
        if ($file =~ /.jpg/i || $file =~ /.jpeg/i) {
            $size = &jpegsize($STREAM);
        } elsif($file =~ /.gif/i) {
            $size = &gifsize($STREAM);
        } elsif($file =~ /.xbm/i) {
            $size = &xbmsize($STREAM);
        } else {
            return "";
        }
        $_ = $size;
        if(  /\s*width\s*=\s*([0-9]*)\s*/i ){
            ($newwidth)= /\s*width\s*=\s*(\d*)\s*/i;
        }
        if(  /\s*height\s*=\s*([0-9]*)\s*/i ){
            ($newheight)=/\s*height\s*=\s*(\d*)\s*/i;
        }
        close($STREAM);
    }
    return $size;
}

###########################################################################
# Subroutine gets the size of the specified GIF
###########################################################################
sub gifsize {
    my ($GIF) = @_;
    my ($size, $s, $type);
    my ($a,$b,$c,$d);

    read($GIF, $type, 6); 
    if(!($type =~ /GIF8[7,9]a/) || 
       !(read($GIF, $s, 4) == 4) ){
        print "Invalid or Corrupted GIF"; 
        $size="";
    } else {
        ($a,$b,$c,$d)=unpack("C"x4,$s);
        $size=join ("", 'WIDTH=', $b<<8|$a, ' HEIGHT=', $d<<8|$c);
    }
    return $size;
}

sub xbmsize {
    my ($XBM) = @_;
    my ($input)="";
    my ($size, $a, $b);

    $input .= <$XBM>;
    $input .= <$XBM>;
    $_ = $input;
    if( /#define\s*\S*\s*\d*\s*\n#define\s*\S*\s*\d*\s*\n/i ){
       ($a,$b)=/#define\s*\S*\s*(\d*)\s*\n#define\s*\S*\s*(\d*)\s*\n/i;
       $size=join ("", 'WIDTH=', $a, ' HEIGHT=', $b );
   } else {
       print "Hmmm... Doesn't look like an XBM file";
   }
    return $size;
}

# jpegsize : gets the width and height (in pixels) of a jpeg file
# Andrew Tong, werdna@ugcs.caltech.edu           February 14, 1995
# modified slightly by alex@ed.ac.uk
sub jpegsize {
    my ($JPEG) = @_;
    my ($done)=0;
    my $size="";
    my ($c1, $c2, $ch, $s, $length, $marker, $junk, $done);
    my ($a,$b,$c,$d);

    read($JPEG, $c1, 1); read($JPEG, $c2, 1);
    if( !((ord($c1) == 0xFF) && (ord($c2) == 0xD8))){
        printf "This is not a JPEG! (Codes %02X %02X)\n", ord($c1), ord($c2);
        $done=1;
    }
    while (ord($ch) != 0xDA && !$done) {
        # Find next marker (JPEG markers begin with 0xFF)
        # This can hang the program!!
        while (ord($ch) != 0xFF) {  read($JPEG, $ch, 1); }
        # JPEG markers can be padded with unlimited 0xFF's
        while (ord($ch) == 0xFF) { read($JPEG, $ch, 1); }
        # Now, $ch contains the value of the marker.
            $marker=ord($ch);

            if (($marker >= 0xC0) && ($marker <= 0xCF) &&
            ($marker != 0xC4) && ($marker != 0xCC)) {  # it's a SOFn marker
            read ($JPEG, $junk, 3); read($JPEG, $s, 4);
            ($a,$b,$c,$d)=unpack("C"x4,$s);
            $size=join("", 'HEIGHT=',$a<<8|$b,' WIDTH=',$c<<8|$d );
            $done=1;
        } else {
            # We **MUST** skip variables, since FF's within variable 
            # names are NOT valid JPEG markers
            read ($JPEG, $s, 2); 
            ($c1, $c2) = unpack("C"x2,$s); 
            $length = $c1<<8|$c2;
            if( ($length < 2) ){
                print "Erroneous JPEG marker length";
                $done=1;
            } else {
                read($JPEG, $junk, $length-2);
            }
        }
    }
    return $size;
}

###########################################################################
# Subroutine grabs a gif from another server and gets its size
###########################################################################


sub URLsize {
    my ($fullurl) = @_;
    my($dummy, $dummy, $serverstring, $url) = split(/\//, $fullurl, 4);
    my($them,$port) = split(/:/, $serverstring);
    my $port = 80 unless $port;
    $them = 'localhost' unless $them;
    my $size="";
    my ($newheight, $newwidth);
    my $S = new IO::Handle;

    $_=$url;
    if( /gif/i || /jpeg/i || /jpg/i || /xbm/i ) {
        my ($remote, $iaddr, $paddr, $proto, $line);
        $remote = $them;
        if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
        die "No port" unless $port;
        $iaddr   = inet_aton($remote)               || die "no host: $remote";
        $paddr   = sockaddr_in($port, $iaddr);

        $proto   = getprotobyname('tcp');
        socket($S, PF_INET, SOCK_STREAM, $proto)  || return "socket: $!";
        connect($S, $paddr)    || return "connect: $!";
        select($S); $| = 1; select(STDOUT);



        print $S "GET /$url\n";
        if ($url =~ /.jpg/i || $url =~ /.jpeg/i) {
            $size = &jpegsize($S);
        } elsif($url =~ /.gif/i) {
            $size = &gifsize($S);
        } elsif($url =~ /.xbm/i) {
            $size = &xbmsize($S);
        } else {
            return "";
        }               
        $_ = $size;
        if(  /\s*width\s*=\s*([0-9]*)\s*/i ){
            ($newwidth)= /\s*width\s*=\s*(\d*)\s*/i;
        }
        if(  /\s*height\s*=\s*([0-9]*)\s*/i ){
            ($newheight)=/\s*height\s*=\s*(\d*)\s*/i;
        }
    } else {
        $size="";
    }
    return $size;
}