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