usr_bin/wwwis

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