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