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

   1 #!/usr/local/bin/perl5 -w
   2 #
   3 # webcollage, Copyright (c) 1999, 2000 by Jamie Zawinski <jwz@jwz.org>
   4 # This program decorates the screen with random images from the web.
   5 # One satisfied customer described it as "a nonstop pop culture brainbath."
   6 #
   7 # Permission to use, copy, modify, distribute, and sell this software and its
   8 # documentation for any purpose is hereby granted without fee, provided that
   9 # the above copyright notice appear in all copies and that both that
  10 # copyright notice and this permission notice appear in supporting
  11 # documentation.  No representations are made about the suitability of this
  12 # software for any purpose.  It is provided "as is" without express or
  13 # implied warranty.
  14
  15 # To run this as a display mode with xscreensaver, add this to `programs':
  16 #
  17 #   default-n:  webcollage -root                                        \n\
  18 #   default-n:  webcollage -root -filter 'vidwhacker -stdin -stdout'    \n\
  19
  20 require 5;
  21 #use diagnostics;
  22 use strict;
  23
  24 use Socket;
  25 require Time::Local;
  26 require POSIX;
  27 use Fcntl ':flock'; # import LOCK_* constants
  28
  29
  30 my $version = q{ $Revision: 1.60 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
  31 my $copyright = "WebCollage $version, Copyright (c) 1999" .
  32     " Jamie Zawinski <jwz\@jwz.org>\n" .
  33     "            http://www.jwz.org/xscreensaver/\n";
  34
  35 my $argv0 = $0;
  36 my $progname = $argv0; $progname =~ s@.*/@@g;
  37
  38 my $random_redirector = "http://random.yahoo.com/bin/ryl";
  39 my $image_randomizer_1 = "http://www.altavista.com/query" .
  40                          "?mmdo=3" .
  41                          "&nbq=12" .
  42                          "&stype=simage" .
  43                          "&iclr=1" .
  44                          "&ibw=1" .
  45                          "&iexc=1" .
  46                          "&what=web" .
  47                          "&q=";
  48 my $image_randomizer_2 = "http://www.hotbot.com/?clickSrc=search" .
  49                          "&submit=SEARCH&SM=SC&LG=any" .
  50                          "&AM0=MC&AT0=words&AW0=" .
  51                          "&AM1=MN&AT1=words&AW1=" .
  52                          "&savenummod=2&date=within" .
  53                          "&DV=0&DR=newer&DM=1&DD=1&DY=99&FVI=1&FS=&RD=RG" .
  54                          "&RG=all&Domain=&PS=A&PD=&STEM=1&DC=50&DE=0&_v=2" .
  55                          "&OPs=MDRTP&NUMMOD=2" .
  56                          "&MT=";
  57 my $image_randomizer_3 = "http://www.altavista.com/cgi-bin/query?pg=q" .
  58                          "&text=yes&kl=XX&stype=stext&q=";
  59 my $image_randomizer_4 = "http://search.news.yahoo.com/search/news_photos?" .
  60                          "&z=&n=100&o=o&2=&3=&p=";
  61
  62 # I guess Photopoint got wise to me, because now they are doing error
  63 # checking on the user ("u=") and album ("a=") parameters.  Oh well.
  64 #
  65 #my $photo_randomizer   = "http://albums.photopoint.com/j/View?u=1&a=1&p=";
  66 #my $photo_randomizer_lo = 10000001;
  67 #my $photo_randomizer_hi = 12400000;
  68
  69 my $image_ppm   = ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp") . "/webcollage." . $$;
  70 my $image_tmp1  = $image_ppm . "-1";
  71 my $image_tmp2  = $image_ppm . "-2";
  72
  73 my $img_width;            # size of the image being generated.
  74 my $img_height;
  75
  76 my $http_proxy = undef;
  77 my $http_timeout = 30;
  78 my $cvt_timeout = 10;
  79
  80 # programs we can use to write to the root window (tried in ascending order.)
  81 my $ppm_to_root_window_cmd_1 = "xloadimage -onroot -quiet %%PPM%%";
  82 my $ppm_to_root_window_cmd_2 = "xli -quiet -onroot -center" .
  83                                " -border black %%PPM%%";
  84 my $ppm_to_root_window_cmd_3 = "xv -root -rmode 5 -viewonly" .
  85                                " +noresetroot %%PPM%% -quit";
  86
  87 my $ppm_to_root_window_cmd = undef;     # initialized by x_output()
  88
  89 my $filter_cmd = undef;
  90 my $post_filter_cmd = undef;
  91 my $background = undef;
  92 my $no_output_p = 0;
  93 my $urls_only_p = 0;
  94 my $delay = 0;
  95
  96 my $wordlist = "/usr/dict/words";
  97
  98 if (!-r $wordlist) {
  99     $wordlist = "/usr/share/dict/words";        # BSD
 100 }
 101 if (!-r $wordlist) {
 102     $wordlist = "/usr/share/lib/dict/words";    # Irix
 103 }
 104 die "$wordlist doesn't exist!\n" unless (-r $wordlist);
 105
 106
 107 my $min_width = 50;
 108 my $min_height = 50;
 109 my $min_ratio = 1/5;
 110
 111 my $verbose = 0;
 112
 113 my %rejected_urls;
 114 my @tripwire_words = ("aberrate", "abode", "amorphous", "antioch",
 115                       "arrhenius", "arteriole", "blanket", "brainchild",
 116                       "burdensome", "carnival", "cherub", "chord", "clever",
 117                       "dedicate", "dilogarithm", "dolan", "dryden",
 118                       "eggplant");
 119
 120
 121
 122
 123 ##############################################################################
 124 #
 125 # Retrieving URLs
 126 #
 127 ##############################################################################
 128
 129 # returns three values: the HTTP response line; the document headers;
 130 # and the document body.
 131 #
 132 sub get_document_1 {
 133     my ( $url, $referer, $timeout ) = @_;
 134
 135     if (!defined($timeout)) { $timeout = $http_timeout; }
 136     if ($timeout <= 0) { return (); }
 137     if ($timeout > $http_timeout) { $timeout = $http_timeout; }
 138
 139     if ( $verbose > 3 ) {
 140         print STDERR "$progname: get_document_1 $url " .
 141             ($referer ? $referer : "") . "\n";
 142     }
 143
 144     my($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
 145     if (! ($url_proto && $url_proto =~ m/^http:$/i)) {
 146         if ($verbose) { print STDERR "$progname: not an HTTP URL: $url\n"; }
 147         return ();
 148     }
 149
 150     $path = "" unless $path;
 151
 152     my($them,$port) = split(/:/, $serverstring);
 153     $port = 80 unless $port;
 154
 155     my $them2 = $them;
 156     my $port2 = $port;
 157     if ($http_proxy) {
 158         $serverstring = $http_proxy if $http_proxy;
 159         ($them2,$port2) = split(/:/, $serverstring);
 160         $port2 = 80 unless $port2;
 161     }
 162
 163     my ($remote, $iaddr, $paddr, $proto, $line);
 164     $remote = $them2;
 165     if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') }
 166     return unless $port2;
 167     $iaddr   = inet_aton($remote) || return;
 168     $paddr   = sockaddr_in($port2, $iaddr);
 169
 170
 171     my $head = "";
 172     my $body = "";
 173
 174     @_ =
 175     eval {
 176         local $SIG{ALRM}  = sub {
 177             if ($verbose > 0) {
 178                 print STDERR "$progname: timed out ($timeout) for $url\n";
 179             }
 180             die "alarm\n"
 181             };
 182         alarm $timeout;
 183
 184         $proto   = getprotobyname('tcp');
 185         if (!socket(S, PF_INET, SOCK_STREAM, $proto)) {
 186             print STDERR "$progname: socket: $!\n" if ($verbose);
 187             return;
 188         }
 189         if (!connect(S, $paddr)) {
 190             print STDERR "$progname: connect($serverstring): $!\n"
 191                 if ($verbose);
 192             return;
 193         }
 194
 195         select(S); $| = 1; select(STDOUT);
 196
 197         my $cookie;
 198         if ($remote =~ m/\baltavista\.com$/i) {
 199             # kludge to tell the various altavista sites to be uncensored.
 200             $cookie = "AV_ALL=1";
 201         }
 202
 203         print S ("GET " . ($http_proxy ? $url : "/$path") . " HTTP/1.0\r\n" .
 204                  "Host: $them\r\n" .
 205                  "User-Agent: $progname/$version\r\n" .
 206                  ($referer ? "Referer: $referer\r\n" : "") .
 207                  ($cookie ? "Cookie: $cookie\r\n" : "") .
 208                  "\r\n");
 209         my $http = <S>;
 210
 211         while (<S>) {
 212             $head .= $_;
 213             last if m@^[\r\n]@;
 214         }
 215         while (<S>) {
 216             $body .= $_;
 217         }
 218
 219         close S;
 220
 221         if ( $verbose > 3 ) {
 222             print STDERR "$progname:    ==> $http\n";
 223         }
 224
 225         return ( $http, $head, $body );
 226     };
 227     die if ($@ && $@ ne "alarm\n");       # propagate errors
 228     if ($@) {
 229         # timed out
 230         $head = undef;
 231         $body = undef;
 232         return ();
 233     } else {
 234         # didn't
 235         alarm 0;
 236         return @_;
 237     }
 238 }
 239
 240
 241 # returns two values: the document headers; and the document body.
 242 # if the given URL did a redirect, returns the redirected-to document.
 243 #
 244 sub get_document {
 245     my ( $url, $referer, $timeout ) = @_;
 246     my $start = time;
 247
 248     my $orig_url = $url;
 249     my $loop_count = 0;
 250     my $max_loop_count = 4;
 251
 252     do {
 253         if (defined($timeout) && $timeout <= 0) { return (); }
 254
 255         my ( $http, $head, $body ) = get_document_1 ($url, $referer, $timeout);
 256
 257         if (defined ($timeout)) {
 258             my $now = time;
 259             my $elapsed = $now - $start;
 260             $timeout -= $elapsed;
 261             $start = $now;
 262         }
 263
 264         return () if ( ! $body );
 265
 266         if ( $http =~ m@HTTP/[0-9.]+ 30[23]@ ) {
 267             $_ = $head;
 268             my ( $location ) = m@^location:[ \t]*(.*)$@im;
 269             if ( $location ) {
 270                 $location =~ s/[\r\n]$//;
 271
 272                 if ( $verbose > 3 ) {
 273                     print STDERR "$progname: redirect from " .
 274                         "$url to $location\n";
 275                 }
 276                 $referer = $url;
 277                 $url = $location;
 278
 279                 if ($url =~ m@^/@) {
 280                     $referer =~ m@^(http://[^/]+)@i;
 281                     $url = $1 . $url;
 282                 } elsif (! ($url =~ m@^[a-z]+:@i)) {
 283                     $_ = $referer;
 284                     s@[^/]+$@@g if m@^http://[^/]+/@i;
 285                     $_ .= "/" if m@^http://[^/]+$@i;
 286                     $url = $_ . $url;
 287                 }
 288
 289             } else {
 290                 return ( $url, $body );
 291             }
 292
 293             if ($loop_count++ > $max_loop_count) {
 294                 if ( $verbose > 1 ) {
 295                     print STDERR "$progname: too many redirects " .
 296                         "($max_loop_count) from $orig_url\n";
 297                 }
 298                 $body = undef;
 299                 return ();
 300             }
 301
 302         } elsif ( $http =~ m@HTTP/[0-9.]+ [4-9][0-9][0-9]@ ) {
 303             # http errors -- return nothing.
 304             $body = undef;
 305             return ();
 306
 307         } else {
 308
 309             return ( $url, $body );
 310         }
 311
 312     } while (1);
 313 }
 314
 315
 316 # given a URL and the body text at that URL, selects and returns a random
 317 # image from it.  returns () if no suitable images found.
 318 #
 319 sub pick_image_from_body {
 320     my ( $url, $body ) = @_;
 321
 322     my $base = $url;
 323     $_ = $url;
 324
 325     # if there's at least one slash after the host, take off the last
 326     # pathname component
 327     if ( m@^http://[^/]+/@io ) {
 328         $base =~ s@[^/]+$@@go;
 329     }
 330
 331     # if there are no slashes after the host at all, put one on the end.
 332     if ( m@^http://[^/]+$@io ) {
 333         $base .= "/";
 334     }
 335
 336     if ( $verbose > 3 ) {
 337         print STDERR "$progname: base is $base\n";
 338     }
 339
 340
 341     $_ = $body;
 342
 343     # strip out newlines, compress whitespace
 344     s/[\r\n\t ]+/ /go;
 345
 346     # nuke comments
 347     s/<!--.*?-->//go;
 348
 349
 350     # There are certain web sites that list huge numbers of dictionary
 351     # words in their bodies or in their <META NAME=KEYWORDS> tags (surprise!
 352     # Porn sites tend not to be reputable!)
 353     #
 354     # I do not want webcollage to filter on content: I want it to select
 355     # randomly from the set of images on the web.  All the logic here for
 356     # rejecting some images is really a set of heuristics for rejecting
 357     # images that are not really images: for rejecting *text* that is in
 358     # GIF/JPEG form.  I don't want text, I want pictures, and I want the
 359     # content of the pictures to be randomly selected from among all the
 360     # available content.
 361     #
 362     # So, filtering out "dirty" pictures by looking for "dirty" keywords
 363     # would be wrong: dirty pictures exist, like it or not, so webcollage
 364     # should be able to select them.
 365     #
 366     # However, picking a random URL is a hard thing to do.  The mechanism I'm
 367     # using is to search for a selection of random words.  This is not
 368     # perfect, but works ok most of the time.  The way it breaks down is when
 369     # some URLs get precedence because their pages list *every word* as
 370     # related -- those URLs come up more often than others.
 371     #
 372     # So, after we've retrieved a URL, if it has too many keywords, reject
 373     # it.  We reject it not on the basis of what those keywords are, but on
 374     # the basis that by having so many, the page has gotten an unfair
 375     # advantage against our randomizer.
 376     #
 377     my $trip_count = 0;
 378     foreach my $trip (@tripwire_words) {
 379         $trip_count++ if m/$trip/i;
 380     }
 381     if ($trip_count >= $#tripwire_words - 2) {
 382         if ($verbose > 1) {
 383             print STDERR "$progname: there is probably a dictionary in" .
 384                 " \"$url\": rejecting.\n";
 385         }
 386         $rejected_urls{$url} = -1;
 387         $body = undef;
 388         $_ = undef;
 389         return ();
 390     }
 391
 392
 393     my @urls;
 394     my %unique_urls;
 395
 396     foreach (split(/ *</)) {
 397         if ( m/^meta /i ) {
 398
 399             # Likewise, reject any web pages that have a KEYWORDS meta tag
 400             # that is too long.
 401             #
 402             if (m/name ?= ?\"?keywords\"?/i &&
 403                 m/content ?= ?\"([^\"]+)\"/) {
 404                 my $L = length($1);
 405                 if ($L > 1000) {
 406                     if ($verbose > 1) {
 407                         print STDERR "$progname: keywords of" .
 408                             " length $L in $url: rejecting.\n";
 409                     }
 410                     $rejected_urls{$url} = $L;
 411                     $body = undef;
 412                     $_ = undef;
 413                     return ();
 414                 } elsif ( $verbose > 2 ) {
 415                     print STDERR "$progname: keywords of length $L" .
 416                         " in $url (ok.)\n";
 417                 }
 418             }
 419
 420         } elsif ( m/^(img|a) .*(src|href) ?= ?\"? ?(.*?)[ >\"]/io ) {
 421
 422             my $was_inline = ( "$1" eq "a" || "$1" eq "A" );
 423             my $link = $3;
 424             my ( $width )  = m/width ?=[ \"]*(\d+)/oi;
 425             my ( $height ) = m/height ?=[ \"]*(\d+)/oi;
 426             $_ = $link;
 427
 428             if ( m@^/@o ) {
 429                 my $site;
 430                 ( $site = $base ) =~ s@^(http://[^/]*).*@$1@gio;
 431                 $_ = "$site$link";
 432             } elsif ( ! m@^[^/:?]+:@ ) {
 433                 $_ = "$base$link";
 434                 s@/\./@/@g;
 435                 while (s@/\.\./@/@g) {
 436                 }
 437             }
 438
 439             # skip non-http
 440             if ( ! m@^http://@io ) {
 441                 next;
 442             }
 443
 444             # skip non-image
 445             if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg)$@io ) {
 446                 next;
 447             }
 448
 449             # skip really short or really narrow images
 450             if ( $width && $width < $min_width) {
 451                 if ( $verbose > 2 ) {
 452                     if (!$height) { $height = "?"; }
 453                     print STDERR "$progname: skip narrow image " .
 454                         "$_ (${width}x$height)\n";
 455                 }
 456                 next;
 457             }
 458
 459             if ( $height && $height < $min_height) {
 460                 if ( $verbose > 2 ) {
 461                     if (!$width) { $width = "?"; }
 462                     print STDERR "$progname: skip short image " .
 463                         "$_ (${width}x$height)\n";
 464                 }
 465                 next;
 466             }
 467
 468             # skip images with ratios that make them look like banners.
 469             if ( $min_ratio && $width && $height &&
 470                 ($width * $min_ratio ) > $height ) {
 471                 if ( $verbose > 2 ) {
 472                     if (!$height) { $height = "?"; }
 473                     print STDERR "$progname: skip bad ratio " .
 474                         "$_ (${width}x$height)\n";
 475                 }
 476                 next;
 477             }
 478
 479             my $url = $_;
 480
 481             if ( $unique_urls{$url} ) {
 482                 if ( $verbose > 2 ) {
 483                     print STDERR "$progname: skip duplicate image $_\n";
 484                 }
 485                 next;
 486             }
 487
 488             if ( $verbose > 2 ) {
 489                 print STDERR "$progname: got $url" .
 490                     ($width && $height ? " (${width}x${height})" : "") .
 491                     ($was_inline ? " (inline)" : "") . "\n";
 492             }
 493
 494             $urls[++$#urls] = $url;
 495             $unique_urls{$url}++;
 496
 497             # jpegs are preferable to gifs.
 498             $_ = $url;
 499             if ( ! m@[.]gif$@io ) {
 500                 $urls[++$#urls] = $url;
 501             }
 502
 503             # pointers to images are preferable to inlined images.
 504             if ( ! $was_inline ) {
 505                 $urls[++$#urls] = $url;
 506                 $urls[++$#urls] = $url;
 507             }
 508         }
 509     }
 510
 511     $_ = undef;
 512     $body = undef;
 513
 514     if ( $#urls == 0 ) {
 515         if ( $verbose > 2 ) {
 516             print STDERR "$progname: no images on $base\n";
 517         }
 518         return ();
 519     }
 520
 521     return () if ( $#urls < 1 );
 522
 523     # pick a random element of the table
 524     my $i = ((rand() * 99999) % $#urls);
 525     $url = $urls[$i];
 526
 527     if ( $verbose > 2 ) {
 528         print STDERR "$progname: picked $url\n";
 529     }
 530
 531     return $url;
 532 }
 533
 534
 535 # Using the URL-randomizer, picks a random image on a random page, and
 536 # returns two URLs: the page containing the image, and the image.
 537 # Returns () if nothing found this time.
 538 #
 539 sub pick_from_url_randomizer {
 540     my ( $timeout ) = @_;
 541
 542     if ( $verbose > 3 ) {
 543         print STDERR "\n\n$progname: picking from $random_redirector...\n\n";
 544     }
 545
 546     my ( $base, $body ) = get_document ($random_redirector, undef, $timeout);
 547
 548     if (!$base || !$body) {
 549         $body = undef;
 550         return;
 551     }
 552     my $img = pick_image_from_body ($base, $body);
 553     $body = undef;
 554
 555     if ($img) {
 556         return ($base, $img, "yahoo");
 557     } else {
 558         return ();
 559     }
 560 }
 561
 562
 563 sub random_word {
 564
 565     my $word = 0;
 566     if (open (IN, "<$wordlist")) {
 567         my $size = (stat(IN))[7];
 568         my $pos = rand $size;
 569         if (seek (IN, $pos, 0)) {
 570             $word = <IN>;   # toss partial line
 571             $word = <IN>;   # keep next line
 572         }
 573         if (!$word) {
 574           seek( IN, 0, 0 );
 575           $word = <IN>;
 576         }
 577         close (IN);
 578     }
 579
 580     return 0 if (!$word);
 581
 582     $word =~ s/^[ \t\n\r]+//;
 583     $word =~ s/[ \t\n\r]+$//;
 584     $word =~ s/ys$/y/;
 585     $word =~ s/ally$//;
 586     $word =~ s/ly$//;
 587     $word =~ s/ies$/y/;
 588     $word =~ s/ally$/al/;
 589     $word =~ s/izes$/ize/;
 590     $word =~ tr/A-Z/a-z/;
 591
 592     if ( $word =~ s/[ \t\n\r]/\+/g ) {  # convert intra-word spaces to "+".
 593       $word = "\%22$word\%22";          # And put quotes (%22) around it.
 594     }
 595
 596     return $word;
 597 }
 598
 599
 600
 601 # Using the image-randomizer, picks a random image on a random page, and
 602 # returns two URLs: the page containing the image, and the image.
 603 # Returns () if nothing found this time.
 604 #
 605 sub pick_from_image_randomizer {
 606     my ( $timeout, $which ) = @_;
 607
 608     my $words = random_word;
 609     $words .= "%20" . random_word;
 610     $words .= "%20" . random_word;
 611     $words .= "%20" . random_word;
 612     $words .= "%20" . random_word;
 613
 614     my $search_url = ($which == 0 ? $image_randomizer_1 :
 615                       $which == 1 ? $image_randomizer_2 :
 616                       $which == 2 ? $image_randomizer_3 :
 617                       $image_randomizer_4) .
 618         $words;
 619
 620     # Pick a random search-result page instead of always taking the first.
 621     # This assumes there are at least 10 pages...
 622     if ($which == 0) {
 623         $search_url .= "&pgno=" . (int(rand(9)) + 1);
 624     } elsif ($which == 2) {
 625         $search_url .= "&stq=" . (10 * (int(rand(9)) + 1));
 626     }
 627
 628     if ( $verbose > 3 ) {
 629         $_ = $words; s/%20/ /g; print STDERR "$progname: search words: $_\n";
 630     }
 631
 632     if ( $verbose > 3 ) {
 633         print STDERR "\n\n$progname: picking from $search_url\n";
 634     }
 635
 636     my $start = time;
 637     my ( $base, $body ) = get_document ($search_url, undef, $timeout);
 638     if (defined ($timeout)) {
 639         $timeout -= (time - $start);
 640         if ($timeout <= 0) {
 641             $body = undef;
 642             return ();
 643         }
 644     }
 645
 646     return () if (! $body);
 647
 648
 649     my @subpages;
 650     my $skipped = 0;
 651
 652     my $search_count = "?";
 653     if ($which == 0 &&
 654         $body =~ m@found (approximately |about )?(<B>)?(\d+)(</B>)? image@) {
 655         $search_count = $3;
 656     } elsif ($which == 1 && $body =~ m@<NOBR>((\d{1,3})(,\d{3})*)&nbsp;@i) {
 657         $search_count = $1;
 658     } elsif ($which == 2 && $body =~ m@found ((\d{1,3})(,\d{3})*|\d+) Web p@) {
 659         $search_count = $1;
 660     }
 661     1 while ($search_count =~ s/^(\d+)(\d{3})/$1,$2/);
 662
 663     my $length = length($body);
 664     my $href_count = 0;
 665
 666     $_ = $body;
 667
 668 #    s/Result [Pp]ages:.*$//s;            # trim off page footer
 669 #    s/^.*?IMAGE RESULTS//s;              # trim off page header
 670
 671     s/Have you tried these resources.*//s;  # let's try it again
 672
 673     s/[\r\n\t ]+/ /g;
 674
 675     s/(<A )/\n$1/gi;
 676     foreach (split(/\n/)) {
 677         $href_count++;
 678         my ($u) = m@<A\s.*\bHREF\s*=\s*([^>]+)>@i;
 679         next unless $u;
 680         if ($u =~ m/^\"([^\"]*)\"/) { $u = $1; }   # quoted string
 681         elsif ($u =~ m/^([^\s]*)\s/) { $u = $1; }  # or token
 682
 683         if ($which == 1) {
 684             # Kludge to decode HotBot pages
 685             next unless ($u =~ m@/director\.asp\?target=(http%3A[^&>]+)@);
 686             $u = url_decode($1);
 687         }
 688
 689         next unless ($u =~ m@^http://@i);  # skip non-http and relative urls.
 690
 691         next if ($u =~ m@[/.]altavista\.com\b@i);     # skip altavista builtins
 692         next if ($u =~ m@[/.]altavista\.[a-z]{2}\b@i); # altavista.fr, etc
 693         next if ($u =~ m@[/.]av\.com\b@i);
 694         next if ($u =~ m@[/.]virage\.com\b@i);
 695         next if ($u =~ m@[/.]photoloft\.com\b@i);
 696         next if ($u =~ m@[/.]shopping\.com\b@i);
 697         next if ($u =~ m@[/.]thetrip\.com\b@i);
 698         next if ($u =~ m@[/.]cmgi\.com\b@i);
 699         next if ($u =~ m@[/.]intelihealth\.com\b@i);
 700         next if ($u =~ m@[/.]wildweb\.com\b@i);
 701         next if ($u =~ m@[/.]digital\.com\b@i);
 702         next if ($u =~ m@[/.]doubleclick\.net\b@i);
 703         next if ($u =~ m@[/.]freeim\.org\b@i);
 704         next if ($u =~ m@[/.]clicktomarket\.com\b@i);  # you cretins
 705         next if ($u =~ m@[/.]teragram\.com\b@i);
 706
 707         # must lose this one for altavista, even though it loses images of
 708         # every single customer of akamai.  Oh well, those people have lots
 709         # of money, and so their images are probably boring anyway.
 710         next if ($u =~ m@[/.]akamai\.net@i);
 711
 712         if ($which == 0 && $u =~ m@[/.]corbis\.com@) {
 713            $skipped = 1;
 714             if ( $verbose > 3 ) {
 715                 print STDERR "$progname: skipping corbis URL: $u\n";
 716             }
 717             next;
 718
 719         } elsif ($which == 3 &&
 720                  ($u =~ m@^http://[^/]+$@ ||              # no slashes
 721                   $u =~ m@/$@ ||                          # ends in /
 722                   ! ($u =~ m@dailynews\.yahoo\.com@))) {  # not dailynews
 723 #            $skipped = 1;
 724             if ( $verbose > 3 ) {
 725                 print STDERR "$progname: skipping non-AP URL: $u\n";
 726             }
 727             next;
 728
 729         } elsif ( $rejected_urls{$u} ) {
 730             if ( $verbose > 3 ) {
 731                 my $L = $rejected_urls{$u};
 732                 print STDERR "$progname: pre-rejecting sub-page: $u\n";
 733             }
 734             next;
 735
 736         } elsif ( $verbose > 3 ) {
 737             print STDERR "$progname: sub-page: $u\n";
 738         }
 739
 740         $subpages[++$#subpages] = $u;
 741     }
 742
 743     if ( $#subpages < 0 ) {
 744         if (!$skipped && $verbose > 1) {
 745             print STDERR "$progname: found nothing on $base " .
 746                 "($length bytes, $href_count links).\n";
 747         }
 748         $body = undef;
 749         $_ = undef;
 750         return ();
 751     }
 752
 753     # pick a random element of the table
 754     my $i = ((rand() * 99999) % ($#subpages + 1));
 755     my $subpage = $subpages[$i];
 756
 757     if ( $verbose > 3 ) {
 758         print STDERR "$progname: picked page $subpage\n";
 759     }
 760
 761
 762     $body = undef;
 763     $_ = undef;
 764
 765     my ( $base2, $body2 ) = get_document ($subpage, $base, $timeout);
 766
 767     if (!$base2 || !$body2) {
 768         $body2 = undef;
 769         return ();
 770     }
 771
 772     my $img = pick_image_from_body ($base2, $body2);
 773     $body2 = undef;
 774
 775     if ($img) {
 776         return ($base2, $img,
 777                 ($which == 0 ? "imagevista" :
 778                  $which == 1 ? "hotbot" :
 779                  $which == 2 ? "altavista" :
 780                  "ap") .
 781                 "/$search_count");
 782     } else {
 783         return ();
 784     }
 785 }
 786
 787
 788 # Using the photo site, generate a random URL that will hopefully point
 789 # to an image.  Returns two URLs, both of which are the URL of the image.
 790 # Returns () if nothing found this time.
 791 #
 792 #sub pick_from_photo_randomizer {
 793 #    my ( $timeout ) = @_;
 794 #    my $n = ($photo_randomizer_lo +
 795 #             int(rand() * ($photo_randomizer_hi - $photo_randomizer_lo)));
 796 #    my $url = $photo_randomizer . $n;
 797 #    return ( $url, $url, "photopoint" );
 798 #}
 799
 800
 801 # Picks a random image on a random page, and returns two URLs:
 802 # the page containing the image, and the image.
 803 # Returns () if nothing found this time.
 804 # Uses the url-randomizer 1 time in 5, else the image randomizer.
 805 #
 806 my $total_0 = 0;
 807 my $total_1 = 0;
 808 my $total_2 = 0;
 809 my $total_3 = 0;
 810 my $total_4 = 0;
 811 my $count_0 = 0;
 812 my $count_1 = 0;
 813 my $count_2 = 0;
 814 my $count_3 = 0;
 815 my $count_4 = 0;
 816
 817 sub pick_image {
 818     my ( $timeout ) = @_;
 819     my $r = int(rand(100));
 820
 821     my ($base, $img, $source, $total, $count);
 822
 823     if ($r < 20) {
 824         ($base, $img, $source) = pick_from_url_randomizer ($timeout);
 825         $total = ++$total_0;
 826         $count = ++$count_0 if $img;
 827
 828     } elsif ($r < 60) {
 829         ($base, $img, $source) = pick_from_image_randomizer ($timeout, 0);
 830         $total = ++$total_1;
 831         $count = ++$count_1 if $img;
 832
 833      } elsif ($r < 65) {
 834          ($base, $img, $source) = pick_from_image_randomizer ($timeout, 3);
 835          $total = ++$total_4;
 836          $count = ++$count_4 if $img;
 837
 838 #    } elsif ($r < 70) {
 839 #        ($base, $img, $source) = pick_from_photo_randomizer ($timeout);
 840 #        $total = ++$total_4;
 841 #        $count = ++$count_4 if $img;
 842
 843 #    } elsif ($r < 80) {
 844 #        # HotBot sucks: 98% of the time, it says "no pages match your
 845 #        # search", and then if I load the URL again by hand, it works.
 846 #        # I don't understand what's going wrong here, but we're not getting
 847 #        # any good data back from them, so forget it for now.
 848 #
 849 #        ($base, $img, $source) = pick_from_image_randomizer ($timeout, 1);
 850 #        $total = ++$total_2;
 851 #        $count = ++$count_2 if $img;
 852
 853     } else {
 854         ($base, $img, $source) = pick_from_image_randomizer ($timeout, 2);
 855         $total = ++$total_3;
 856         $count = ++$count_3 if $img;
 857     }
 858
 859     if ($source && $total > 0) {
 860         $source .= " " . int(($count / $total) * 100) . "%";
 861     }
 862     return ($base, $img, $source);
 863 }
 864
 865
 866 # Does %-decoding.
 867 #
 868 sub url_decode {
 869     ($_) = @_;
 870     tr/+/ /;
 871     s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
 872     return $_;
 873 }
 874
 875
 876 # Given the raw body of a GIF document, returns the dimensions of the image.
 877 #
 878 sub gif_size {
 879     my ($body) = @_;
 880     my $type = substr($body, 0, 6);
 881     my $s;
 882     return () unless ($type =~ /GIF8[7,9]a/);
 883     $s = substr ($body, 6, 10);
 884     my ($a,$b,$c,$d) = unpack ("C"x4, $s);
 885     return (($b<<8|$a), ($d<<8|$c));
 886 }
 887
 888 # Given the raw body of a JPEG document, returns the dimensions of the image.
 889 #
 890 sub jpeg_size {
 891     my ($body) = @_;
 892     my $i = 0;
 893     my $L = length($body);
 894
 895     my $c1 = substr($body, $i, 1); $i++;
 896     my $c2 = substr($body, $i, 1); $i++;
 897     return () unless (ord($c1) == 0xFF && ord($c2) == 0xD8);
 898
 899     my $ch = "0";
 900     while (ord($ch) != 0xDA && $i < $L) {
 901         # Find next marker, beginning with 0xFF.
 902         while (ord($ch) != 0xFF) {
 903             $ch = substr($body, $i, 1); $i++;
 904         }
 905         # markers can be padded with any number of 0xFF.
 906         while (ord($ch) == 0xFF) {
 907             $ch = substr($body, $i, 1); $i++;
 908         }
 909
 910         # $ch contains the value of the marker.
 911         my $marker = ord($ch);
 912
 913         if (($marker >= 0xC0) &&
 914             ($marker <= 0xCF) &&
 915             ($marker != 0xC4) &&
 916             ($marker != 0xCC)) {  # it's a SOFn marker
 917             $i += 3;
 918             my $s = substr($body, $i, 4); $i += 4;
 919             my ($a,$b,$c,$d) = unpack("C"x4, $s);
 920             return (($c<<8|$d), ($a<<8|$b));
 921
 922         } else {
 923             # We must skip variables, since FFs in variable names aren't
 924             # valid JPEG markers.
 925             my $s = substr($body, $i, 2); $i += 2;
 926             my ($c1, $c2) = unpack ("C"x2, $s);
 927             my $length = ($c1 << 8) | $c2;
 928             return () if ($length < 2);
 929             $i += $length-2;
 930         }
 931     }
 932     return ();
 933 }
 934
 935 # Given the raw body of a GIF or JPEG document, returns the dimensions of
 936 # the image.
 937 #
 938 sub image_size {
 939     my ($body) = @_;
 940     my ($w, $h) = gif_size ($body);
 941     if ($w && $h) { return ($w, $h); }
 942     return jpeg_size ($body);
 943 }
 944
 945
 946 # returns the full path of the named program, or undef.
 947 #
 948 sub which {
 949     my ($prog) = @_;
 950     foreach (split (/:/, $ENV{PATH})) {
 951         if (-x "$_/$prog") {
 952             return $prog;
 953         }
 954     }
 955     return undef;
 956 }
 957
 958
 959 # Like rand(), but chooses numbers with a bell curve distribution.
 960 sub bellrand {
 961     ($_) = @_;
 962     $_ = 1.0 unless defined($_);
 963     $_ /= 3.0;
 964     return (rand($_) + rand($_) + rand($_));
 965 }
 966
 967
 968 ##############################################################################
 969 #
 970 # Generating a list of urls only
 971 #
 972 ##############################################################################
 973
 974 sub url_only_output {
 975     do {
 976         my ($base, $img) = pick_image;
 977         if ($img) {
 978             $base =~ s/ /%20/g;
 979             $img  =~ s/ /%20/g;
 980             print "$img $base\n";
 981         }
 982     } while (1);
 983 }
 984
 985 ##############################################################################
 986 #
 987 # Running as an xscreensaver module
 988 #
 989 ##############################################################################
 990
 991 sub x_cleanup {
 992     my ($sig) = @_;
 993     if ($verbose > 0) { print STDERR "$progname: caught signal $sig.\n"; }
 994     unlink $image_ppm, $image_tmp1, $image_tmp2;
 995     exit 1;
 996 }
 997
 998
 999 # Like system, but prints status about exit codes, and kills this process
1000 # with whatever signal killed the sub-process, if any.
1001 #
1002 sub nontrapping_system {
1003     $! = 0;
1004
1005     if ($verbose > 1) {
1006         $_ = join(" ", @_);
1007         s/\"[^\"]+\"/\"...\"/g;
1008         print STDERR "$progname: executing \"$_\"\n";
1009     }
1010
1011     my $rc = system @_;
1012
1013     if ($rc == 0) {
1014         if ($verbose > 1) {
1015             print STDERR "$progname: subproc exited normally.\n";
1016         }
1017     } elsif (($rc & 0xff) == 0) {
1018         $rc >>= 8;
1019         if ($verbose) {
1020             print "$progname: subproc exited with status $rc.\n";
1021         }
1022     } else {
1023         if ($rc & 0x80) {
1024             if ($verbose) {
1025                 print "$progname: subproc dumped core.\n";
1026             }
1027             $rc &= ~0x80;
1028         }
1029         if ($verbose) {
1030             print "$progname: subproc died with signal $rc.\n";
1031         }
1032         # die that way ourselves.
1033         kill $rc, $$;
1034     }
1035
1036     return $rc;
1037 }
1038
1039
1040 # Given the URL of a GIF or JPEG image, and the body of that image, writes a
1041 # PPM to the given output file.  Returns the width/height of the image if
1042 # successful.
1043 #
1044 sub image_to_pnm {
1045     my ($url, $body, $output) = @_;
1046     my ($cmd, $cmd2, $w, $h);
1047
1048     if ((@_ = gif_size ($body))) {
1049         ($w, $h) = @_;
1050         $cmd = "giftopnm";
1051     } elsif ((@_ = jpeg_size ($body))) {
1052         ($w, $h) = @_;
1053         $cmd = "djpeg";
1054     } else {
1055         return ();
1056     }
1057
1058     $cmd2 = "exec $cmd";        # yes, this really is necessary.  if we don't
1059                                 # do this, the process doesn't die properly.
1060     if ($verbose <= 1) {
1061         #
1062         # We get a "giftopnm: got a 'Application Extension' extension"
1063         # warning any time it's an animgif.
1064         #
1065         # Note that "giftopnm: EOF / read error on image data" is not
1066         # always a fatal error -- sometimes the image looks fine anyway.
1067         #
1068         $cmd2 .= " 2>/dev/null";
1069     }
1070
1071     # There exist corrupted GIF and JPEG files that can make giftopnm and
1072     # djpeg lose their minds and go into a loop.  So this gives those programs
1073     # a small timeout -- if they don't complete in time, kill them.
1074     #
1075     my $pid;
1076     @_ = eval {
1077         my $timed_out;
1078
1079         local $SIG{ALRM}  = sub {
1080             if ($verbose > 0) {
1081                 print STDERR "$progname: timed out ($cvt_timeout) for " .
1082                     "$cmd on \"$url\" in pid $pid\n";
1083             }
1084             kill ('TERM', $pid) if ($pid);
1085             $timed_out = 1;
1086             $body = undef;
1087         };
1088
1089         if (($pid = open(PIPE, "| $cmd2 > $output"))) {
1090             $timed_out = 0;
1091             alarm $cvt_timeout;
1092             print PIPE $body;
1093             $body = undef;
1094             close PIPE;
1095
1096             if ($verbose > 3) { print STDERR "$progname: awaiting $pid\n"; }
1097             waitpid ($pid, 0);
1098             if ($verbose > 3) { print STDERR "$progname: $pid completed\n"; }
1099
1100
1101             my $size = (stat($output))[7];
1102             if ($size < 5) {
1103                 if ($verbose) {
1104                     print STDERR "$progname: $cmd on ${w}x$h \"$url\" failed" .
1105                         " ($size bytes)\n";
1106                 }
1107                 return ();
1108             }
1109
1110             if ($verbose > 1) {
1111                 print STDERR "$progname: created ${w}x$h $output ($cmd)\n";
1112             }
1113             return ($w, $h);
1114         } else {
1115             print STDERR "$progname: $cmd failed: $!\n";
1116             return ();
1117         }
1118     };
1119     die if ($@ && $@ ne "alarm\n");       # propagate errors
1120     if ($@) {
1121         # timed out
1122         $body = undef;
1123         return ();
1124     } else {
1125         # didn't
1126         alarm 0;
1127         $body = undef;
1128         return @_;
1129     }
1130 }
1131
1132 sub x_output {
1133
1134     my $win_cmd_1 = $ppm_to_root_window_cmd_1;
1135     my $win_cmd_2 = $ppm_to_root_window_cmd_2;
1136     my $win_cmd_3 = $ppm_to_root_window_cmd_3;
1137     $win_cmd_1 =~ s/^([^ \t\r\n]+).*$/$1/;
1138     $win_cmd_2 =~ s/^([^ \t\r\n]+).*$/$1/;
1139     $win_cmd_3 =~ s/^([^ \t\r\n]+).*$/$1/;
1140
1141     # make sure the various programs we execute exist, right up front.
1142     foreach ("ppmmake", "giftopnm", "djpeg", "pnmpaste", "pnmscale",
1143              "pnmcut") {
1144         which ($_) || die "$progname: $_ not found on \$PATH.\n";
1145     }
1146
1147     if (which($win_cmd_1)) {
1148         $ppm_to_root_window_cmd = $ppm_to_root_window_cmd_1;
1149     } elsif (which($win_cmd_2)) {
1150         $ppm_to_root_window_cmd = $ppm_to_root_window_cmd_2;
1151     } elsif (which($win_cmd_3)) {
1152         $ppm_to_root_window_cmd = $ppm_to_root_window_cmd_3;
1153      } else {
1154         die "$progname: didn't find $win_cmd_1, $win_cmd_2, or $win_cmd_3 on \$PATH.\n";
1155     }
1156
1157     $SIG{HUP}  = \&x_cleanup;
1158     $SIG{INT}  = \&x_cleanup;
1159     $SIG{QUIT} = \&x_cleanup;
1160     $SIG{ABRT} = \&x_cleanup;
1161     $SIG{KILL} = \&x_cleanup;
1162     $SIG{TERM} = \&x_cleanup;
1163
1164     # Need this so that if giftopnm dies, we don't die.
1165     $SIG{PIPE} = 'IGNORE';
1166
1167     if (!$img_width || !$img_height) {
1168         $_ = "xdpyinfo";
1169         which ($_) || die "$progname: $_ not found on \$PATH.\n";
1170         $_ = `$_`;
1171         ($img_width, $img_height) = m/dimensions: *(\d+)x(\d+) /;
1172         if (!defined($img_height)) {
1173             die "$progname: xdpyinfo failed.\n";
1174         }
1175     }
1176
1177     my $bgcolor = "#000000";
1178     my $bgimage = undef;
1179
1180     if ($background) {
1181         if ($background =~ m/^\#[0-9a-f]+$/i) {
1182             $bgcolor = $background;
1183         } elsif (-r $background) {
1184             $bgimage = $background;
1185
1186         } elsif (! $background =~ m@^[-a-z0-9 ]+$@i) {
1187             print STDERR "$progname: not a color or readable file: " .
1188                 "$background\n";
1189             exit 1;
1190         } else {
1191             # default to assuming it's a color
1192             $bgcolor = $background;
1193         }
1194     }
1195
1196     # Create the sold-colored base image.
1197     #
1198     $_ = "ppmmake '$bgcolor' $img_width $img_height";
1199     if ($verbose > 1) {
1200         print STDERR "$progname: creating base image: $_\n";
1201     }
1202     nontrapping_system "$_ > $image_ppm";
1203
1204     # Paste the default background image in the middle of it.
1205     #
1206     if ($bgimage) {
1207         my ($iw, $ih);
1208
1209         my $body = "";
1210         local *IMG;
1211         open(IMG, "<$bgimage") || die ("couldn't open $bgimage: $!\n");
1212         my $cmd;
1213         while (<IMG>) { $body .= $_; }
1214         close (IMG);
1215         if ((@_ = gif_size ($body))) {
1216             ($iw, $ih) = @_;
1217             $cmd = "giftopnm |";
1218         } elsif ((@_ = jpeg_size ($body))) {
1219             ($iw, $ih) = @_;
1220             $cmd = "djpeg |";
1221         } elsif ($body =~ m/^P\d\n(\d+) (\d+)\n/) {
1222             $iw = $1;
1223             $ih = $2;
1224             $cmd = "";
1225         } else {
1226             die "$progname: $bgimage is not a GIF, JPEG, or PPM.\n";
1227         }
1228
1229         my $x = int (($img_width  - $iw) / 2);
1230         my $y = int (($img_height - $ih) / 2);
1231         if ($verbose > 1) {
1232             print STDERR "$progname: pasting $bgimage (${iw}x$ih) into base ".
1233                 "image at $x,$y\n";
1234         }
1235
1236         $cmd .= "pnmpaste - $x $y $image_ppm > $image_tmp1";
1237         open (IMG, "| $cmd") || die ("running $cmd: $!\n");
1238         print IMG $body;
1239         $body = undef;
1240         close (IMG);
1241         if ($verbose > 1) {
1242             print STDERR "$progname: subproc exited normally.\n";
1243         }
1244         rename ($image_tmp1, $image_ppm) ||
1245             die ("renaming $image_tmp1 to $image_ppm: $!\n");
1246     }
1247
1248     while (1) {
1249         my ($base, $img, $source) = pick_image();
1250         if ($img) {
1251             my ($headers, $body) = get_document ($img, $base);
1252             if ($body) {
1253                 handle_image ($base, $img, $body, $source);
1254                 $body = undef;
1255             }
1256         }
1257         unlink $image_tmp1, $image_tmp2;
1258         sleep $delay;
1259     }
1260 }
1261
1262 sub handle_image {
1263     my ($base, $img, $body, $source) = @_;
1264
1265     if ($verbose > 1) {
1266         print STDERR "$progname: got $img (" . length($body) . ")\n";
1267     }
1268
1269     my ($iw, $ih) = image_to_pnm ($img, $body, $image_tmp1);
1270     $body = undef;
1271     return 0 unless ($iw && $ih);
1272
1273     my $ow = $iw;  # used only for error messages
1274     my $oh = $ih;
1275
1276     # don't just tack this onto the front of the pipeline -- we want it to
1277     # be able to change the size of the input image.
1278     #
1279     if ($filter_cmd) {
1280         if ($verbose > 1) {
1281             print STDERR "$progname: running $filter_cmd\n";
1282         }
1283
1284         my $rc = nontrapping_system "($filter_cmd) < $image_tmp1 >$image_tmp2";
1285         if ($rc != 0) {
1286             if ($verbose) {
1287                 print STDERR "$progname: failed command: \"$filter_cmd\"\n";
1288                 print STDERR "$progname: failed url: \"$img\" (${ow}x$oh)\n";
1289             }
1290             return;
1291         }
1292         rename ($image_tmp2, $image_tmp1);
1293
1294         # re-get the width/height in case the filter resized it.
1295         local *IMG;
1296         open(IMG, "<$image_tmp1") || return 0;
1297         $_ = <IMG>;
1298         $_ = <IMG>;
1299         ($iw, $ih) = m/^(\d+) (\d+)$/;
1300         close (IMG);
1301         return 0 unless ($iw && $ih);
1302     }
1303
1304     my $target_w = $img_width;
1305     my $target_h = $img_height;
1306
1307     my $cmd = "";
1308
1309
1310     # Usually scale the image to fit on the screen -- but sometimes scale it
1311     # to fit on half or a quarter of the screen.  Note that we don't merely
1312     # scale it to fit, we instead cut it in half until it fits -- that should
1313     # give a wider distribution of sizes.
1314     #
1315     if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; }
1316     if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; }
1317
1318     if ($iw > $target_w || $ih > $target_h) {
1319         while ($iw > $target_w ||
1320                $ih > $target_h) {
1321             $iw = int($iw / 2);
1322             $ih = int($ih / 2);
1323         }
1324         if ($iw <= 10 || $ih <= 10) {
1325             if ($verbose > 1) {
1326                 print STDERR "$progname: scaling to ${iw}x$ih would " .
1327                     "have been bogus.\n";
1328             }
1329             return 0;
1330         }
1331
1332         if ($verbose > 1) {
1333             print STDERR "$progname: scaling to ${iw}x$ih\n";
1334         }
1335
1336         $cmd .= " | pnmscale -xsize $iw -ysize $ih";
1337     }
1338
1339
1340     my $src = $image_tmp1;
1341
1342     my $crop_x = 0;     # the sub-rectangle of the image
1343     my $crop_y = 0;     # that we will actually paste.
1344     my $crop_w = $iw;
1345     my $crop_h = $ih;
1346
1347     # The chance that we will randomly crop out a section of an image starts
1348     # out fairly low, but goes up for images that are very large, or images
1349     # that have ratios that make them look like banners (we try to avoid
1350     # banner images entirely, but they slip through when the IMG tags didn't
1351     # have WIDTH and HEIGHT specified.)
1352     #
1353     my $crop_chance = 0.2;
1354     if ($iw > $img_width * 0.4 || $ih > $img_height * 0.4) {
1355         $crop_chance += 0.2;
1356     }
1357     if ($iw > $img_width * 0.7 || $ih > $img_height * 0.7) {
1358         $crop_chance += 0.2;
1359     }
1360     if ($min_ratio && ($iw * $min_ratio) > $ih) {
1361         $crop_chance += 0.7;
1362     }
1363
1364     if ($verbose > 2 && $crop_chance > 0.1) {
1365         print STDERR "$progname: crop chance: $crop_chance\n";
1366     }
1367
1368     if (rand() < $crop_chance) {
1369
1370         my $ow = $crop_w;
1371         my $oh = $crop_h;
1372
1373         if ($crop_w > $min_width) {
1374             # if it's a banner, select the width linearly.
1375             # otherwise, select a bell.
1376             my $r = (($min_ratio && ($iw * $min_ratio) > $ih)
1377                      ? rand()
1378                      : bellrand());
1379             $crop_w = $min_width + int ($r * ($crop_w - $min_width));
1380             $crop_x = int (rand() * ($ow - $crop_w));
1381         }
1382         if ($crop_h > $min_height) {
1383             # height always selects as a bell.
1384             $crop_h = $min_height + int (bellrand() * ($crop_h - $min_height));
1385             $crop_y = int (rand() * ($oh - $crop_h));
1386         }
1387
1388         if ($verbose > 1 &&
1389             ($crop_x != 0   || $crop_y != 0 ||
1390              $crop_w != $iw || $crop_h != $ih)) {
1391             print STDERR "$progname: randomly cropping to " .
1392                 "${crop_w}x$crop_h \@ $crop_x,$crop_y\n";
1393         }
1394     }
1395
1396     # Where the image should logically land -- this might be negative.
1397     #
1398     my $x = int((rand() * ($img_width  + $crop_w/2)) - $crop_w*3/4);
1399     my $y = int((rand() * ($img_height + $crop_h/2)) - $crop_h*3/4);
1400
1401     # if we have chosen to paste the image outside of the rectangle of the
1402     # screen, then we need to crop it.
1403     #
1404     if ($x < 0 ||
1405         $y < 0 ||
1406         $x + $crop_w > $img_width ||
1407         $y + $crop_h > $img_height) {
1408
1409         if ($verbose > 1) {
1410             print STDERR "$progname: cropping for effective paste of " .
1411                 "${crop_w}x$crop_h \@ $x,$y\n";
1412         }
1413
1414         if ($x < 0) { $crop_x -= $x; $crop_w += $x; $x = 0; }
1415         if ($y < 0) { $crop_y -= $y; $crop_h += $y; $y = 0; }
1416
1417         if ($x + $crop_w >= $img_width)  { $crop_w = $img_width  - $x - 1; }
1418         if ($y + $crop_h >= $img_height) { $crop_h = $img_height - $y - 1; }
1419     }
1420
1421     # If any cropping needs to happen, add pnmcut.
1422     #
1423     if ($crop_x != 0   || $crop_y != 0 ||
1424         $crop_w != $iw || $crop_h != $ih) {
1425         $iw = $crop_w;
1426         $ih = $crop_h;
1427         $cmd .= " | pnmcut $crop_x $crop_y $iw $ih";
1428         if ($verbose > 1) {
1429             print STDERR "$progname: cropping to ${crop_w}x$crop_h \@ " .
1430                 "$crop_x,$crop_y\n";
1431         }
1432     }
1433
1434     if ($verbose > 1) {
1435         print STDERR "$progname: pasting ${iw}x$ih \@ $x,$y in $image_ppm\n";
1436     }
1437
1438     $cmd .= " | pnmpaste - $x $y $image_ppm";
1439
1440     $cmd =~ s@^ *\| *@@;
1441     my $rc = nontrapping_system "($cmd) < $image_tmp1 > $image_tmp2";
1442
1443     if ($rc != 0) {
1444         if ($verbose) {
1445             print STDERR "$progname: failed command: \"$cmd\"\n";
1446             print STDERR "$progname: failed url: \"$img\" (${ow}x$oh)\n";
1447         }
1448         return;
1449     }
1450
1451     rename ($image_tmp2, $image_ppm) || return;
1452
1453     my $target = "$image_ppm";
1454
1455     # don't just tack this onto the end of the pipeline -- we don't want it
1456     # to end up in $image_ppm, because we don't want the results to be
1457     # cumulative.
1458     #
1459     if ($post_filter_cmd) {
1460         $target = $image_tmp1;
1461         $rc = nontrapping_system "($post_filter_cmd) < $image_ppm > $target";
1462         if ($rc != 0) {
1463             if ($verbose) {
1464                 print STDERR "$progname: filter failed: " .
1465                     "\"$post_filter_cmd\"\n";
1466             }
1467             return;
1468         }
1469     }
1470
1471     if (!$no_output_p) {
1472         my $tsize = (stat($target))[7];
1473         if ($tsize > 200) {
1474             $cmd = $ppm_to_root_window_cmd;
1475             $cmd =~ s/%%PPM%%/$target/;
1476
1477             # xv seems to hate being killed.  it tends to forget to clean
1478             # up after itself, and leaves windows around and colors allocated.
1479             # I had this same problem with vidwhacker, and I'm not entirely
1480             # sure what I did to fix it.  But, let's try this: launch xv
1481             # in the background, so that killing this process doesn't kill it.
1482             # it will die of its own accord soon enough.  So this means we
1483             # start pumping bits to the root window in parallel with starting
1484             # the next network retrieval, which is probably a better thing
1485             # to do anyway.
1486             #
1487             $cmd .= "&";
1488
1489             $rc = nontrapping_system ($cmd);
1490
1491             if ($rc != 0) {
1492                 if ($verbose) {
1493                     print STDERR "$progname: display failed: \"$cmd\"\n";
1494                 }
1495                 return;
1496             }
1497
1498         } elsif ($verbose > 1) {
1499             print STDERR "$progname: $target size is $tsize\n";
1500         }
1501     }
1502
1503     if ($verbose > 0) {
1504         print STDOUT "image: ${iw}x${ih} @ $x,$y $base $source\n";
1505     }
1506
1507     return 1;
1508 }
1509
1510
1511 sub main {
1512     $| = 1;
1513     srand(time ^ $$);
1514
1515     my $root_p = 0;
1516
1517     # historical suckage: the environment variable name is lower case.
1518     $http_proxy = $ENV{http_proxy} || $ENV{HTTP_PROXY};
1519
1520     while ($_ = $ARGV[0]) {
1521         shift @ARGV;
1522         if ($_ eq "-display" ||
1523             $_ eq "-displ" ||
1524             $_ eq "-disp" ||
1525             $_ eq "-dis" ||
1526             $_ eq "-dpy" ||
1527             $_ eq "-d") {
1528             $ENV{DISPLAY} = shift @ARGV;
1529         } elsif ($_ eq "-root") {
1530             $root_p = 1;
1531         } elsif ($_ eq "-no-output") {
1532             $no_output_p = 1;
1533         } elsif ($_ eq "-urls-only") {
1534             $urls_only_p = 1;
1535             $no_output_p = 1;
1536         } elsif ($_ eq "-verbose") {
1537             $verbose++;
1538         } elsif (m/^-v+$/) {
1539             $verbose += length($_)-1;
1540         } elsif ($_ eq "-delay") {
1541             $delay = shift @ARGV;
1542         } elsif ($_ eq "-timeout") {
1543             $http_timeout = shift @ARGV;
1544         } elsif ($_ eq "-filter") {
1545             $filter_cmd = shift @ARGV;
1546         } elsif ($_ eq "-filter2") {
1547             $post_filter_cmd = shift @ARGV;
1548         } elsif ($_ eq "-background" || $_ eq "-bg") {
1549             $background = shift @ARGV;
1550         } elsif ($_ eq "-size") {
1551             $_ = shift @ARGV;
1552             if (m@^(\d+)x(\d+)$@) {
1553                 $img_width = $1;
1554                 $img_height = $2;
1555             } else {
1556                 die "$progname: argument to \"-size\" must be" .
1557                     " of the form \"640x400\"\n";
1558             }
1559         } elsif ($_ eq "-proxy" || $_ eq "-http-proxy") {
1560             $http_proxy = shift @ARGV;
1561         } else {
1562             die "$copyright\nusage: $progname [-root]" .
1563                 " [-display dpy] [-root] [-verbose] [-timeout secs]\n" .
1564                 "\t\t  [-delay secs] [-filter cmd] [-filter2 cmd]\n" .
1565                 "\t\t  [-http-proxy host[:port]]\n";
1566         }
1567     }
1568
1569     if ($http_proxy && $http_proxy eq "") {
1570         $http_proxy = undef;
1571     }
1572     if ($http_proxy && $http_proxy =~ m@^http://([^/]*)/?$@ ) {
1573         # historical suckage: allow "http://host:port" as well as "host:port".
1574         $http_proxy = $1;
1575     }
1576
1577     if (!$root_p && !$no_output_p) {
1578         die "$copyright" .
1579             "$progname: the -root argument is mandatory (for now.)\n";
1580     }
1581
1582     if (!$no_output_p && !$ENV{DISPLAY}) {
1583         die "$progname: \$DISPLAY is not set.\n";
1584     }
1585
1586     if ($urls_only_p) {
1587         url_only_output;
1588     } else {
1589         x_output;
1590     }
1591 }
1592
1593 main;
1594 exit (0);