#!/usr/bonsaitools/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 Socket; use lib "../bonsai"; require 'header.pl'; print "Content-type: text/html\n\n"; EmitHtmlTitleAndHeader("tinderbox: add images", "add images"); $| = 1; require "tbglobals.pl"; require "imagelog.pl"; &split_cgi_args; sub Error { my ($msg) = @_; print "


"; print ""; exit 1; } if( $url = $form{"url"} ){ $quote = $form{"quote"}; $quote =~ s/[\r\n]/ /g; $url =~ s/[\r\n]/ /g; $width = ""; $height = ""; # I think we don't want to allow this --jwz # $width = $form{"width"}; # $height = $form{"height"}; if ($width eq "" || $height eq "") { $size = &URLsize($url); if ($size =~ /WIDTH=([0-9]*)/) { $width = $1; } if ($size =~ /HEIGHT=([0-9]*)/) { $height = $1; } if ($width eq "" || $height eq "") { Error "Couldn't get image size for \"$url\".\n"; } } print "


$quote

"; if( $form{"submit"} ne "Yes" ){ my $u2 = $url; my $q2 = $quote; $u2 =~ s@&@&@g; $u2 =~ s@<@<@g; $u2 =~ s@\"@"@g; $q2 =~ s@&@&@g; $q2 =~ s@<@<@g; $q2 =~ s@\"@"@g; print "

Image URL: $u2
Caption: $q2
Does that look right?
(If not, hit \`Back' and fix it.)
"; } else { &add_imagelog( $url, $quote, $width, $height ); print "

Has been added

Return to Log"; } } else { print "

Add an image and a funny caption.

Image URL:
Caption:


"; } sub split_cgi_args { local($i,$var,$value, $s); $s = $ENV{"QUERY_STRING"}; @args= split(/\&/, $s ); for $i (@args) { ($var, $value) = split(/=/, $i); $value =~ tr/+/ /; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $form{$var} = $value; } } #sub imgsize { # local($file)= @_; # # #first try to open the file # if( !open(STREAM, "<$file") ){ # Error "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 ########################################################################### # bug: it thinks that # http://cvs1.mozilla.org/webtools/tinderbox/data/knotts.gif # is 640x400, but it's really 200x245. # giftrans says of that image: # # Header: "GIF87a" # Logical Screen Descriptor: # Logical Screen Width: 640 pixels # Logical Screen Height: 480 pixels # Image Descriptor: # Image Width: 200 pixels # Image Height: 245 pixels sub gifsize { local($GIF) = @_; read($GIF, $type, 6); if(!($type =~ /GIF8[7,9]a/) || !(read($GIF, $s, 4) == 4) ){ Error "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 { local($XBM) = @_; local($input)=""; $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 { Error "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 { local($JPEG) = @_; local($done)=0; $size=""; read($JPEG, $c1, 1); read($JPEG, $c2, 1); if( !((ord($c1) == 0xFF) && (ord($c2) == 0xD8))){ my $s = sprintf "This is not a JPEG! (Codes %02X %02X)\n", ord($c1), ord($c2); Error $s; $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) ){ Error "Bad JPEG file: erroneous 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) = @_; $_ = $fullurl; if ( ! m@^http://@ ) { Error "HTTP URLs only, please: \"$_\" is no good."; } my($dummy, $dummy, $serverstring, $url) = split(/\//, $fullurl, 4); my($them,$port) = split(/:/, $serverstring); my $port = 80 unless $port; my $size=""; $_ = $them; if ( m@^[^.]*$@ ) { Error "Fully-qualified host names only, please: \"$_\" is no good."; } $_=$url; 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) || die "socket: $!"; connect(S, $paddr) || die "connect: $!"; select(S); $| = 1; select(STDOUT); print S "GET /$url HTTP/1.0\r\n"; print S "Host: $them\r\n"; print S "User-Agent: Tinderbox/0.0\r\n"; print S "\r\n"; $_ = ; if (! m@^HTTP/[0-9.]+ 200@ ) { Error "$them responded:
$_"; } my $ctype = ""; while () { # print "read: $_
\n"; if ( m@^Content-Type:[ \t]*([^ \t\r\n]+)@io ) { $ctype = $1; } last if (/^[\r\n]/); } $_ = $ctype; if ( $_ eq "" ) { Error "Server returned no content-type for \"$fullurl\"?"; } elsif ( m@image/jpeg@i || m@image/pjpeg@i ) { $size = &jpegsize(S); } elsif ( m@image/gif@i ) { $size = &gifsize(S); } elsif ( m@image/xbm@i || m@image/x-xbm@i || m@image/x-xbitmap@i ) { $size = &xbmsize(S); } else { Error "Not a GIF, JPEG, or XBM: that was of type \"$ctype\"."; } $_ = $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; } if ( $newwidth eq "" || $newheight eq "" ) { return ""; } else { if ( $newwidth <= 5 || $newheight <= 5 ) { Error "${newwidth}x${newheight} seems small, don't you think?"; } elsif ( $newwidth >= 400 || $newheight >= 400 ) { Error "${newwidth}x${newheight} is too big; please" . " keep it under 400x400." } return $size; } } sub dokill { kill 9,$child if $child; }