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

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