git.hungrycats.org Git - xscreensaver/blob - hacks/webcollage

   1 #!/usr/bin/perl -w
   2 #
   3 # webcollage, Copyright (c) 1999-2001 by Jamie Zawinski <jwz@jwz.org>
   4 # This program decorates the screen with random images from the web.
   5 # One satisfied customer described it as "a nonstop pop culture brainbath."
   6 #
   7 # Permission to use, copy, modify, distribute, and sell this software and its
   8 # documentation for any purpose is hereby granted without fee, provided that
   9 # the above copyright notice appear in all copies and that both that
  10 # copyright notice and this permission notice appear in supporting
  11 # documentation.  No representations are made about the suitability of this
  12 # software for any purpose.  It is provided "as is" without express or
  13 # implied warranty.
  14
  15 # To run this as a display mode with xscreensaver, add this to `programs':
  16 #
  17 #   default-n:  webcollage -root                                        \n\
  18 #   default-n:  webcollage -root -filter 'vidwhacker -stdin -stdout'    \n\
  19
  20
  21 require 5;
  22 use strict;
  23
  24 # We can't "use diagnostics" here, because that library malfunctions if
  25 # you signal and catch alarms: it says "Uncaught exception from user code"
  26 # and exits, even though I damned well AM catching it!
  27 #use diagnostics;
  28
  29
  30 use Socket;
  31 require Time::Local;
  32 require POSIX;
  33 use Fcntl ':flock'; # import LOCK_* constants
  34 use POSIX qw(strftime);
  35
  36
  37 my $progname = $0; $progname =~ s@.*/@@g;
  38 my $version = q{ $Revision: 1.82 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
  39 my $copyright = "WebCollage $version, Copyright (c) 1999-2001" .
  40     " Jamie Zawinski <jwz\@jwz.org>\n" .
  41     "            http://www.jwz.org/xscreensaver/\n";
  42
  43
  44
  45 my @search_methods = (  30, "imagevista", \&pick_from_alta_vista_images,
  46                         28, "altavista",  \&pick_from_alta_vista_text,
  47                         18, "yahoorand",  \&pick_from_yahoo_random_link,
  48                         14, "googleimgs", \&pick_from_google_images,
  49                          2, "yahoonews",  \&pick_from_yahoo_news_text,
  50                          8, "lycos",      \&pick_from_lycos_text,
  51
  52                      # Hotbot gives me "no matches" just about every time.
  53                      # Then I try the same URL again, and it works.  I guess
  54                      # it caches searches, and webcollage always busts its
  55                      # cache and time out?  Or it just sucks.
  56                      #   0, "hotbot",     \&pick_from_hotbot_text,
  57                       );
  58
  59 #@search_methods=(100, "googleimgs",\&pick_from_google_images);
  60
  61 # programs we can use to write to the root window (tried in ascending order.)
  62 #
  63 my @root_displayers = (
  64   "xloadimage -quiet -onroot -center -border black",
  65   "xli        -quiet -onroot -center -border black",
  66   "xv         -root -quit -viewonly +noresetroot -rmode 5" .
  67   "           -rfg black -rbg black",
  68   "chbg       -once -xscreensaver",
  69
  70 # this lame program wasn't built with vroot.h:
  71 # "xsri       -scale -keep-aspect -center-horizontal -center-vertical",
  72 );
  73
  74
  75 # Some sites need cookies to work properly.   These are they.
  76 #
  77 my %cookies = (
  78   "www.altavista.com"  =>  "AV_ALL=1",   # request uncensored searches
  79   "web.altavista.com"  =>  "AV_ALL=1",
  80
  81                                          # log in as "cipherpunk"
  82   "www.nytimes.com"    =>  'NYT-S=18cHMIlJOn2Y1bu5xvEG3Ufuk6E1oJ.' .
  83                            'FMxWaQV0igaB5Yi/Q/guDnLeoL.pe7i1oakSb' .
  84                            '/VqfdUdb2Uo27Vzt1jmPn3cpYRlTw9',
  85 );
  86
  87
  88 # Some sites have  managed to poison the search engines.  These are they.
  89 # (We auto-detect sites that have poisoned the search engines via excessive
  90 # keywords or dictionary words,  but these are ones that slip through
  91 # anyway.)
  92 #
  93 # This can contain full host names, or 2 or 3 component domains.
  94 #
  95 my %poisoners = (
  96   "die.net"                 => 1,  # 'l33t h4ck3r d00dz.
  97   "genforum.genealogy.com"  => 1,  # Cluttering altavista with human names.
  98   "rootsweb.com"            => 1,  # Cluttering altavista with human names.
  99   "akamai.net"              => 1,  # Lots of sites have their images on Akamai.
 100                                    # But those are pretty much all banners.
 101                                    # Since Akamai is super-expensive, let's
 102                                    # go out on a limb and assume that all of
 103                                    # their customers are rich-and-boring.
 104   "bartleby.com"            => 1,  # Dictionary, cluttering altavista.
 105   "encyclopedia.com"        => 1,  # Dictionary, cluttering altavista.
 106   "onlinedictionary.datasegment.com" => 1,  # Dictionary, cluttering altavista.
 107 );
 108
 109
 110 # When verbosity is turned on, we warn about sites that we seem to be hitting
 111 # a lot: usually this means some new poisoner has made it into the search
 112 # engines.  But sometimes, the warning is just because that site has a lot
 113 # of stuff on it.  So these are the sites that are immune to the "frequent
 114 # site" diagnostic message.
 115 #
 116 my %warningless_sites = (
 117   "home.earthlink.net"      => 1,  # Lots of home pages here.
 118   "www.geocities.com"       => 1,
 119   "www.angelfire.com"       => 1,
 120   "members.aol.com"         => 1,
 121
 122   "yimg.com"                => 1,  # This is where dailynews.yahoo.com stores
 123   "eimg.com"                => 1,  # its images, so pick_from_yahoo_news_text()
 124                                    # hits this every time.
 125 );
 126
 127
 128 ##############################################################################
 129 #
 130 # Various global flags set by command line parameters, or computed
 131 #
 132 ##############################################################################
 133
 134
 135 my $current_state = "???";      # for diagnostics
 136 my $load_method;
 137 my $last_search;
 138 my $image_succeeded = -1;
 139 my $suppress_audit = 0;
 140
 141 my $verbose_imgmap = 0;         # print out rectangles and URLs only (stdout)
 142 my $verbose_warnings = 0;       # print out warnings when things go wrong
 143 my $verbose_load = 0;           # diagnostics about loading of URLs
 144 my $verbose_filter = 0;         # diagnostics about page selection/rejection
 145 my $verbose_net = 0;            # diagnostics about network I/O
 146 my $verbose_pbm = 0;            # diagnostics about PBM pipelines
 147 my $verbose_http = 0;           # diagnostics about all HTTP activity
 148 my $verbose_exec = 0;           # diagnostics about executing programs
 149
 150 my $report_performance_interval = 60 * 15;  # print some stats every 15 minutes
 151
 152 my $http_proxy = undef;
 153 my $http_timeout = 30;
 154 my $cvt_timeout = 10;
 155
 156 my $min_width = 50;
 157 my $min_height = 50;
 158 my $min_ratio = 1/5;
 159
 160 my $min_gif_area = (120 * 120);
 161
 162
 163 my $no_output_p = 0;
 164 my $urls_only_p = 0;
 165
 166 my $wordlist;
 167
 168 my %rejected_urls;
 169 my @tripwire_words = ("aberrate", "abode", "amorphous", "antioch",
 170                       "arrhenius", "arteriole", "blanket", "brainchild",
 171                       "burdensome", "carnival", "cherub", "chord", "clever",
 172                       "dedicate", "dilogarithm", "dolan", "dryden",
 173                       "eggplant");
 174
 175
 176 ##############################################################################
 177 #
 178 # Retrieving URLs
 179 #
 180 ##############################################################################
 181
 182 # returns three values: the HTTP response line; the document headers;
 183 # and the document body.
 184 #
 185 sub get_document_1 {
 186   my ( $url, $referer, $timeout ) = @_;
 187
 188   if (!defined($timeout)) { $timeout = $http_timeout; }
 189   if ($timeout > $http_timeout) { $timeout = $http_timeout; }
 190
 191   if ($timeout <= 0) {
 192     LOG (($verbose_net || $verbose_load), "timed out for $url");
 193     return ();
 194   }
 195
 196   LOG ($verbose_net, "get_document_1 $url " . ($referer ? $referer : ""));
 197
 198   if (! ($url =~ m@^http://@i)) {
 199     LOG ($verbose_net, "not an HTTP URL: $url");
 200     return ();
 201   }
 202
 203   my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
 204   $path = "" unless $path;
 205
 206   my ($them,$port) = split(/:/, $serverstring);
 207   $port = 80 unless $port;
 208
 209   my $them2 = $them;
 210   my $port2 = $port;
 211   if ($http_proxy) {
 212     $serverstring = $http_proxy if $http_proxy;
 213     ($them2,$port2) = split(/:/, $serverstring);
 214     $port2 = 80 unless $port2;
 215   }
 216
 217   my ($remote, $iaddr, $paddr, $proto, $line);
 218   $remote = $them2;
 219   if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') }
 220   if (!$port2) {
 221     LOG (($verbose_net || $verbose_load), "unrecognised port in $url");
 222     return ();
 223   }
 224   $iaddr   = inet_aton($remote);
 225   if (!$iaddr) {
 226     LOG (($verbose_net || $verbose_load), "host not found: $remote");
 227     return ();
 228   }
 229   $paddr   = sockaddr_in($port2, $iaddr);
 230
 231
 232   my $head = "";
 233   my $body = "";
 234
 235   @_ =
 236     eval {
 237       local $SIG{ALRM} = sub {
 238         LOG (($verbose_net || $verbose_load), "timed out ($timeout) for $url");
 239         die "alarm\n";
 240       };
 241       alarm $timeout;
 242
 243       $proto   = getprotobyname('tcp');
 244       if (!socket(S, PF_INET, SOCK_STREAM, $proto)) {
 245         LOG (($verbose_net || $verbose_load), "socket: $!");
 246         return ();
 247       }
 248       if (!connect(S, $paddr)) {
 249         LOG (($verbose_net || $verbose_load), "connect($serverstring): $!");
 250         return ();
 251       }
 252
 253       select(S); $| = 1; select(STDOUT);
 254
 255       my $cookie = $cookies{$them};
 256
 257       my $user_agent = "$progname/$version";
 258       if ($url =~ m@^http://www\.altavista\.com/@) {
 259         # block this, you turkeys.
 260         $user_agent = "Mozilla/4.76 [en] (X11; U; Linux 2.2.16-22 i686; Nav)";
 261       }
 262
 263       my $hdrs = "GET " . ($http_proxy ? $url : "/$path") . " HTTP/1.0\r\n" .
 264                  "Host: $them\r\n" .
 265                  "User-Agent: $user_agent\r\n";
 266       if ($referer) {
 267         $hdrs .= "Referer: $referer\r\n";
 268       }
 269       if ($cookie) {
 270         my @cc = split(/\r?\n/, $cookie);
 271         $hdrs .= "Cookie: " . join('; ', @cc) . "\r\n";
 272       }
 273       $hdrs .= "\r\n";
 274
 275       foreach (split('\r?\n', $hdrs)) {
 276         LOG ($verbose_http, "  ==> $_");
 277       }
 278       print S $hdrs;
 279       my $http = <S>;
 280
 281       $_  = $http;
 282       s/[\r\n]+$//s;
 283       LOG ($verbose_http, "  <== $_");
 284
 285       while (<S>) {
 286         $head .= $_;
 287         s/[\r\n]+$//s;
 288         last if m@^$@;
 289         LOG ($verbose_http, "  <== $_");
 290
 291         if (m@^Set-cookie:\s*([^;\r\n]+)@i) {
 292           set_cookie($them, $1)
 293         }
 294       }
 295
 296       my $lines = 0;
 297       while (<S>) {
 298         $body .= $_;
 299         $lines++;
 300       }
 301
 302       LOG ($verbose_http,
 303            "  <== [ body ]: $lines lines, " . length($body) . " bytes");
 304
 305       close S;
 306
 307       if (!$http) {
 308         LOG (($verbose_net || $verbose_load), "null response: $url");
 309         return ();
 310       }
 311
 312       return ( $http, $head, $body );
 313     };
 314   die if ($@ && $@ ne "alarm\n");       # propagate errors
 315   if ($@) {
 316     # timed out
 317     $head = undef;
 318     $body = undef;
 319     $suppress_audit = 1;
 320     return ();
 321   } else {
 322     # didn't
 323     alarm 0;
 324     return @_;
 325   }
 326 }
 327
 328
 329 # returns two values: the document headers; and the document body.
 330 # if the given URL did a redirect, returns the redirected-to document.
 331 #
 332 sub get_document {
 333   my ( $url, $referer, $timeout ) = @_;
 334   my $start = time;
 335
 336   my $orig_url = $url;
 337   my $loop_count = 0;
 338   my $max_loop_count = 4;
 339
 340   do {
 341     if (defined($timeout) && $timeout <= 0) {
 342       LOG (($verbose_net || $verbose_load), "timed out for $url");
 343       $suppress_audit = 1;
 344       return ();
 345     }
 346
 347     my ( $http, $head, $body ) = get_document_1 ($url, $referer, $timeout);
 348
 349     if (defined ($timeout)) {
 350       my $now = time;
 351       my $elapsed = $now - $start;
 352       $timeout -= $elapsed;
 353       $start = $now;
 354     }
 355
 356     return () unless $http; # error message already printed
 357
 358     $http =~ s/[\r\n]+$//s;
 359
 360     if ( $http =~ m@^HTTP/[0-9.]+ 30[123]@ ) {
 361       $_ = $head;
 362       my ( $location ) = m@^location:[ \t]*(.*)$@im;
 363       if ( $location ) {
 364         $location =~ s/[\r\n]$//;
 365
 366         LOG ($verbose_net, "redirect from $url to $location");
 367         $referer = $url;
 368         $url = $location;
 369
 370         if ($url =~ m@^/@) {
 371           $referer =~ m@^(http://[^/]+)@i;
 372           $url = $1 . $url;
 373         } elsif (! ($url =~ m@^[a-z]+:@i)) {
 374           $_ = $referer;
 375           s@[^/]+$@@g if m@^http://[^/]+/@i;
 376           $_ .= "/" if m@^http://[^/]+$@i;
 377           $url = $_ . $url;
 378         }
 379
 380       } else {
 381         LOG ($verbose_net, "no Location with \"$http\"");
 382         return ( $url, $body );
 383       }
 384
 385       if ($loop_count++ > $max_loop_count) {
 386         LOG ($verbose_net,
 387              "too many redirects ($max_loop_count) from $orig_url");
 388         $body = undef;
 389         return ();
 390       }
 391
 392     } elsif ( $http =~ m@^HTTP/[0-9.]+ ([4-9][0-9][0-9].*)$@ ) {
 393
 394       LOG (($verbose_net || $verbose_load), "failed: $1 ($url)");
 395
 396       # http errors -- return nothing.
 397       $body = undef;
 398       return ();
 399
 400     } elsif (!$body) {
 401
 402       LOG (($verbose_net || $verbose_load), "document contains no data: $url");
 403       return ();
 404
 405     } else {
 406
 407       # ok!
 408       return ( $url, $body );
 409     }
 410
 411   } while (1);
 412 }
 413
 414 # If we already have a cookie defined for this site, and the site is trying
 415 # to overwrite that very same cookie, let it do so.  This is because nytimes
 416 # expires its cookies - it lets you upgrade to a new cookie without logging
 417 # in again, but you have to present the old cookie to get the new cookie.
 418 # So, by doing this, the built-in cypherpunks cookie will never go "stale".
 419 #
 420 sub set_cookie {
 421   my ($host, $cookie) = @_;
 422   my $oc = $cookies{$host};
 423   return unless $oc;
 424   $_ = $oc;
 425   my ($oc_name, $oc_value) = m@^([^= \t\r\n]+)=(.*)$@;
 426   $_ = $cookie;
 427   my ($nc_name, $nc_value) = m@^([^= \t\r\n]+)=(.*)$@;
 428
 429   if ($oc_name eq $nc_name &&
 430       $oc_value ne $nc_value) {
 431     $cookies{$host} = $cookie;
 432     LOG ($verbose_net, "overwrote ${host}'s $oc_name cookie");
 433   }
 434 }
 435
 436
 437 ############################################################################
 438 #
 439 # Extracting image URLs from HTML
 440 #
 441 ############################################################################
 442
 443 # given a URL and the body text at that URL, selects and returns a random
 444 # image from it.  returns () if no suitable images found.
 445 #
 446 sub pick_image_from_body {
 447   my ( $url, $body ) = @_;
 448
 449   my $base = $url;
 450   $_ = $url;
 451
 452   # if there's at least one slash after the host, take off the last
 453   # pathname component
 454   if ( m@^http://[^/]+/@io ) {
 455     $base =~ s@[^/]+$@@go;
 456   }
 457
 458   # if there are no slashes after the host at all, put one on the end.
 459   if ( m@^http://[^/]+$@io ) {
 460     $base .= "/";
 461   }
 462
 463   $_ = $body;
 464
 465   # strip out newlines, compress whitespace
 466   s/[\r\n\t ]+/ /go;
 467
 468   # nuke comments
 469   s/<!--.*?-->//go;
 470
 471
 472   # There are certain web sites that list huge numbers of dictionary
 473   # words in their bodies or in their <META NAME=KEYWORDS> tags (surprise!
 474   # Porn sites tend not to be reputable!)
 475   #
 476   # I do not want webcollage to filter on content: I want it to select
 477   # randomly from the set of images on the web.  All the logic here for
 478   # rejecting some images is really a set of heuristics for rejecting
 479   # images that are not really images: for rejecting *text* that is in
 480   # GIF/JPEG form.  I don't want text, I want pictures, and I want the
 481   # content of the pictures to be randomly selected from among all the
 482   # available content.
 483   #
 484   # So, filtering out "dirty" pictures by looking for "dirty" keywords
 485   # would be wrong: dirty pictures exist, like it or not, so webcollage
 486   # should be able to select them.
 487   #
 488   # However, picking a random URL is a hard thing to do.  The mechanism I'm
 489   # using is to search for a selection of random words.  This is not
 490   # perfect, but works ok most of the time.  The way it breaks down is when
 491   # some URLs get precedence because their pages list *every word* as
 492   # related -- those URLs come up more often than others.
 493   #
 494   # So, after we've retrieved a URL, if it has too many keywords, reject
 495   # it.  We reject it not on the basis of what those keywords are, but on
 496   # the basis that by having so many, the page has gotten an unfair
 497   # advantage against our randomizer.
 498   #
 499   my $trip_count = 0;
 500   foreach my $trip (@tripwire_words) {
 501     $trip_count++ if m/$trip/i;
 502   }
 503
 504   if ($trip_count >= $#tripwire_words - 2) {
 505     LOG (($verbose_filter || $verbose_load),
 506          "there is probably a dictionary in \"$url\": rejecting.");
 507     $rejected_urls{$url} = -1;
 508     $body = undef;
 509     $_ = undef;
 510     return ();
 511   }
 512
 513
 514   my @urls;
 515   my %unique_urls;
 516
 517   foreach (split(/ *</)) {
 518     if ( m/^meta /i ) {
 519
 520       # Likewise, reject any web pages that have a KEYWORDS meta tag
 521       # that is too long.
 522       #
 523       if (m/name ?= ?\"?keywords\"?/i &&
 524           m/content ?= ?\"([^\"]+)\"/) {
 525         my $L = length($1);
 526         if ($L > 1000) {
 527           LOG (($verbose_filter || $verbose_load),
 528                "excessive keywords ($L bytes) in $url: rejecting.");
 529           $rejected_urls{$url} = $L;
 530           $body = undef;
 531           $_ = undef;
 532           return ();
 533         } else {
 534           LOG ($verbose_filter, "  keywords ($L bytes) in $url (ok)");
 535         }
 536       }
 537
 538     } elsif ( m/^(img|a) .*(src|href) ?= ?\"? ?(.*?)[ >\"]/io ) {
 539
 540       my $was_inline = ( "$1" eq "a" || "$1" eq "A" );
 541       my $link = $3;
 542       my ( $width )  = m/width ?=[ \"]*(\d+)/oi;
 543       my ( $height ) = m/height ?=[ \"]*(\d+)/oi;
 544       $_ = $link;
 545
 546       if ( m@^/@o ) {
 547         my $site;
 548         ( $site = $base ) =~ s@^(http://[^/]*).*@$1@gio;
 549         $_ = "$site$link";
 550       } elsif ( ! m@^[^/:?]+:@ ) {
 551         $_ = "$base$link";
 552         s@/\./@/@g;
 553         while (s@/\.\./@/@g) {
 554         }
 555       }
 556
 557       # skip non-http
 558       if ( ! m@^http://@io ) {
 559         next;
 560       }
 561
 562       # skip non-image
 563       if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg)$@io ) {
 564         next;
 565       }
 566
 567       # skip really short or really narrow images
 568       if ( $width && $width < $min_width) {
 569         if (!$height) { $height = "?"; }
 570         LOG ($verbose_filter, "  skip narrow image $_ (${width}x$height)");
 571         next;
 572       }
 573
 574       if ( $height && $height < $min_height) {
 575         if (!$width) { $width = "?"; }
 576         LOG ($verbose_filter, "  skip short image $_ (${width}x$height)");
 577         next;
 578       }
 579
 580       # skip images with ratios that make them look like banners.
 581       if ($min_ratio && $width && $height &&
 582           ($width * $min_ratio ) > $height) {
 583         if (!$height) { $height = "?"; }
 584         LOG ($verbose_filter, "  skip bad ratio $_ (${width}x$height)");
 585         next;
 586       }
 587
 588       # skip GIFs with a small number of pixels -- those usually suck.
 589       if ($width && $height &&
 590           m/\.gif$/io &&
 591           ($width * $height) < $min_gif_area) {
 592         LOG ($verbose_filter, "  skip small GIF $_ (${width}x$height)");
 593         next;
 594       }
 595
 596
 597       my $url = $_;
 598
 599       if ($unique_urls{$url}) {
 600         LOG ($verbose_filter, "  skip duplicate image $_");
 601         next;
 602       }
 603
 604       LOG ($verbose_filter,
 605            "  image $url" .
 606            ($width && $height ? " (${width}x${height})" : "") .
 607            ($was_inline ? " (inline)" : ""));
 608
 609       $urls[++$#urls] = $url;
 610       $unique_urls{$url}++;
 611
 612       # jpegs are preferable to gifs.
 613       $_ = $url;
 614       if ( ! m@[.]gif$@io ) {
 615         $urls[++$#urls] = $url;
 616       }
 617
 618       # pointers to images are preferable to inlined images.
 619       if ( ! $was_inline ) {
 620         $urls[++$#urls] = $url;
 621         $urls[++$#urls] = $url;
 622       }
 623     }
 624   }
 625
 626   my $fsp = ($body =~ m@<frameset@i);
 627
 628   $_ = undef;
 629   $body = undef;
 630
 631   @urls = depoison (@urls);
 632
 633   if ( $#urls < 0 ) {
 634     LOG ($verbose_load, "no images on $base" . ($fsp ? " (frameset)" : ""));
 635     return ();
 636   }
 637
 638   # pick a random element of the table
 639   my $i = int(rand($#urls+1));
 640   $url = $urls[$i];
 641
 642   LOG ($verbose_load, "picked image " .($i+1) . "/" . ($#urls+1) . ": $url");
 643
 644   return $url;
 645 }
 646
 647
 648 \f
 649 ############################################################################
 650 #
 651 # Subroutines for getting pages and images out of search engines
 652 #
 653 ############################################################################
 654
 655
 656 sub pick_dictionary {
 657   my @dicts = ("/usr/dict/words",
 658                "/usr/share/dict/words",
 659                "/usr/share/lib/dict/words");
 660   foreach my $f (@dicts) {
 661     if (-f $f) {
 662       $wordlist = $f;
 663       last;
 664     }
 665   }
 666   error ("$dicts[0] does not exist") unless defined($wordlist);
 667 }
 668
 669 # returns a random word from the dictionary
 670 #
 671 sub random_word {
 672     my $word = 0;
 673     if (open (IN, "<$wordlist")) {
 674         my $size = (stat(IN))[7];
 675         my $pos = rand $size;
 676         if (seek (IN, $pos, 0)) {
 677             $word = <IN>;   # toss partial line
 678             $word = <IN>;   # keep next line
 679         }
 680         if (!$word) {
 681           seek( IN, 0, 0 );
 682           $word = <IN>;
 683         }
 684         close (IN);
 685     }
 686
 687     return 0 if (!$word);
 688
 689     $word =~ s/^[ \t\n\r]+//;
 690     $word =~ s/[ \t\n\r]+$//;
 691     $word =~ s/ys$/y/;
 692     $word =~ s/ally$//;
 693     $word =~ s/ly$//;
 694     $word =~ s/ies$/y/;
 695     $word =~ s/ally$/al/;
 696     $word =~ s/izes$/ize/;
 697     $word =~ tr/A-Z/a-z/;
 698
 699     if ( $word =~ s/[ \t\n\r]/\+/g ) {  # convert intra-word spaces to "+".
 700       $word = "\%22$word\%22";          # And put quotes (%22) around it.
 701     }
 702
 703     return $word;
 704 }
 705
 706 sub random_words {
 707   return (random_word . "%20" .
 708           random_word . "%20" .
 709           random_word . "%20" .
 710           random_word . "%20" .
 711           random_word);
 712 }
 713
 714
 715 sub url_quote {
 716   my ($s) = @_;
 717   $s =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
 718   return $s;
 719 }
 720
 721 sub url_unquote {
 722   my ($s) = @_;
 723   $s =~ s/[+]/ /g;
 724   $s =~ s/%([a-z0-9]{2})/chr(hex($1))/ige;
 725   return $s;
 726 }
 727
 728
 729 # Loads the given URL (a search on some search engine) and returns:
 730 # - the total number of hits the search engine claimed it had;
 731 # - a list of URLs from the page that the search engine returned;
 732 # Note that this list contains all kinds of internal search engine
 733 # junk URLs too -- caller must prune them.
 734 #
 735 sub pick_from_search_engine {
 736   my ( $timeout, $search_url, $words ) = @_;
 737
 738   $_ = $words;
 739   s/%20/ /g;
 740
 741   print STDERR "\n\n" if ($verbose_load);
 742
 743   LOG ($verbose_load, "words: $_");
 744   LOG ($verbose_load, "URL: $search_url");
 745
 746   $last_search = $search_url;   # for warnings
 747
 748   my $start = time;
 749   my ( $base, $body ) = get_document ($search_url, undef, $timeout);
 750   if (defined ($timeout)) {
 751     $timeout -= (time - $start);
 752     if ($timeout <= 0) {
 753       $body = undef;
 754       LOG (($verbose_net || $verbose_load),
 755            "timed out (late) for $search_url");
 756       $suppress_audit = 1;
 757       return ();
 758     }
 759   }
 760
 761   return () if (! $body);
 762
 763
 764   my @subpages;
 765
 766   my $search_count = "?";
 767   if ($body =~ m@found (approximately |about )?(<B>)?(\d+)(</B>)? image@) {
 768     $search_count = $3;
 769   } elsif ($body =~ m@<NOBR>((\d{1,3})(,\d{3})*)&nbsp;@i) {
 770     $search_count = $1;
 771   } elsif ($body =~ m@found ((\d{1,3})(,\d{3})*|\d+) Web p@) {
 772     $search_count = $1;
 773   } elsif ($body =~ m@found about ((\d{1,3})(,\d{3})*|\d+) results@) {
 774     $search_count = $1;
 775   } elsif ($body =~ m@\b\d+ - \d+ of (\d+)\b@i) { # imagevista
 776     $search_count = $1;
 777   } elsif ($body =~ m@About ((\d{1,3})(,\d{3})*) images@i) { # imagevista
 778     $search_count = $1;
 779   } elsif ($body =~ m@We found ((\d{1,3})(,\d{3})*|\d+) results@i) { # *vista
 780     $search_count = $1;
 781   } elsif ($body =~ m@ of about <B>((\d{1,3})(,\d{3})*)<@i) { # googleimages
 782     $search_count = $1;
 783   } elsif ($body =~ m@<B>((\d{1,3})(,\d{3})*)</B> Web sites were found@i) {
 784     $search_count = $1;    # lycos
 785   } elsif ($body =~ m@WEB.*?RESULTS.*?\b((\d{1,3})(,\d{3})*)\b.*?Matches@i) {
 786     $search_count = $1;                          # hotbot
 787   } elsif ($body =~ m@no photos were found containing@i) { # imagevista
 788     $search_count = "0";
 789   } elsif ($body =~ m@found no document matching@i) { # altavista
 790     $search_count = "0";
 791   }
 792   1 while ($search_count =~ s/^(\d+)(\d{3})/$1,$2/);
 793
 794 #  if ($search_count eq "?" || $search_count eq "0") {
 795 #    local *OUT;
 796 #    my $file = "/tmp/wc.html";
 797 #    open(OUT, ">$file") || error ("writing $file: $!");
 798 #    print OUT $body;
 799 #    close OUT;
 800 #    print STDERR  blurb() . "###### wrote $file\n";
 801 #  }
 802
 803
 804   my $length = length($body);
 805   my $href_count = 0;
 806
 807   $_ = $body;
 808
 809   s/[\r\n\t ]+/ /g;
 810
 811
 812   s/(<A )/\n$1/gi;
 813   foreach (split(/\n/)) {
 814     $href_count++;
 815     my ($u) = m@<A\s.*\bHREF\s*=\s*([^>]+)>@i;
 816     next unless $u;
 817
 818     if ($u =~ m/^\"([^\"]*)\"/) { $u = $1; }   # quoted string
 819     elsif ($u =~ m/^([^\s]*)\s/) { $u = $1; }  # or token
 820
 821     if ( $rejected_urls{$u} ) {
 822       LOG ($verbose_filter, "  pre-rejecting candidate: $u");
 823       next;
 824     }
 825
 826     LOG ($verbose_http, "    HREF: $u");
 827
 828     $subpages[++$#subpages] = $u;
 829   }
 830
 831   if ( $#subpages < 0 ) {
 832     LOG ($verbose_filter,
 833          "found nothing on $base ($length bytes, $href_count links).");
 834     return ();
 835   }
 836
 837   LOG ($verbose_filter, "" . $#subpages+1 . " links on $search_url");
 838
 839   return ($search_count, @subpages);
 840 }
 841
 842
 843 sub depoison {
 844   my (@urls) = @_;
 845   my @urls2 = ();
 846   foreach (@urls) {
 847     my ($h) = m@^http://([^/: \t\r\n]+)@i;
 848
 849     next unless defined($h);
 850
 851     if ($poisoners{$h}) {
 852       LOG (($verbose_filter), "  rejecting poisoner: $_");
 853       next;
 854     }
 855     if ($h =~ m@([^.]+\.[^.]+\.[^.]+)$@ &&
 856         $poisoners{$1}) {
 857       LOG (($verbose_filter), "  rejecting poisoner: $_");
 858       next;
 859     }
 860     if ($h =~ m@([^.]+\.[^.]+)$@ &&
 861         $poisoners{$1}) {
 862       LOG (($verbose_filter), "  rejecting poisoner: $_");
 863       next;
 864     }
 865
 866     push @urls2, $_;
 867   }
 868   return @urls2;
 869 }
 870
 871
 872 # given a list of URLs, picks one at random; loads it; and returns a
 873 # random image from it.
 874 # returns the url of the page loaded; the url of the image chosen;
 875 # and a debugging description string.
 876 #
 877 sub pick_image_from_pages {
 878   my ($base, $total_hit_count, $unfiltered_link_count, $timeout, @pages) = @_;
 879
 880   $total_hit_count = "?" unless defined($total_hit_count);
 881
 882   @pages = depoison (@pages);
 883   LOG ($verbose_load,
 884        "" . ($#pages+1) . " candidates of $unfiltered_link_count links" .
 885        " ($total_hit_count total)");
 886
 887   return () if ($#pages < 0);
 888
 889   my $i = int(rand($#pages+1));
 890   my $page = $pages[$i];
 891
 892   LOG ($verbose_load, "picked page $page");
 893
 894   $suppress_audit = 1;
 895
 896   my ( $base2, $body2 ) = get_document ($page, $base, $timeout);
 897
 898   if (!$base2 || !$body2) {
 899     $body2 = undef;
 900     return ();
 901   }
 902
 903   my $img = pick_image_from_body ($base2, $body2);
 904   $body2 = undef;
 905
 906   if ($img) {
 907     return ($base2, $img);
 908   } else {
 909     return ();
 910   }
 911 }
 912
 913 \f
 914 ############################################################################
 915 #
 916 # Pick images from random pages returned by the Yahoo Random Link
 917 #
 918 ############################################################################
 919
 920 # yahoorand
 921 my $yahoo_random_link = "http://random.yahoo.com/bin/ryl";
 922
 923
 924 # Picks a random page; picks a random image on that page;
 925 # returns two URLs: the page containing the image, and the image.
 926 # Returns () if nothing found this time.
 927 #
 928 sub pick_from_yahoo_random_link {
 929   my ( $timeout ) = @_;
 930
 931   print STDERR "\n\n" if ($verbose_load);
 932   LOG ($verbose_load, "URL: $yahoo_random_link");
 933
 934   $last_search = $yahoo_random_link;   # for warnings
 935
 936   $suppress_audit = 1;
 937
 938   my ( $base, $body ) = get_document ($yahoo_random_link, undef, $timeout);
 939   if (!$base || !$body) {
 940     $body = undef;
 941     return;
 942   }
 943
 944   LOG ($verbose_load, "redirected to: $base");
 945
 946   my $img = pick_image_from_body ($base, $body);
 947   $body = undef;
 948
 949   if ($img) {
 950     return ($base, $img);
 951   } else {
 952     return ();
 953   }
 954 }
 955
 956 \f
 957 ############################################################################
 958 #
 959 # Pick images by feeding random words into Alta Vista Image Search
 960 #
 961 ############################################################################
 962
 963
 964 my $alta_vista_images_url = "http://www.altavista.com/cgi-bin/query" .
 965                             "?ipht=1" .       # photos
 966                             "&igrph=1" .      # graphics
 967                             "&iclr=1" .       # color
 968                             "&ibw=1" .        # b&w
 969                             "&micat=1" .      # no partner sites
 970                             "&imgset=1" .     # no partner sites
 971                             "&stype=simage" . # do image search
 972                             "&mmW=1" .        # unknown, but required
 973                             "&q=";
 974
 975 # imagevista
 976 sub pick_from_alta_vista_images {
 977   my ( $timeout ) = @_;
 978
 979   my $words = random_words;
 980   my $page = (int(rand(9)) + 1);
 981   my $search_url = $alta_vista_images_url . $words;
 982
 983   if ($page > 1) {
 984     $search_url .= "&pgno=" . $page;            # page number
 985     $search_url .= "&stq=" . (($page-1) * 12);  # first hit result on page
 986   }
 987
 988   my ($search_hit_count, @subpages) =
 989     pick_from_search_engine ($timeout, $search_url, $words);
 990
 991   my @candidates = ();
 992   foreach my $u (@subpages) {
 993
 994     # altavista is encoding their URLs now.
 995     next unless ($u =~
 996     m@^/r\?ck_sm=[a-zA-Z0-9]+\&ref=[a-zA-Z0-9]+(\&uid=[a-zA-Z0-9]+)?\&r=(.*)@);
 997     $u = url_unquote($2);
 998
 999     next unless ($u =~ m@^http://@i);    #  skip non-HTTP or relative URLs
1000     next if ($u =~ m@[/.]altavista\.com\b@i);     # skip altavista builtins
1001     next if ($u =~ m@[/.]doubleclick\.net\b@i);   # you cretins
1002     next if ($u =~ m@[/.]clicktomarket\.com\b@i); # more cretins
1003
1004     next if ($u =~ m@[/.]viewimages\.com\b@i);    # stacked deck
1005     next if ($u =~ m@[/.]gettyimages\.com\b@i);
1006
1007     LOG ($verbose_filter, "  candidate: $u");
1008     push @candidates, $u;
1009   }
1010
1011   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1012                                 $timeout, @candidates);
1013 }
1014
1015
1016 \f
1017 ############################################################################
1018 #
1019 # Pick images by feeding random words into Google Image Search
1020 # By Charles Gales <gales@us.ibm.com>
1021 #
1022 ############################################################################
1023
1024
1025 my $google_images_url =     "http://images.google.com/images" .
1026                             "?site=images" .  # photos
1027                             "&btnG=Search" .  # graphics
1028                             "&safe=off" .     # no screening
1029                             "&imgsafe=off" .
1030                             "&q=";
1031
1032 # googleimgs
1033 sub pick_from_google_images {
1034   my ( $timeout ) = @_;
1035
1036   my $words = random_word;   # only one word for Google
1037   my $page = (int(rand(9)) + 1);
1038   my $num = 20;     # 20 images per page
1039   my $search_url = $google_images_url . $words;
1040
1041   if ($page > 1) {
1042     $search_url .= "&start=" . $page*$num;      # page number
1043     $search_url .= "&num="   . $num;            #images per page
1044   }
1045
1046   my ($search_hit_count, @subpages) =
1047     pick_from_search_engine ($timeout, $search_url, $words);
1048
1049   my @candidates = ();
1050   foreach my $u (@subpages) {
1051     next unless ($u =~ m@imgres\?imgurl@i);    #  All pics start with this
1052     next if ($u =~ m@[/.]google\.com\b@i);     # skip google builtins
1053
1054     if ($u =~ m@^/imgres\?imgurl=(.*?)\&imgrefurl=(.*?)\&@) {
1055       my $urlf = $2;
1056       LOG ($verbose_filter, "  candidate: $urlf");
1057       push @candidates, $urlf;
1058     }
1059   }
1060
1061   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1062                                 $timeout, @candidates);
1063 }
1064
1065
1066 \f
1067 ############################################################################
1068 #
1069 # Pick images by feeding random words into Alta Vista Text Search
1070 #
1071 ############################################################################
1072
1073
1074 my $alta_vista_url_1 = "http://www.altavista.com/cgi-bin/query?pg=q" .
1075                        "&text=yes&kl=XX&stype=stext&q=";
1076 my $alta_vista_url_2 = "http://www.altavista.com/sites/search/web?pg=q" .
1077                        "&kl=XX&search=Search&q=";
1078
1079 my $alta_vista_url = $alta_vista_url_2;
1080
1081 # altavista
1082 sub pick_from_alta_vista_text {
1083   my ( $timeout ) = @_;
1084
1085   my $words = random_words;
1086   my $page = (int(rand(9)) + 1);
1087   my $search_url = $alta_vista_url . $words;
1088
1089   if ($page > 1) {
1090     $search_url .= "&pgno=" . $page;
1091     $search_url .= "&stq=" . (($page-1) * 10);
1092   }
1093
1094   my ($search_hit_count, @subpages) =
1095     pick_from_search_engine ($timeout, $search_url, $words);
1096
1097   my @candidates = ();
1098   foreach my $u (@subpages) {
1099
1100     # Those altavista fuckers are playing really nasty redirection games
1101     # these days: the filter your clicks through their site, but use
1102     # onMouseOver to make it look like they're not!  Well, it makes it
1103     # easier for us to identify search results...
1104     #
1105     next unless ($u =~
1106       m@^/r\?ck_sm=[a-zA-Z0-9]+\&ref=[a-zA-Z0-9]+\&uid=[a-zA-Z0-9]+\&r=(.*)@);
1107     $u = url_unquote($1);
1108
1109     LOG ($verbose_filter, "  candidate: $u");
1110     push @candidates, $u;
1111   }
1112
1113   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1114                                 $timeout, @candidates);
1115 }
1116
1117
1118 \f
1119 ############################################################################
1120 #
1121 # Pick images by feeding random words into Hotbot
1122 #
1123 ############################################################################
1124
1125 my $hotbot_search_url = "http://hotbot.lycos.com/" .
1126                         "?SM=SC" .
1127                         "&DV=0" .
1128                         "&LG=any" .
1129                         "&FVI=1" .
1130                         "&DC=100" .
1131                         "&DE=0" .
1132                         "&SQ=1" .
1133                         "&TR=13" .
1134                         "&AM1=MC" .
1135                         "&MT=";
1136
1137 sub pick_from_hotbot_text {
1138   my ( $timeout ) = @_;
1139
1140   my $words = random_words;
1141   my $search_url = $hotbot_search_url . $words;
1142
1143   my ($search_hit_count, @subpages) =
1144     pick_from_search_engine ($timeout, $search_url, $words);
1145
1146   my @candidates = ();
1147   foreach my $u (@subpages) {
1148
1149     # Hotbot plays redirection games too
1150     next unless ($u =~ m@^/director.asp\?target=([^&]+)@);
1151     $u = url_decode($1);
1152
1153     LOG ($verbose_filter, "  candidate: $u");
1154     push @candidates, $u;
1155   }
1156
1157   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1158                                 $timeout, @candidates);
1159 }
1160
1161
1162 \f
1163 ############################################################################
1164 #
1165 # Pick images by feeding random words into Lycos
1166 #
1167 ############################################################################
1168
1169 my $lycos_search_url = "http://lycospro.lycos.com/srchpro/" .
1170                        "?lpv=1" .
1171                        "&t=any" .
1172                        "&query=";
1173
1174 sub pick_from_lycos_text {
1175   my ( $timeout ) = @_;
1176
1177   my $words = random_words;
1178   my $start = int(rand(8)) * 10 + 1;
1179   my $search_url = $lycos_search_url . $words . "&start=$start";
1180
1181   my ($search_hit_count, @subpages) =
1182     pick_from_search_engine ($timeout, $search_url, $words);
1183
1184   my @candidates = ();
1185   foreach my $u (@subpages) {
1186
1187     # Lycos plays exact the same redirection game as hotbot.
1188     # Note that "id=0" is used for internal advertising links,
1189     # and 1+ are used for  search results.
1190     next unless ($u =~ m@^http://click.hotbot.com/director.asp\?id=[1-9]\d*&target=([^&]+)@);
1191     $u = url_decode($1);
1192
1193     LOG ($verbose_filter, "  candidate: $u");
1194     push @candidates, $u;
1195   }
1196
1197   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1198                                 $timeout, @candidates);
1199 }
1200
1201
1202 \f
1203 ############################################################################
1204 #
1205 # Pick images by feeding random words into news.yahoo.com
1206 #
1207 ############################################################################
1208
1209 my $yahoo_news_url = "http://search.news.yahoo.com/search/news_photos?" .
1210                      "&z=&n=100&o=o&2=&3=&p=";
1211
1212 # yahoonews
1213 sub pick_from_yahoo_news_text {
1214   my ( $timeout ) = @_;
1215
1216   my $words = random_words;
1217   my $search_url = $yahoo_news_url . $words;
1218
1219   my ($search_hit_count, @subpages) =
1220     pick_from_search_engine ($timeout, $search_url, $words);
1221
1222   my @candidates = ();
1223   foreach my $u (@subpages) {
1224     # only accept URLs on Yahoo's news site
1225     next unless ($u =~ m@^http://dailynews.yahoo.com/@i);
1226
1227     LOG ($verbose_filter, "  candidate: $u");
1228     push @candidates, $u;
1229   }
1230
1231   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1232                                 $timeout, @candidates);
1233 }
1234
1235
1236
1237 \f
1238 ############################################################################
1239 #
1240 # Pick a random image in a random way
1241 #
1242 ############################################################################
1243
1244
1245 # Picks a random image on a random page, and returns two URLs:
1246 # the page containing the image, and the image.
1247 # Returns () if nothing found this time.
1248 # Uses the url-randomizer 1 time in 5, else the image randomizer.
1249 #
1250
1251 sub pick_image {
1252   my ( $timeout ) = @_;
1253
1254   $current_state = "select";
1255   $load_method = "none";
1256
1257   my $n = int(rand(100));
1258   my $fn = undef;
1259   my $total = 0;
1260   my @rest = @search_methods;
1261
1262   while (@rest) {
1263     my $pct  = shift @rest;
1264     my $name = shift @rest;
1265     my $tfn  = shift @rest;
1266     $total += $pct;
1267     if ($total > $n && !defined($fn)) {
1268       $fn = $tfn;
1269       $current_state = $name;
1270       $load_method = $current_state;
1271     }
1272   }
1273
1274   if ($total != 100) {
1275     error ("internal error: \@search_methods totals to $total%!");
1276   }
1277
1278   record_attempt ($current_state);
1279   return $fn->($timeout);
1280 }
1281
1282
1283 \f
1284 ############################################################################
1285 #
1286 # Statistics and logging
1287 #
1288 ############################################################################
1289
1290 sub timestr {
1291   return strftime ("%H:%M:%S: ", localtime);
1292 }
1293
1294 sub blurb {
1295   return "$progname: " . timestr() . "$current_state: ";
1296 }
1297
1298 sub error {
1299   my ($err) = @_;
1300   print STDERR blurb() . "$err\n";
1301   exit 1;
1302 }
1303
1304
1305 my $lastlog = "";
1306
1307 sub clearlog {
1308   $lastlog = "";
1309 }
1310
1311 sub showlog {
1312   my $head = "$progname: DEBUG: ";
1313   foreach (split (/\n/, $lastlog)) {
1314     print STDERR "$head$_\n";
1315   }
1316   $lastlog = "";
1317 }
1318
1319 sub LOG {
1320   my ($print, $msg) = @_;
1321   my $blurb = timestr() . "$current_state: ";
1322   $lastlog .= "$blurb$msg\n";
1323   print STDERR "$progname: $blurb$msg\n" if $print;
1324 }
1325
1326
1327 my %stats_attempts;
1328 my %stats_successes;
1329 my %stats_elapsed;
1330
1331 my $last_state = undef;
1332 sub record_attempt {
1333   my ($name) = @_;
1334
1335   if ($last_state) {
1336     record_failure($last_state) unless ($image_succeeded > 0);
1337   }
1338   $last_state = $name;
1339
1340   clearlog();
1341   report_performance();
1342
1343   start_timer($name);
1344   $image_succeeded = 0;
1345   $suppress_audit = 0;
1346 }
1347
1348 sub record_success {
1349   my ($name, $url, $base) = @_;
1350   if (defined($stats_successes{$name})) {
1351     $stats_successes{$name}++;
1352   } else {
1353     $stats_successes{$name} = 1;
1354   }
1355
1356   stop_timer ($name, 1);
1357   my $o = $current_state;
1358   $current_state = $name;
1359   save_recent_url ($url, $base);
1360   $current_state = $o;
1361   $image_succeeded = 1;
1362   clearlog();
1363 }
1364
1365
1366 sub record_failure {
1367   my ($name) = @_;
1368
1369   return if $image_succeeded;
1370
1371   stop_timer ($name, 0);
1372   if ($verbose_load && !$verbose_exec) {
1373
1374     if ($suppress_audit) {
1375       print STDERR "$progname: " . timestr() . "(audit log suppressed)\n";
1376       return;
1377     }
1378
1379     my $o = $current_state;
1380     $current_state = "DEBUG";
1381
1382     my $line =  "#" x 78;
1383     print STDERR "\n\n\n";
1384     print STDERR ("#" x 78) . "\n";
1385     print STDERR blurb() . "failed to get an image.  Full audit log:\n";
1386     print STDERR "\n";
1387     showlog();
1388     print STDERR ("-" x 78) . "\n";
1389     print STDERR "\n\n";
1390
1391     $current_state = $o;
1392   }
1393   $image_succeeded = 0;
1394 }
1395
1396
1397
1398 sub stats_of {
1399   my ($name) = @_;
1400   my $i = $stats_successes{$name};
1401   my $j = $stats_attempts{$name};
1402   $i = 0 unless $i;
1403   $j = 0 unless $j;
1404   return "" . ($j ? int($i * 100 / $j) : "0") . "%";
1405 }
1406
1407
1408 my $current_start_time = 0;
1409
1410 sub start_timer {
1411   my ($name) = @_;
1412   $current_start_time = time;
1413
1414   if (defined($stats_attempts{$name})) {
1415     $stats_attempts{$name}++;
1416   } else {
1417     $stats_attempts{$name} = 1;
1418   }
1419   if (!defined($stats_elapsed{$name})) {
1420     $stats_elapsed{$name} = 0;
1421   }
1422 }
1423
1424 sub stop_timer {
1425   my ($name, $success) = @_;
1426   $stats_elapsed{$name} += time - $current_start_time;
1427 }
1428
1429
1430 my $last_report_time = 0;
1431 sub report_performance {
1432
1433   return unless $verbose_warnings;
1434
1435   my $now = time;
1436   return unless ($now >= $last_report_time + $report_performance_interval);
1437   my $ot = $last_report_time;
1438   $last_report_time = $now;
1439
1440   return if ($ot == 0);
1441
1442   my $blurb = "$progname: " . timestr();
1443
1444   print STDERR "\n";
1445   print STDERR "${blurb}Current standings:\n";
1446
1447   foreach my $name (sort keys (%stats_attempts)) {
1448     my $try = $stats_attempts{$name};
1449     my $suc = $stats_successes{$name} || 0;
1450     my $pct = int($suc * 100 / $try);
1451     my $secs = $stats_elapsed{$name};
1452     my $secs_link = int($secs / $try);
1453     print STDERR sprintf ("$blurb   %-12s %4s (%d/%d);\t %2d secs/link\n",
1454                           "$name:", "$pct%", $suc, $try, $secs_link);
1455   }
1456 }
1457
1458
1459
1460 my $max_recent_images = 400;
1461 my $max_recent_sites  = 20;
1462 my @recent_images = ();
1463 my @recent_sites = ();
1464
1465 sub save_recent_url {
1466   my ($url, $base) = @_;
1467
1468   return unless ($verbose_warnings);
1469
1470   $_ = $url;
1471   my ($site) = m@^http://([^ \t\n\r/:]+)@;
1472
1473   my $done = 0;
1474   foreach (@recent_images) {
1475     if ($_ eq $url) {
1476       print STDERR blurb() . "WARNING: recently-duplicated image: $url" .
1477         " (on $base via $last_search)\n";
1478       $done = 1;
1479       last;
1480     }
1481   }
1482
1483   # suppress "duplicate site" warning via %warningless_sites.
1484   #
1485   if ($warningless_sites{$site}) {
1486     $done = 1;
1487   } elsif ($site =~ m@([^.]+\.[^.]+\.[^.]+)$@ &&
1488            $warningless_sites{$1}) {
1489     $done = 1;
1490   } elsif ($site =~ m@([^.]+\.[^.]+)$@ &&
1491            $warningless_sites{$1}) {
1492     $done = 1;
1493   }
1494
1495   if (!$done) {
1496     foreach (@recent_sites) {
1497       if ($_ eq $site) {
1498         print STDERR blurb() . "WARNING: recently-duplicated site: $site" .
1499         " ($url on $base via $last_search)\n";
1500         last;
1501       }
1502     }
1503   }
1504
1505   push @recent_images, $url;
1506   push @recent_sites,  $site;
1507   shift @recent_images if ($#recent_images >= $max_recent_images);
1508   shift @recent_sites  if ($#recent_sites  >= $max_recent_sites);
1509 }
1510
1511
1512 \f
1513 ##############################################################################
1514 #
1515 # other utilities
1516 #
1517 ##############################################################################
1518
1519 # Does %-decoding.
1520 #
1521 sub url_decode {
1522   ($_) = @_;
1523   tr/+/ /;
1524   s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
1525   return $_;
1526 }
1527
1528
1529 # Given the raw body of a GIF document, returns the dimensions of the image.
1530 #
1531 sub gif_size {
1532   my ($body) = @_;
1533   my $type = substr($body, 0, 6);
1534   my $s;
1535   return () unless ($type =~ /GIF8[7,9]a/);
1536   $s = substr ($body, 6, 10);
1537   my ($a,$b,$c,$d) = unpack ("C"x4, $s);
1538   return (($b<<8|$a), ($d<<8|$c));
1539 }
1540
1541 # Given the raw body of a JPEG document, returns the dimensions of the image.
1542 #
1543 sub jpeg_size {
1544   my ($body) = @_;
1545   my $i = 0;
1546   my $L = length($body);
1547
1548   my $c1 = substr($body, $i, 1); $i++;
1549   my $c2 = substr($body, $i, 1); $i++;
1550   return () unless (ord($c1) == 0xFF && ord($c2) == 0xD8);
1551
1552   my $ch = "0";
1553   while (ord($ch) != 0xDA && $i < $L) {
1554     # Find next marker, beginning with 0xFF.
1555     while (ord($ch) != 0xFF) {
1556       $ch = substr($body, $i, 1); $i++;
1557     }
1558     # markers can be padded with any number of 0xFF.
1559     while (ord($ch) == 0xFF) {
1560       $ch = substr($body, $i, 1); $i++;
1561     }
1562
1563     # $ch contains the value of the marker.
1564     my $marker = ord($ch);
1565
1566     if (($marker >= 0xC0) &&
1567         ($marker <= 0xCF) &&
1568         ($marker != 0xC4) &&
1569         ($marker != 0xCC)) {  # it's a SOFn marker
1570       $i += 3;
1571       my $s = substr($body, $i, 4); $i += 4;
1572       my ($a,$b,$c,$d) = unpack("C"x4, $s);
1573       return (($c<<8|$d), ($a<<8|$b));
1574
1575     } else {
1576       # We must skip variables, since FFs in variable names aren't
1577       # valid JPEG markers.
1578       my $s = substr($body, $i, 2); $i += 2;
1579       my ($c1, $c2) = unpack ("C"x2, $s);
1580       my $length = ($c1 << 8) | $c2;
1581       return () if ($length < 2);
1582       $i += $length-2;
1583     }
1584   }
1585   return ();
1586 }
1587
1588 # Given the raw body of a GIF or JPEG document, returns the dimensions of
1589 # the image.
1590 #
1591 sub image_size {
1592   my ($body) = @_;
1593   my ($w, $h) = gif_size ($body);
1594   if ($w && $h) { return ($w, $h); }
1595   return jpeg_size ($body);
1596 }
1597
1598
1599 # returns the full path of the named program, or undef.
1600 #
1601 sub which {
1602   my ($prog) = @_;
1603   foreach (split (/:/, $ENV{PATH})) {
1604     if (-x "$_/$prog") {
1605       return $prog;
1606     }
1607   }
1608   return undef;
1609 }
1610
1611
1612 # Like rand(), but chooses numbers with a bell curve distribution.
1613 sub bellrand {
1614   ($_) = @_;
1615   $_ = 1.0 unless defined($_);
1616   $_ /= 3.0;
1617   return (rand($_) + rand($_) + rand($_));
1618 }
1619
1620
1621 ##############################################################################
1622 #
1623 # Generating a list of urls only
1624 #
1625 ##############################################################################
1626
1627 sub url_only_output {
1628   do {
1629     my ($base, $img) = pick_image;
1630     if ($img) {
1631       $base =~ s/ /%20/g;
1632       $img  =~ s/ /%20/g;
1633       print "$img $base\n";
1634     }
1635   } while (1);
1636 }
1637
1638 ##############################################################################
1639 #
1640 # Running as an xscreensaver module
1641 #
1642 ##############################################################################
1643
1644 my $image_ppm   = ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp") . "/webcollage." . $$;
1645 my $image_tmp1  = $image_ppm . "-1";
1646 my $image_tmp2  = $image_ppm . "-2";
1647
1648 my $filter_cmd = undef;
1649 my $post_filter_cmd = undef;
1650 my $background = undef;
1651
1652 my $img_width;            # size of the image being generated.
1653 my $img_height;
1654
1655 my $delay = 0;
1656
1657
1658 sub x_cleanup {
1659   my ($sig) = @_;
1660   print STDERR blurb() . "caught signal $sig.\n" if ($verbose_exec);
1661   unlink $image_ppm, $image_tmp1, $image_tmp2;
1662   exit 1;
1663 }
1664
1665
1666 # Like system, but prints status about exit codes, and kills this process
1667 # with whatever signal killed the sub-process, if any.
1668 #
1669 sub nontrapping_system {
1670   $! = 0;
1671
1672   $_ = join(" ", @_);
1673   s/\"[^\"]+\"/\"...\"/g;
1674
1675   LOG ($verbose_exec, "executing \"$_\"");
1676
1677   my $rc = system @_;
1678
1679   if ($rc == 0) {
1680     LOG ($verbose_exec, "subproc exited normally.");
1681   } elsif (($rc & 0xff) == 0) {
1682     $rc >>= 8;
1683     LOG ($verbose_exec, "subproc exited with status $rc.");
1684   } else {
1685     if ($rc & 0x80) {
1686       LOG ($verbose_exec, "subproc dumped core.");
1687       $rc &= ~0x80;
1688     }
1689     LOG ($verbose_exec, "subproc died with signal $rc.");
1690     # die that way ourselves.
1691     kill $rc, $$;
1692   }
1693
1694   return $rc;
1695 }
1696
1697
1698 # Given the URL of a GIF or JPEG image, and the body of that image, writes a
1699 # PPM to the given output file.  Returns the width/height of the image if
1700 # successful.
1701 #
1702 sub image_to_pnm {
1703   my ($url, $body, $output) = @_;
1704   my ($cmd, $cmd2, $w, $h);
1705
1706   if ((@_ = gif_size ($body))) {
1707     ($w, $h) = @_;
1708     $cmd = "giftopnm";
1709   } elsif ((@_ = jpeg_size ($body))) {
1710     ($w, $h) = @_;
1711     $cmd = "djpeg";
1712   } else {
1713     LOG (($verbose_pbm || $verbose_load),
1714          "not a GIF or JPG" .
1715          (($body =~ m@<(base|html|head|body|script|table|a href)>@i)
1716           ? " (looks like HTML)" : "") .
1717          ": $url");
1718     $suppress_audit = 1;
1719     return ();
1720   }
1721
1722   $cmd2 = "exec $cmd";        # yes, this really is necessary.  if we don't
1723                               # do this, the process doesn't die properly.
1724   if (!$verbose_pbm) {
1725     #
1726     # We get a "giftopnm: got a 'Application Extension' extension"
1727     # warning any time it's an animgif.
1728     #
1729     # Note that "giftopnm: EOF / read error on image data" is not
1730     # always a fatal error -- sometimes the image looks fine anyway.
1731     #
1732     $cmd2 .= " 2>/dev/null";
1733   }
1734
1735   # There exist corrupted GIF and JPEG files that can make giftopnm and
1736   # djpeg lose their minds and go into a loop.  So this gives those programs
1737   # a small timeout -- if they don't complete in time, kill them.
1738   #
1739   my $pid;
1740   @_ = eval {
1741     my $timed_out;
1742
1743     local $SIG{ALRM}  = sub {
1744       LOG ($verbose_pbm,
1745            "timed out ($cvt_timeout) for $cmd on \"$url\" in pid $pid");
1746       kill ('TERM', $pid) if ($pid);
1747       $timed_out = 1;
1748       $body = undef;
1749     };
1750
1751     if (($pid = open(PIPE, "| $cmd2 > $output"))) {
1752       $timed_out = 0;
1753       alarm $cvt_timeout;
1754       print PIPE $body;
1755       $body = undef;
1756       close PIPE;
1757
1758       LOG ($verbose_exec, "awaiting $pid");
1759       waitpid ($pid, 0);
1760       LOG ($verbose_exec, "$pid completed");
1761
1762       my $size = (stat($output))[7];
1763       $size = -1 unless defined($size);
1764       if ($size < 5) {
1765         LOG ($verbose_pbm, "$cmd on ${w}x$h \"$url\" failed ($size bytes)");
1766         return ();
1767       }
1768
1769       LOG ($verbose_pbm, "created ${w}x$h $output ($cmd)");
1770       return ($w, $h);
1771     } else {
1772       print STDERR blurb() . "$cmd failed: $!\n";
1773       return ();
1774     }
1775   };
1776   die if ($@ && $@ ne "alarm\n");       # propagate errors
1777   if ($@) {
1778     # timed out
1779     $body = undef;
1780     return ();
1781   } else {
1782     # didn't
1783     alarm 0;
1784     $body = undef;
1785     return @_;
1786   }
1787 }
1788
1789 sub pick_root_displayer {
1790   my @names = ();
1791
1792   foreach my $cmd (@root_displayers) {
1793     $_ = $cmd;
1794     my ($name) = m/^([^ ]+)/;
1795     push @names, "\"$name\"";
1796     LOG ($verbose_exec, "looking for $name...");
1797     foreach my $dir (split (/:/, $ENV{PATH})) {
1798       LOG ($verbose_exec, "  checking $dir/$name");
1799       return $cmd if (-x "$dir/$name");
1800     }
1801   }
1802
1803   $names[$#names] = "or " . $names[$#names];
1804   error "none of: " . join (", ", @names) . " were found on \$PATH.";
1805 }
1806
1807
1808 my $ppm_to_root_window_cmd = undef;
1809
1810
1811 sub x_or_pbm_output {
1812
1813   # make sure the various programs we execute exist, right up front.
1814   #
1815   foreach ("ppmmake", "giftopnm", "djpeg", "pnmpaste", "pnmscale", "pnmcut") {
1816     which ($_) || error "$_ not found on \$PATH.";
1817   }
1818
1819   # find a root-window displayer program.
1820   #
1821   $ppm_to_root_window_cmd = pick_root_displayer();
1822
1823
1824   $SIG{HUP}  = \&x_cleanup;
1825   $SIG{INT}  = \&x_cleanup;
1826   $SIG{QUIT} = \&x_cleanup;
1827   $SIG{ABRT} = \&x_cleanup;
1828   $SIG{KILL} = \&x_cleanup;
1829   $SIG{TERM} = \&x_cleanup;
1830
1831   # Need this so that if giftopnm dies, we don't die.
1832   $SIG{PIPE} = 'IGNORE';
1833
1834   if (!$img_width || !$img_height) {
1835     $_ = "xdpyinfo";
1836     which ($_) || error "$_ not found on \$PATH.";
1837     $_ = `$_`;
1838     ($img_width, $img_height) = m/dimensions: *(\d+)x(\d+) /;
1839     if (!defined($img_height)) {
1840       error "xdpyinfo failed.";
1841     }
1842   }
1843
1844   my $bgcolor = "#000000";
1845   my $bgimage = undef;
1846
1847   if ($background) {
1848     if ($background =~ m/^\#[0-9a-f]+$/i) {
1849       $bgcolor = $background;
1850
1851     } elsif (-r $background) {
1852       $bgimage = $background;
1853
1854     } elsif (! $background =~ m@^[-a-z0-9 ]+$@i) {
1855       error "not a color or readable file: $background";
1856
1857     } else {
1858       # default to assuming it's a color
1859       $bgcolor = $background;
1860     }
1861   }
1862
1863   # Create the sold-colored base image.
1864   #
1865   $_ = "ppmmake '$bgcolor' $img_width $img_height";
1866   LOG ($verbose_pbm, "creating base image: $_");
1867   nontrapping_system "$_ > $image_ppm";
1868
1869   # Paste the default background image in the middle of it.
1870   #
1871   if ($bgimage) {
1872     my ($iw, $ih);
1873
1874     my $body = "";
1875     local *IMG;
1876     open(IMG, "<$bgimage") || error "couldn't open $bgimage: $!";
1877     my $cmd;
1878     while (<IMG>) { $body .= $_; }
1879     close (IMG);
1880
1881     if ((@_ = gif_size ($body))) {
1882       ($iw, $ih) = @_;
1883       $cmd = "giftopnm |";
1884
1885     } elsif ((@_ = jpeg_size ($body))) {
1886       ($iw, $ih) = @_;
1887       $cmd = "djpeg |";
1888
1889     } elsif ($body =~ m/^P\d\n(\d+) (\d+)\n/) {
1890       $iw = $1;
1891       $ih = $2;
1892       $cmd = "";
1893
1894     } else {
1895       error "$bgimage is not a GIF, JPEG, or PPM.";
1896     }
1897
1898     my $x = int (($img_width  - $iw) / 2);
1899     my $y = int (($img_height - $ih) / 2);
1900     LOG ($verbose_pbm,
1901          "pasting $bgimage (${iw}x$ih) into base image at $x,$y");
1902
1903     $cmd .= "pnmpaste - $x $y $image_ppm > $image_tmp1";
1904     open (IMG, "| $cmd") || error "running $cmd: $!";
1905     print IMG $body;
1906     $body = undef;
1907     close (IMG);
1908     LOG ($verbose_exec, "subproc exited normally.");
1909     rename ($image_tmp1, $image_ppm) ||
1910       error "renaming $image_tmp1 to $image_ppm: $!";
1911   }
1912
1913   clearlog();
1914
1915   while (1) {
1916     my ($base, $img) = pick_image();
1917     my $source = $current_state;
1918     $current_state = "loadimage";
1919     if ($img) {
1920       my ($headers, $body) = get_document ($img, $base);
1921       if ($body) {
1922         paste_image ($base, $img, $body, $source);
1923         $body = undef;
1924       }
1925     }
1926     $current_state = "idle";
1927     $load_method = "none";
1928
1929     unlink $image_tmp1, $image_tmp2;
1930     sleep $delay;
1931   }
1932 }
1933
1934 sub paste_image {
1935   my ($base, $img, $body, $source) = @_;
1936
1937   $current_state = "paste";
1938
1939   $suppress_audit = 0;
1940
1941   LOG ($verbose_pbm, "got $img (" . length($body) . ")");
1942
1943   my ($iw, $ih) = image_to_pnm ($img, $body, $image_tmp1);
1944   $body = undef;
1945   if (!$iw || !$ih) {
1946     LOG ($verbose_pbm, "unable to make PBM from $img");
1947     return 0;
1948   }
1949
1950   record_success ($load_method, $img, $base);
1951
1952
1953   my $ow = $iw;  # used only for error messages
1954   my $oh = $ih;
1955
1956   # don't just tack this onto the front of the pipeline -- we want it to
1957   # be able to change the size of the input image.
1958   #
1959   if ($filter_cmd) {
1960     LOG ($verbose_pbm, "running $filter_cmd");
1961
1962     my $rc = nontrapping_system "($filter_cmd) < $image_tmp1 >$image_tmp2";
1963     if ($rc != 0) {
1964       LOG(($verbose_pbm || $verbose_load), "failed command: \"$filter_cmd\"");
1965       LOG(($verbose_pbm || $verbose_load), "failed URL: \"$img\" (${ow}x$oh)");
1966       return;
1967     }
1968     rename ($image_tmp2, $image_tmp1);
1969
1970     # re-get the width/height in case the filter resized it.
1971     local *IMG;
1972     open(IMG, "<$image_tmp1") || return 0;
1973     $_ = <IMG>;
1974     $_ = <IMG>;
1975     ($iw, $ih) = m/^(\d+) (\d+)$/;
1976     close (IMG);
1977     return 0 unless ($iw && $ih);
1978   }
1979
1980   my $target_w = $img_width;
1981   my $target_h = $img_height;
1982
1983   my $cmd = "";
1984
1985
1986   # Usually scale the image to fit on the screen -- but sometimes scale it
1987   # to fit on half or a quarter of the screen.  Note that we don't merely
1988   # scale it to fit, we instead cut it in half until it fits -- that should
1989   # give a wider distribution of sizes.
1990   #
1991   if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; }
1992   if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; }
1993
1994   if ($iw > $target_w || $ih > $target_h) {
1995     while ($iw > $target_w ||
1996            $ih > $target_h) {
1997       $iw = int($iw / 2);
1998       $ih = int($ih / 2);
1999     }
2000     if ($iw <= 10 || $ih <= 10) {
2001       LOG ($verbose_pbm, "scaling to ${iw}x$ih would have been bogus.");
2002       return 0;
2003     }
2004
2005     LOG ($verbose_pbm, "scaling to ${iw}x$ih");
2006
2007     $cmd .= " | pnmscale -xsize $iw -ysize $ih";
2008   }
2009
2010
2011   my $src = $image_tmp1;
2012
2013   my $crop_x = 0;     # the sub-rectangle of the image
2014   my $crop_y = 0;     # that we will actually paste.
2015   my $crop_w = $iw;
2016   my $crop_h = $ih;
2017
2018   # The chance that we will randomly crop out a section of an image starts
2019   # out fairly low, but goes up for images that are very large, or images
2020   # that have ratios that make them look like banners (we try to avoid
2021   # banner images entirely, but they slip through when the IMG tags didn't
2022   # have WIDTH and HEIGHT specified.)
2023   #
2024   my $crop_chance = 0.2;
2025   if ($iw > $img_width * 0.4 || $ih > $img_height * 0.4) {
2026     $crop_chance += 0.2;
2027   }
2028   if ($iw > $img_width * 0.7 || $ih > $img_height * 0.7) {
2029     $crop_chance += 0.2;
2030   }
2031   if ($min_ratio && ($iw * $min_ratio) > $ih) {
2032     $crop_chance += 0.7;
2033   }
2034
2035   if ($crop_chance > 0.1) {
2036     LOG ($verbose_pbm, "crop chance: $crop_chance");
2037   }
2038
2039   if (rand() < $crop_chance) {
2040
2041     my $ow = $crop_w;
2042     my $oh = $crop_h;
2043
2044     if ($crop_w > $min_width) {
2045       # if it's a banner, select the width linearly.
2046       # otherwise, select a bell.
2047       my $r = (($min_ratio && ($iw * $min_ratio) > $ih)
2048                ? rand()
2049                : bellrand());
2050       $crop_w = $min_width + int ($r * ($crop_w - $min_width));
2051       $crop_x = int (rand() * ($ow - $crop_w));
2052     }
2053     if ($crop_h > $min_height) {
2054       # height always selects as a bell.
2055       $crop_h = $min_height + int (bellrand() * ($crop_h - $min_height));
2056       $crop_y = int (rand() * ($oh - $crop_h));
2057     }
2058
2059     if ($crop_x != 0   || $crop_y != 0 ||
2060         $crop_w != $iw || $crop_h != $ih) {
2061       LOG ($verbose_pbm,
2062            "randomly cropping to ${crop_w}x$crop_h \@ $crop_x,$crop_y");
2063     }
2064   }
2065
2066   # Where the image should logically land -- this might be negative.
2067   #
2068   my $x = int((rand() * ($img_width  + $crop_w/2)) - $crop_w*3/4);
2069   my $y = int((rand() * ($img_height + $crop_h/2)) - $crop_h*3/4);
2070
2071   # if we have chosen to paste the image outside of the rectangle of the
2072   # screen, then we need to crop it.
2073   #
2074   if ($x < 0 ||
2075       $y < 0 ||
2076       $x + $crop_w > $img_width ||
2077       $y + $crop_h > $img_height) {
2078
2079     LOG ($verbose_pbm,
2080          "cropping for effective paste of ${crop_w}x$crop_h \@ $x,$y");
2081
2082     if ($x < 0) { $crop_x -= $x; $crop_w += $x; $x = 0; }
2083     if ($y < 0) { $crop_y -= $y; $crop_h += $y; $y = 0; }
2084
2085     if ($x + $crop_w >= $img_width)  { $crop_w = $img_width  - $x - 1; }
2086     if ($y + $crop_h >= $img_height) { $crop_h = $img_height - $y - 1; }
2087   }
2088
2089   # If any cropping needs to happen, add pnmcut.
2090   #
2091   if ($crop_x != 0   || $crop_y != 0 ||
2092         $crop_w != $iw || $crop_h != $ih) {
2093     $iw = $crop_w;
2094     $ih = $crop_h;
2095     $cmd .= " | pnmcut $crop_x $crop_y $iw $ih";
2096     LOG ($verbose_pbm, "cropping to ${crop_w}x$crop_h \@ $crop_x,$crop_y");
2097   }
2098
2099   LOG ($verbose_pbm, "pasting ${iw}x$ih \@ $x,$y in $image_ppm");
2100
2101   $cmd .= " | pnmpaste - $x $y $image_ppm";
2102
2103   $cmd =~ s@^ *\| *@@;
2104
2105   $_ = "($cmd)";
2106   $_ .= " < $image_tmp1 > $image_tmp2";
2107
2108   if ($verbose_pbm) {
2109     $_ = "($_) 2>&1 | sed s'/^/" . blurb() . "/'";
2110   } else {
2111     $_ .= " 2> /dev/null";
2112   }
2113   my $rc = nontrapping_system ($_);
2114
2115   if ($rc != 0) {
2116     LOG (($verbose_pbm || $verbose_load), "failed command: \"$cmd\"");
2117     LOG (($verbose_pbm || $verbose_load), "failed URL: \"$img\" (${ow}x$oh)");
2118     return;
2119   }
2120
2121   rename ($image_tmp2, $image_ppm) || return;
2122
2123   my $target = "$image_ppm";
2124
2125   # don't just tack this onto the end of the pipeline -- we don't want it
2126   # to end up in $image_ppm, because we don't want the results to be
2127   # cumulative.
2128   #
2129   if ($post_filter_cmd) {
2130     $target = $image_tmp1;
2131     $rc = nontrapping_system "($post_filter_cmd) < $image_ppm > $target";
2132     if ($rc != 0) {
2133       LOG ($verbose_pbm, "filter failed: \"$post_filter_cmd\"\n");
2134       return;
2135     }
2136   }
2137
2138   if (!$no_output_p) {
2139     my $tsize = (stat($target))[7];
2140     if ($tsize > 200) {
2141       $cmd = "$ppm_to_root_window_cmd $target";
2142
2143       # xv seems to hate being killed.  it tends to forget to clean
2144       # up after itself, and leaves windows around and colors allocated.
2145       # I had this same problem with vidwhacker, and I'm not entirely
2146       # sure what I did to fix it.  But, let's try this: launch xv
2147       # in the background, so that killing this process doesn't kill it.
2148       # it will die of its own accord soon enough.  So this means we
2149       # start pumping bits to the root window in parallel with starting
2150       # the next network retrieval, which is probably a better thing
2151       # to do anyway.
2152       #
2153       $cmd .= " &";
2154
2155       $rc = nontrapping_system ($cmd);
2156
2157       if ($rc != 0) {
2158         LOG (($verbose_pbm || $verbose_load), "display failed: \"$cmd\"");
2159         return;
2160       }
2161
2162     } else {
2163       LOG ($verbose_pbm, "$target size is $tsize");
2164     }
2165   }
2166
2167   $source .= "-" . stats_of($source);
2168   print STDOUT "image: ${iw}x${ih} @ $x,$y $base $source\n"
2169     if ($verbose_imgmap);
2170
2171   clearlog();
2172
2173   return 1;
2174 }
2175
2176
2177 sub main {
2178   $| = 1;
2179   srand(time ^ $$);
2180
2181   my $verbose = 0;
2182   my $dict;
2183
2184   $current_state = "init";
2185   $load_method = "none";
2186
2187   my $root_p = 0;
2188
2189   # historical suckage: the environment variable name is lower case.
2190   $http_proxy = $ENV{http_proxy} || $ENV{HTTP_PROXY};
2191
2192   while ($_ = $ARGV[0]) {
2193     shift @ARGV;
2194     if ($_ eq "-display" ||
2195         $_ eq "-displ" ||
2196         $_ eq "-disp" ||
2197         $_ eq "-dis" ||
2198         $_ eq "-dpy" ||
2199         $_ eq "-d") {
2200       $ENV{DISPLAY} = shift @ARGV;
2201     } elsif ($_ eq "-root") {
2202       $root_p = 1;
2203     } elsif ($_ eq "-no-output") {
2204       $no_output_p = 1;
2205     } elsif ($_ eq "-urls-only") {
2206       $urls_only_p = 1;
2207       $no_output_p = 1;
2208     } elsif ($_ eq "-verbose") {
2209       $verbose++;
2210     } elsif (m/^-v+$/) {
2211       $verbose += length($_)-1;
2212     } elsif ($_ eq "-delay") {
2213       $delay = shift @ARGV;
2214     } elsif ($_ eq "-timeout") {
2215       $http_timeout = shift @ARGV;
2216     } elsif ($_ eq "-filter") {
2217       $filter_cmd = shift @ARGV;
2218     } elsif ($_ eq "-filter2") {
2219       $post_filter_cmd = shift @ARGV;
2220     } elsif ($_ eq "-background" || $_ eq "-bg") {
2221       $background = shift @ARGV;
2222     } elsif ($_ eq "-size") {
2223       $_ = shift @ARGV;
2224       if (m@^(\d+)x(\d+)$@) {
2225         $img_width = $1;
2226         $img_height = $2;
2227       } else {
2228         error "argument to \"-size\" must be of the form \"640x400\"";
2229       }
2230     } elsif ($_ eq "-proxy" || $_ eq "-http-proxy") {
2231       $http_proxy = shift @ARGV;
2232     } elsif ($_ eq "-dictionary" || $_ eq "-dict") {
2233       $dict = shift @ARGV;
2234     } else {
2235       print STDERR "$copyright\nusage: $progname [-root]" .
2236                  " [-display dpy] [-root] [-verbose] [-timeout secs]\n" .
2237                  "\t\t  [-delay secs] [-filter cmd] [-filter2 cmd]\n" .
2238                  "\t\t  [-dictionary dictionary-file]\n" .
2239                  "\t\t  [-http-proxy host[:port]]\n";
2240       exit 1;
2241     }
2242   }
2243
2244   if ($http_proxy && $http_proxy eq "") {
2245     $http_proxy = undef;
2246   }
2247   if ($http_proxy && $http_proxy =~ m@^http://([^/]*)/?$@ ) {
2248     # historical suckage: allow "http://host:port" as well as "host:port".
2249     $http_proxy = $1;
2250   }
2251
2252   if (!$root_p && !$no_output_p) {
2253     print STDERR $copyright;
2254     error "the -root argument is mandatory (for now.)";
2255   }
2256
2257   if (!$no_output_p && !$ENV{DISPLAY}) {
2258     error "\$DISPLAY is not set.";
2259   }
2260
2261
2262   if ($verbose == 1) {
2263     $verbose_imgmap   = 1;
2264     $verbose_warnings = 1;
2265
2266   } elsif ($verbose == 2) {
2267     $verbose_imgmap   = 1;
2268     $verbose_warnings = 1;
2269     $verbose_load     = 1;
2270
2271   } elsif ($verbose == 3) {
2272     $verbose_imgmap   = 1;
2273     $verbose_warnings = 1;
2274     $verbose_load     = 1;
2275     $verbose_filter   = 1;
2276
2277   } elsif ($verbose == 4) {
2278     $verbose_imgmap   = 1;
2279     $verbose_warnings = 1;
2280     $verbose_load     = 1;
2281     $verbose_filter   = 1;
2282     $verbose_net      = 1;
2283
2284   } elsif ($verbose == 5) {
2285     $verbose_imgmap   = 1;
2286     $verbose_warnings = 1;
2287     $verbose_load     = 1;
2288     $verbose_filter   = 1;
2289     $verbose_net      = 1;
2290     $verbose_pbm      = 1;
2291
2292   } elsif ($verbose == 6) {
2293     $verbose_imgmap   = 1;
2294     $verbose_warnings = 1;
2295     $verbose_load     = 1;
2296     $verbose_filter   = 1;
2297     $verbose_net      = 1;
2298     $verbose_pbm      = 1;
2299     $verbose_http     = 1;
2300
2301   } elsif ($verbose >= 7) {
2302     $verbose_imgmap   = 1;
2303     $verbose_warnings = 1;
2304     $verbose_load     = 1;
2305     $verbose_filter   = 1;
2306     $verbose_net      = 1;
2307     $verbose_pbm      = 1;
2308     $verbose_http     = 1;
2309     $verbose_exec     = 1;
2310   }
2311
2312   if ($dict) {
2313     error ("$dict does not exist") unless (-f $dict);
2314     $wordlist = $dict;
2315   } else {
2316     pick_dictionary();
2317   }
2318
2319   if ($urls_only_p) {
2320     url_only_output;
2321   } else {
2322     x_or_pbm_output;
2323   }
2324 }
2325
2326 main;
2327 exit (0);