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

   1 #!/usr/bin/perl -w
   2 #
   3 # webcollage, Copyright (c) 1999-2005 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
  16 # To run this as a display mode with xscreensaver, add this to `programs':
  17 #
  18 #     webcollage -root
  19 #     webcollage -root -filter 'vidwhacker -stdin -stdout'
  20 #
  21 #
  22 # You can see this in action at http://www.jwz.org/webcollage/ --
  23 # it auto-reloads about once a minute.  To make a page similar to
  24 # that on your own system, do this:
  25 #
  26 #     webcollage -size '800x600' -imagemap $HOME/www/webcollage/index
  27 #
  28 #
  29 # If you have the "driftnet" program installed, webcollage can display a
  30 # collage of images sniffed off your local ethernet, instead of pulled out
  31 # of search engines: in that way, your screensaver can display the images
  32 # that your co-workers are downloading!
  33 #
  34 # Driftnet is available here: http://www.ex-parrot.com/~chris/driftnet/
  35 # Use it like so:
  36 #
  37 #     webcollage -root -driftnet
  38 #
  39 # Driftnet is the Unix implementation of the MacOS "EtherPEG" program.
  40
  41
  42 require 5;
  43 use strict;
  44
  45 # We can't "use diagnostics" here, because that library malfunctions if
  46 # you signal and catch alarms: it says "Uncaught exception from user code"
  47 # and exits, even though I damned well AM catching it!
  48 #use diagnostics;
  49
  50
  51 use Socket;
  52 require Time::Local;
  53 require POSIX;
  54 use Fcntl ':flock'; # import LOCK_* constants
  55 use POSIX qw(strftime);
  56
  57 use bytes;  # Larry can take Unicode and shove it up his ass sideways.
  58             # Perl 5.8.0 causes us to start getting incomprehensible
  59             # errors about UTF-8 all over the place without this.
  60
  61
  62 my $progname = $0; $progname =~ s@.*/@@g;
  63 my $version = q{ $Revision: 1.127 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
  64 my $copyright = "WebCollage $version, Copyright (c) 1999-2005" .
  65     " Jamie Zawinski <jwz\@jwz.org>\n" .
  66     "            http://www.jwz.org/webcollage/\n";
  67
  68
  69
  70 my @search_methods = (  58, "altavista",    \&pick_from_alta_vista_random_link,
  71                         11, "livejournal",  \&pick_from_livejournal_images,
  72                          7, "yahoorand",    \&pick_from_yahoo_random_link,
  73                         10, "googlephotos", \&pick_from_google_image_photos,
  74                          6, "googleimgs",   \&pick_from_google_images,
  75                          3, "googlenums",   \&pick_from_google_image_numbers,
  76                          5, "flickr",       \&pick_from_flickr,
  77
  78                      # In Apr 2002, Google asked me to stop searching them.
  79                      # I asked them to add a "random link" url.  They said
  80                      # "that would be easy, we'll think about it" and then
  81                      # never wrote back.  Booo Google!  Booooo!  So, screw
  82                      # those turkeys, I've turned Google searching back on.
  83                      # I'm sure they can take it.  (Jan 2005.)
  84
  85                      # Jan 2005: Yahoo fucked up their search form so that
  86                      # it's no longer possible to do "or" searches on news
  87                      # images, so we rarely get any hits there any more.
  88                      #
  89                      #  0, "yahoonews",   \&pick_from_yahoo_news_text,
  90
  91                      # Dec 2004: the ircimages guy's server can't take the
  92                      # heat, so he started banning the webcollage user agent.
  93                      # I tried to convince him to add a lighter-weight page to
  94                      # support webcollage better, but he doesn't care.
  95                      #
  96                      #  0, "ircimages", \&pick_from_ircimages,
  97
  98                      # Dec 2002: Alta Vista has a new "random link" URL now.
  99                      # They added it specifically to better support webcollage!
 100                      # That was super cool of them.  This is how we used to do
 101                      # it, before:
 102                      #
 103                      #  0, "avimages", \&pick_from_alta_vista_images,
 104                      #  0, "avtext",   \&pick_from_alta_vista_text,
 105
 106                      # This broke in 2004.  Eh, Lycos sucks anyway.
 107                      #
 108                      #   0, "lycos",      \&pick_from_lycos_text,
 109
 110                      # This broke in 2003, I think.  I suspect Hotbot is
 111                      # actually the same search engine data as Lycos.
 112                      #
 113                      #  0, "hotbot",     \&pick_from_hotbot_text,
 114                       );
 115
 116 # programs we can use to write to the root window (tried in ascending order.)
 117 #
 118 my @root_displayers = (
 119   "xscreensaver-getimage -root -file",
 120   "chbg       -once -xscreensaver -max_size 100",
 121   "xv         -root -quit -viewonly +noresetroot -quick24 -rmode 5" .
 122   "           -rfg black -rbg black",
 123   "xli        -quiet -onroot -center -border black",
 124   "xloadimage -quiet -onroot -center -border black",
 125
 126 # this lame program wasn't built with vroot.h:
 127 # "xsri       -scale -keep-aspect -center-horizontal -center-vertical",
 128 );
 129
 130
 131 # Some sites need cookies to work properly.   These are they.
 132 #
 133 my %cookies = (
 134   "www.altavista.com"  =>  "AV_ALL=1",   # request uncensored searches
 135   "web.altavista.com"  =>  "AV_ALL=1",
 136
 137                                          # log in as "cipherpunk"
 138   "www.nytimes.com"    =>  'NYT-S=18cHMIlJOn2Y1bu5xvEG3Ufuk6E1oJ.' .
 139                            'FMxWaQV0igaB5Yi/Q/guDnLeoL.pe7i1oakSb' .
 140                            '/VqfdUdb2Uo27Vzt1jmPn3cpYRlTw9',
 141
 142   "ircimages.com"      =>  'disclaimer=1',
 143 );
 144
 145
 146 # If this is set, it's a helper program to use for pasting images together:
 147 # this is a lot faster and more efficient than using PPM pipelines, which is
 148 # what we do if this program doesn't exist.  (We check for "webcollage-helper"
 149 # on $PATH at startup, and set this variable appropriately.)
 150 #
 151 my $webcollage_helper = undef;
 152
 153
 154 # If we have the webcollage-helper program, then it will paste the images
 155 # together with transparency!  0.0 is invisible, 1.0 is totally opaque.
 156 #
 157 my $opacity = 0.85;
 158
 159
 160 # Some sites have  managed to poison the search engines.  These are they.
 161 # (We auto-detect sites that have poisoned the search engines via excessive
 162 # keywords or dictionary words,  but these are ones that slip through
 163 # anyway.)
 164 #
 165 # This can contain full host names, or 2 or 3 component domains.
 166 #
 167 my %poisoners = (
 168   "die.net"                 => 1,  # 'l33t h4ck3r d00dz.
 169   "genforum.genealogy.com"  => 1,  # Cluttering avtext with human names.
 170   "rootsweb.com"            => 1,  # Cluttering avtext with human names.
 171   "akamai.net"              => 1,  # Lots of sites have their images on Akamai.
 172   "akamaitech.net"          => 1,  # But those are pretty much all banners.
 173                                    # Since Akamai is super-expensive, let's
 174                                    # go out on a limb and assume that all of
 175                                    # their customers are rich-and-boring.
 176   "bartleby.com"            => 1,  # Dictionary, cluttering avtext.
 177   "encyclopedia.com"        => 1,  # Dictionary, cluttering avtext.
 178   "onlinedictionary.datasegment.com" => 1,  # Dictionary, cluttering avtext.
 179   "hotlinkpics.com"         => 1,  # Porn site that has poisoned avimages
 180                                    # (I don't see how they did it, though!)
 181   "alwayshotels.com"        => 1,  # Poisoned Lycos pretty heavily.
 182   "nextag.com"              => 1,  # Poisoned Alta Vista real good.
 183 );
 184
 185
 186 # When verbosity is turned on, we warn about sites that we seem to be hitting
 187 # a lot: usually this means some new poisoner has made it into the search
 188 # engines.  But sometimes, the warning is just because that site has a lot
 189 # of stuff on it.  So these are the sites that are immune to the "frequent
 190 # site" diagnostic message.
 191 #
 192 my %warningless_sites = (
 193   "home.earthlink.net"      => 1,  # Lots of home pages here.
 194   "www.geocities.com"       => 1,
 195   "www.angelfire.com"       => 1,
 196   "members.aol.com"         => 1,
 197   "img.photobucket.com"     => 1,
 198   "pics.livejournal.com"    => 1,
 199   "tinypic.com"             => 1,
 200   "flickr.com"              => 1,
 201
 202   "yimg.com"                => 1,  # This is where dailynews.yahoo.com stores
 203   "eimg.com"                => 1,  # its images, so pick_from_yahoo_news_text()
 204                                    # hits this every time.
 205
 206   "images.quizfarm.com"     => 1,  # damn those LJ quizzes...
 207   "images.quizilla.com"     => 1,
 208   "images.quizdiva.net"     => 1,
 209
 210   "driftnet"                => 1,  # builtin...
 211 );
 212
 213
 214 # For decoding HTML-encoded character entities to URLs.
 215 #
 216 my %entity_table = (
 217    "apos"   => '\'',
 218    "quot"   => '"', "amp"    => '&', "lt"     => '<', "gt"     => '>',
 219    "nbsp"   => ' ', "iexcl"  => '¡', "cent"   => '¢', "pound"  => '£',
 220    "curren" => '¤', "yen"    => '¥', "brvbar" => '¦', "sect"   => '§',
 221    "uml"    => '¨', "copy"   => '©', "ordf"   => 'ª', "laquo"  => '«',
 222    "not"    => '¬', "shy"    => '', "reg"    => '®', "macr"   => '¯',
 223    "deg"    => '°', "plusmn" => '±', "sup2"   => '²', "sup3"   => '³',
 224    "acute"  => '´', "micro"  => 'µ', "para"   => '¶', "middot" => '·',
 225    "cedil"  => '¸', "sup1"   => '¹', "ordm"   => 'º', "raquo"  => '»',
 226    "frac14" => '¼', "frac12" => '½', "frac34" => '¾', "iquest" => '¿',
 227    "Agrave" => 'À', "Aacute" => 'Á', "Acirc"  => 'Â', "Atilde" => 'Ã',
 228    "Auml"   => 'Ä', "Aring"  => 'Å', "AElig"  => 'Æ', "Ccedil" => 'Ç',
 229    "Egrave" => 'È', "Eacute" => 'É', "Ecirc"  => 'Ê', "Euml"   => 'Ë',
 230    "Igrave" => 'Ì', "Iacute" => 'Í', "Icirc"  => 'Î', "Iuml"   => 'Ï',
 231    "ETH"    => 'Ð', "Ntilde" => 'Ñ', "Ograve" => 'Ò', "Oacute" => 'Ó',
 232    "Ocirc"  => 'Ô', "Otilde" => 'Õ', "Ouml"   => 'Ö', "times"  => '×',
 233    "Oslash" => 'Ø', "Ugrave" => 'Ù', "Uacute" => 'Ú', "Ucirc"  => 'Û',
 234    "Uuml"   => 'Ü', "Yacute" => 'Ý', "THORN"  => 'Þ', "szlig"  => 'ß',
 235    "agrave" => 'à', "aacute" => 'á', "acirc"  => 'â', "atilde" => 'ã',
 236    "auml"   => 'ä', "aring"  => 'å', "aelig"  => 'æ', "ccedil" => 'ç',
 237    "egrave" => 'è', "eacute" => 'é', "ecirc"  => 'ê', "euml"   => 'ë',
 238    "igrave" => 'ì', "iacute" => 'í', "icirc"  => 'î', "iuml"   => 'ï',
 239    "eth"    => 'ð', "ntilde" => 'ñ', "ograve" => 'ò', "oacute" => 'ó',
 240    "ocirc"  => 'ô', "otilde" => 'õ', "ouml"   => 'ö', "divide" => '÷',
 241    "oslash" => 'ø', "ugrave" => 'ù', "uacute" => 'ú', "ucirc"  => 'û',
 242    "uuml"   => 'ü', "yacute" => 'ý', "thorn"  => 'þ', "yuml"   => 'ÿ',
 243    "ndash"  => '-', "mdash"  => "--"
 244 );
 245
 246
 247 ##############################################################################
 248 #
 249 # Various global flags set by command line parameters, or computed
 250 #
 251 ##############################################################################
 252
 253
 254 my $current_state = "???";      # for diagnostics
 255 my $load_method;
 256 my $last_search;
 257 my $image_succeeded = -1;
 258 my $suppress_audit = 0;
 259
 260 my $verbose_imgmap = 0;         # print out rectangles and URLs only (stdout)
 261 my $verbose_warnings = 0;       # print out warnings when things go wrong
 262 my $verbose_load = 0;           # diagnostics about loading of URLs
 263 my $verbose_filter = 0;         # diagnostics about page selection/rejection
 264 my $verbose_net = 0;            # diagnostics about network I/O
 265 my $verbose_pbm = 0;            # diagnostics about PBM pipelines
 266 my $verbose_http = 0;           # diagnostics about all HTTP activity
 267 my $verbose_exec = 0;           # diagnostics about executing programs
 268
 269 my $report_performance_interval = 60 * 15;  # print some stats every 15 minutes
 270
 271 my $http_proxy = undef;
 272 my $http_timeout = 20;
 273 my $cvt_timeout = 10;
 274
 275 my $min_width = 50;
 276 my $min_height = 50;
 277 my $min_ratio = 1/5;
 278
 279 my $min_gif_area = (120 * 120);
 280
 281
 282 my $no_output_p = 0;
 283 my $urls_only_p = 0;
 284 my $imagemap_base = undef;
 285
 286 my @pids_to_kill = ();  # forked pids we should kill when we exit, if any.
 287
 288 my $driftnet_magic = 'driftnet';
 289 my $driftnet_dir = undef;
 290 my $default_driftnet_cmd = "driftnet -a -m 100";
 291
 292 my $wordlist;
 293
 294 my %rejected_urls;
 295 my @tripwire_words = ("aberrate", "abode", "amorphous", "antioch",
 296                       "arrhenius", "arteriole", "blanket", "brainchild",
 297                       "burdensome", "carnival", "cherub", "chord", "clever",
 298                       "dedicate", "dilogarithm", "dolan", "dryden",
 299                       "eggplant");
 300
 301
 302 ##############################################################################
 303 #
 304 # Retrieving URLs
 305 #
 306 ##############################################################################
 307
 308 # returns three values: the HTTP response line; the document headers;
 309 # and the document body.
 310 #
 311 sub get_document_1($$$) {
 312   my ($url, $referer, $timeout) = @_;
 313
 314   if (!defined($timeout)) { $timeout = $http_timeout; }
 315   if ($timeout > $http_timeout) { $timeout = $http_timeout; }
 316
 317   if ($timeout <= 0) {
 318     LOG (($verbose_net || $verbose_load), "timed out for $url");
 319     return ();
 320   }
 321
 322   LOG ($verbose_net, "get_document_1 $url " . ($referer ? $referer : ""));
 323
 324   if (! ($url =~ m@^http://@i)) {
 325     LOG ($verbose_net, "not an HTTP URL: $url");
 326     return ();
 327   }
 328
 329   my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
 330   $path = "" unless $path;
 331
 332   if (!$url_proto || !$serverstring) {
 333     LOG (($verbose_net || $verbose_load), "unparsable URL: $url");
 334     return ();
 335   }
 336
 337   my ($them,$port) = split(/:/, $serverstring);
 338   $port = 80 unless $port;
 339
 340   my $them2 = $them;
 341   my $port2 = $port;
 342   if ($http_proxy) {
 343     $serverstring = $http_proxy if $http_proxy;
 344     $serverstring =~ s@^[a-z]+://@@;
 345     ($them2,$port2) = split(/:/, $serverstring);
 346     $port2 = 80 unless $port2;
 347   }
 348
 349   my ($remote, $iaddr, $paddr, $proto, $line);
 350   $remote = $them2;
 351   if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') }
 352   if (!$port2) {
 353     LOG (($verbose_net || $verbose_load), "unrecognised port in $url");
 354     return ();
 355   }
 356   $iaddr   = inet_aton($remote);
 357   if (!$iaddr) {
 358     LOG (($verbose_net || $verbose_load), "host not found: $remote");
 359     return ();
 360   }
 361   $paddr   = sockaddr_in($port2, $iaddr);
 362
 363
 364   my $head = "";
 365   my $body = "";
 366
 367   @_ =
 368     eval {
 369       local $SIG{ALRM} = sub {
 370         LOG (($verbose_net || $verbose_load), "timed out ($timeout) for $url");
 371         die "alarm\n";
 372       };
 373       alarm $timeout;
 374
 375       $proto   = getprotobyname('tcp');
 376       if (!socket(S, PF_INET, SOCK_STREAM, $proto)) {
 377         LOG (($verbose_net || $verbose_load), "socket: $!");
 378         return ();
 379       }
 380       if (!connect(S, $paddr)) {
 381         LOG (($verbose_net || $verbose_load), "connect($serverstring): $!");
 382         return ();
 383       }
 384
 385       select(S); $| = 1; select(STDOUT);
 386
 387       my $cookie = $cookies{$them};
 388
 389       my $user_agent = "$progname/$version";
 390
 391       if ($url =~ m@^http://www\.altavista\.com/@ ||
 392           $url =~ m@^http://random\.yahoo\.com/@ ||
 393           $url =~ m@^http://images\.google\.com/@) {
 394         # block this, you turkeys.
 395         $user_agent = "Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7.5)" .
 396           " Gecko/20041111 Firefox/1.0";
 397       }
 398
 399       my $hdrs = "GET " . ($http_proxy ? $url : "/$path") . " HTTP/1.0\r\n" .
 400                  "Host: $them\r\n" .
 401                  "User-Agent: $user_agent\r\n";
 402       if ($referer) {
 403         $hdrs .= "Referer: $referer\r\n";
 404       }
 405       if ($cookie) {
 406         my @cc = split(/\r?\n/, $cookie);
 407         $hdrs .= "Cookie: " . join('; ', @cc) . "\r\n";
 408       }
 409       $hdrs .= "\r\n";
 410
 411       foreach (split('\r?\n', $hdrs)) {
 412         LOG ($verbose_http, "  ==> $_");
 413       }
 414       print S $hdrs;
 415       my $http = <S> || "";
 416
 417       # Kludge: the Yahoo Random Link is now returning as its first
 418       # line "Status: 301" instead of "HTTP/1.0 301 Found".  Fix it...
 419       #
 420       $http =~ s@^Status:\s+(\d+)\b@HTTP/1.0 $1@i;
 421
 422       $_  = $http;
 423       s/[\r\n]+$//s;
 424       LOG ($verbose_http, "  <== $_");
 425
 426       while (<S>) {
 427         $head .= $_;
 428         s/[\r\n]+$//s;
 429         last if m@^$@;
 430         LOG ($verbose_http, "  <== $_");
 431
 432         if (m@^Set-cookie:\s*([^;\r\n]+)@i) {
 433           set_cookie($them, $1)
 434         }
 435       }
 436
 437       my $lines = 0;
 438       while (<S>) {
 439         $body .= $_;
 440         $lines++;
 441       }
 442
 443       LOG ($verbose_http,
 444            "  <== [ body ]: $lines lines, " . length($body) . " bytes");
 445
 446       close S;
 447
 448       if (!$http) {
 449         LOG (($verbose_net || $verbose_load), "null response: $url");
 450         return ();
 451       }
 452
 453       $SIG{ALRM} = 'DEFAULT';  # seem to be suffering a race?
 454       return ( $http, $head, $body );
 455     };
 456   die if ($@ && $@ ne "alarm\n");       # propagate errors
 457
 458   if ($@ && $@ ne "alarm\n") {
 459     print STDERR blurb() . "DIE " . join(" ", $@) . "\n";
 460     die;
 461   }
 462
 463   if ($@) {
 464     # timed out
 465     $head = undef;
 466     $body = undef;
 467     $suppress_audit = 1;
 468     return ();
 469   } else {
 470     # didn't
 471     alarm 0;
 472     return @_;
 473   }
 474 }
 475
 476
 477 # returns two values: the document headers; and the document body.
 478 # if the given URL did a redirect, returns the redirected-to document.
 479 #
 480 sub get_document($$;$) {
 481   my ($url, $referer, $timeout) = @_;
 482   my $start = time;
 483
 484   if (defined($referer) && $referer eq $driftnet_magic) {
 485     return get_driftnet_file ($url);
 486   }
 487
 488   my $orig_url = $url;
 489   my $loop_count = 0;
 490   my $max_loop_count = 4;
 491
 492   do {
 493     if (defined($timeout) && $timeout <= 0) {
 494       LOG (($verbose_net || $verbose_load), "timed out for $url");
 495       $suppress_audit = 1;
 496       return ();
 497     }
 498
 499     my ( $http, $head, $body ) = get_document_1 ($url, $referer, $timeout);
 500
 501     if (defined ($timeout)) {
 502       my $now = time;
 503       my $elapsed = $now - $start;
 504       $timeout -= $elapsed;
 505       $start = $now;
 506     }
 507
 508     return () unless $http; # error message already printed
 509
 510     $http =~ s/[\r\n]+$//s;
 511
 512     if ( $http =~ m@^HTTP/[0-9.]+ 30[123]@ ) {
 513       $_ = $head;
 514
 515       my ( $location ) = m@^location:[ \t]*(.*)$@im;
 516       if ( $location ) {
 517         $location =~ s/[\r\n]$//;
 518
 519         LOG ($verbose_net, "redirect from $url to $location");
 520         $referer = $url;
 521         $url = $location;
 522
 523         if ($url =~ m@^/@) {
 524           $referer =~ m@^(http://[^/]+)@i;
 525           $url = $1 . $url;
 526         } elsif (! ($url =~ m@^[a-z]+:@i)) {
 527           $_ = $referer;
 528           s@[^/]+$@@g if m@^http://[^/]+/@i;
 529           $_ .= "/" if m@^http://[^/]+$@i;
 530           $url = $_ . $url;
 531         }
 532
 533       } else {
 534         LOG ($verbose_net, "no Location with \"$http\"");
 535         return ( $url, $body );
 536       }
 537
 538       if ($loop_count++ > $max_loop_count) {
 539         LOG ($verbose_net,
 540              "too many redirects ($max_loop_count) from $orig_url");
 541         $body = undef;
 542         return ();
 543       }
 544
 545     } elsif ( $http =~ m@^HTTP/[0-9.]+ ([4-9][0-9][0-9].*)$@ ) {
 546
 547       LOG (($verbose_net || $verbose_load), "failed: $1 ($url)");
 548
 549       # http errors -- return nothing.
 550       $body = undef;
 551       return ();
 552
 553     } elsif (!$body) {
 554
 555       LOG (($verbose_net || $verbose_load), "document contains no data: $url");
 556       return ();
 557
 558     } else {
 559
 560       # ok!
 561       return ( $url, $body );
 562     }
 563
 564   } while (1);
 565 }
 566
 567 # If we already have a cookie defined for this site, and the site is trying
 568 # to overwrite that very same cookie, let it do so.  This is because nytimes
 569 # expires its cookies - it lets you upgrade to a new cookie without logging
 570 # in again, but you have to present the old cookie to get the new cookie.
 571 # So, by doing this, the built-in cypherpunks cookie will never go "stale".
 572 #
 573 sub set_cookie($$) {
 574   my ($host, $cookie) = @_;
 575   my $oc = $cookies{$host};
 576   return unless $oc;
 577   $_ = $oc;
 578   my ($oc_name, $oc_value) = m@^([^= \t\r\n]+)=(.*)$@;
 579   $_ = $cookie;
 580   my ($nc_name, $nc_value) = m@^([^= \t\r\n]+)=(.*)$@;
 581
 582   if ($oc_name eq $nc_name &&
 583       $oc_value ne $nc_value) {
 584     $cookies{$host} = $cookie;
 585     LOG ($verbose_net, "overwrote ${host}'s $oc_name cookie");
 586   }
 587 }
 588
 589
 590 ############################################################################
 591 #
 592 # Extracting image URLs from HTML
 593 #
 594 ############################################################################
 595
 596 # given a URL and the body text at that URL, selects and returns a random
 597 # image from it.  returns () if no suitable images found.
 598 #
 599 sub pick_image_from_body($$) {
 600   my ($url, $body) = @_;
 601
 602   my $base = $url;
 603   $_ = $url;
 604
 605   # if there's at least one slash after the host, take off the last
 606   # pathname component
 607   if ( m@^http://[^/]+/@io ) {
 608     $base =~ s@[^/]+$@@go;
 609   }
 610
 611   # if there are no slashes after the host at all, put one on the end.
 612   if ( m@^http://[^/]+$@io ) {
 613     $base .= "/";
 614   }
 615
 616   $_ = $body;
 617
 618   # strip out newlines, compress whitespace
 619   s/[\r\n\t ]+/ /go;
 620
 621   # nuke comments
 622   s/<!--.*?-->//go;
 623
 624
 625   # There are certain web sites that list huge numbers of dictionary
 626   # words in their bodies or in their <META NAME=KEYWORDS> tags (surprise!
 627   # Porn sites tend not to be reputable!)
 628   #
 629   # I do not want webcollage to filter on content: I want it to select
 630   # randomly from the set of images on the web.  All the logic here for
 631   # rejecting some images is really a set of heuristics for rejecting
 632   # images that are not really images: for rejecting *text* that is in
 633   # GIF/JPEG/PNG form.  I don't want text, I want pictures, and I want
 634   # the content of the pictures to be randomly selected from among all
 635   # the available content.
 636   #
 637   # So, filtering out "dirty" pictures by looking for "dirty" keywords
 638   # would be wrong: dirty pictures exist, like it or not, so webcollage
 639   # should be able to select them.
 640   #
 641   # However, picking a random URL is a hard thing to do.  The mechanism I'm
 642   # using is to search for a selection of random words.  This is not
 643   # perfect, but works ok most of the time.  The way it breaks down is when
 644   # some URLs get precedence because their pages list *every word* as
 645   # related -- those URLs come up more often than others.
 646   #
 647   # So, after we've retrieved a URL, if it has too many keywords, reject
 648   # it.  We reject it not on the basis of what those keywords are, but on
 649   # the basis that by having so many, the page has gotten an unfair
 650   # advantage against our randomizer.
 651   #
 652   my $trip_count = 0;
 653   foreach my $trip (@tripwire_words) {
 654     $trip_count++ if m/$trip/i;
 655   }
 656
 657   if ($trip_count >= $#tripwire_words - 2) {
 658     LOG (($verbose_filter || $verbose_load),
 659          "there is probably a dictionary in \"$url\": rejecting.");
 660     $rejected_urls{$url} = -1;
 661     $body = undef;
 662     $_ = undef;
 663     return ();
 664   }
 665
 666
 667   my @urls;
 668   my %unique_urls;
 669
 670   foreach (split(/ *</)) {
 671     if ( m/^meta /i ) {
 672
 673       # Likewise, reject any web pages that have a KEYWORDS meta tag
 674       # that is too long.
 675       #
 676       if (m/name ?= ?\"?keywords\"?/i &&
 677           m/content ?= ?\"([^\"]+)\"/) {
 678         my $L = length($1);
 679         if ($L > 1000) {
 680           LOG (($verbose_filter || $verbose_load),
 681                "excessive keywords ($L bytes) in $url: rejecting.");
 682           $rejected_urls{$url} = $L;
 683           $body = undef;
 684           $_ = undef;
 685           return ();
 686         } else {
 687           LOG ($verbose_filter, "  keywords ($L bytes) in $url (ok)");
 688         }
 689       }
 690
 691     } elsif ( m/^(img|a) .*(src|href) ?= ?\"? ?(.*?)[ >\"]/io ) {
 692
 693       my $was_inline = (! ( "$1" eq "a" || "$1" eq "A" ));
 694       my $link = $3;
 695       my ( $width )  = m/width ?=[ \"]*(\d+)/oi;
 696       my ( $height ) = m/height ?=[ \"]*(\d+)/oi;
 697       $_ = $link;
 698
 699       if ( m@^/@o ) {
 700         my $site;
 701         ( $site = $base ) =~ s@^(http://[^/]*).*@$1@gio;
 702         $_ = "$site$link";
 703       } elsif ( ! m@^[^/:?]+:@ ) {
 704         $_ = "$base$link";
 705         s@/\./@/@g;
 706         1 while (s@/[^/]+/\.\./@/@g);
 707       }
 708
 709       # skip non-http
 710       if ( ! m@^http://@io ) {
 711         next;
 712       }
 713
 714       # skip non-image
 715       if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg|png)$@io ) {
 716         next;
 717       }
 718
 719       # skip really short or really narrow images
 720       if ( $width && $width < $min_width) {
 721         if (!$height) { $height = "?"; }
 722         LOG ($verbose_filter, "  skip narrow image $_ (${width}x$height)");
 723         next;
 724       }
 725
 726       if ( $height && $height < $min_height) {
 727         if (!$width) { $width = "?"; }
 728         LOG ($verbose_filter, "  skip short image $_ (${width}x$height)");
 729         next;
 730       }
 731
 732       # skip images with ratios that make them look like banners.
 733       if ($min_ratio && $width && $height &&
 734           ($width * $min_ratio ) > $height) {
 735         if (!$height) { $height = "?"; }
 736         LOG ($verbose_filter, "  skip bad ratio $_ (${width}x$height)");
 737         next;
 738       }
 739
 740       # skip GIFs with a small number of pixels -- those usually suck.
 741       if ($width && $height &&
 742           m/\.gif$/io &&
 743           ($width * $height) < $min_gif_area) {
 744         LOG ($verbose_filter, "  skip small GIF $_ (${width}x$height)");
 745         next;
 746       }
 747
 748       # skip images with a URL that indicates a Yahoo thumbnail.
 749       if (m@\.yimg\.com/.*/t/@) {
 750         if (!$width)  { $width  = "?"; }
 751         if (!$height) { $height = "?"; }
 752         LOG ($verbose_filter, "  skip yahoo thumb $_ (${width}x$height)");
 753         next;
 754       }
 755
 756       my $url = $_;
 757
 758       if ($unique_urls{$url}) {
 759         LOG ($verbose_filter, "  skip duplicate image $_");
 760         next;
 761       }
 762
 763       LOG ($verbose_filter,
 764            "  image $url" .
 765            ($width && $height ? " (${width}x${height})" : "") .
 766            ($was_inline ? " (inline)" : ""));
 767
 768       $urls[++$#urls] = $url;
 769       $unique_urls{$url}++;
 770
 771       # JPEGs are preferable to GIFs and PNGs.
 772       $_ = $url;
 773       if ( ! m@[.](gif|png)$@io ) {
 774         $urls[++$#urls] = $url;
 775       }
 776
 777       # pointers to images are preferable to inlined images.
 778       if ( ! $was_inline ) {
 779         $urls[++$#urls] = $url;
 780         $urls[++$#urls] = $url;
 781       }
 782     }
 783   }
 784
 785   my $fsp = ($body =~ m@<frameset@i);
 786
 787   $_ = undef;
 788   $body = undef;
 789
 790   @urls = depoison (@urls);
 791
 792   if ( $#urls < 0 ) {
 793     LOG ($verbose_load, "no images on $base" . ($fsp ? " (frameset)" : ""));
 794     return ();
 795   }
 796
 797   # pick a random element of the table
 798   my $i = int(rand($#urls+1));
 799   $url = $urls[$i];
 800
 801   LOG ($verbose_load, "picked image " .($i+1) . "/" . ($#urls+1) . ": $url");
 802
 803   return $url;
 804 }
 805
 806
 807 \f
 808 ############################################################################
 809 #
 810 # Subroutines for getting pages and images out of search engines
 811 #
 812 ############################################################################
 813
 814
 815 sub pick_dictionary() {
 816   my @dicts = ("/usr/dict/words",
 817                "/usr/share/dict/words",
 818                "/usr/share/lib/dict/words");
 819   foreach my $f (@dicts) {
 820     if (-f $f) {
 821       $wordlist = $f;
 822       last;
 823     }
 824   }
 825   error ("$dicts[0] does not exist") unless defined($wordlist);
 826 }
 827
 828 # returns a random word from the dictionary
 829 #
 830 sub random_word() {
 831
 832   local *IN;
 833   if (! open (IN, "<$wordlist")) {
 834     return undef;
 835   }
 836
 837   my $size = (stat(IN))[7];
 838   my $word = undef;
 839   my $count = 0;
 840
 841   while (1) {
 842     error ("looping ($count) while reading $wordlist")
 843       if (++$count > 100);
 844
 845     my $pos = int (rand ($size));
 846     if (seek (IN, $pos, 0)) {
 847       $word = <IN>;   # toss partial line
 848       $word = <IN>;   # keep next line
 849     }
 850
 851     next unless ($word);
 852     next if ($word =~ m/^[-\']/);
 853
 854     $word = lc($word);
 855     $word =~ s/^.*-//s;
 856     $word =~ s/^[^a-z]+//s;
 857     $word =~ s/[^a-z]+$//s;
 858     $word =~ s/\'s$//s;
 859     $word =~ s/ys$/y/s;
 860     $word =~ s/ally$//s;
 861     $word =~ s/ly$//s;
 862     $word =~ s/ies$/y/s;
 863     $word =~ s/ally$/al/s;
 864     $word =~ s/izes$/ize/s;
 865     $word =~ s/esses$/ess/s;
 866     $word =~ s/(.{5})ing$/$1/s;
 867
 868     next if (length ($word) > 14);
 869     last if ($word);
 870   }
 871
 872   close (IN);
 873
 874   if ( $word =~ s/\s/\+/gs ) {  # convert intra-word spaces to "+".
 875     $word = "\%22$word\%22";    # And put quotes (%22) around it.
 876   }
 877
 878   return $word;
 879 }
 880
 881
 882 sub random_words($) {
 883   my ($or_p) = @_;
 884   my $sep = ($or_p ? "%20OR%20" : "%20");
 885   return (random_word . $sep .
 886           random_word . $sep .
 887           random_word . $sep .
 888           random_word . $sep .
 889           random_word);
 890 }
 891
 892
 893 sub url_quote($) {
 894   my ($s) = @_;
 895   $s =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge;
 896   return $s;
 897 }
 898
 899 sub url_unquote($) {
 900   my ($s) = @_;
 901   $s =~ s/[+]/ /g;
 902   $s =~ s/%([a-z0-9]{2})/chr(hex($1))/ige;
 903   return $s;
 904 }
 905
 906 sub html_quote($) {
 907   my ($s) = @_;
 908   $s =~ s/&/&amp;/gi;
 909   $s =~ s/</&lt;/gi;
 910   $s =~ s/>/&gt;/gi;
 911   $s =~ s/\"/&quot;/gi;
 912   return $s;
 913 }
 914
 915 sub html_unquote($) {
 916   my ($s) = @_;
 917   $s =~ s/(&([a-z]+);)/{ $entity_table{$2} || $1; }/gexi;  # e.g., &apos;
 918   $s =~ s/(&\#(\d+);)/{ chr($2) }/gexi;                    # e.g., &#39;
 919   return $s;
 920 }
 921
 922
 923 # Loads the given URL (a search on some search engine) and returns:
 924 # - the total number of hits the search engine claimed it had;
 925 # - a list of URLs from the page that the search engine returned;
 926 # Note that this list contains all kinds of internal search engine
 927 # junk URLs too -- caller must prune them.
 928 #
 929 sub pick_from_search_engine($$$) {
 930   my ( $timeout, $search_url, $words ) = @_;
 931
 932   $_ = $words;
 933   s/%20/ /g;
 934
 935   print STDERR "\n\n" if ($verbose_load);
 936
 937   LOG ($verbose_load, "words: $_");
 938   LOG ($verbose_load, "URL: $search_url");
 939
 940   $last_search = $search_url;   # for warnings
 941
 942   my $start = time;
 943   my ( $base, $body ) = get_document ($search_url, undef, $timeout);
 944   if (defined ($timeout)) {
 945     $timeout -= (time - $start);
 946     if ($timeout <= 0) {
 947       $body = undef;
 948       LOG (($verbose_net || $verbose_load),
 949            "timed out (late) for $search_url");
 950       $suppress_audit = 1;
 951       return ();
 952     }
 953   }
 954
 955   return () if (! $body);
 956
 957
 958   my @subpages;
 959
 960   my $search_count = "?";
 961   if ($body =~ m@found (approximately |about )?(<B>)?(\d+)(</B>)? image@) {
 962     $search_count = $3;
 963   } elsif ($body =~ m@<NOBR>((\d{1,3})(,\d{3})*)&nbsp;@i) {
 964     $search_count = $1;
 965   } elsif ($body =~ m@found ((\d{1,3})(,\d{3})*|\d+) Web p@) {
 966     $search_count = $1;
 967   } elsif ($body =~ m@found about ((\d{1,3})(,\d{3})*|\d+) results@) {
 968     $search_count = $1;
 969   } elsif ($body =~ m@\b\d+ - \d+ of (\d+)\b@i) { # avimages
 970     $search_count = $1;
 971   } elsif ($body =~ m@About ((\d{1,3})(,\d{3})*) images@i) { # avimages
 972     $search_count = $1;
 973   } elsif ($body =~ m@We found ((\d{1,3})(,\d{3})*|\d+) results@i) { # *vista
 974     $search_count = $1;
 975   } elsif ($body =~ m@ of about <B>((\d{1,3})(,\d{3})*)<@i) { # googleimages
 976     $search_count = $1;
 977   } elsif ($body =~ m@<B>((\d{1,3})(,\d{3})*)</B> Web sites were found@i) {
 978     $search_count = $1;    # lycos
 979   } elsif ($body =~ m@WEB.*?RESULTS.*?\b((\d{1,3})(,\d{3})*)\b.*?Matches@i) {
 980     $search_count = $1;                          # hotbot
 981   } elsif ($body =~ m@no photos were found containing@i) { # avimages
 982     $search_count = "0";
 983   } elsif ($body =~ m@found no document matching@i) { # avtext
 984     $search_count = "0";
 985   }
 986   1 while ($search_count =~ s/^(\d+)(\d{3})/$1,$2/);
 987
 988 #  if ($search_count eq "?" || $search_count eq "0") {
 989 #    local *OUT;
 990 #    my $file = "/tmp/wc.html";
 991 #    open(OUT, ">$file") || error ("writing $file: $!");
 992 #    print OUT $body;
 993 #    close OUT;
 994 #    print STDERR  blurb() . "###### wrote $file\n";
 995 #  }
 996
 997
 998   my $length = length($body);
 999   my $href_count = 0;
1000
1001   $_ = $body;
1002
1003   s/[\r\n\t ]+/ /g;
1004
1005
1006   s/(<A )/\n$1/gi;
1007   foreach (split(/\n/)) {
1008     $href_count++;
1009     my ($u) = m@<A\s.*\bHREF\s*=\s*([^>]+)>@i;
1010     next unless $u;
1011
1012     if ($u =~ m/^\"([^\"]*)\"/) { $u = $1; }   # quoted string
1013     elsif ($u =~ m/^([^\s]*)\s/) { $u = $1; }  # or token
1014
1015     if ( $rejected_urls{$u} ) {
1016       LOG ($verbose_filter, "  pre-rejecting candidate: $u");
1017       next;
1018     }
1019
1020     LOG ($verbose_http, "    HREF: $u");
1021
1022     $subpages[++$#subpages] = $u;
1023   }
1024
1025   if ( $#subpages < 0 ) {
1026     LOG ($verbose_filter,
1027          "found nothing on $base ($length bytes, $href_count links).");
1028     return ();
1029   }
1030
1031   LOG ($verbose_filter, "" . $#subpages+1 . " links on $search_url");
1032
1033   return ($search_count, @subpages);
1034 }
1035
1036
1037 sub depoison(@) {
1038   my (@urls) = @_;
1039   my @urls2 = ();
1040   foreach (@urls) {
1041     my ($h) = m@^http://([^/: \t\r\n]+)@i;
1042
1043     next unless defined($h);
1044
1045     if ($poisoners{$h}) {
1046       LOG (($verbose_filter), "  rejecting poisoner: $_");
1047       next;
1048     }
1049     if ($h =~ m@([^.]+\.[^.]+\.[^.]+)$@ &&
1050         $poisoners{$1}) {
1051       LOG (($verbose_filter), "  rejecting poisoner: $_");
1052       next;
1053     }
1054     if ($h =~ m@([^.]+\.[^.]+)$@ &&
1055         $poisoners{$1}) {
1056       LOG (($verbose_filter), "  rejecting poisoner: $_");
1057       next;
1058     }
1059
1060     push @urls2, $_;
1061   }
1062   return @urls2;
1063 }
1064
1065
1066 # given a list of URLs, picks one at random; loads it; and returns a
1067 # random image from it.
1068 # returns the url of the page loaded; the url of the image chosen.
1069 #
1070 sub pick_image_from_pages($$$$@) {
1071   my ($base, $total_hit_count, $unfiltered_link_count, $timeout, @pages) = @_;
1072
1073   $total_hit_count = "?" unless defined($total_hit_count);
1074
1075   @pages = depoison (@pages);
1076   LOG ($verbose_load,
1077        "" . ($#pages+1) . " candidates of $unfiltered_link_count links" .
1078        " ($total_hit_count total)");
1079
1080   return () if ($#pages < 0);
1081
1082   my $i = int(rand($#pages+1));
1083   my $page = $pages[$i];
1084
1085   LOG ($verbose_load, "picked page $page");
1086
1087   $suppress_audit = 1;
1088
1089   my ( $base2, $body2 ) = get_document ($page, $base, $timeout);
1090
1091   if (!$base2 || !$body2) {
1092     $body2 = undef;
1093     return ();
1094   }
1095
1096   my $img = pick_image_from_body ($base2, $body2);
1097   $body2 = undef;
1098
1099   if ($img) {
1100     return ($base2, $img);
1101   } else {
1102     return ();
1103   }
1104 }
1105
1106 \f
1107 ############################################################################
1108 #
1109 # Pick images from random pages returned by the Yahoo Random Link
1110 #
1111 ############################################################################
1112
1113 # yahoorand
1114 my $yahoo_random_link = "http://random.yahoo.com/fast/ryl";
1115
1116
1117 # Picks a random page; picks a random image on that page;
1118 # returns two URLs: the page containing the image, and the image.
1119 # Returns () if nothing found this time.
1120 #
1121 sub pick_from_yahoo_random_link($) {
1122   my ($timeout) = @_;
1123
1124   print STDERR "\n\n" if ($verbose_load);
1125   LOG ($verbose_load, "URL: $yahoo_random_link");
1126
1127   $last_search = $yahoo_random_link;   # for warnings
1128
1129   $suppress_audit = 1;
1130
1131   my ( $base, $body ) = get_document ($yahoo_random_link, undef, $timeout);
1132   if (!$base || !$body) {
1133     $body = undef;
1134     return;
1135   }
1136
1137   LOG ($verbose_load, "redirected to: $base");
1138
1139   my $img = pick_image_from_body ($base, $body);
1140   $body = undef;
1141
1142   if ($img) {
1143     return ($base, $img);
1144   } else {
1145     return ();
1146   }
1147 }
1148
1149 \f
1150 ############################################################################
1151 #
1152 # Pick images from random pages returned by the Alta Vista Random Link
1153 #
1154 ############################################################################
1155
1156 # altavista
1157 my $alta_vista_random_link = "http://www.altavista.com/image/randomlink";
1158
1159
1160 # Picks a random page; picks a random image on that page;
1161 # returns two URLs: the page containing the image, and the image.
1162 # Returns () if nothing found this time.
1163 #
1164 sub pick_from_alta_vista_random_link($) {
1165   my ($timeout) = @_;
1166
1167   print STDERR "\n\n" if ($verbose_load);
1168   LOG ($verbose_load, "URL: $alta_vista_random_link");
1169
1170   $last_search = $alta_vista_random_link;   # for warnings
1171
1172   $suppress_audit = 1;
1173
1174   my ( $base, $body ) = get_document ($alta_vista_random_link,
1175                                       undef, $timeout);
1176   if (!$base || !$body) {
1177     $body = undef;
1178     return;
1179   }
1180
1181   LOG ($verbose_load, "redirected to: $base");
1182
1183   my $img = pick_image_from_body ($base, $body);
1184   $body = undef;
1185
1186   if ($img) {
1187     return ($base, $img);
1188   } else {
1189     return ();
1190   }
1191 }
1192
1193 \f
1194 ############################################################################
1195 #
1196 # Pick images by feeding random words into Alta Vista Image Search
1197 #
1198 ############################################################################
1199
1200
1201 my $alta_vista_images_url = "http://www.altavista.com/image/results" .
1202                             "?ipht=1" .       # photos
1203                             "&igrph=1" .      # graphics
1204                             "&iclr=1" .       # color
1205                             "&ibw=1" .        # b&w
1206                             "&micat=1" .      # no partner sites
1207                             "&sc=on" .        # "site collapse"
1208                             "&q=";
1209
1210 # avimages
1211 sub pick_from_alta_vista_images($) {
1212   my ($timeout) = @_;
1213
1214   my $words = random_word();
1215   my $page = (int(rand(9)) + 1);
1216   my $search_url = $alta_vista_images_url . $words;
1217
1218   if ($page > 1) {
1219     $search_url .= "&pgno=" . $page;            # page number
1220     $search_url .= "&stq=" . (($page-1) * 12);  # first hit result on page
1221   }
1222
1223   my ($search_hit_count, @subpages) =
1224     pick_from_search_engine ($timeout, $search_url, $words);
1225
1226   my @candidates = ();
1227   foreach my $u (@subpages) {
1228
1229     # avimages is encoding their URLs now.
1230     next unless ($u =~ s/^.*\*\*(http%3a.*$)/$1/gsi);
1231     $u = url_unquote($u);
1232
1233     next unless ($u =~ m@^http://@i);    #  skip non-HTTP or relative URLs
1234     next if ($u =~ m@[/.]altavista\.com\b@i);     # skip altavista builtins
1235     next if ($u =~ m@[/.]yahoo\.com\b@i);         # yahoo and av in cahoots?
1236     next if ($u =~ m@[/.]doubleclick\.net\b@i);   # you cretins
1237     next if ($u =~ m@[/.]clicktomarket\.com\b@i); # more cretins
1238
1239     next if ($u =~ m@[/.]viewimages\.com\b@i);    # stacked deck
1240     next if ($u =~ m@[/.]gettyimages\.com\b@i);
1241
1242     LOG ($verbose_filter, "  candidate: $u");
1243     push @candidates, $u;
1244   }
1245
1246   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1247                                 $timeout, @candidates);
1248 }
1249
1250
1251 \f
1252 ############################################################################
1253 #
1254 # Pick images by feeding random words into Google Image Search.
1255 # By Charles Gales <gales@us.ibm.com>
1256 #
1257 ############################################################################
1258
1259
1260 my $google_images_url =     "http://images.google.com/images" .
1261                             "?site=images" .  # photos
1262                             "&btnG=Search" .  # graphics
1263                             "&safe=off" .     # no screening
1264                             "&imgsafe=off" .
1265                             "&q=";
1266
1267 # googleimgs
1268 sub pick_from_google_images($;$$) {
1269   my ($timeout, $words, $max_page) = @_;
1270
1271   if (!defined($words)) {
1272     $words = random_word;   # only one word for Google
1273   }
1274
1275   my $page = (int(rand(9)) + 1);
1276   my $num = 20;     # 20 images per page
1277   my $search_url = $google_images_url . $words;
1278
1279   if ($page > 1) {
1280     $search_url .= "&start=" . $page*$num;      # page number
1281     $search_url .= "&num="   . $num;            #images per page
1282   }
1283
1284   my ($search_hit_count, @subpages) =
1285     pick_from_search_engine ($timeout, $search_url, $words);
1286
1287   my @candidates = ();
1288   my %referers;
1289   foreach my $u (@subpages) {
1290     next unless ($u =~ m@imgres\?imgurl@i);    #  All pics start with this
1291     next if ($u =~ m@[/.]google\.com\b@i);     # skip google builtins
1292
1293     if ($u =~ m@^/imgres\?imgurl=(.*?)\&imgrefurl=(.*?)\&@) {
1294       my $ref = $2;
1295       my $img = $1;
1296       $img = "http://$img" unless ($img =~ m/^http:/i);
1297
1298       LOG ($verbose_filter, "  candidate: $ref");
1299       push @candidates, $img;
1300       $referers{$img} = $ref;
1301     }
1302   }
1303
1304   @candidates = depoison (@candidates);
1305   return () if ($#candidates < 0);
1306   my $i = int(rand($#candidates+1));
1307   my $img = $candidates[$i];
1308   my $ref = $referers{$img};
1309
1310   LOG ($verbose_load, "picked image " . ($i+1) . ": $img (on $ref)");
1311   return ($ref, $img);
1312 }
1313
1314
1315 \f
1316 ############################################################################
1317 #
1318 # Pick images by feeding random numbers into Google Image Search.
1319 # By jwz, suggested by Ian O'Donnell.
1320 #
1321 ############################################################################
1322
1323
1324 # googlenums
1325 sub pick_from_google_image_numbers($) {
1326   my ($timeout) = @_;
1327
1328   my $max = 9999;
1329   my $number = int(rand($max));
1330
1331   $number = sprintf("%04d", $number)
1332     if (rand() < 0.3);
1333
1334   pick_from_google_images ($timeout, "$number");
1335 }
1336
1337
1338 \f
1339 ############################################################################
1340 #
1341 # Pick images by feeding random digital camera file names into
1342 # Google Image Search.
1343 # By jwz, inspired by the excellent Random Personal Picture Finder
1344 # at http://www.diddly.com/random/
1345 #
1346 ############################################################################
1347
1348 my @photomakers = (
1349   #
1350   # Common digital camera file name formats, as described at
1351   # http://www.diddly.com/random/about.html
1352   #
1353   sub { sprintf ("dcp%05d.jpg",  int(rand(4000))); },   # Kodak
1354   sub { sprintf ("dsc%05d.jpg",  int(rand(4000))); },   # Nikon
1355   sub { sprintf ("dscn%04d.jpg", int(rand(4000))); },   # Nikon
1356   sub { sprintf ("mvc-%03d.jpg", int(rand(999)));  },   # Sony Mavica
1357   sub { sprintf ("mvc%05d.jpg",  int(rand(9999))); },   # Sony Mavica
1358   sub { sprintf ("P101%04d.jpg", int(rand(9999))); },   # Olympus w/ date=101
1359   sub { sprintf ("P%x%02d%04d.jpg",                     # Olympus
1360                  int(rand(0xC)), int(rand(30))+1,
1361                  rand(9999)); },
1362   sub { sprintf ("IMG_%03d.jpg",  int(rand(999))); },   # ?
1363   sub { sprintf ("IMAG%04d.jpg",  int(rand(9999))); },  # RCA and Samsung
1364   sub { my $n = int(rand(9999));                        # Canon
1365           sprintf ("1%02d-%04d.jpg", int($n/100), $n); },
1366   sub { my $n = int(rand(9999));                        # Canon
1367           sprintf ("1%02d-%04d_IMG.jpg",
1368                    int($n/100), $n); },
1369   sub { sprintf ("IMG_%04d.jpg", int(rand(9999))); },   # Canon
1370   sub { sprintf ("dscf%04d.jpg", int(rand(9999))); },   # Fuji Finepix
1371   sub { sprintf ("pdrm%04d.jpg", int(rand(9999))); },   # Toshiba PDR
1372   sub { sprintf ("IM%06d.jpg", int(rand(9999))); },     # HP Photosmart
1373   sub { sprintf ("EX%06d.jpg", int(rand(9999))); },     # HP Photosmart
1374 #  sub { my $n = int(rand(3));                          # Kodak DC-40,50,120
1375 #        sprintf ("DC%04d%s.jpg", int(rand(9999)),
1376 #                 $n == 0 ? 'S' : $n == 1 ? 'M' : 'L'); },
1377   sub { sprintf ("pict%04d.jpg", int(rand(9999))); },   # Minolta Dimage
1378   sub { sprintf ("P%07d.jpg", int(rand(9999))); },      # Kodak DC290
1379 #  sub { sprintf ("%02d%02d%04d.jpg",                   # Casio QV3000, QV4000
1380 #                 int(rand(12))+1, int(rand(31))+1,
1381 #                 int(rand(999))); },
1382 #  sub { sprintf ("%02d%x%02d%04d.jpg",                 # Casio QV7000
1383 #                 int(rand(6)), # year
1384 #                 int(rand(12))+1, int(rand(31))+1,
1385 #                 int(rand(999))); },
1386   sub { sprintf ("IMGP%04d.jpg", int(rand(9999))); },   # Pentax Optio S
1387   sub { sprintf ("PANA%04d.jpg", int(rand(9999))); },   # Panasonic vid still
1388   sub { sprintf ("HPIM%04d.jpg", int(rand(9999))); },   # HP Photosmart
1389   sub { sprintf ("PCDV%04d.jpg", int(rand(9999))); },   # ?
1390  );
1391
1392
1393 # googlephotos
1394 sub pick_from_google_image_photos($) {
1395   my ($timeout) = @_;
1396
1397   my $i = int(rand($#photomakers + 1));
1398   my $fn = $photomakers[$i];
1399   my $file = &$fn;
1400   my $words .= $file . "%20filetype:jpg";
1401
1402   pick_from_google_images ($timeout, $words);
1403 }
1404
1405
1406 \f
1407 ############################################################################
1408 #
1409 # Pick images by feeding random words into Alta Vista Text Search
1410 #
1411 ############################################################################
1412
1413
1414 my $alta_vista_url = "http://www.altavista.com/web/results" .
1415                      "?pg=aq" .
1416                      "&aqmode=s" .
1417                      "&filetype=html" .
1418                      "&sc=on" .        # "site collapse"
1419                      "&nbq=50" .
1420                      "&aqo=";
1421
1422 # avtext
1423 sub pick_from_alta_vista_text($) {
1424   my ($timeout) = @_;
1425
1426   my $words = random_words(0);
1427   my $page = (int(rand(9)) + 1);
1428   my $search_url = $alta_vista_url . $words;
1429
1430   if ($page > 1) {
1431     $search_url .= "&pgno=" . $page;
1432     $search_url .= "&stq=" . (($page-1) * 10);
1433   }
1434
1435   my ($search_hit_count, @subpages) =
1436     pick_from_search_engine ($timeout, $search_url, $words);
1437
1438   my @candidates = ();
1439   foreach my $u (@subpages) {
1440
1441     # Those altavista fuckers are playing really nasty redirection games
1442     # these days: the filter your clicks through their site, but use
1443     # onMouseOver to make it look like they're not!  Well, it makes it
1444     # easier for us to identify search results...
1445     #
1446     next unless ($u =~ s/^.*\*\*(http%3a.*$)/$1/gsi);
1447     $u = url_unquote($u);
1448
1449     next unless ($u =~ m@^http://@i);    #  skip non-HTTP or relative URLs
1450     next if ($u =~ m@[/.]altavista\.com\b@i);     # skip altavista builtins
1451     next if ($u =~ m@[/.]yahoo\.com\b@i);         # yahoo and av in cahoots?
1452
1453     LOG ($verbose_filter, "  candidate: $u");
1454     push @candidates, $u;
1455   }
1456
1457   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1458                                 $timeout, @candidates);
1459 }
1460
1461
1462 \f
1463 ############################################################################
1464 #
1465 # Pick images by feeding random words into Hotbot
1466 #
1467 ############################################################################
1468
1469 my $hotbot_search_url =("http://hotbot.lycos.com/default.asp" .
1470                         "?ca=w" .
1471                         "&descriptiontype=0" .
1472                         "&imagetoggle=1" .
1473                         "&matchmode=any" .
1474                         "&nummod=2" .
1475                         "&recordcount=50" .
1476                         "&sitegroup=1" .
1477                         "&stem=1" .
1478                         "&cobrand=undefined" .
1479                         "&query=");
1480
1481 sub pick_from_hotbot_text($) {
1482   my ($timeout) = @_;
1483
1484   $last_search = $hotbot_search_url;   # for warnings
1485
1486   # lycos seems to always give us back dictionaries and word lists if
1487   # we search for more than one word...
1488   #
1489   my $words = random_word();
1490
1491   my $start = int(rand(8)) * 10 + 1;
1492   my $search_url = $hotbot_search_url . $words . "&first=$start&page=more";
1493
1494   my ($search_hit_count, @subpages) =
1495     pick_from_search_engine ($timeout, $search_url, $words);
1496
1497   my @candidates = ();
1498   foreach my $u (@subpages) {
1499
1500     # Hotbot plays redirection games too
1501     # (not any more?)
1502 #    next unless ($u =~ m@/director.asp\?.*\btarget=([^&]+)@);
1503 #    $u = url_decode($1);
1504
1505     next unless ($u =~ m@^http://@i);    #  skip non-HTTP or relative URLs
1506     next if ($u =~ m@[/.]hotbot\.com\b@i);     # skip hotbot builtins
1507     next if ($u =~ m@[/.]lycos\.com\b@i);      # skip hotbot builtins
1508     next if ($u =~ m@[/.]inktomi\.com\b@i);    # skip hotbot builtins
1509
1510     LOG ($verbose_filter, "  candidate: $u");
1511     push @candidates, $u;
1512   }
1513
1514   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1515                                 $timeout, @candidates);
1516 }
1517
1518
1519 \f
1520 ############################################################################
1521 #
1522 # Pick images by feeding random words into Lycos
1523 #
1524 ############################################################################
1525
1526 my $lycos_search_url = "http://search.lycos.com/default.asp" .
1527                        "?lpv=1" .
1528                        "&loc=searchhp" .
1529                        "&tab=web" .
1530                        "&query=";
1531
1532 sub pick_from_lycos_text($) {
1533   my ($timeout) = @_;
1534
1535   $last_search = $lycos_search_url;   # for warnings
1536
1537   # lycos seems to always give us back dictionaries and word lists if
1538   # we search for more than one word...
1539   #
1540   my $words = random_word();
1541
1542   my $start = int(rand(8)) * 10 + 1;
1543   my $search_url = $lycos_search_url . $words . "&first=$start&page=more";
1544
1545   my ($search_hit_count, @subpages) =
1546     pick_from_search_engine ($timeout, $search_url, $words);
1547
1548   my @candidates = ();
1549   foreach my $u (@subpages) {
1550
1551     # Lycos plays redirection games.
1552     # (not any more?)
1553 #    next unless ($u =~ m@^http://click.lycos.com/director.asp
1554 #                         .*
1555 #                         \btarget=([^&]+)
1556 #                         .*
1557 #                        @x);
1558 #    $u = url_decode($1);
1559
1560     next unless ($u =~ m@^http://@i);    #  skip non-HTTP or relative URLs
1561     next if ($u =~ m@[/.]hotbot\.com\b@i);     # skip lycos builtins
1562     next if ($u =~ m@[/.]lycos\.com\b@i);      # skip lycos builtins
1563     next if ($u =~ m@[/.]terralycos\.com\b@i); # skip lycos builtins
1564     next if ($u =~ m@[/.]inktomi\.com\b@i);    # skip lycos builtins
1565
1566
1567     LOG ($verbose_filter, "  candidate: $u");
1568     push @candidates, $u;
1569   }
1570
1571   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1572                                 $timeout, @candidates);
1573 }
1574
1575
1576 \f
1577 ############################################################################
1578 #
1579 # Pick images by feeding random words into news.yahoo.com
1580 #
1581 ############################################################################
1582
1583 my $yahoo_news_url = "http://news.search.yahoo.com/search/news" .
1584                      "?c=news_photos" .
1585                      "&p=";
1586
1587 # yahoonews
1588 sub pick_from_yahoo_news_text($) {
1589   my ($timeout) = @_;
1590
1591   $last_search = $yahoo_news_url;   # for warnings
1592
1593   my $words = random_word();
1594   my $search_url = $yahoo_news_url . $words;
1595
1596   my ($search_hit_count, @subpages) =
1597     pick_from_search_engine ($timeout, $search_url, $words);
1598
1599   my @candidates = ();
1600   foreach my $u (@subpages) {
1601
1602     # de-redirectize the URLs
1603     $u =~ s@^http://rds\.yahoo\.com/.*-http%3A@http:@s;
1604
1605     # only accept URLs on Yahoo's news site
1606     next unless ($u =~ m@^http://dailynews\.yahoo\.com/@i ||
1607                  $u =~ m@^http://story\.news\.yahoo\.com/@i);
1608     next unless ($u =~ m@&u=/@);
1609
1610     LOG ($verbose_filter, "  candidate: $u");
1611     push @candidates, $u;
1612   }
1613
1614   return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1,
1615                                 $timeout, @candidates);
1616 }
1617
1618
1619 \f
1620 ############################################################################
1621 #
1622 # Pick images from LiveJournal's list of recently-posted images.
1623 #
1624 ############################################################################
1625
1626 my $livejournal_img_url = "http://www.livejournal.com/stats/latest-img.bml";
1627
1628 # With most of our image sources, we get a random page and then select
1629 # from the images on it.  However, in the case of LiveJournal, the page
1630 # of images tends to update slowly; so we'll remember the last N entries
1631 # on it and randomly select from those, to get a wider variety each time.
1632
1633 my $lj_cache_size = 1000;
1634 my @lj_cache = (); # fifo, for ordering by age
1635 my %lj_cache = (); # hash, for detecting dups
1636
1637 # livejournal
1638 sub pick_from_livejournal_images($) {
1639   my ($timeout) = @_;
1640
1641   $last_search = $livejournal_img_url;   # for warnings
1642
1643   my ( $base, $body ) = get_document ($livejournal_img_url, undef, $timeout);
1644   return () unless $body;
1645
1646   $body =~ s/\n/ /gs;
1647   $body =~ s/(<recent-image)\b/\n$1/gsi;
1648
1649   foreach (split (/\n/, $body)) {
1650     next unless (m/^<recent-image\b/);
1651     next unless (m/\bIMG=[\'\"]([^\'\"]+)[\'\"]/si);
1652     my $img = html_unquote ($1);
1653
1654     next if ($lj_cache{$img}); # already have it
1655
1656     next unless (m/\bURL=[\'\"]([^\'\"]+)[\'\"]/si);
1657     my $page = html_unquote ($1);
1658     my @pair = ($img, $page);
1659     LOG ($verbose_filter, "  candidate: $img");
1660     push @lj_cache, \@pair;
1661     $lj_cache{$img} = \@pair;
1662   }
1663
1664   return () if ($#lj_cache == -1);
1665
1666   my $n = $#lj_cache+1;
1667   my $i = int(rand($n));
1668   my ($img, $page) = @{$lj_cache[$i]};
1669
1670   # delete this one from @lj_cache and from %lj_cache.
1671   #
1672   @lj_cache = ( @lj_cache[0 .. $i-1],
1673                 @lj_cache[$i+1 .. $#lj_cache] );
1674   delete $lj_cache{$img};
1675
1676   # Keep the size of the cache under the limit by nuking older entries
1677   #
1678   while ($#lj_cache >= $lj_cache_size) {
1679     my $pairP = shift @lj_cache;
1680     my $img = $pairP->[0];
1681     delete $lj_cache{$img};
1682   }
1683
1684   LOG ($verbose_load, "picked image " .($i+1) . "/$n: $img");
1685
1686   return ($page, $img);
1687 }
1688
1689 \f
1690 ############################################################################
1691 #
1692 # Pick images from ircimages.com (images that have been in the /topic of
1693 # various IRC channels.)
1694 #
1695 ############################################################################
1696
1697 my $ircimages_url = "http://ircimages.com/";
1698
1699 # ircimages
1700 sub pick_from_ircimages($) {
1701   my ($timeout) = @_;
1702
1703   $last_search = $ircimages_url;   # for warnings
1704
1705   my $n = int(rand(2900));
1706   my $search_url = $ircimages_url . "page-$n";
1707
1708   my ( $base, $body ) = get_document ($search_url, undef, $timeout);
1709   return () unless $body;
1710
1711   my @candidates = ();
1712
1713   $body =~ s/\n/ /gs;
1714   $body =~ s/(<A)\b/\n$1/gsi;
1715
1716   foreach (split (/\n/, $body)) {
1717
1718     my ($u) = m@<A\s.*\bHREF\s*=\s*([^>]+)>@i;
1719     next unless $u;
1720
1721     if ($u =~ m/^\"([^\"]*)\"/) { $u = $1; }   # quoted string
1722     elsif ($u =~ m/^([^\s]*)\s/) { $u = $1; }  # or token
1723
1724     next unless ($u =~ m/^http:/i);
1725     next if ($u =~ m@^http://(searchirc\.com\|ircimages\.com)@i);
1726     next unless ($u =~ m@[.](gif|jpg|jpeg|pjpg|pjpeg|png)$@i);
1727
1728     LOG ($verbose_http, "    HREF: $u");
1729     push @candidates, $u;
1730   }
1731
1732   LOG ($verbose_filter, "" . $#candidates+1 . " links on $search_url");
1733
1734   return () if ($#candidates == -1);
1735
1736   my $i = int(rand($#candidates+1));
1737   my $img = $candidates[$i];
1738
1739   LOG ($verbose_load, "picked image " .($i+1) . "/" . ($#candidates+1) .
1740        ": $img");
1741
1742   $search_url = $img;  # hmm...
1743   return ($search_url, $img);
1744 }
1745
1746 \f
1747 ############################################################################
1748 #
1749 # Pick images from Flickr's page of recently-posted photos.
1750 #
1751 ############################################################################
1752
1753 my $flickr_img_url = "http://www.flickr.com/photos/";
1754
1755 # Like LiveJournal, the Flickr page of images tends to update slowly,
1756 # so remember the last N entries on it and randomly select from those.
1757
1758 # I know that Flickr has an API (http://www.flickr.com/services/api/)
1759 # but it was easy enough to scrape the HTML, so I didn't bother exploring.
1760
1761 my $flickr_cache_size = 1000;
1762 my @flickr_cache = (); # fifo, for ordering by age
1763 my %flickr_cache = (); # hash, for detecting dups
1764
1765
1766 # flickr
1767 sub pick_from_flickr($) {
1768   my ($timeout) = @_;
1769
1770   my $start = 16 * int(rand(100));
1771
1772   $last_search = $flickr_img_url;   # for warnings
1773   $last_search .= "?start=$start" if ($start > 0);
1774
1775   my ( $base, $body ) = get_document ($last_search, undef, $timeout);
1776   return () unless $body;
1777
1778   $body =~ s/[\r\n]/ /gs;
1779   $body =~ s/(<a)\b/\n$1/gsi;
1780
1781   my $count = 0;
1782   my $count2 = 0;
1783   foreach (split (/\n/, $body)) {
1784     my ($page, $thumb) = m@<A \s [^<>]* \b HREF=\"([^<>\"]+)\" [^<>]* > \s*
1785                            <IMG \s [^<>]* \b SRC=\"([^<>\"]+)\" @xsi;
1786     next unless defined ($thumb);
1787     $page = html_unquote ($page);
1788     $thumb = html_unquote ($thumb);
1789
1790     next unless ($thumb =~ m@^http://photos\d*\.flickr\.com/@);
1791
1792     my $base = "http://www.flickr.com/";
1793     $page  =~ s@^/@$base@;
1794     $thumb =~ s@^/@$base@;
1795
1796     my $img = $thumb;
1797     $img =~ s/_[a-z](\.[a-z\d]+)$/$1/si;  # take off "thumb" suffix
1798
1799     $count++;
1800     next if ($flickr_cache{$img}); # already have it
1801
1802     my @pair = ($img, $page, $start);
1803     LOG ($verbose_filter, "  candidate: $img");
1804     push @flickr_cache, \@pair;
1805     $flickr_cache{$img} = \@pair;
1806     $count2++;
1807   }
1808
1809   return () if ($#flickr_cache == -1);
1810
1811   my $n = $#flickr_cache+1;
1812   my $i = int(rand($n));
1813   my ($img, $page) = @{$flickr_cache[$i]};
1814
1815   # delete this one from @flickr_cache and from %flickr_cache.
1816   #
1817   @flickr_cache = ( @flickr_cache[0 .. $i-1],
1818                     @flickr_cache[$i+1 .. $#flickr_cache] );
1819   delete $flickr_cache{$img};
1820
1821   # Keep the size of the cache under the limit by nuking older entries
1822   #
1823   while ($#flickr_cache >= $flickr_cache_size) {
1824     my $pairP = shift @flickr_cache;
1825     my $img = $pairP->[0];
1826     delete $flickr_cache{$img};
1827   }
1828
1829   LOG ($verbose_load, "picked image " .($i+1) . "/$n: $img");
1830
1831   return ($page, $img);
1832 }
1833
1834 \f
1835 ############################################################################
1836 #
1837 # Pick images by waiting for driftnet to populate a temp dir with files.
1838 # Requires driftnet version 0.1.5 or later.
1839 # (Driftnet is a program by Chris Lightfoot that sniffs your local ethernet
1840 # for images being downloaded by others.)
1841 # Driftnet/webcollage integration by jwz.
1842 #
1843 ############################################################################
1844
1845 # driftnet
1846 sub pick_from_driftnet($) {
1847   my ($timeout) = @_;
1848
1849   my $id = $driftnet_magic;
1850   my $dir = $driftnet_dir;
1851   my $start = time;
1852   my $now;
1853
1854   error ("\$driftnet_dir unset?") unless ($dir);
1855   $dir =~ s@/+$@@;
1856
1857   error ("$dir unreadable") unless (-d "$dir/.");
1858
1859   $timeout = $http_timeout unless ($timeout);
1860   $last_search = $id;
1861
1862   while ($now = time, $now < $start + $timeout) {
1863     local *DIR;
1864     opendir (DIR, $dir) || error ("$dir: $!");
1865     while (my $file = readdir(DIR)) {
1866       next if ($file =~ m/^\./);
1867       $file = "$dir/$file";
1868       closedir DIR;
1869       LOG ($verbose_load, "picked file $file ($id)");
1870       return ($id, $file);
1871     }
1872     closedir DIR;
1873   }
1874   LOG (($verbose_net || $verbose_load), "timed out for $id");
1875   return ();
1876 }
1877
1878
1879 sub get_driftnet_file($) {
1880   my ($file) = @_;
1881
1882   error ("\$driftnet_dir unset?") unless ($driftnet_dir);
1883
1884   my $id = $driftnet_magic;
1885   my $re = qr/$driftnet_dir/;
1886   error ("$id: $file not in $driftnet_dir?")
1887     unless ($file =~ m@^$re@o);
1888
1889   local *IN;
1890   open (IN, $file) || error ("$id: $file: $!");
1891   my $body = '';
1892   while (<IN>) { $body .= $_; }
1893   close IN || error ("$id: $file: $!");
1894   unlink ($file) || error ("$id: $file: rm: $!");
1895   return ($id, $body);
1896 }
1897
1898
1899 sub spawn_driftnet($) {
1900   my ($cmd) = @_;
1901
1902   # make a directory to use.
1903   while (1) {
1904     my $tmp = $ENV{TEMPDIR} || "/tmp";
1905     $driftnet_dir = sprintf ("$tmp/driftcollage-%08x", rand(0xffffffff));
1906     LOG ($verbose_exec, "mkdir $driftnet_dir");
1907     last if mkdir ($driftnet_dir, 0700);
1908   }
1909
1910   if (! ($cmd =~ m/\s/)) {
1911     # if the command didn't have any arguments in it, then it must be just
1912     # a pointer to the executable.  Append the default args to it.
1913     my $dargs = $default_driftnet_cmd;
1914     $dargs =~ s/^[^\s]+//;
1915     $cmd .= $dargs;
1916   }
1917
1918   # point the driftnet command at our newly-minted private directory.
1919   #
1920   $cmd .= " -d $driftnet_dir";
1921   $cmd .= ">/dev/null" unless ($verbose_exec);
1922
1923   my $pid = fork();
1924   if ($pid < 0) { error ("fork: $!\n"); }
1925   if ($pid) {
1926     # parent fork
1927     push @pids_to_kill, $pid;
1928     LOG ($verbose_exec, "forked for \"$cmd\"");
1929   } else {
1930     # child fork
1931     nontrapping_system ($cmd) || error ("exec: $!");
1932   }
1933
1934   # wait a bit, then make sure the process actually started up.
1935   #
1936   sleep (1);
1937   error ("pid $pid failed to start \"$cmd\"")
1938     unless (1 == kill (0, $pid));
1939 }
1940
1941 \f
1942 ############################################################################
1943 #
1944 # Pick a random image in a random way
1945 #
1946 ############################################################################
1947
1948
1949 # Picks a random image on a random page, and returns two URLs:
1950 # the page containing the image, and the image.
1951 # Returns () if nothing found this time.
1952 #
1953
1954 sub pick_image(;$) {
1955   my ($timeout) = @_;
1956
1957   $current_state = "select";
1958   $load_method = "none";
1959
1960   my $n = int(rand(100));
1961   my $fn = undef;
1962   my $total = 0;
1963   my @rest = @search_methods;
1964
1965   while (@rest) {
1966     my $pct  = shift @rest;
1967     my $name = shift @rest;
1968     my $tfn  = shift @rest;
1969     $total += $pct;
1970     if ($total > $n && !defined($fn)) {
1971       $fn = $tfn;
1972       $current_state = $name;
1973       $load_method = $current_state;
1974     }
1975   }
1976
1977   if ($total != 100) {
1978     error ("internal error: \@search_methods totals to $total%!");
1979   }
1980
1981   record_attempt ($current_state);
1982   return $fn->($timeout);
1983 }
1984
1985
1986 \f
1987 ############################################################################
1988 #
1989 # Statistics and logging
1990 #
1991 ############################################################################
1992
1993 sub timestr() {
1994   return strftime ("%H:%M:%S: ", localtime);
1995 }
1996
1997 sub blurb() {
1998   return "$progname: " . timestr() . "$current_state: ";
1999 }
2000
2001 sub error($) {
2002   my ($err) = @_;
2003   print STDERR blurb() . "$err\n";
2004   exit 1;
2005 }
2006
2007 sub stacktrace() {
2008   my $i = 1;
2009   print STDERR "$progname: stack trace:\n";
2010   while (1) {
2011     my ($package, $filename, $line, $subroutine) = caller($i++);
2012     last unless defined($package);
2013     $filename =~ s@^.*/@@;
2014     print STDERR "  $filename#$line, $subroutine\n";
2015   }
2016 }
2017
2018
2019 my $lastlog = "";
2020
2021 sub clearlog() {
2022   $lastlog = "";
2023 }
2024
2025 sub showlog() {
2026   my $head = "$progname: DEBUG: ";
2027   foreach (split (/\n/, $lastlog)) {
2028     print STDERR "$head$_\n";
2029   }
2030   $lastlog = "";
2031 }
2032
2033 sub LOG($$) {
2034   my ($print, $msg) = @_;
2035   my $blurb = timestr() . "$current_state: ";
2036   $lastlog .= "$blurb$msg\n";
2037   print STDERR "$progname: $blurb$msg\n" if $print;
2038 }
2039
2040
2041 my %stats_attempts;
2042 my %stats_successes;
2043 my %stats_elapsed;
2044
2045 my $last_state = undef;
2046 sub record_attempt($) {
2047   my ($name) = @_;
2048
2049   if ($last_state) {
2050     record_failure($last_state) unless ($image_succeeded > 0);
2051   }
2052   $last_state = $name;
2053
2054   clearlog();
2055   report_performance();
2056
2057   start_timer($name);
2058   $image_succeeded = 0;
2059   $suppress_audit = 0;
2060 }
2061
2062 sub record_success($$$) {
2063   my ($name, $url, $base) = @_;
2064   if (defined($stats_successes{$name})) {
2065     $stats_successes{$name}++;
2066   } else {
2067     $stats_successes{$name} = 1;
2068   }
2069
2070   stop_timer ($name, 1);
2071   my $o = $current_state;
2072   $current_state = $name;
2073   save_recent_url ($url, $base);
2074   $current_state = $o;
2075   $image_succeeded = 1;
2076   clearlog();
2077 }
2078
2079
2080 sub record_failure($) {
2081   my ($name) = @_;
2082
2083   return if $image_succeeded;
2084
2085   stop_timer ($name, 0);
2086   if ($verbose_load && !$verbose_exec) {
2087
2088     if ($suppress_audit) {
2089       print STDERR "$progname: " . timestr() . "(audit log suppressed)\n";
2090       return;
2091     }
2092
2093     my $o = $current_state;
2094     $current_state = "DEBUG";
2095
2096     my $line =  "#" x 78;
2097     print STDERR "\n\n\n";
2098     print STDERR ("#" x 78) . "\n";
2099     print STDERR blurb() . "failed to get an image.  Full audit log:\n";
2100     print STDERR "\n";
2101     showlog();
2102     print STDERR ("-" x 78) . "\n";
2103     print STDERR "\n\n";
2104
2105     $current_state = $o;
2106   }
2107   $image_succeeded = 0;
2108 }
2109
2110
2111
2112 sub stats_of($) {
2113   my ($name) = @_;
2114   my $i = $stats_successes{$name};
2115   my $j = $stats_attempts{$name};
2116   $i = 0 unless $i;
2117   $j = 0 unless $j;
2118   return "" . ($j ? int($i * 100 / $j) : "0") . "%";
2119 }
2120
2121
2122 my $current_start_time = 0;
2123
2124 sub start_timer($) {
2125   my ($name) = @_;
2126   $current_start_time = time;
2127
2128   if (defined($stats_attempts{$name})) {
2129     $stats_attempts{$name}++;
2130   } else {
2131     $stats_attempts{$name} = 1;
2132   }
2133   if (!defined($stats_elapsed{$name})) {
2134     $stats_elapsed{$name} = 0;
2135   }
2136 }
2137
2138 sub stop_timer($$) {
2139   my ($name, $success) = @_;
2140   $stats_elapsed{$name} += time - $current_start_time;
2141 }
2142
2143
2144 my $last_report_time = 0;
2145 sub report_performance() {
2146
2147   return unless $verbose_warnings;
2148
2149   my $now = time;
2150   return unless ($now >= $last_report_time + $report_performance_interval);
2151   my $ot = $last_report_time;
2152   $last_report_time = $now;
2153
2154   return if ($ot == 0);
2155
2156   my $blurb = "$progname: " . timestr();
2157
2158   print STDERR "\n";
2159   print STDERR "${blurb}Current standings:\n";
2160
2161   foreach my $name (sort keys (%stats_attempts)) {
2162     my $try = $stats_attempts{$name};
2163     my $suc = $stats_successes{$name} || 0;
2164     my $pct = int($suc * 100 / $try);
2165     my $secs = $stats_elapsed{$name};
2166     my $secs_link = int($secs / $try);
2167     print STDERR sprintf ("$blurb   %-12s %4s (%d/%d);\t %2d secs/link\n",
2168                           "$name:", "$pct%", $suc, $try, $secs_link);
2169   }
2170 }
2171
2172
2173
2174 my $max_recent_images = 400;
2175 my $max_recent_sites  = 20;
2176 my @recent_images = ();
2177 my @recent_sites = ();
2178
2179 sub save_recent_url($$) {
2180   my ($url, $base) = @_;
2181
2182   return unless ($verbose_warnings);
2183
2184   $_ = $url;
2185   my ($site) = m@^http://([^ \t\n\r/:]+)@;
2186   return unless defined ($site);
2187
2188   if ($base eq $driftnet_magic) {
2189     $site = $driftnet_magic;
2190     @recent_images = ();
2191   }
2192
2193   my $done = 0;
2194   foreach (@recent_images) {
2195     if ($_ eq $url) {
2196       print STDERR blurb() . "WARNING: recently-duplicated image: $url" .
2197         " (on $base via $last_search)\n";
2198       $done = 1;
2199       last;
2200     }
2201   }
2202
2203   # suppress "duplicate site" warning via %warningless_sites.
2204   #
2205   if ($warningless_sites{$site}) {
2206     $done = 1;
2207   } elsif ($site =~ m@([^.]+\.[^.]+\.[^.]+)$@ &&
2208            $warningless_sites{$1}) {
2209     $done = 1;
2210   } elsif ($site =~ m@([^.]+\.[^.]+)$@ &&
2211            $warningless_sites{$1}) {
2212     $done = 1;
2213   }
2214
2215   if (!$done) {
2216     foreach (@recent_sites) {
2217       if ($_ eq $site) {
2218         print STDERR blurb() . "WARNING: recently-duplicated site: $site" .
2219         " ($url on $base via $last_search)\n";
2220         last;
2221       }
2222     }
2223   }
2224
2225   push @recent_images, $url;
2226   push @recent_sites,  $site;
2227   shift @recent_images if ($#recent_images >= $max_recent_images);
2228   shift @recent_sites  if ($#recent_sites  >= $max_recent_sites);
2229 }
2230
2231
2232 \f
2233 ##############################################################################
2234 #
2235 # other utilities
2236 #
2237 ##############################################################################
2238
2239 # Does %-decoding.
2240 #
2241 sub url_decode($) {
2242   ($_) = @_;
2243   tr/+/ /;
2244   s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
2245   return $_;
2246 }
2247
2248
2249 # Given the raw body of a GIF document, returns the dimensions of the image.
2250 #
2251 sub gif_size($) {
2252   my ($body) = @_;
2253   my $type = substr($body, 0, 6);
2254   my $s;
2255   return () unless ($type =~ /GIF8[7,9]a/);
2256   $s = substr ($body, 6, 10);
2257   my ($a,$b,$c,$d) = unpack ("C"x4, $s);
2258   return (($b<<8|$a), ($d<<8|$c));
2259 }
2260
2261 # Given the raw body of a JPEG document, returns the dimensions of the image.
2262 #
2263 sub jpeg_size($) {
2264   my ($body) = @_;
2265   my $i = 0;
2266   my $L = length($body);
2267
2268   my $c1 = substr($body, $i, 1); $i++;
2269   my $c2 = substr($body, $i, 1); $i++;
2270   return () unless (ord($c1) == 0xFF && ord($c2) == 0xD8);
2271
2272   my $ch = "0";
2273   while (ord($ch) != 0xDA && $i < $L) {
2274     # Find next marker, beginning with 0xFF.
2275     while (ord($ch) != 0xFF) {
2276       return () if (length($body) <= $i);
2277       $ch = substr($body, $i, 1); $i++;
2278     }
2279     # markers can be padded with any number of 0xFF.
2280     while (ord($ch) == 0xFF) {
2281       return () if (length($body) <= $i);
2282       $ch = substr($body, $i, 1); $i++;
2283     }
2284
2285     # $ch contains the value of the marker.
2286     my $marker = ord($ch);
2287
2288     if (($marker >= 0xC0) &&
2289         ($marker <= 0xCF) &&
2290         ($marker != 0xC4) &&
2291         ($marker != 0xCC)) {  # it's a SOFn marker
2292       $i += 3;
2293       return () if (length($body) <= $i);
2294       my $s = substr($body, $i, 4); $i += 4;
2295       my ($a,$b,$c,$d) = unpack("C"x4, $s);
2296       return (($c<<8|$d), ($a<<8|$b));
2297
2298     } else {
2299       # We must skip variables, since FFs in variable names aren't
2300       # valid JPEG markers.
2301       return () if (length($body) <= $i);
2302       my $s = substr($body, $i, 2); $i += 2;
2303       my ($c1, $c2) = unpack ("C"x2, $s);
2304       my $length = ($c1 << 8) | $c2;
2305       return () if ($length < 2);
2306       $i += $length-2;
2307     }
2308   }
2309   return ();
2310 }
2311
2312 # Given the raw body of a PNG document, returns the dimensions of the image.
2313 #
2314 sub png_size($) {
2315   my ($body) = @_;
2316   return () unless ($body =~ m/^\211PNG\r/);
2317   my ($bits) = ($body =~ m/^.{12}(.{12})/s);
2318   return () unless defined ($bits);
2319   return () unless ($bits =~ /^IHDR/);
2320   my ($ign, $w, $h) = unpack("a4N2", $bits);
2321   return ($w, $h);
2322 }
2323
2324
2325 # Given the raw body of a GIF, JPEG, or PNG document, returns the dimensions
2326 # of the image.
2327 #
2328 sub image_size($) {
2329   my ($body) = @_;
2330   my ($w, $h) = gif_size ($body);
2331   if ($w && $h) { return ($w, $h); }
2332   ($w, $h) = jpeg_size ($body);
2333   if ($w && $h) { return ($w, $h); }
2334   return png_size ($body);
2335 }
2336
2337
2338 # returns the full path of the named program, or undef.
2339 #
2340 sub which($) {
2341   my ($prog) = @_;
2342   foreach (split (/:/, $ENV{PATH})) {
2343     if (-x "$_/$prog") {
2344       return $prog;
2345     }
2346   }
2347   return undef;
2348 }
2349
2350
2351 # Like rand(), but chooses numbers with a bell curve distribution.
2352 sub bellrand(;$) {
2353   ($_) = @_;
2354   $_ = 1.0 unless defined($_);
2355   $_ /= 3.0;
2356   return (rand($_) + rand($_) + rand($_));
2357 }
2358
2359
2360 sub exit_cleanup() {
2361   x_cleanup();
2362   print STDERR "$progname: exiting\n" if ($verbose_warnings);
2363   if (@pids_to_kill) {
2364     print STDERR blurb() . "killing: " . join(' ', @pids_to_kill) . "\n";
2365     kill ('TERM', @pids_to_kill);
2366   }
2367 }
2368
2369 sub signal_cleanup($) {
2370   my ($sig) = @_;
2371   print STDERR blurb() . (defined($sig)
2372                           ? "caught signal $sig."
2373                           : "exiting.")
2374                        . "\n"
2375     if ($verbose_exec || $verbose_warnings);
2376   exit 1;
2377 }
2378
2379
2380
2381 ##############################################################################
2382 #
2383 # Generating a list of urls only
2384 #
2385 ##############################################################################
2386
2387 sub url_only_output() {
2388   do {
2389     my ($base, $img) = pick_image;
2390     if ($img) {
2391       $base =~ s/ /%20/g;
2392       $img  =~ s/ /%20/g;
2393       print "$img $base\n";
2394     }
2395   } while (1);
2396 }
2397
2398 ##############################################################################
2399 #
2400 # Running as an xscreensaver module, or as a web page imagemap
2401 #
2402 ##############################################################################
2403
2404 my $image_ppm   = sprintf ("%s/webcollage-%08x",
2405                            ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp"),
2406                            rand(0xFFFFFFFF));
2407 my $image_tmp1  = sprintf ("%s/webcollage-1-%08x",
2408                            ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp"),
2409                            rand(0xFFFFFFFF));
2410 my $image_tmp2  = sprintf ("%s/webcollage-2-%08x",
2411                            ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp"),
2412                            rand(0xFFFFFFFF));
2413
2414 my $filter_cmd = undef;
2415 my $post_filter_cmd = undef;
2416 my $background = undef;
2417
2418 my @imagemap_areas = ();
2419 my $imagemap_html_tmp = undef;
2420 my $imagemap_jpg_tmp = undef;
2421
2422
2423 my $img_width;            # size of the image being generated.
2424 my $img_height;
2425
2426 my $delay = 2;
2427
2428 sub x_cleanup() {
2429   unlink $image_ppm, $image_tmp1, $image_tmp2;
2430   unlink $imagemap_html_tmp, $imagemap_jpg_tmp
2431     if (defined ($imagemap_html_tmp));
2432 }
2433
2434
2435 # Like system, but prints status about exit codes, and kills this process
2436 # with whatever signal killed the sub-process, if any.
2437 #
2438 sub nontrapping_system(@) {
2439   $! = 0;
2440
2441   $_ = join(" ", @_);
2442   s/\"[^\"]+\"/\"...\"/g;
2443
2444   LOG ($verbose_exec, "executing \"$_\"");
2445
2446   my $rc = system @_;
2447
2448   if ($rc == 0) {
2449     LOG ($verbose_exec, "subproc exited normally.");
2450   } elsif (($rc & 0xff) == 0) {
2451     $rc >>= 8;
2452     LOG ($verbose_exec, "subproc exited with status $rc.");
2453   } else {
2454     if ($rc & 0x80) {
2455       LOG ($verbose_exec, "subproc dumped core.");
2456       $rc &= ~0x80;
2457     }
2458     LOG ($verbose_exec, "subproc died with signal $rc.");
2459     # die that way ourselves.
2460     kill $rc, $$;
2461   }
2462
2463   return $rc;
2464 }
2465
2466
2467 # Given the URL of a GIF, JPEG, or PNG image, and the body of that image,
2468 # writes a PPM to the given output file.  Returns the width/height of the
2469 # image if successful.
2470 #
2471 sub image_to_pnm($$$) {
2472   my ($url, $body, $output) = @_;
2473   my ($cmd, $cmd2, $w, $h);
2474
2475   if ((@_ = gif_size ($body))) {
2476     ($w, $h) = @_;
2477     $cmd = "giftopnm";
2478   } elsif ((@_ = jpeg_size ($body))) {
2479     ($w, $h) = @_;
2480     $cmd = "djpeg";
2481   } elsif ((@_ = png_size ($body))) {
2482     ($w, $h) = @_;
2483     $cmd = "pngtopnm";
2484   } else {
2485     LOG (($verbose_pbm || $verbose_load),
2486          "not a GIF, JPG, or PNG" .
2487          (($body =~ m@<(base|html|head|body|script|table|a href)\b@i)
2488           ? " (looks like HTML)" : "") .
2489          ": $url");
2490     $suppress_audit = 1;
2491     return ();
2492   }
2493
2494   $cmd2 = "exec $cmd";        # yes, this really is necessary.  if we don't
2495                               # do this, the process doesn't die properly.
2496   if (!$verbose_pbm) {
2497     #
2498     # We get a "giftopnm: got a 'Application Extension' extension"
2499     # warning any time it's an animgif.
2500     #
2501     # Note that "giftopnm: EOF / read error on image data" is not
2502     # always a fatal error -- sometimes the image looks fine anyway.
2503     #
2504     $cmd2 .= " 2>/dev/null";
2505   }
2506
2507   # There exist corrupted GIF and JPEG files that can make giftopnm and
2508   # djpeg lose their minds and go into a loop.  So this gives those programs
2509   # a small timeout -- if they don't complete in time, kill them.
2510   #
2511   my $pid;
2512   @_ = eval {
2513     my $timed_out;
2514
2515     local $SIG{ALRM}  = sub {
2516       LOG ($verbose_pbm,
2517            "timed out ($cvt_timeout) for $cmd on \"$url\" in pid $pid");
2518       kill ('TERM', $pid) if ($pid);
2519       $timed_out = 1;
2520       $body = undef;
2521     };
2522
2523     if (($pid = open(PIPE, "| $cmd2 > $output"))) {
2524       $timed_out = 0;
2525       alarm $cvt_timeout;
2526       print PIPE $body;
2527       $body = undef;
2528       close PIPE;
2529
2530       LOG ($verbose_exec, "awaiting $pid");
2531       waitpid ($pid, 0);
2532       LOG ($verbose_exec, "$pid completed");
2533
2534       my $size = (stat($output))[7];
2535       $size = -1 unless defined($size);
2536       if ($size < 5) {
2537         LOG ($verbose_pbm, "$cmd on ${w}x$h \"$url\" failed ($size bytes)");
2538         return ();
2539       }
2540
2541       LOG ($verbose_pbm, "created ${w}x$h $output ($cmd)");
2542       return ($w, $h);
2543     } else {
2544       print STDERR blurb() . "$cmd failed: $!\n";
2545       return ();
2546     }
2547   };
2548   die if ($@ && $@ ne "alarm\n");       # propagate errors
2549   if ($@) {
2550     # timed out
2551     $body = undef;
2552     return ();
2553   } else {
2554     # didn't
2555     alarm 0;
2556     $body = undef;
2557     return @_;
2558   }
2559 }
2560
2561 sub pick_root_displayer() {
2562   my @names = ();
2563
2564   foreach my $cmd (@root_displayers) {
2565     $_ = $cmd;
2566     my ($name) = m/^([^ ]+)/;
2567     push @names, "\"$name\"";
2568     LOG ($verbose_exec, "looking for $name...");
2569     foreach my $dir (split (/:/, $ENV{PATH})) {
2570       LOG ($verbose_exec, "  checking $dir/$name");
2571       return $cmd if (-x "$dir/$name");
2572     }
2573   }
2574
2575   $names[$#names] = "or " . $names[$#names];
2576   error "none of: " . join (", ", @names) . " were found on \$PATH.";
2577 }
2578
2579
2580 my $ppm_to_root_window_cmd = undef;
2581
2582
2583 sub x_or_pbm_output($) {
2584   my ($window_id) = @_;
2585
2586   # Check for our helper program, to see whether we need to use PPM pipelines.
2587   #
2588   $_ = "webcollage-helper";
2589   if (defined ($webcollage_helper) || which ($_)) {
2590     $webcollage_helper = $_ unless (defined($webcollage_helper));
2591     LOG ($verbose_pbm, "found \"$webcollage_helper\"");
2592     $webcollage_helper .= " -v";
2593   } else {
2594     LOG (($verbose_pbm || $verbose_load), "no $_ program");
2595   }
2596
2597   # make sure the various programs we execute exist, right up front.
2598   #
2599   my @progs = ("ppmmake");  # always need this one
2600
2601   if (!defined($webcollage_helper)) {
2602     # Only need these others if we don't have the helper.
2603     @progs = (@progs,
2604               "giftopnm", "pngtopnm", "djpeg",
2605               "pnmpaste", "pnmscale", "pnmcut");
2606   }
2607
2608   foreach (@progs) {
2609     which ($_) || error "$_ not found on \$PATH.";
2610   }
2611
2612   # find a root-window displayer program.
2613   #
2614   $ppm_to_root_window_cmd = pick_root_displayer();
2615
2616   if (defined ($window_id)) {
2617     error ("-window-id only works if xscreensaver-getimage is installed")
2618       unless ($ppm_to_root_window_cmd =~ m/^xscreensaver-getimage\b/);
2619
2620     error ("unparsable window id: $window_id")
2621       unless ($window_id =~ m/^\d+$|^0x[\da-f]+$/i);
2622     $ppm_to_root_window_cmd =~ s/--?root\b/$window_id/ ||
2623       error ("unable to munge displayer: $ppm_to_root_window_cmd");
2624   }
2625
2626   if (!$img_width || !$img_height) {
2627
2628     if (!defined ($window_id) &&
2629         defined ($ENV{XSCREENSAVER_WINDOW})) {
2630       $window_id = $ENV{XSCREENSAVER_WINDOW};
2631     }
2632
2633     if (!defined ($window_id)) {
2634       $_ = "xdpyinfo";
2635       which ($_) || error "$_ not found on \$PATH.";
2636       $_ = `$_`;
2637       ($img_width, $img_height) = m/dimensions: *(\d+)x(\d+) /;
2638       if (!defined($img_height)) {
2639         error "xdpyinfo failed.";
2640       }
2641     } else {  # we have a window id
2642       $_ = "xwininfo";
2643       which ($_) || error "$_ not found on \$PATH.";
2644       $_ .= " -id $window_id";
2645       $_ = `$_`;
2646       ($img_width, $img_height) = m/^\s*Width:\s*(\d+)\n\s*Height:\s*(\d+)\n/m;
2647
2648       if (!defined($img_height)) {
2649         error "xwininfo failed.";
2650       }
2651     }
2652   }
2653
2654   my $bgcolor = "#000000";
2655   my $bgimage = undef;
2656
2657   if ($background) {
2658     if ($background =~ m/^\#[0-9a-f]+$/i) {
2659       $bgcolor = $background;
2660
2661     } elsif (-r $background) {
2662       $bgimage = $background;
2663
2664     } elsif (! $background =~ m@^[-a-z0-9 ]+$@i) {
2665       error "not a color or readable file: $background";
2666
2667     } else {
2668       # default to assuming it's a color
2669       $bgcolor = $background;
2670     }
2671   }
2672
2673   # Create the sold-colored base image.
2674   #
2675   $_ = "ppmmake '$bgcolor' $img_width $img_height";
2676   LOG ($verbose_pbm, "creating base image: $_");
2677   nontrapping_system "$_ > $image_ppm";
2678
2679   # Paste the default background image in the middle of it.
2680   #
2681   if ($bgimage) {
2682     my ($iw, $ih);
2683
2684     my $body = "";
2685     local *IMG;
2686     open(IMG, "<$bgimage") || error "couldn't open $bgimage: $!";
2687     my $cmd;
2688     while (<IMG>) { $body .= $_; }
2689     close (IMG);
2690
2691     if ((@_ = gif_size ($body))) {
2692       ($iw, $ih) = @_;
2693       $cmd = "giftopnm |";
2694
2695     } elsif ((@_ = jpeg_size ($body))) {
2696       ($iw, $ih) = @_;
2697       $cmd = "djpeg |";
2698
2699     } elsif ((@_ = png_size ($body))) {
2700       ($iw, $ih) = @_;
2701       $cmd = "pngtopnm |";
2702
2703     } elsif ($body =~ m/^P\d\n(\d+) (\d+)\n/) {
2704       $iw = $1;
2705       $ih = $2;
2706       $cmd = "";
2707
2708     } else {
2709       error "$bgimage is not a GIF, JPEG, PNG, or PPM.";
2710     }
2711
2712     my $x = int (($img_width  - $iw) / 2);
2713     my $y = int (($img_height - $ih) / 2);
2714     LOG ($verbose_pbm,
2715          "pasting $bgimage (${iw}x$ih) into base image at $x,$y");
2716
2717     $cmd .= "pnmpaste - $x $y $image_ppm > $image_tmp1";
2718     open (IMG, "| $cmd") || error "running $cmd: $!";
2719     print IMG $body;
2720     $body = undef;
2721     close (IMG);
2722     LOG ($verbose_exec, "subproc exited normally.");
2723     rename ($image_tmp1, $image_ppm) ||
2724       error "renaming $image_tmp1 to $image_ppm: $!";
2725   }
2726
2727   clearlog();
2728
2729   while (1) {
2730     my ($base, $img) = pick_image();
2731     my $source = $current_state;
2732     $current_state = "loadimage";
2733     if ($img) {
2734       my ($headers, $body) = get_document ($img, $base);
2735       if ($body) {
2736         paste_image ($base, $img, $body, $source);
2737         $body = undef;
2738       }
2739     }
2740     $current_state = "idle";
2741     $load_method = "none";
2742
2743     unlink $image_tmp1, $image_tmp2;
2744     sleep $delay;
2745   }
2746 }
2747
2748 sub paste_image($$$$) {
2749   my ($base, $img, $body, $source) = @_;
2750
2751   $current_state = "paste";
2752
2753   $suppress_audit = 0;
2754
2755   LOG ($verbose_pbm, "got $img (" . length($body) . ")");
2756
2757   my ($iw, $ih);
2758
2759   # If we are using the webcollage-helper, then we do not need to convert this
2760   # image to a PPM.  But, if we're using a filter command, we still must, since
2761   # that's what the filters expect (webcollage-helper can read PPMs, so that's
2762   # fine.)
2763   #
2764   if (defined ($webcollage_helper) &&
2765       !defined ($filter_cmd)) {
2766
2767     ($iw, $ih) = image_size ($body);
2768     if (!$iw || !$ih) {
2769       LOG (($verbose_pbm || $verbose_load),
2770            "not a GIF, JPG, or PNG" .
2771            (($body =~ m@<(base|html|head|body|script|table|a href)>@i)
2772             ? " (looks like HTML)" : "") .
2773            ": $img");
2774       $suppress_audit = 1;
2775       $body = undef;
2776       return 0;
2777     }
2778
2779     local *OUT;
2780     open (OUT, ">$image_tmp1") || error ("writing $image_tmp1: $!");
2781     print OUT $body || error ("writing $image_tmp1: $!");
2782     close OUT || error ("writing $image_tmp1: $!");
2783
2784   } else {
2785     ($iw, $ih) = image_to_pnm ($img, $body, $image_tmp1);
2786     $body = undef;
2787     if (!$iw || !$ih) {
2788       LOG ($verbose_pbm, "unable to make PBM from $img");
2789       return 0;
2790     }
2791   }
2792
2793   record_success ($load_method, $img, $base);
2794
2795
2796   my $ow = $iw;  # used only for error messages
2797   my $oh = $ih;
2798
2799   # don't just tack this onto the front of the pipeline -- we want it to
2800   # be able to change the size of the input image.
2801   #
2802   if ($filter_cmd) {
2803     LOG ($verbose_pbm, "running $filter_cmd");
2804
2805     my $rc = nontrapping_system "($filter_cmd) < $image_tmp1 >$image_tmp2";
2806     if ($rc != 0) {
2807       LOG(($verbose_pbm || $verbose_load), "failed command: \"$filter_cmd\"");
2808       LOG(($verbose_pbm || $verbose_load), "failed URL: \"$img\" (${ow}x$oh)");
2809       return;
2810     }
2811     rename ($image_tmp2, $image_tmp1);
2812
2813     # re-get the width/height in case the filter resized it.
2814     local *IMG;
2815     open(IMG, "<$image_tmp1") || return 0;
2816     $_ = <IMG>;
2817     $_ = <IMG>;
2818     ($iw, $ih) = m/^(\d+) (\d+)$/;
2819     close (IMG);
2820     return 0 unless ($iw && $ih);
2821   }
2822
2823   my $target_w = $img_width;   # max rectangle into which the image must fit
2824   my $target_h = $img_height;
2825
2826   my $cmd = "";
2827   my $scale = 1.0;
2828
2829
2830   # Usually scale the image to fit on the screen -- but sometimes scale it
2831   # to fit on half or a quarter of the screen.  (We do this by reducing the
2832   # size of the target rectangle.)  Note that the image is not merely scaled
2833   # to fit; we instead cut the image in half repeatedly until it fits in the
2834   # target rectangle -- that gives a wider distribution of sizes.
2835   #
2836   if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; } # reduce target rect
2837   if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; }
2838
2839   if ($iw > $target_w || $ih > $target_h) {
2840     while ($iw > $target_w ||
2841            $ih > $target_h) {
2842       $iw = int($iw / 2);
2843       $ih = int($ih / 2);
2844       $scale /= 2;
2845     }
2846     if ($iw <= 10 || $ih <= 10) {
2847       LOG ($verbose_pbm, "scaling to ${iw}x$ih would have been bogus.");
2848       return 0;
2849     }
2850
2851     LOG ($verbose_pbm, "scaling to ${iw}x$ih ($scale)");
2852
2853     $cmd .= " | pnmscale -xsize $iw -ysize $ih";
2854   }
2855
2856
2857   my $src = $image_tmp1;
2858
2859   my $crop_x = 0;     # the sub-rectangle of the image
2860   my $crop_y = 0;     # that we will actually paste.
2861   my $crop_w = $iw;
2862   my $crop_h = $ih;
2863
2864   # The chance that we will randomly crop out a section of an image starts
2865   # out fairly low, but goes up for images that are very large, or images
2866   # that have ratios that make them look like banners (we try to avoid
2867   # banner images entirely, but they slip through when the IMG tags didn't
2868   # have WIDTH and HEIGHT specified.)
2869   #
2870   my $crop_chance = 0.2;
2871   if ($iw > $img_width * 0.4 || $ih > $img_height * 0.4) {
2872     $crop_chance += 0.2;
2873   }
2874   if ($iw > $img_width * 0.7 || $ih > $img_height * 0.7) {
2875     $crop_chance += 0.2;
2876   }
2877   if ($min_ratio && ($iw * $min_ratio) > $ih) {
2878     $crop_chance += 0.7;
2879   }
2880
2881   if ($crop_chance > 0.1) {
2882     LOG ($verbose_pbm, "crop chance: $crop_chance");
2883   }
2884
2885   if (rand() < $crop_chance) {
2886
2887     my $ow = $crop_w;
2888     my $oh = $crop_h;
2889
2890     if ($crop_w > $min_width) {
2891       # if it's a banner, select the width linearly.
2892       # otherwise, select a bell.
2893       my $r = (($min_ratio && ($iw * $min_ratio) > $ih)
2894                ? rand()
2895                : bellrand());
2896       $crop_w = $min_width + int ($r * ($crop_w - $min_width));
2897       $crop_x = int (rand() * ($ow - $crop_w));
2898     }
2899     if ($crop_h > $min_height) {
2900       # height always selects as a bell.
2901       $crop_h = $min_height + int (bellrand() * ($crop_h - $min_height));
2902       $crop_y = int (rand() * ($oh - $crop_h));
2903     }
2904
2905     if ($crop_x != 0   || $crop_y != 0 ||
2906         $crop_w != $iw || $crop_h != $ih) {
2907       LOG ($verbose_pbm,
2908            "randomly cropping to ${crop_w}x$crop_h \@ $crop_x,$crop_y");
2909     }
2910   }
2911
2912   # Where the image should logically land -- this might be negative.
2913   #
2914   my $x = int((rand() * ($img_width  + $crop_w/2)) - $crop_w*3/4);
2915   my $y = int((rand() * ($img_height + $crop_h/2)) - $crop_h*3/4);
2916
2917   # if we have chosen to paste the image outside of the rectangle of the
2918   # screen, then we need to crop it.
2919   #
2920   if ($x < 0 ||
2921       $y < 0 ||
2922       $x + $crop_w > $img_width ||
2923       $y + $crop_h > $img_height) {
2924
2925     LOG ($verbose_pbm,
2926          "cropping for effective paste of ${crop_w}x$crop_h \@ $x,$y");
2927
2928     if ($x < 0) { $crop_x -= $x; $crop_w += $x; $x = 0; }
2929     if ($y < 0) { $crop_y -= $y; $crop_h += $y; $y = 0; }
2930
2931     if ($x + $crop_w >= $img_width)  { $crop_w = $img_width  - $x - 1; }
2932     if ($y + $crop_h >= $img_height) { $crop_h = $img_height - $y - 1; }
2933   }
2934
2935   # If any cropping needs to happen, add pnmcut.
2936   #
2937   if ($crop_x != 0   || $crop_y != 0 ||
2938       $crop_w != $iw || $crop_h != $ih) {
2939     $iw = $crop_w;
2940     $ih = $crop_h;
2941     $cmd .= " | pnmcut $crop_x $crop_y $iw $ih";
2942     LOG ($verbose_pbm, "cropping to ${crop_w}x$crop_h \@ $crop_x,$crop_y");
2943   }
2944
2945   LOG ($verbose_pbm, "pasting ${iw}x$ih \@ $x,$y in $image_ppm");
2946
2947   $cmd .= " | pnmpaste - $x $y $image_ppm";
2948
2949   $cmd =~ s@^ *\| *@@;
2950
2951   if (defined ($webcollage_helper)) {
2952     $cmd = "$webcollage_helper $image_tmp1 $image_ppm " .
2953                               "$scale $opacity " .
2954                               "$crop_x $crop_y $x $y " .
2955                               "$iw $ih";
2956     $_ = $cmd;
2957
2958   } else {
2959     # use a PPM pipeline
2960     $_ = "($cmd)";
2961     $_ .= " < $image_tmp1 > $image_tmp2";
2962   }
2963
2964   if ($verbose_pbm) {
2965     $_ = "($_) 2>&1 | sed s'/^/" . blurb() . "/'";
2966   } else {
2967     $_ .= " 2> /dev/null";
2968   }
2969
2970   my $rc = nontrapping_system ($_);
2971
2972   if (defined ($webcollage_helper) && -z $image_ppm) {
2973     LOG (1, "failed command: \"$cmd\"");
2974     print STDERR "\naudit log:\n\n\n";
2975     print STDERR ("#" x 78) . "\n";
2976     print STDERR blurb() . "$image_ppm has zero size\n";
2977     showlog();
2978     print STDERR "\n\n";
2979     exit (1);
2980   }
2981
2982   if ($rc != 0) {
2983     LOG (($verbose_pbm || $verbose_load), "failed command: \"$cmd\"");
2984     LOG (($verbose_pbm || $verbose_load), "failed URL: \"$img\" (${ow}x$oh)");
2985     return;
2986   }
2987
2988   if (!defined ($webcollage_helper)) {
2989     rename ($image_tmp2, $image_ppm) || return;
2990   }
2991
2992   my $target = "$image_ppm";
2993
2994   # don't just tack this onto the end of the pipeline -- we don't want it
2995   # to end up in $image_ppm, because we don't want the results to be
2996   # cumulative.
2997   #
2998   if ($post_filter_cmd) {
2999
3000     my $cmd;
3001
3002     $target = $image_tmp1;
3003     if (!defined ($webcollage_helper)) {
3004       $cmd = "($post_filter_cmd) < $image_ppm > $target";
3005     } else {
3006       # Blah, my scripts need the JPEG data, but some other folks need
3007       # the PPM data -- what to do?  Ignore the problem, that's what!
3008 #     $cmd = "djpeg < $image_ppm | ($post_filter_cmd) > $target";
3009       $cmd = "($post_filter_cmd) < $image_ppm > $target";
3010     }
3011
3012     $rc = nontrapping_system ($cmd);
3013     if ($rc != 0) {
3014       LOG ($verbose_pbm, "filter failed: \"$post_filter_cmd\"\n");
3015       return;
3016     }
3017   }
3018
3019   if (!$no_output_p) {
3020     my $tsize = (stat($target))[7];
3021     if ($tsize > 200) {
3022       $cmd = "$ppm_to_root_window_cmd $target";
3023
3024       # xv seems to hate being killed.  it tends to forget to clean
3025       # up after itself, and leaves windows around and colors allocated.
3026       # I had this same problem with vidwhacker, and I'm not entirely
3027       # sure what I did to fix it.  But, let's try this: launch xv
3028       # in the background, so that killing this process doesn't kill it.
3029       # it will die of its own accord soon enough.  So this means we
3030       # start pumping bits to the root window in parallel with starting
3031       # the next network retrieval, which is probably a better thing
3032       # to do anyway.
3033       #
3034       $cmd .= " &";
3035
3036       $rc = nontrapping_system ($cmd);
3037
3038       if ($rc != 0) {
3039         LOG (($verbose_pbm || $verbose_load), "display failed: \"$cmd\"");
3040         return;
3041       }
3042
3043     } else {
3044       LOG ($verbose_pbm, "$target size is $tsize");
3045     }
3046   }
3047
3048   $source .= "-" . stats_of($source);
3049   print STDOUT "image: ${iw}x${ih} @ $x,$y $base $source\n"
3050     if ($verbose_imgmap);
3051   if ($imagemap_base) {
3052     update_imagemap ($base, $x, $y, $iw, $ih,
3053                      $image_ppm, $img_width, $img_height);
3054   }
3055
3056   clearlog();
3057
3058   return 1;
3059 }
3060
3061
3062 sub update_imagemap($$$$$$$$) {
3063   my ($url, $x, $y, $w, $h, $image_ppm, $image_width, $image_height) = @_;
3064
3065   $current_state = "imagemap";
3066
3067   my $max_areas = 200;
3068
3069   $url = html_quote ($url);
3070   my $x2 = $x + $w;
3071   my $y2 = $y + $h;
3072   my $area = "<AREA SHAPE=RECT COORDS=\"$x,$y,$x2,$y2\" HREF=\"$url\">";
3073   unshift @imagemap_areas, $area;       # put one on the front
3074   if ($#imagemap_areas >= $max_areas) {
3075     pop @imagemap_areas;                # take one off the back.
3076   }
3077
3078   LOG ($verbose_pbm, "area: $x,$y,$x2,$y2 (${w}x$h)");
3079
3080   my $map_name = $imagemap_base;
3081   $map_name =~ s@^.*/@@;
3082   $map_name = 'collage' if ($map_name eq '');
3083
3084   my $imagemap_html = $imagemap_base . ".html";
3085   my $imagemap_jpg  = $imagemap_base . ".jpg";
3086
3087   if (!defined ($imagemap_html_tmp)) {
3088     $imagemap_html_tmp = $imagemap_html . sprintf (".%08x", rand(0xffffffff));
3089     $imagemap_jpg_tmp  = $imagemap_jpg  . sprintf (".%08x", rand(0xffffffff));
3090   }
3091
3092   # Read the imagemap html file (if any) to get a template.
3093   #
3094   my $template_html = '';
3095   {
3096     local *IN;
3097     if (open (IN, "<$imagemap_html")) {
3098       while (<IN>) { $template_html .= $_; }
3099       close IN;
3100       LOG ($verbose_pbm, "read template $imagemap_html");
3101     }
3102
3103     if ($template_html =~ m/^\s*$/s) {
3104       $template_html = ("<MAP NAME=\"$map_name\"></MAP>\n" .
3105                         "<IMG SRC=\"$imagemap_base.jpg\"" .
3106                         " USEMAP=\"$map_name\">\n");
3107       LOG ($verbose_pbm, "created dummy template");
3108     }
3109   }
3110
3111   # Write the jpg to a tmp file
3112   #
3113   {
3114     my $cmd;
3115     if (defined ($webcollage_helper)) {
3116       $cmd = "cp -p $image_ppm $imagemap_jpg_tmp";
3117     } else {
3118       $cmd = "cjpeg < $image_ppm > $imagemap_jpg_tmp";
3119     }
3120     my $rc = nontrapping_system ($cmd);
3121     if ($rc != 0) {
3122       error ("imagemap jpeg failed: \"$cmd\"\n");
3123     }
3124   }
3125
3126   # Write the html to a tmp file
3127   #
3128   {
3129     my $body = $template_html;
3130     my $areas = join ("\n\t", @imagemap_areas);
3131     my $map = ("<MAP NAME=\"$map_name\">\n\t$areas\n</MAP>");
3132     my $img = ("<IMG SRC=\"$imagemap_base.jpg\" " .
3133                "BORDER=0 " .
3134                "WIDTH=$image_width HEIGHT=$image_height " .
3135                "USEMAP=\"#$map_name\">");
3136     $body =~ s@(<MAP\s+NAME=\"[^\"]*\"\s*>).*?(</MAP>)@$map@is;
3137     $body =~ s@<IMG\b[^<>]*\bUSEMAP\b[^<>]*>@$img@is;
3138
3139     # if there are magic webcollage spans in the html, update those too.
3140     #
3141     {
3142       my @st = stat ($imagemap_jpg_tmp);
3143       my $date = strftime("%d-%b-%Y %l:%M:%S %p %Z", localtime($st[9]));
3144       my $size = int(($st[7] / 1024) + 0.5) . "K";
3145       $body =~ s@(<SPAN\s+CLASS=\"webcollage_date\">).*?(</SPAN>)@$1$date$2@si;
3146       $body =~ s@(<SPAN\s+CLASS=\"webcollage_size\">).*?(</SPAN>)@$1$size$2@si;
3147     }
3148
3149     local *OUT;
3150     open (OUT, ">$imagemap_html_tmp") || error ("$imagemap_html_tmp: $!");
3151     print OUT $body                   || error ("$imagemap_html_tmp: $!");
3152     close OUT                         || error ("$imagemap_html_tmp: $!");
3153     LOG ($verbose_pbm, "wrote $imagemap_html_tmp");
3154   }
3155
3156   # Rename the two tmp files to the real files
3157   #
3158   rename ($imagemap_html_tmp, $imagemap_html) ||
3159     error "renaming $imagemap_html_tmp to $imagemap_html";
3160   LOG ($verbose_pbm, "wrote $imagemap_html");
3161   rename ($imagemap_jpg_tmp,  $imagemap_jpg) ||
3162     error "renaming $imagemap_jpg_tmp to $imagemap_jpg";
3163   LOG ($verbose_pbm, "wrote $imagemap_jpg");
3164 }
3165
3166
3167 sub init_signals() {
3168
3169   $SIG{HUP}  = \&signal_cleanup;
3170   $SIG{INT}  = \&signal_cleanup;
3171   $SIG{QUIT} = \&signal_cleanup;
3172   $SIG{ABRT} = \&signal_cleanup;
3173   $SIG{KILL} = \&signal_cleanup;
3174   $SIG{TERM} = \&signal_cleanup;
3175
3176   # Need this so that if giftopnm dies, we don't die.
3177   $SIG{PIPE} = 'IGNORE';
3178 }
3179
3180 END { exit_cleanup(); }
3181
3182
3183 sub main() {
3184   $| = 1;
3185   srand(time ^ $$);
3186
3187   my $verbose = 0;
3188   my $dict;
3189   my $driftnet_cmd = 0;
3190
3191   $current_state = "init";
3192   $load_method = "none";
3193
3194   my $root_p = 0;
3195   my $window_id = undef;
3196
3197   # historical suckage: the environment variable name is lower case.
3198   $http_proxy = $ENV{http_proxy} || $ENV{HTTP_PROXY};
3199
3200   while ($_ = $ARGV[0]) {
3201     shift @ARGV;
3202     if ($_ eq "-display" ||
3203         $_ eq "-displ" ||
3204         $_ eq "-disp" ||
3205         $_ eq "-dis" ||
3206         $_ eq "-dpy" ||
3207         $_ eq "-d") {
3208       $ENV{DISPLAY} = shift @ARGV;
3209     } elsif ($_ eq "-root") {
3210       $root_p = 1;
3211     } elsif ($_ eq "-window-id" || $_ eq "--window-id") {
3212       $window_id = shift @ARGV;
3213       $root_p = 1;
3214     } elsif ($_ eq "-no-output") {
3215       $no_output_p = 1;
3216     } elsif ($_ eq "-urls-only") {
3217       $urls_only_p = 1;
3218       $no_output_p = 1;
3219     } elsif ($_ eq "-imagemap") {
3220       $imagemap_base = shift @ARGV;
3221       $no_output_p = 1;
3222     } elsif ($_ eq "-verbose") {
3223       $verbose++;
3224     } elsif (m/^-v+$/) {
3225       $verbose += length($_)-1;
3226     } elsif ($_ eq "-delay") {
3227       $delay = shift @ARGV;
3228     } elsif ($_ eq "-timeout") {
3229       $http_timeout = shift @ARGV;
3230     } elsif ($_ eq "-filter") {
3231       $filter_cmd = shift @ARGV;
3232     } elsif ($_ eq "-filter2") {
3233       $post_filter_cmd = shift @ARGV;
3234     } elsif ($_ eq "-background" || $_ eq "-bg") {
3235       $background = shift @ARGV;
3236     } elsif ($_ eq "-size") {
3237       $_ = shift @ARGV;
3238       if (m@^(\d+)x(\d+)$@) {
3239         $img_width = $1;
3240         $img_height = $2;
3241       } else {
3242         error "argument to \"-size\" must be of the form \"640x400\"";
3243       }
3244     } elsif ($_ eq "-proxy" || $_ eq "-http-proxy") {
3245       $http_proxy = shift @ARGV;
3246     } elsif ($_ eq "-dictionary" || $_ eq "-dict") {
3247       $dict = shift @ARGV;
3248     } elsif ($_ eq "-opacity") {
3249       $opacity = shift @ARGV;
3250       error ("opacity must be between 0.0 and 1.0")
3251         if ($opacity <= 0 || $opacity > 1);
3252     } elsif ($_ eq "-driftnet" || $_ eq "--driftnet") {
3253       @search_methods = ( 100, "driftnet", \&pick_from_driftnet );
3254       if (! ($ARGV[0] =~ m/^-/)) {
3255         $driftnet_cmd = shift @ARGV;
3256       } else {
3257         $driftnet_cmd = $default_driftnet_cmd;
3258       }
3259     } elsif ($_ eq "-debug" || $_ eq "--debug") {
3260       my $which = shift @ARGV;
3261       my @rest = @search_methods;
3262       my $ok = 0;
3263       while (@rest) {
3264         my $pct  = shift @rest;
3265         my $name = shift @rest;
3266         my $tfn  = shift @rest;
3267
3268         if ($name eq $which) {
3269           @search_methods = (100, $name, $tfn);
3270           $ok = 1;
3271           last;
3272         }
3273       }
3274       error "no such search method as \"$which\"" unless ($ok);
3275       LOG (1, "DEBUG: using only \"$which\"");
3276
3277     } else {
3278       print STDERR "$copyright\nusage: $progname " .
3279               "[-root] [-display dpy] [-verbose] [-debug which]\n" .
3280         "\t\t  [-timeout secs] [-delay secs] [-size WxH]\n" .
3281         "\t\t  [-no-output] [-urls-only] [-imagemap filename]\n" .
3282         "\t\t  [-filter cmd] [-filter2 cmd] [-background color]\n" .
3283         "\t\t  [-dictionary dictionary-file] [-http-proxy host[:port]]\n" .
3284         "\t\t  [-driftnet [driftnet-program-and-args]]\n" .
3285         "\n";
3286       exit 1;
3287     }
3288   }
3289
3290   if ($http_proxy && $http_proxy eq "") {
3291     $http_proxy = undef;
3292   }
3293   if ($http_proxy && $http_proxy =~ m@^http://([^/]*)/?$@ ) {
3294     # historical suckage: allow "http://host:port" as well as "host:port".
3295     $http_proxy = $1;
3296   }
3297
3298   if (!$root_p && !$no_output_p) {
3299     print STDERR $copyright;
3300     error "the -root argument is mandatory (for now.)";
3301   }
3302
3303   if (!$no_output_p && !$ENV{DISPLAY}) {
3304     error "\$DISPLAY is not set.";
3305   }
3306
3307
3308   if ($verbose == 1) {
3309     $verbose_imgmap   = 1;
3310     $verbose_warnings = 1;
3311
3312   } elsif ($verbose == 2) {
3313     $verbose_imgmap   = 1;
3314     $verbose_warnings = 1;
3315     $verbose_load     = 1;
3316
3317   } elsif ($verbose == 3) {
3318     $verbose_imgmap   = 1;
3319     $verbose_warnings = 1;
3320     $verbose_load     = 1;
3321     $verbose_filter   = 1;
3322
3323   } elsif ($verbose == 4) {
3324     $verbose_imgmap   = 1;
3325     $verbose_warnings = 1;
3326     $verbose_load     = 1;
3327     $verbose_filter   = 1;
3328     $verbose_net      = 1;
3329
3330   } elsif ($verbose == 5) {
3331     $verbose_imgmap   = 1;
3332     $verbose_warnings = 1;
3333     $verbose_load     = 1;
3334     $verbose_filter   = 1;
3335     $verbose_net      = 1;
3336     $verbose_pbm      = 1;
3337
3338   } elsif ($verbose == 6) {
3339     $verbose_imgmap   = 1;
3340     $verbose_warnings = 1;
3341     $verbose_load     = 1;
3342     $verbose_filter   = 1;
3343     $verbose_net      = 1;
3344     $verbose_pbm      = 1;
3345     $verbose_http     = 1;
3346
3347   } elsif ($verbose >= 7) {
3348     $verbose_imgmap   = 1;
3349     $verbose_warnings = 1;
3350     $verbose_load     = 1;
3351     $verbose_filter   = 1;
3352     $verbose_net      = 1;
3353     $verbose_pbm      = 1;
3354     $verbose_http     = 1;
3355     $verbose_exec     = 1;
3356   }
3357
3358   if ($dict) {
3359     error ("$dict does not exist") unless (-f $dict);
3360     $wordlist = $dict;
3361   } else {
3362     pick_dictionary();
3363   }
3364
3365   init_signals();
3366
3367   spawn_driftnet ($driftnet_cmd) if ($driftnet_cmd);
3368
3369   if ($urls_only_p) {
3370     url_only_output ();
3371   } else {
3372     x_or_pbm_output ($window_id);
3373   }
3374 }
3375
3376 main();
3377 exit (0);