usr_bin/wwwis

   1 #!/usr/bin/perl -w
   2 #
   3 # wwwis: adds HEIGHT= and WIDTH= to images referenced in specified HTML file.
   4 #
   5 # for documentation - changelog and latest version
   6 # see http://www.bloodyeck.com/wwwis/
   7 #
   8 # this program by (and copyright)    Alex Knowles, Alex@bloodyEck.com
   9 # based on original code and idea by Andrew Tong,  werdna@ugcs.caltech.edu
  10 #
  11 # You may distribute this code under the GNU public license
  12 #
  13 # THIS SOFTWARE IS PROVIDED "AS-IS" WITHOUT WARRANTY OF ANY KIND.
  14 #
  15 # RCS $Id: wwwis,v 2.43 2004/12/02 18:32:13 ark Exp $
  16
  17 use strict;
  18 use File::Copy;
  19 use Socket;
  20 # if you do not have these system libraries make sure you comment them out
  21 # and have the options UsePerlCp, searchURLS, TryServer ALL SET TO NO
  22
  23 if( ! $\ ){
  24   # this stops the error Use of uninitialized value at .../File/Copy.pm line 84
  25   # print "Out rec sep not defined?? someone help me with this\n";
  26   $\='';
  27 }
  28
  29 # this array specifies what options are available what the default
  30 # value is and also what type it is, files are checked to see if they
  31 # exist and the only possible values for choice are given.
  32 # you should only need to change the third column
  33 my(@options)=
  34   ('searchURLS',      'bool',    'Yes',
  35    'DocumentRoot',    'file',    '/usr/local/etc/httpd/htdocs',
  36    'UserDir',         'string',  'html',
  37    'MakeBackup',      'bool',    'Yes',
  38    'BackupExtension', 'string',  '~',
  39    'OverwriteBackup', 'choice',  'Yes', 3, 'Yes','No','Ask',
  40    'ChangeIfThere',   'choice',  'Yes', 4, 'Yes','No','Ask','Clever',
  41    'Skip1x1',         'bool',    'Yes',
  42    'SkipThreshold',   'integer', '0', # 0 disables this option
  43    'DoChmodChown',    'bool',    'No',
  44    'UpcaseTags',      'choice',  'No',  4, 'Yes','No','Upper','Lower',
  45    'UpcaseNewTags',   'bool',    'No',
  46    'TryServer',       'bool',    'Yes',
  47    'QuoteNums',       'choice',  'No',  4, 'Yes','No','Single','Double',
  48    'Munge%',          'bool',    'Yes',
  49    'NeedAlt',         'bool',    'Yes',
  50    'SkipCGI',         'bool',    'Yes',
  51    'UseNewGifsize',   'bool',    'No',
  52    'UseHash',         'bool',    'Yes',
  53    'Base',            'string',  '',
  54    'InFilter',        'string',  '',
  55    'OutFilter',       'string',  '',
  56    'Quiet',           'bool',    'No',
  57    'Script',          'string',  '',
  58    'Proxy',           'string',  '',
  59    'SkipFilter',      'string',  '',
  60    'IgnoreLinks',     'bool',    'Yes',
  61    'UsePerlCp',       'bool',    'Yes',
  62    );
  63
  64 #####################################################################
  65 ######### YOU SHOULD NOT HAVE TO CHANGE ANYTHING BELOW HERE #########
  66 #####################################################################
  67
  68
  69 my($Base,   $SkipCGI,  $InFilter, $MakeBackup,   $SearchURLS, $OverwriteBackup,
  70    $Proxy,  $UseHash,  $OutFilter, $UpcaseTags,  $UpcaseNewTags,
  71    $UseNewGifsize, $debug,
  72    $Script, $UserDir,  $TryServer, $DoChmodChown,$ChangeIfThere, $IgnoreLinks,
  73    $NeedAlt,$MungePer, $QuoteNums, $DocumentRoot,$BackupExtension, $Quiet,
  74    $UsePerlCp, $Skip1x1, $SkipThreshold, $SkipFilter );
  75
  76 my( %hashx, %hashy );
  77
  78 # O.K. now we have defined the options go and get them and set the global vars
  79 my(@optionval)=&GetConfigFile(@options);
  80 &SetGlobals();
  81
  82 $|=1;   # make it so that I can fit lots of info on one line...
  83
  84 ############################################################################
  85 # Main routine.  processes all files specified on command line, skipping
  86 # any file for which a .bak file exists.
  87 ############################################################################
  88 while (@ARGV) {
  89   my($FILE)=shift;
  90   if( $FILE =~ /^-/ ){
  91     &proc_arg($FILE);
  92     next;
  93   }
  94
  95   print "$FILE -- ";
  96
  97   if( -s $FILE && -T $FILE ){
  98     if ( -e "$FILE$BackupExtension"){
  99       if( &isfalse($OverwriteBackup) ){
 100         print "Skipping -- found $FILE$BackupExtension\n";
 101         next;
 102       } elsif ( $OverwriteBackup =~ /ASK/i ){
 103         print "overwite $FILE$BackupExtension [Yn]\n";
 104         $_=<STDIN>;
 105         if( /n/i ){
 106           print " - Skipping\n";
 107           next;
 108         }
 109       }
 110     }
 111     if ( -l $FILE and &istrue($IgnoreLinks) ){
 112       print "Skipping -- this file is a symbolic link\n";
 113       next;
 114     }
 115     print "Processing...\n";
 116     &convert($FILE);
 117   } else {
 118     print "Skipping -- Doesn't look like a text file to me!\n";
 119     next;
 120   }
 121 }
 122
 123 # SetGlobals:
 124 # This converts the optionval array into global variables
 125 # this is cos I don't know how to store pointers to variables in arrys (sorry)
 126 sub SetGlobals
 127 {
 128   my($i)=0;
 129
 130   $SearchURLS =         $optionval[$i++];
 131   $DocumentRoot =       $optionval[$i++];
 132   $UserDir =            $optionval[$i++];
 133   $MakeBackup =         $optionval[$i++];
 134   $BackupExtension =    $optionval[$i++];
 135   $OverwriteBackup =    $optionval[$i++];
 136   $ChangeIfThere =      $optionval[$i++];
 137   $Skip1x1 =            $optionval[$i++];
 138   $SkipThreshold =      $optionval[$i++];
 139   $DoChmodChown =       $optionval[$i++];
 140   $UpcaseTags =         $optionval[$i++];
 141   $UpcaseNewTags =      $optionval[$i++];
 142   $TryServer =          $optionval[$i++];
 143   $QuoteNums =          $optionval[$i++];
 144   $MungePer =           $optionval[$i++];
 145   $NeedAlt =            $optionval[$i++];
 146   $SkipCGI =            $optionval[$i++];
 147   $UseNewGifsize =      $optionval[$i++];
 148   $UseHash =            $optionval[$i++];
 149   $Base =               $optionval[$i++];
 150   $InFilter =           $optionval[$i++];
 151   $OutFilter =          $optionval[$i++];
 152   $Quiet =              $optionval[$i++];
 153   $Script =             $optionval[$i++];
 154   $Proxy =              $optionval[$i++];
 155   $SkipFilter =         $optionval[$i++];
 156   $IgnoreLinks =        $optionval[$i++];
 157   $UsePerlCp   =        $optionval[$i++];
 158
 159   # do a quick check just to see we got everything
 160   $i--;
 161   if( $i!=$#optionval ){
 162     print "Internal Error: number of options is not equal to globals!\n";
 163     print "Please Email alex\@ed.ac.uk for help\n";
 164     exit;
 165   }
 166 }
 167
 168 ###########################################################################
 169 # Subroutine does all the actual HTML parsing --- grabs image URLs and tells
 170 # other routines to open the images and get their size
 171 ###########################################################################
 172 sub convert {
 173   my($file) = @_;
 174   my($ox,$oy,$nx,$ny);
 175   my($changed,$type,$tag,$five,$user,$original,@original);
 176   my($widthtag,$heighttag);
 177   my($HTMLbase,$i);
 178   my(@PATH,$REL,$rel);
 179
 180   my($ino, $mode, $uid, $gid, $ngid, $nuid );
 181
 182   $changed=0;   # did we change this file
 183   $original=""; # the string containing the whole file
 184
 185   $widthtag=&istrue($UpcaseNewTags)?"WIDTH":"width";
 186   $heighttag=&istrue($UpcaseNewTags)?"HEIGHT":"height";
 187
 188
 189   if( !open(ORIGINAL, $InFilter =~ /\S+/ ? "$InFilter $file|" : "<$file") ){
 190     print "Couldn't open $file\n";
 191     return;
 192   }
 193   while (<ORIGINAL>) {
 194     $original .= $_;
 195   }
 196   close (ORIGINAL);
 197   @PATH = split(/[\\\/]/, $file); # \\ for NT (brian_helterline@om.cv.hp.com)
 198   pop(@PATH);
 199   $REL = join("/", @PATH);
 200
 201   # print out the header to the columns
 202   printf(" %s %-34s %-9s %-9s\n",'Type','File','   Old','   New') if (isfalse($Quiet));
 203
 204   @original=split(/</, $original);
 205   for ($i=0; $i <= $#original; $i++) {
 206     # make the tags upper case if that's is what the user wants
 207     if( &istrue( $UpcaseTags) && $original[$i] !~ /^!--/ ){
 208       $original[$i]=&changecase($original[$i]);
 209     }
 210
 211     if ($original[$i] =~ /^BASE\s+HREF\s*=\s*(\"[^\"]+\"|\'[^\']+\'|\S+)/i){ #"
 212       # we found a BASE tag this is quite important to us!
 213       $HTMLbase=&strip_quotes($1);
 214       print " BASE $HTMLbase\n" if (isfalse($Quiet));
 215     } elsif ($original[$i] =~
 216              /^((IMG|FIGURE|INPUT)\s+([^\000]*\s+)?SRC\s*=\s*(\"[^\"]+\"|\'[^\']+\'|\S+)[^\000]*)>/i){       #"
 217       # we found an IMG or FIGURE tag! this is really important
 218
 219       # initialise some of my flags
 220       if( !defined($1) || !defined($2) || !defined($4) ){
 221         print "  Couldn't find tagtype or images source for tag number $i!\n";
 222         return;
 223       }
 224       $tag=$1;  # The whole HTML tag (with attributes)
 225       $type=$2; # this is either IMG or FIGURE
 226       $five=$4; # we put the SRC in a variable called five for historic reasons
 227       $five=&strip_quotes($five);
 228       $ox=0; $oy=0; # old X & Y values (Was Width & Height)
 229       $nx=0; $ny=0; # the new values
 230
 231       printf("  %3s %-34s ",substr($type,0,3),$five) if (isfalse($Quiet));
 232
 233       if(&istrue($SkipCGI) &&
 234          $five =~ /(\.(cgi|pl)$|\/cgi-bin\/|\/cgi\/)/ ){
 235         print "\"$file\": Skipping CGI program\n" if (isfalse($Quiet));
 236         next;
 237       }
 238       if( $SkipFilter && $five =~/$SkipFilter/i ){
 239         print "\"$file\": SkipFilter matched\n" if (isfalse($Quiet));
 240         next;
 241       }
 242
 243       if( $tag =~ /(width|height)\s*=\s*[\"\']?\d+%/i ){ #"
 244         # we found a % sign near width or height
 245         if( ! &istrue($MungePer) ){
 246           print "\"$file\": Found % Skipping\n";
 247           next;
 248         }
 249       } else {
 250         $ox=$2 if( $tag =~ /\s*width\s*=\s*(\"|\')?(\d+)\s*/i );  #"
 251         $oy=$2 if( $tag =~ /\s*height\s*=\s*(\"|\')?(\d+)\s*/i ); #"
 252       }
 253
 254       printf("(%3d,%3d) ",$ox,$oy) if (isfalse($Quiet));
 255
 256       if( $ox && $oy && &isfalse($ChangeIfThere) ){
 257         print "Already There\n";
 258         next;
 259       }
 260
 261       if( defined($HTMLbase) && $HTMLbase =~ /\S+/ ){
 262         print "\nUsing HTMLbase to turn:$five\n" if $debug;
 263         $five=&ARKjoinURL($HTMLbase,$five);
 264         print "Into                :$five\n"     if $debug;
 265       }
 266
 267       if ($five =~ /^http:\/\/.*/) {
 268         if (&istrue($SearchURLS)) {
 269           ($nx,$ny) = &URLsize($five);
 270         }
 271       } elsif ($five =~ /^\/\~.*/) {
 272         @PATH = split(/\//, $five);
 273         shift(@PATH); $user = shift(@PATH) ; $rel = join ("/", @PATH);
 274         $user =~ s/^\~//;
 275         $user=(getpwnam( $user ))[7];
 276         print "User dir is $user/$UserDir/$rel\n" if $debug;
 277         ($nx,$ny) = &imgsize("$user/$UserDir/$rel",$five);
 278       } elsif ($five =~ /^\/.*/) {
 279         ($nx,$ny) = &imgsize("$DocumentRoot$five",$five);
 280       } else {
 281         if ($REL eq '') {
 282           ($nx,$ny) = &imgsize("$five",$five);
 283         } else {
 284           ($nx,$ny) = &imgsize("$REL/$five",$five);
 285         }
 286       }
 287
 288       if( $nx==0 && $ny==0 ){
 289         print "\"$file\": No Values : $!\n";
 290         next;
 291       }
 292
 293       printf( "(%3d,%3d) ", $nx,$ny) if (isfalse($Quiet));
 294
 295       if(&istrue($Skip1x1) &&
 296          $nx==1 && $ny==1){
 297         print "Skipping 1x1 image\n" if (isfalse($Quiet));
 298         next;
 299       }
 300
 301       if (&istrue($SkipThreshold) && $nx<=$SkipThreshold &&
 302           $ny<=$SkipThreshold){
 303         print "Skipping $nx"."x$ny image (\$SkipThreshold=$SkipThreshold)\n" if
 304           (isfalse($Quiet));
 305         next;
 306       }
 307
 308       if( $nx && $ny && &do_change($ox,$oy,$nx,$ny)){
 309         $changed=1;             # mark the page as changed
 310         $original[$i]=&replce_attrib($original[$i],$heighttag,$ny);
 311         $original[$i]=&replce_attrib($original[$i],$widthtag,$nx);
 312         if( $ox==0 && $oy==0 ){
 313           print "Added tags " if (isfalse($Quiet));
 314         } else {
 315           print "Updated " if (isfalse($Quiet));
 316         }
 317       }
 318
 319       print "Needs Alt" if(&istrue($NeedAlt) && $tag !~ /ALT\s*=\s*\S+/i );
 320
 321       print "\n" if (isfalse($Quiet));
 322     }
 323   }
 324
 325   if( !($changed)) {
 326     print " No need to write \"$file\": nothing changed\n";
 327     return;
 328   }
 329
 330   if( ! &isfalse($MakeBackup) ){
 331     # maybe I should move the rest of this stuff into a separate function?
 332     if( &istrue($DoChmodChown) ){
 333       # find out about this file
 334       ($ino,$mode,$uid,$gid) = (stat($file))[1,2,4,5];
 335       if ($ino == 0 || !rename($file, "$file$BackupExtension")) {
 336         if( $ino == 0 ){
 337           print "Couldn't stat \"$file\" for permissions & ownership: $!\n";
 338         } else {
 339           print "couldn't rename \"$file\" for backup: $!\n";
 340         }
 341         return;
 342       }
 343     } else {
 344       if( &istrue( $UsePerlCp ) ){
 345         copy( $file, "$file$BackupExtension" );
 346       } else {
 347         # system( "cp $file $file$BackupExtension" );
 348         # we could have added the -p flag e.g. cp -p ....
 349         # use copy cos this keeps the permissions the same!
 350         system( "cp -p $file $file$BackupExtension" );
 351       }
 352     }
 353   }
 354
 355   $file="output.html" if $debug;
 356
 357   if(open(CONVERTED, $OutFilter =~ /\S+/ ? "|$OutFilter $file" : ">$file") ){
 358     print CONVERTED join("<", @original);
 359     close(CONVERTED);
 360
 361     if( &istrue($DoChmodChown) ){
 362       # now change the ownership & permissions
 363       chmod $mode, $file || print "Warning: Couldn't chmod $file\n";
 364       # It seems that chown doesn't necessarily indicate any errors
 365       chown $uid, $gid, $file || print "Warning: Couldn't chown $file\n";
 366
 367       ($nuid,$ngid) = (stat($file))[4,5];
 368       if ($nuid != $uid ||
 369           $ngid != $gid   ){
 370         print "Warning: $file now has different group or owner\n";
 371       }
 372     }
 373     # if we defined a script to run the make it so....
 374     system("$Script $file")     if( $Script =~ /\S+/ );
 375   } else {
 376     print "Either: could not backup or could not write to $file!\n";
 377   }
 378 }
 379
 380 # replaces the $attrib's value to $val in $line
 381 # if $attrib is not present it is inserted at the start of the tag
 382 sub replce_attrib
 383 {
 384   my($line,$attrib,$val)=@_;
 385   my( $start, $oldval );
 386
 387   # argument checking
 388   if(!defined($line ) ||
 389      !defined($attrib) ||
 390      !defined($val)){
 391     print "Error: dodgy arguments to replace_attrib!\n";
 392     return $line if(defined($line)); # have no effect if we can
 393     exit;
 394   }
 395
 396   $attrib =~ tr/[A-Z]/[a-z]/ if($UpcaseTags=~/lower/i);
 397
 398   if( !(&isfalse($QuoteNums)) ){
 399     if( $QuoteNums =~ /single/i ){
 400       $val = "\'" . $val . "\'";
 401     } else {
 402       $val = "\"" . $val . "\"";
 403     }
 404   }
 405
 406   if( $line =~ /(\s+$attrib\s*=\s*)([\'\"]?\d+%?[\'\"]?)[^\000]*>/i ){ #"
 407     $start=$1;
 408     $oldval=$2;
 409     $line =~ s/$start$oldval/$start$val/;
 410   } else {
 411     $line =~ s/(\S+\s+)/$1$attrib=$val /;
 412   }
 413   return $line;
 414 }
 415
 416 sub ask_for_change{
 417   my($ret)=1;
 418   print "Change [Yn]?";
 419   $_=<STDIN>;
 420   if( /n/i ){
 421     $ret=0;
 422   }
 423   return $ret;
 424 }
 425
 426 sub do_change{
 427   my($oldwidth, $oldheight, $newwidth, $newheight) = @_;
 428   my($wrat);
 429   my($hrat);
 430
 431   return 0 if (!defined($oldwidth)      ||
 432                !defined($oldheight)     ||
 433                !defined($newwidth)      ||
 434                !defined($newheight)     ||
 435                !($newwidth)             ||
 436                !($newheight)              ||
 437                ($oldwidth ==$newwidth &&
 438                 $newheight==$oldheight));
 439
 440   return 1 if(!($oldwidth) && !($oldheight) );
 441
 442   if( &isfalse($ChangeIfThere) ){
 443     return 0;
 444   } elsif( $ChangeIfThere =~ /clever/i ){
 445     if( $oldwidth ){
 446       eval { $wrat= $newwidth  / $oldwidth  }; warn $@ if $@;
 447       if( $wrat < 1.0 ){
 448         eval {$wrat = 1/ $wrat }; warn $@ if $@;
 449       }
 450     } else {
 451       $wrat=1.5;
 452     }
 453     if( $oldheight ){
 454       eval { $hrat= $newheight / $oldheight }; warn $@ if $@;
 455       if( $hrat < 1.0 ){
 456         eval {$hrat = 1/ $hrat }; warn $@ if $@;
 457       }
 458     } else {
 459       $hrat=1.5;
 460     }
 461     if((int($wrat) == $wrat) &&
 462        (int($hrat) == $hrat) ){
 463       return 0;
 464     } else {
 465       return &ask_for_change();
 466     }
 467   } elsif($ChangeIfThere =~ /ask/i){
 468     return &ask_for_change();
 469   }
 470   return 1;
 471 }
 472
 473 # looking at the filename really sucks I should be using the first 4 bytes
 474 # of the image. If I ever do it these are the numbers.... (from chris@w3.org)
 475 #  PNG 89 50 4e 47
 476 #  MNG 8a 4d 4e 47
 477 #  GIF 47 49 46 38
 478 #  JPG ff d8 ff e0
 479 #  XBM 23 64 65 66
 480 sub imgsize {
 481   my($file)= shift @_;
 482   my($ref)=@_ ? shift @_ : "";
 483   my($x,$y)=(0,0);
 484
 485   # first check the hash table (if we use one)
 486   # then try and open the file
 487   # then try the server if we know of one
 488   if(&istrue($UseHash) &&
 489      $hashx{$file}     &&
 490      $hashy{$file}     ){
 491     print "Hash " if $debug;
 492     $x=$hashx{$file};
 493     $y=$hashy{$file};
 494   } elsif( defined($file) && open(STRM, "<$file") ){
 495     binmode( STRM ); # for crappy MS OSes - Win/Dos/NT use is NOT SUPPORTED
 496     if ($file =~ /\.jpg$/i || $file =~ /\.jpeg$/i) {
 497       ($x,$y) = &jpegsize(\*STRM);
 498     } elsif($file =~ /\.gif$/i) {
 499       ($x,$y) = &gifsize(\*STRM);
 500     } elsif($file =~ /\.xbm$/i) {
 501       ($x,$y) = &xbmsize(\*STRM);
 502     } elsif($file =~ /\.[pm]ng$/i) {
 503       ($x,$y) = &pngsize(\*STRM);
 504     } else {
 505       print "$file is not gif, xbm, jpeg, png or mng (or has stupid name)";
 506     }
 507     close(STRM);
 508
 509     if(&istrue($UseHash) && $x && $y){
 510       $hashx{$file}=$x;
 511       $hashy{$file}=$y;
 512     }
 513
 514   } else {
 515     # we couldn't open the file maybe we want to try the server?
 516
 517     if(&istrue($TryServer) &&
 518        defined($ref) &&
 519        $ref =~ /\S+/ &&
 520        $Base =~ /\S+/ ){
 521       $ref= &ARKjoinURL( $Base, $ref );
 522       print "Trying server for $ref\n" if $debug;
 523
 524       ($x,$y)=&URLsize($ref);
 525     }
 526   }
 527
 528   return ($x,$y);
 529 }
 530
 531 ###########################################################################
 532 # Subroutine gets the size of the specified GIF
 533 ###########################################################################
 534 sub gifsize
 535 {
 536   my($GIF) = @_;
 537   if( &istrue($UseNewGifsize) ){
 538     return &NEWgifsize($GIF);
 539   } else {
 540     return &OLDgifsize($GIF);
 541   }
 542 }
 543
 544
 545 sub OLDgifsize {
 546   my($GIF) = @_;
 547   my($type,$a,$b,$c,$d,$s)=(0,0,0,0,0,0);
 548
 549   if(defined( $GIF )            &&
 550      read($GIF, $type, 6)       &&
 551      $type =~ /GIF8[7,9]a/      &&
 552      read($GIF, $s, 4) == 4     ){
 553     ($a,$b,$c,$d)=unpack("C"x4,$s);
 554     return ($b<<8|$a,$d<<8|$c);
 555   }
 556   return (0,0);
 557 }
 558
 559 # part of NEWgifsize
 560 sub gif_blockskip {
 561   my ($GIF, $skip, $type) = @_;
 562   my ($s)=0;
 563   my ($dummy)='';
 564
 565   read ($GIF, $dummy, $skip);   # Skip header (if any)
 566   while (1) {
 567     if (eof ($GIF)) {
 568       warn "Invalid/Corrupted GIF (at EOF in GIF $type)\n";
 569       return "";
 570     }
 571     read($GIF, $s, 1);          # Block size
 572     last if ord($s) == 0;       # Block terminator
 573     read ($GIF, $dummy, ord($s));       # Skip data
 574   }
 575 }
 576
 577 # this code by "Daniel V. Klein" <dvk@lonewolf.com>
 578 sub NEWgifsize {
 579   my($GIF) = @_;
 580   my($cmapsize, $a, $b, $c, $d, $e)=0;
 581   my($type,$s)=(0,0);
 582   my($x,$y)=(0,0);
 583   my($dummy)='';
 584
 585   return($x,$y) if(!defined $GIF);
 586
 587   read($GIF, $type, 6);
 588   if($type !~ /GIF8[7,9]a/ || read($GIF, $s, 7) != 7 ){
 589     warn "Invalid/Corrupted GIF (bad header)\n";
 590     return($x,$y);
 591   }
 592   ($e)=unpack("x4 C",$s);
 593   if ($e & 0x80) {
 594     $cmapsize = 3 * 2**(($e & 0x07) + 1);
 595     if (!read($GIF, $dummy, $cmapsize)) {
 596       warn "Invalid/Corrupted GIF (global color map too small?)\n";
 597       return($x,$y);
 598     }
 599   }
 600  FINDIMAGE:
 601   while (1) {
 602     if (eof ($GIF)) {
 603       warn "Invalid/Corrupted GIF (at EOF w/o Image Descriptors)\n";
 604       return($x,$y);
 605     }
 606     read($GIF, $s, 1);
 607     ($e) = unpack("C", $s);
 608     if ($e == 0x2c) {           # Image Descriptor (GIF87a, GIF89a 20.c.i)
 609       if (read($GIF, $s, 8) != 8) {
 610         warn "Invalid/Corrupted GIF (missing image header?)\n";
 611         return($x,$y);
 612       }
 613       ($a,$b,$c,$d)=unpack("x4 C4",$s);
 614       $x=$b<<8|$a;
 615       $y=$d<<8|$c;
 616       return($x,$y);
 617     }
 618     if ($type eq "GIF89a") {
 619       if ($e == 0x21) {         # Extension Introducer (GIF89a 23.c.i)
 620         read($GIF, $s, 1);
 621         ($e) = unpack("C", $s);
 622         if ($e == 0xF9) {       # Graphic Control Extension (GIF89a 23.c.ii)
 623           read($GIF, $dummy, 6);        # Skip it
 624           next FINDIMAGE;       # Look again for Image Descriptor
 625         } elsif ($e == 0xFE) {  # Comment Extension (GIF89a 24.c.ii)
 626           &gif_blockskip ($GIF, 0, "Comment");
 627           next FINDIMAGE;       # Look again for Image Descriptor
 628         } elsif ($e == 0x01) {  # Plain Text Label (GIF89a 25.c.ii)
 629           &gif_blockskip ($GIF, 12, "text data");
 630           next FINDIMAGE;       # Look again for Image Descriptor
 631         } elsif ($e == 0xFF) {  # Application Extension Label (GIF89a 26.c.ii)
 632           &gif_blockskip ($GIF, 11, "application data");
 633           next FINDIMAGE;       # Look again for Image Descriptor
 634         } else {
 635           printf STDERR "Invalid/Corrupted GIF (Unknown extension %#x)\n", $e;
 636           return($x,$y);
 637         }
 638       }
 639       else {
 640         printf STDERR "Invalid/Corrupted GIF (Unknown code %#x)\n", $e;
 641         return($x,$y);
 642       }
 643     }
 644     else {
 645       warn "Invalid/Corrupted GIF (missing GIF87a Image Descriptor)\n";
 646       return($x,$y);
 647     }
 648   }
 649 }
 650
 651 sub xbmsize {
 652   my($XBM) = @_;
 653   my($input)="";
 654
 655   if( defined( $XBM ) ){
 656     $input .= <$XBM>;
 657     $input .= <$XBM>;
 658     $input .= <$XBM>;
 659     $_ = $input;
 660     if( /.define\s+\S+\s+(\d+)\s*\n.define\s+\S+\s+(\d+)\s*\n/i ){
 661       return ($1,$2);
 662     }
 663   }
 664   return (0,0);
 665 }
 666
 667 #  pngsize : gets the width & height (in pixels) of a png file
 668 # cor this program is on the cutting edge of technology! (pity it's blunt!)
 669 #  GRR 970619:  fixed bytesex assumption
 670 sub pngsize {
 671   my($PNG) = @_;
 672   my($head) = "";
 673 # my($x,$y);
 674   my($a, $b, $c, $d, $e, $f, $g, $h)=0;
 675
 676   if(defined($PNG)                              &&
 677      read( $PNG, $head, 8 ) == 8                &&
 678      ( $head eq "\x8a\x4d\x4e\x47\x0d\x0a\x1a\x0a" ||
 679        $head eq "\x89\x50\x4e\x47\x0d\x0a\x1a\x0a" )  &&
 680      read($PNG, $head, 4) == 4                  &&
 681      read($PNG, $head, 4) == 4                  &&
 682      ($head eq "MHDR" ||
 683       $head eq "IHDR")                          &&
 684      read($PNG, $head, 8) == 8                  ){
 685 #   ($x,$y)=unpack("I"x2,$head);   # doesn't work on little-endian machines
 686 #   return ($x,$y);
 687     ($a,$b,$c,$d,$e,$f,$g,$h)=unpack("C"x8,$head);
 688     return ($a<<24|$b<<16|$c<<8|$d, $e<<24|$f<<16|$g<<8|$h);
 689   }
 690   return (0,0);
 691 }
 692
 693 # jpegsize : gets the width and height (in pixels) of a jpeg file
 694 # Andrew Tong, werdna@ugcs.caltech.edu           February 14, 1995
 695 # modified slightly by alex@ed.ac.uk
 696 sub jpegsize {
 697   my($JPEG) = @_;
 698   my($done)=0;
 699   my($c1,$c2,$ch,$s,$length, $dummy)=(0,0,0,0,0,0);
 700   my($a,$b,$c,$d);
 701
 702   if(defined($JPEG)             &&
 703      read($JPEG, $c1, 1)        &&
 704      read($JPEG, $c2, 1)        &&
 705      ord($c1) == 0xFF           &&
 706      ord($c2) == 0xD8           ){
 707     while (ord($ch) != 0xDA && !$done) {
 708       # Find next marker (JPEG markers begin with 0xFF)
 709       # This can hang the program!!
 710       while (ord($ch) != 0xFF) { return(0,0) unless read($JPEG, $ch, 1); }
 711       # JPEG markers can be padded with unlimited 0xFF's
 712       while (ord($ch) == 0xFF) { return(0,0) unless read($JPEG, $ch, 1); }
 713       # Now, $ch contains the value of the marker.
 714       if ((ord($ch) >= 0xC0) && (ord($ch) <= 0xC3)) {
 715         return(0,0) unless read ($JPEG, $dummy, 3);
 716         return(0,0) unless read($JPEG, $s, 4);
 717         ($a,$b,$c,$d)=unpack("C"x4,$s);
 718         return ($c<<8|$d, $a<<8|$b );
 719       } else {
 720         # We **MUST** skip variables, since FF's within variable names are
 721         # NOT valid JPEG markers
 722         return(0,0) unless read ($JPEG, $s, 2);
 723         ($c1, $c2) = unpack("C"x2,$s);
 724         $length = $c1<<8|$c2;
 725         last if (!defined($length) || $length < 2);
 726         read($JPEG, $dummy, $length-2);
 727       }
 728     }
 729   }
 730   return (0,0);
 731 }
 732
 733 # this is untested contributed code From: Jan Paul Schmidt <jps@fundament.org>
 734 # if you have problems with the jpegsize above - try this one!
 735 sub jpegsize2
 736 {
 737   my($JPEG) = @_;
 738   my( $i, $w, $y, $h, $j, $b ) = (0,0,0,0,0,0);
 739
 740   read $JPEG, $b, 4;
 741   $j = unpack "N", $b;
 742
 743   if ($j == 0xffd8ffe0) {
 744     do {
 745       read $JPEG, $b, 2;
 746       seek $JPEG, unpack("n", $b) - 2, 1;
 747       read $JPEG, $b, 2;
 748       $j = unpack "n", $b;
 749       if ($j >= 0xffc0 and $j <= 0xffc3) {
 750         seek $JPEG, 3, 1;
 751
 752         read $JPEG, $b, 2;
 753         $h = unpack "n", $b;
 754
 755         read $JPEG, $b, 2;
 756         $w = unpack "n", $b;
 757         goto done; # last;
 758       }
 759     } while not eof($JPEG);
 760   done:
 761   }
 762   return ($w, $h );
 763 }
 764
 765 ###########################################################################
 766 # Subroutine grabs a gif from another server, and gets its size
 767 ###########################################################################
 768
 769
 770 sub URLsize {
 771   my($five) = @_;
 772   my($dummy, $server, $url);
 773   my($c1, $c2, $c3, $c4)=(0,0,0,0);
 774
 775   my( $x,$y) = (0,0);
 776
 777   print "URLsize: $five\n" if $debug;
 778
 779   # first check the hash table (if we're using one)
 780   if(&istrue($UseHash) &&
 781      $hashx{$five}     &&
 782      $hashy{$five}     ){
 783     print "Hash " if $debug;
 784
 785     $x=$hashx{$five};
 786     $y=$hashy{$five};
 787     return($x,$y);
 788   }
 789
 790   if( $Proxy =~ /\S+/ ){
 791     ($dummy, $dummy, $server, $url)     = split(/\//, $Proxy, 4);
 792     $url=$five;
 793   } else {
 794     ($dummy, $dummy, $server, $url) = split(/\//, $five, 4);
 795     $url= '/' . $url;
 796   }
 797
 798   my($them,$port) = split(/:/, $server);
 799   my( $iaddr, $paddr, $proto );
 800
 801   $port = 80 unless $port;
 802   $them = 'localhost' unless $them;
 803
 804   print "\nThey are $them on port $port\n" if $debug;# && $Proxy;
 805   print "url is $url\n"                    if $debug;
 806
 807   $_=$url;
 808   if( /gif/i || /jpeg/i || /jpg/i || /xbm/i || /png/i ){
 809
 810     $iaddr= inet_aton( $them );
 811     $paddr= sockaddr_in( $port, $iaddr );
 812     $proto=getprotobyname('tcp');
 813
 814     # Make the socket filehandle.
 815
 816     if(socket(STRM, PF_INET, SOCK_STREAM, $proto) &&
 817        connect(STRM,$paddr) ){
 818       # Set socket to be command buffered.
 819       select(STRM); $| = 1; select(STDOUT);
 820
 821       print "Getting $url\n" if $debug;
 822
 823       my $str=("GET $url HTTP/1.1\n".
 824                #"User-Agent: Mozilla/4.08 [en] (WWWIS)\n".
 825                #"Accept: */*\n".
 826                "Connection: close\n".
 827                "Host: $them\n\n");
 828
 829       print "$str" if $debug;
 830
 831       print STRM $str;
 832
 833       # we're looking for \n\r\n\r
 834       while ((ord($c1) != 10) || (ord($c2) != 13) || (ord ($c3) != 10) ||
 835              (ord($c4) != 13)) {
 836         $c4 = $c3;
 837         $c3 = $c2;
 838         $c2 = $c1;
 839         read(STRM, $c1, 1);
 840         print "$c1" if $debug;
 841       }
 842       print "\n" if $debug;
 843
 844       if ($url =~ /\.jpg$/i || $url =~ /\.jpeg$/i) {
 845         ($x,$y) = &jpegsize(\*STRM);
 846       } elsif($url =~ /\.gif$/i) {
 847         ($x,$y) = &gifsize(\*STRM);
 848       } elsif($url =~ /\.xbm$/i) {
 849         ($x,$y) = &xbmsize(\*STRM);
 850       } elsif($url =~ /\.png$/i) {
 851         ($x,$y) = &pngsize(\*STRM);
 852       } else {
 853         print "$url is not gif, jpeg, xbm or png (or has stupid name)";
 854       }
 855
 856       close ( STRM );
 857     } else {
 858       # there was a problem
 859       print "ERROR: $!";
 860     }
 861   } else {
 862     print "$url is not gif, xbm or jpeg (or has stupid name)";
 863   }
 864   if(&istrue($UseHash) && $x && $y){
 865     $hashx{$five}=$x;
 866     $hashy{$five}=$y;
 867   }
 868   return ($x,$y);
 869 }
 870
 871 sub istrue
 872 {
 873   my( $val)=@_;
 874   return (defined($val) && ($val =~ /^y(es)?/i || $val =~ /true/i ));
 875 }
 876
 877 sub isfalse
 878 {
 879   my( $val)=@_;
 880   return (defined($val) && ($val =~ /^no?/i || $val =~ /false/i ));
 881 }
 882
 883 sub strip_quotes{
 884   my($name)=@_;
 885
 886   $_=$name; # now to gte rid of quotes if they were there
 887      if(  /\"([^\"]*)\"/ ){ return $1; } #"
 888   elsif(  /\'([^\']*)\'/ ){ return $1; }
 889   return $name;
 890 }
 891
 892 # this doesn't cope with \-ed " which it should!!!
 893 # I also didn't cope with javascript stuff like onChange (whoops)
 894 # this is why it is unsupported.
 895 sub changecase{
 896   my($text)=@_;
 897   my( @line )=();
 898   my( $ostr, $str, $j )=("","",0);
 899
 900   $text=~/^([^>]*)>/;
 901   return $text if( !defined($1));
 902   $ostr=$str=$1;
 903
 904   @line=split(/\"/, $str); #"
 905
 906   for( $j=0 ; $j <= $#line ; $j+=2 ){
 907     if( $UpcaseTags =~ /lower/i ){
 908       $line[$j] =~ tr/[A-Z]/[a-z]/;
 909     } else {
 910       $line[$j] =~ tr/[a-z]/[A-Z]/;
 911     }
 912   }
 913   if( $str =~ /\"$/ ){ #"
 914     $str=join( "\"", @line , "");
 915   } else {
 916     $str=join( "\"", @line );
 917   }
 918   $text=~ s/^$ostr/$str/;
 919
 920   return $text;
 921 }
 922
 923 # joins together two URLS to make one url
 924 # e.g. http://www/             +  fish.html = http://www/fish.html
 925 # e.g. http://www/index.html   +  fish.html = http://www/fish.html
 926 # e.g. http://www/s/index.html + /fish.html = http://www/fish.html
 927 sub ARKjoinURL
 928 {
 929   my($base,$url)=@_;
 930
 931   # if url has a double // in it then it is fine thank you!
 932   return $url if( $url =~ /\/\// );
 933
 934   # strip down base url to make sure that it doesn't have a .html at the end
 935   $base=~s/[^\/]*$//;
 936
 937   if( $url =~ /^\// ){
 938     # strip off leading directories
 939     $base =~ s/(\/\/[^\/]*)\/.*$/$1/;
 940   }
 941
 942   return ($base . $url);
 943 }
 944
 945 # File: wwwis-options.pl                -*- Perl -*-
 946 # Created by: Alex Knowles (alex@ed.ac.uk) Sat Nov  2 16:41:12 1996
 947 # Last Modified: Time-stamp: <03 Nov 96 1549 Alex Knowles>
 948 # RCS $Id: wwwis,v 2.43 2004/12/02 18:32:13 ark Exp $
 949 ############################################################################
 950 # There now follows some routines to get the configuration file
 951 ############################################################################
 952
 953 # NextOption:
 954 # give me the start of the next option (as options can take up a
 955 # different number of array elements)
 956 sub NextOption
 957 {
 958   my($i) = @_;
 959
 960   $_=$options[$i+1];
 961   if( /string/i || /integer/i || /file/i || /bool/i ){
 962     $i+=3;
 963   } elsif( /choice/i ){
 964     $i+=4+$options[$i+3];
 965   }else {
 966     print "unknown option type! $_\n";
 967     exit 2;
 968   }
 969   return $i;
 970 }
 971
 972 # ShowOptions: now I use -usage it's much better
 973
 974 # CheckOption:
 975 # Check if $val (arg2) is valid for option which starts at options[$i (arg1)]
 976 # returns either 0 (failure) or 1 (success)
 977 sub CheckOption
 978 {
 979   my($i,$val) = @_;
 980   my($k);
 981
 982   return 0 unless $i && $val;
 983
 984   $_=$options[$i+1];
 985   if( /string/i ){
 986     # can't think of a check for this
 987   }elsif( /integer/i ){
 988     if( $val !~ /^\d+$/ ){
 989       print "$val is not an integer!\n";
 990       return 0;
 991     }
 992   } elsif( /file/i ){
 993     if( ! (-e ($val) ) ){
 994       print "can't find file $val for $options[$i]\n";
 995       return 0;
 996     }
 997   }elsif( /bool/i ){
 998     if( $val !~ /^(y(es)?|no?)$/i ){
 999       print "$val is neither Yes nor No\n";
1000       return 0;
1001     }
1002   }elsif( /choice/i ){
1003     for( $k=0 ; $k < $options[$i+3] ; $k++ ){
1004       if( $val =~ /^$options[$i+4+$k]$/i ){
1005         return 1;
1006       }
1007     }
1008     print "$val is not a valid value for $options[$i]\n";
1009     return 0;
1010   }else {
1011     print "unknown option type! $_\n";
1012     exit 2;
1013   }
1014   return 1;
1015 }
1016
1017 # GetConfigFile:
1018 # Read user's configuration file, if such exists.  If WWWIMAGESIZERC is
1019 # set in user's environment, then read the file referenced, otherwise
1020 # try for $HOME/.wwwimagesizerc
1021 sub GetConfigFile
1022 {
1023   my( @options )= @_;
1024   my( @optionval )=();
1025   # my(*CONFIG);
1026   my($filename)="";
1027   my(@files)=();
1028   my($i,$j,$line);
1029
1030   #first go through options array and puyt the default values into optionval
1031   $i=0;
1032   $j=0;
1033   while( $i < $#options ){
1034     $optionval[$j]=$options[$i+2];
1035     $i=&NextOption($i);
1036     $j++;
1037   }
1038
1039   push(@files,$ENV{'WWWISRC'}) if $ENV{'WWWISRC'};
1040   push(@files,$ENV{'WWWIMAGESIZERC'}) if $ENV{'WWWIMAGESIZERC'};
1041   push(@files,("$ENV{'HOME'}/.wwwisrc",
1042               "$ENV{'HOME'}/.wwwimagesizerc",)) if $ENV{'HOME'};
1043
1044   foreach $i (@files){
1045     if( defined($i) && -f $i ){
1046       $filename=$i;
1047       last;
1048     }
1049   }
1050
1051   if(defined($filename) &&
1052      -f $filename               &&
1053      open(CONFIG,"< $filename") ){
1054     while (<CONFIG>){
1055       # skip lines with a hash on them
1056       s/#.*$//;
1057       next if /^\s*$/;
1058
1059       $line=$_;
1060       if( $line =~ /^(\S+)(\s+|\s*:\s*)(.+)$/ ){
1061         if( !(&proc_option($1,$3)) ){
1062           print "Invalid .wwwisrc line: $line";
1063         }
1064       }
1065     }
1066     close CONFIG;
1067   } else {
1068     if( -f $filename ){
1069       print "Unable to read config file `$filename': $!\n";
1070     }
1071   }
1072   return @optionval;
1073 }
1074
1075 sub proc_option
1076 {
1077   my($opt,$value)=@_;
1078   my($i,$j,$proced)=(0,0,0);
1079
1080   return 0 unless $opt && $value;
1081
1082   while( !$proced && $i < $#options ){
1083     if( $options[$i] =~ /$opt/i ){
1084       $proced=1;
1085       if( &CheckOption($i,$value) ){
1086         $optionval[$j]=$value;
1087       } else {
1088         printf("Invalid .wwwisrc value \"%s\" for option \"%s\"\n",
1089                $value,$options[$i]);
1090       }
1091     }
1092
1093     $i=&NextOption($i); # move onto the next option
1094     $j++;
1095   }
1096   return $proced;
1097 }
1098
1099 sub proc_arg
1100 {
1101   my($arg)= @_;
1102
1103   return if !defined($arg);
1104
1105   if( $arg =~ /^-+v(ersion)?$/i ){
1106     my($version)='$Revision: 2.43 $ ';
1107     my($progname)=$0;
1108     $progname =~ s/.*\///;      # we only want the name
1109     $version =~ s/[^\d\.]//g;   # we only care about numbers and full stops
1110     print "$progname: $version\n";
1111   } elsif( $arg =~ /^-+u(sage)?$/i ||
1112            $arg =~ /^-+h(elp)?$/i  ){
1113     &usage();
1114   } elsif( $arg =~ /^-+d(ebug)$/i ){
1115     $debug=1;
1116   } elsif( $arg =~ /-+im(a)?g(e)?size/i ){
1117     my($x,$y)=&imgsize(shift @ARGV);
1118     print "WIDTH=$x HEIGHT=$y\n";
1119   } else {
1120     $arg=~s/^-+//;
1121     if( &proc_option( $arg, shift @ARGV)){
1122       &SetGlobals();
1123     } else {
1124       print "Unrecognized option $arg\n";
1125       &usage();
1126       exit;
1127     }
1128   }
1129
1130 }
1131
1132 sub get_values
1133 {
1134   my($i)=@_;
1135   return "" if !defined $i;
1136
1137   if( $options[$i+1] =~ /file/i ){
1138     return ();
1139   } elsif($options[$i+1] =~ /string|integer/i ){
1140     return ();
1141   } elsif($options[$i+1] =~ /bool/i ){
1142     return ('Yes','No');
1143   } elsif($options[$i+1] =~ /choice/i ){
1144     my($start,$end)=(($i+4),($options[$i+3]));
1145     return (@options[$start .. $start+$end-1]);
1146   } else {
1147     print "Unrecognized option type\n";
1148     exit 0;
1149   }
1150 }
1151
1152 sub usage
1153 {
1154   my($progname)=$0;
1155   $progname =~ s/.*\///;        # we only want the name
1156   my($vals)="";
1157
1158   print "$progname: [-version] [-usage] [-option optionval] file.html ... \n";
1159
1160   my($fmt)="  %15s %6s %-10s %s\n";
1161
1162   printf($fmt,"Option Name","Type","Default","Values");
1163   printf($fmt,"-----------","----","-------","------");
1164
1165   my($i,$j)=(0,0);
1166
1167   while( $i < $#options ){
1168     $vals=join(',', &get_values($i));
1169     printf($fmt,$options[$i],$options[$i+1],$optionval[$j],$vals);
1170
1171     $i=&NextOption($i);
1172     $j++;
1173   }
1174 }
1175
1176 1;