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