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

   1 #!/usr/local/bin/perl5 -w
   2 #
   3 # webcollage, Copyright (c) 1999 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 # To run this as a CGI program on a web site, do this (these instructions
  21 # work with Apache 1.3 or newer):
  22 #
  23 #   1:  Place this program in your document directory, named "webcollage".
  24 #       The name shouldn't end in .cgi or .html, since this CGI behaves like
  25 #       a directory.
  26 #   2:  Make it world-readable and world-executable.
  27 #   3:  Create a ".htaccess" file in the same directory containing these lines:
  28 #         <Files ~ "^webcollage$">
  29 #         SetHandler cgi-script
  30 #         </Files>
  31 #   4:  Create these files in the same directory, world-writable, zero-length:
  32 #        collage.ppm
  33 #        collage.tmp
  34 #        collage.jpg
  35 #        collage.pending
  36 #        collage.map
  37 #
  38 # Now the CGI is ready to go.
  39
  40 my $copyright = "WebCollage, Copyright (c) 1999" .
  41     " Jamie Zawinski <jwz\@jwz.org>\n" .
  42     "            http://www.jwz.org/xscreensaver/\n";
  43
  44 my $argv0 = $0;
  45 my $progname = $argv0; $progname =~ s@.*/@@g;
  46 my $version = q{ $Revision: 1.7 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
  47
  48 use Socket;
  49 require Time::Local;
  50 require POSIX;
  51 use Fcntl ':flock'; # import LOCK_* constants
  52
  53
  54 #  CGI Parameters
  55
  56 my $data_dir     = "";            # if you want the following files to go in
  57                                   # some directory below ".", name it here.
  58
  59 my $image_ppm    = "${data_dir}collage.ppm"; # names of the various data files.
  60 my $image_tmp    = "${data_dir}collage.tmp";
  61 my $image_jpg    = "${data_dir}collage.jpg";
  62 my $pending_file = "${data_dir}collage.pending";
  63 my $map_file     = "${data_dir}collage.map";
  64
  65 my $url_generation_time  = 60;    # total time to spend getting URLs.
  66 my $image_retrieval_time = 60;    # maximum time to spend loading all images.
  67 my $max_map_entries = 100;        # how many lines to save in $map_file.
  68 my $pastes_per_load = 3;          # how many images to try and paste each time.
  69
  70 my $max_age = 5 * 60;             # minutes before it is considered stale.
  71 my $scale = 1.0;                  # client-side image expansion.
  72
  73 my $img_width = 800;              # size of the image being generated.
  74 my $img_height = 600;
  75
  76 my @all_files = ($image_ppm, $image_tmp, $image_jpg, $pending_file, $map_file);
  77 my $script_date;
  78
  79 # Other Parameters
  80
  81 my $random_redirector = "http://random.yahoo.com/bin/ryl";
  82 my $image_randomizer_a = "http://image.altavista.com/";
  83 my $image_randomizer = $image_randomizer_a . "cgi-bin/avncgi" .
  84                        "?do=3&verb=no&oshape=n&oorder=" .
  85                        "&ophoto=1&oart=1&ocolor=1&obw=1" .
  86                        "&stype=simage&oprem=0&query=";
  87
  88 my $http_timeout = 30;
  89 my $ppm_to_root_window_cmd = "xv -root -rmode 5 -viewonly" .
  90                              " +noresetroot %%PPM%% -quit";
  91 my $filter_cmd = undef;
  92 my $post_filter_cmd = undef;
  93 my $background = undef;
  94 my $no_output_p = 0;
  95 my $urls_only_p = 0;
  96 my $delay = 0;
  97
  98 my $wordlist = "/usr/dict/words";
  99
 100 if (!-r $wordlist) {
 101     $wordlist = "/usr/share/lib/dict/words";    # irix
 102 }
 103
 104
 105 my $min_width = 50;
 106 my $min_height = 50;
 107 my $min_ratio = 1/5;
 108
 109 my $DEBUG = 0;
 110
 111
 112
 113 ##############################################################################
 114 #
 115 # Retrieving URLs
 116 #
 117 ##############################################################################
 118
 119 # returns three values: the HTTP response line; the document headers;
 120 # and the document body.
 121 #
 122 sub get_document_1 {
 123     my ( $url, $referer, $timeout ) = @_;
 124
 125     if (!defined($timeout)) { $timeout = $http_timeout; }
 126     if ($timeout <= 0) { return undef; }
 127     if ($timeout > $http_timeout) { $timeout = $http_timeout; }
 128
 129     if ( $DEBUG > 3 ) {
 130         print STDERR "get_document_1 $url " .
 131             ($referer ? $referer : "") . "\n";
 132     }
 133
 134     my($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4);
 135     if (! ($url_proto && $url_proto =~ m/^http:$/i)) {
 136         if ($DEBUG) { print STDERR "not an HTTP URL: $url\n"; }
 137         return undef;
 138     }
 139     my($them,$port) = split(/:/, $serverstring);
 140     $port = 80 unless $port;
 141     my $size="";
 142
 143     my ($remote, $iaddr, $paddr, $proto, $line);
 144     $remote = $them;
 145     if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
 146     return unless $port;
 147     $iaddr   = inet_aton($remote)               || return;
 148     $paddr   = sockaddr_in($port, $iaddr);
 149
 150     @_ =
 151     eval {
 152         local $SIG{ALRM}  = sub {
 153             if ($DEBUG > 0) {
 154                 print STDERR "timed out ($timeout) for $url\n";
 155             }
 156             die "alarm\n" };
 157         alarm $timeout;
 158
 159         $proto   = getprotobyname('tcp');
 160         socket(S, PF_INET, SOCK_STREAM, $proto)  || return;
 161         connect(S, $paddr)    || return;
 162
 163         select(S); $| = 1; select(STDOUT);
 164
 165         print S ("GET /$path HTTP/1.0\n" .
 166                  "Host: $them\n" .
 167                  "User-Agent: $progname/$version\n" .
 168                  ($referer ? "Referer: $referer\n" : "") .
 169                  "\n");
 170
 171         my $http = <S>;
 172
 173         my $head = "";
 174         my $body = "";
 175         while (<S>) {
 176             $head .= $_;
 177             last if m@^[\r\n]@;
 178         }
 179         while (<S>) {
 180             $body .= $_;
 181         }
 182
 183         close S;
 184
 185         return ( $http, $head, $body );
 186     };
 187     die if ($@ && $@ ne "alarm\n");       # propagate errors
 188     if ($@) {
 189         # timed out
 190         return undef;
 191     } else {
 192         # didn't
 193         alarm 0;
 194         return @_;
 195     }
 196 }
 197
 198
 199 # returns two values: the document headers; and the document body.
 200 # if the given URL did a redirect, returns the redirected-to document.
 201 #
 202 sub get_document {
 203     my ( $url, $referer, $timeout ) = @_;
 204     my $start = time;
 205
 206     do {
 207         if (defined($timeout) && $timeout <= 0) { return undef; }
 208
 209         my ( $http, $head, $body ) = get_document_1 ($url, $referer, $timeout);
 210
 211         if (defined ($timeout)) {
 212             my $now = time;
 213             my $elapsed = $now - $start;
 214             $timeout -= $elapsed;
 215             $start = $now;
 216         }
 217
 218         return undef if ( ! $body );
 219
 220         if ( $http =~ m@HTTP/[0-9.]+ 30[23]@ ) {
 221             $_ = $head;
 222             my ( $location ) = m@^location:[ \t]*(.*)$@im;
 223             if ( $location ) {
 224
 225                 if ( $DEBUG > 3 ) {
 226                     print STDERR "redirect from $url to $location\n";
 227                 }
 228                 $referer = $url;
 229                 $url = $location;
 230             } else {
 231                 return ( $url, $body );
 232             }
 233
 234         } elsif ( $http =~ m@HTTP/[0-9.]+ [4-9][0-9][0-9]@ ) {
 235             # http errors -- return nothing.
 236             return undef;
 237
 238         } else {
 239
 240             return ( $url, $body );
 241         }
 242
 243     } while (1);
 244 }
 245
 246
 247 # given a URL and the body text at that URL, selects and returns a random
 248 # image from it.  returns undef if no suitable images found.
 249 #
 250 sub pick_image_from_body {
 251     my ( $base, $body ) = @_;
 252
 253     $_ = $base;
 254
 255     # if there's at least one slash after the host, take off the last
 256     # pathname component
 257     if ( m@^http://[^/]+/@io ) {
 258         ( $base = $base ) =~ s@[^/]+$@@go;
 259     }
 260
 261     # if there are no slashes after the host at all, put one on the end.
 262     if ( m@^http://[^/]+$@io ) {
 263         $base .= "/";
 264     }
 265
 266     if ( $DEBUG > 3 ) {
 267         print STDERR "base is $base\n";
 268     }
 269
 270
 271     $_ = $body;
 272
 273     # strip out newlines, compress whitespace
 274     s/[\r\n\t ]+/ /go;
 275
 276     # nuke comments
 277     s/<!--.*?-->//go;
 278
 279     my @urls;
 280     my %unique_urls;
 281
 282     foreach (split(/ *</)) {
 283         if ( m/^(img|a) .*(src|href) ?= ?\"? ?(.*?)[ >\"]/io ) {
 284
 285             my $was_inline = ( "$1" eq "a" || "$1" eq "A" );
 286             my $link = $3;
 287             my ( $width )  = m/width ?=[ \"]*([0-9]+)/oi;
 288             my ( $height ) = m/height ?=[ \"]*([0-9]+)/oi;
 289             $_ = $link;
 290
 291             if ( m@^/@o ) {
 292                 my $site;
 293                 ( $site = $base ) =~ s@^(http://[^/]*).*@$1@gio;
 294                 $_ = "$site$link";
 295             } elsif ( ! m@^[^/:?]+:@ ) {
 296                 $_ = "$base$link";
 297                 s@/\./@/@g;
 298                 while (s@/\.\./@/@g) {
 299                 }
 300             }
 301
 302             # skip non-http
 303             if ( ! m@^http://@io ) {
 304                 next;
 305             }
 306
 307             # skip non-image
 308             if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg)$@io ) {
 309                 next;
 310             }
 311
 312 #           # skip GIF?
 313 #           if ( m@[.](gif)@io ) {
 314 ##              if ( $DEBUG > 2 ) { print STDERR "skip GIF $_\n"; }
 315 #               next;
 316 #           }
 317
 318             # skip really short or really narrow images
 319             if ( $width && $width < $min_width) {
 320                 if ( $DEBUG > 2 ) {
 321                     if (!$height) { $height = "?"; }
 322                     print STDERR "skip narrow image $_ ($width x $height)\n";
 323                 }
 324                 next;
 325             }
 326
 327             if ( $height && $height < $min_height) {
 328                 if ( $DEBUG > 2 ) {
 329                     if (!$width) { $width = "?"; }
 330                     print STDERR "skip short image $_ ($width x $height)\n";
 331                 }
 332                 next;
 333             }
 334
 335             # skip images with ratios that make them look like banners.
 336             if ( $min_ratio && $width && $height &&
 337                 ($width * $min_ratio ) > $height ) {
 338                 if ( $DEBUG > 2 ) {
 339                     if (!$height) { $height = "?"; }
 340                     print STDERR "skip bad ratio $_ ($width x $height)\n";
 341                 }
 342                 next;
 343             }
 344
 345             my $url = $_;
 346
 347             if ( $unique_urls{$url} ) {
 348                 if ( $DEBUG > 2 ) { print STDERR "skip duplicate image $_\n"; }
 349                 next;
 350             }
 351
 352             if ( $DEBUG > 2 ) {
 353                 print STDERR "got $url" .
 354                     ($width && $height ? " (${width}x${height})" : "") .
 355                     ($was_inline ? " (inline)" : "") . "\n";
 356             }
 357
 358             $urls[++$#urls] = $url;
 359             $unique_urls{$url}++;
 360
 361             # jpegs are preferable to gifs.
 362             $_ = $url;
 363             if ( ! m@[.]gif$@io ) {
 364                 $urls[++$#urls] = $url;
 365             }
 366
 367             # pointers to images are preferable to inlined images.
 368             if ( ! $was_inline ) {
 369                 $urls[++$#urls] = $url;
 370                 $urls[++$#urls] = $url;
 371             }
 372         }
 373     }
 374
 375     if ( $#urls == 0 ) {
 376         if ( $DEBUG > 2 ) {
 377             print STDERR "no images on $base\n";
 378         }
 379         return undef;
 380     }
 381
 382     return undef if ( $#urls < 1 );
 383
 384     # pick a random element of the table
 385     my $i = ((rand() * 99999) % $#urls);
 386     my $url = $urls[$i];
 387
 388     if ( $DEBUG > 2 ) {
 389         print STDERR "picked $url\n";
 390     }
 391
 392     return $url;
 393 }
 394
 395
 396 # Using the URL-randomizer, picks a random image on a random page, and
 397 # returns two URLs: the page containing the image, and the image.
 398 # Returns undef if nothing found this time.
 399 #
 400 sub pick_from_url_randomizer {
 401     my ( $timeout ) = @_;
 402
 403     if ( $DEBUG > 3 ) {
 404         print STDERR "\n\npicking from $random_redirector...\n\n";
 405     }
 406
 407     my ( $base, $body ) = get_document ($random_redirector, undef, $timeout);
 408
 409     return if (!$base || !$body);
 410     my $img = pick_image_from_body ($base, $body);
 411
 412     if ($img) {
 413         return ($base, $img);
 414     } else {
 415         return undef;
 416     }
 417 }
 418
 419
 420 sub random_word {
 421
 422     my $word = 0;
 423     if (open (IN, "<$wordlist")) {
 424         my $size = (stat(IN))[7];
 425         my $pos = rand $size;
 426         if (seek (IN, $pos, 0)) {
 427             $word = <IN>;   # toss partial line
 428             $word = <IN>;   # keep next line
 429         }
 430         close (IN);
 431     }
 432
 433     return 0 if (!$word);
 434
 435     $word =~ s/^[ \t\n\r]+//;
 436     $word =~ s/[ \t\n\r]+$//;
 437     $word =~ s/ys$/y/;
 438     $word =~ s/ally$//;
 439     $word =~ s/ly$//;
 440     $word =~ s/ies$/y/;
 441     $word =~ s/ally$/al/;
 442     $word =~ s/izes$/ize/;
 443     $word =~ tr/A-Z/a-z/;
 444
 445     return $word;
 446 }
 447
 448
 449
 450 # Using the image-randomizer, picks a random image on a random page, and
 451 # returns two URLs: the page containing the image, and the image.
 452 # Returns undef if nothing found this time.
 453 #
 454 sub pick_from_image_randomizer {
 455     my ( $timeout ) = @_;
 456
 457     my $words = random_word;
 458     $words .= "%20" . random_word;
 459     $words .= "%20" . random_word;
 460     $words .= "%20" . random_word;
 461     $words .= "%20" . random_word;
 462
 463     my $search_url = $image_randomizer . $words;
 464
 465     if ( $DEBUG > 3 ) {
 466         $_ = $words; s/%20/ /g; print STDERR "search words: $_\n";
 467     }
 468
 469     if ( $DEBUG > 3 ) {
 470         print STDERR "\n\npicking from $search_url\n";
 471     }
 472
 473     my $start = time;
 474     my ( $base, $body ) = get_document ($search_url, undef, $timeout);
 475     if (defined ($timeout)) {
 476         $timeout -= (time - $start);
 477         return undef if ($timeout <= 0);
 478     }
 479
 480     return undef if (! $body);
 481
 482
 483     my @subpages;
 484     my $skipped = 0;
 485
 486     $_ = $body;
 487     s/(<A )/\n$1/gi;
 488     foreach (split(/\n/)) {
 489
 490         if ( m@<A HREF=([^>]+)><IMG SRC=http://image\.altavista\.com@i ) {
 491
 492             my $u = $1;
 493             if (m/^"(.*)"$/) { $u = $1; }
 494
 495             if (m@\.corbis\.com/@) {
 496                 $skipped = 1;
 497                 if ( $DEBUG > 3 ) {
 498                     print STDERR "skipping corbis URL: $_\n";
 499                 }
 500                 next;
 501             } elsif ( $DEBUG > 3 ) {
 502                 print STDERR "sub-page: $1\n";
 503             }
 504
 505             $subpages[++$#subpages] = $u;
 506         }
 507     }
 508
 509     if ( $#subpages <= 0 ) {
 510         if (!$skipped) {
 511             print STDERR "Found nothing on $base\n";
 512         }
 513         return undef;
 514     }
 515
 516     # pick a random element of the table
 517     my $i = ((rand() * 99999) % $#subpages);
 518     my $subpage = $subpages[$i];
 519
 520     if ( $DEBUG > 3 ) {
 521         print STDERR "picked page $subpage\n";
 522     }
 523
 524
 525
 526     my ( $base2, $body2 ) = get_document ($subpage, $base, $timeout);
 527
 528     return undef if (!$base2 || !body2);
 529
 530     my $img = pick_image_from_body ($base2, $body2);
 531
 532     if ($img) {
 533         return ($base2, $img);
 534     } else {
 535         return undef;
 536     }
 537 }
 538
 539
 540 # Picks a random image on a random page, and returns two URLs:
 541 # the page containing the image, and the image.
 542 # Returns undef if nothing found this time.
 543 # Uses the url-randomizer 1 time in 5, else the image randomizer.
 544 #
 545 sub pick_image {
 546     my ( $timeout ) = @_;
 547
 548     if (int(rand 5) == 0) {
 549         return pick_from_url_randomizer ($timeout);
 550     } else {
 551         return pick_from_image_randomizer ($timeout);
 552     }
 553 }
 554
 555
 556 # Given the raw body of a GIF document, returns the dimensions of the image.
 557 #
 558 sub gif_size {
 559     my ($body) = @_;
 560     my $type = substr($body, 0, 6);
 561     my $s;
 562     return undef unless ($type =~ /GIF8[7,9]a/);
 563     $s = substr ($body, 6, 10);
 564     my ($a,$b,$c,$d) = unpack ("C"x4, $s);
 565     return (($b<<8|$a), ($d<<8|$c));
 566 }
 567
 568 # Given the raw body of a JPEG document, returns the dimensions of the image.
 569 #
 570 sub jpeg_size {
 571     my ($body) = @_;
 572     my $i = 0;
 573     my $L = length($body);
 574
 575     $c1 = substr($body, $i, 1); $i++;
 576     $c2 = substr($body, $i, 1); $i++;
 577     return undef unless (ord($c1) == 0xFF && ord($c2) == 0xD8);
 578
 579     my $ch = "0";
 580     while (ord($ch) != 0xDA && $i < $L) {
 581         # Find next marker, beginning with 0xFF.
 582         while (ord($ch) != 0xFF) {
 583             $ch = substr($body, $i, 1); $i++;
 584         }
 585         # markers can be padded with any number of 0xFF.
 586         while (ord($ch) == 0xFF) {
 587             $ch = substr($body, $i, 1); $i++;
 588         }
 589
 590         # $ch contains the value of the marker.
 591         my $marker = ord($ch);
 592
 593         if (($marker >= 0xC0) &&
 594             ($marker <= 0xCF) &&
 595             ($marker != 0xC4) &&
 596             ($marker != 0xCC)) {  # it's a SOFn marker
 597             $i += 3;
 598             my $s = substr($body, $i, 4); $i += 4;
 599             my ($a,$b,$c,$d) = unpack("C"x4, $s);
 600             return (($c<<8|$d), ($a<<8|$b));
 601
 602         } else {
 603             # We must skip variables, since FFs in variable names aren't
 604             # valid JPEG markers.
 605             my $s = substr($body, $i, 2); $i += 2;
 606             my ($c1, $c2) = unpack ("C"x2, $s);
 607             my $length = ($c1 << 8) | $c2;
 608             return undef if ($length < 2);
 609             $i += $length-2;
 610         }
 611     }
 612     return undef;
 613 }
 614
 615 # Given the raw body of a GIF or JPEG document, returns the dimensions of
 616 # the image.
 617 #
 618 sub image_size {
 619     my ($body) = @_;
 620     my ($w, $h) = gif_size ($body);
 621     if ($w && $h) { return ($w, $h); }
 622     return jpeg_size ($body);
 623 }
 624
 625
 626 # returns the full path of the named program, or undef.
 627 #
 628 sub which {
 629     my ($prog) = @_;
 630     foreach (split (/:/, $ENV{PATH})) {
 631         if (-x "$_/$prog") {
 632             return $prog;
 633         }
 634     }
 635     return undef;
 636 }
 637
 638 ##############################################################################
 639 #
 640 # Running as a CGI
 641 #
 642 ##############################################################################
 643
 644 my $body_tag = "<BODY BGCOLOR=\"#000000\" TEXT=\"#DDFFDD\"\n" .
 645     "      LINK=\"#00EEEE\" VLINK=\"#EEEE00\" ALINK=\"#FF0000\">\n";
 646
 647 my $html_document =
 648     ("" .
 649      "<HTML>\n" .
 650      "<HEAD>\n" .
 651      " <TITLE>WebCollage</TITLE>\n" .
 652      "\n" .
 653      "</HEAD>\n" .
 654      $body_tag .
 655      "\n" .
 656      "<CENTER><FONT SIZE=1><BR></FONT>" .
 657      "<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0 WIDTH=720>\n" .
 658      " <TR>\n" .
 659      "  <TD ALIGN=CENTER VALIGN=TOP NOWRAP>\n" .
 660      "   <FONT SIZE=\"+3\"><B>WebCollage: </B></FONT>\n" .
 661      "   <FONT SIZE=\"-1\"><BR><B>by\n" .
 662      "     <A HREF=\"http://www.jwz.org/\">Jamie Zawinski</A></B>\n" .
 663      "  </TD>\n" .
 664      "  <TD ALIGN=LEFT VALIGN=TOP>\n" .
 665      "\n" .
 666      "   <P><FONT SIZE=\"+3\"><B>Exterminate All Rational Thought.\n" .
 667      "   </B></FONT>\n" .
 668      "   <BR>This program creates collages out of random images\n" .
 669      "   found on the Web.\n" .
 670      "   <P>More images are being added to the\n" .
 671      "   collage now: please wait for the image below to load.\n" .
 672      "   This will take a minute or two, since it has to contact\n" .
 673      "   other web sites to retrieve the images before it can construct\n" .
 674      "   the collage.  Once the image below is loaded, you can reload\n" .
 675      "   this page to do it again.\n" .
 676      "   <P>If you enjoy this, you might also enjoy\n" .
 677      "   <A HREF=\"http://www.jwz.org/dadadodo/\">DadaDodo</A>.\n" .
 678      "   WebCollage also works as a screen saver, for those of you\n" .
 679      "   using Unix: it is included with the\n" .
 680      "   <A HREF=\"http://www.jwz.org/xscreensaver/\">XScreenSaver</A>\n" .
 681      "   package.<P>\n" .
 682      "  </TD>\n" .
 683      " </TR>\n" .
 684      " <TR>\n" .
 685      "  <TD COLSPAN=2 VALIGN=TOP ALIGN=CENTER><TABLE \n" .
 686      "      BORDER=2 WIDTH=%%WIDTH%% HEIGHT=%%HEIGHT%% \n" .
 687      "      CELLPADDING=0 CELLSPACING=0>\n" .
 688      "    <TR><TD BGCOLOR=\"#C0C0C0\">\n" .
 689      "      %%MAP%%\n" .
 690      "     <A NAME=\"#image\">\n" .
 691      "     <IMG SRC=\"%%IMAGE%%\" BORDER=0 \n" .
 692      "      WIDTH=%%WIDTH%% HEIGHT=%%HEIGHT%% \n" .
 693      "      USEMAP=\"#collage\"></A></TD></TR>\n" .
 694      "  </TABLE></TD>\n" .
 695      " </TR>\n" .
 696      "</TABLE>\n" .
 697      "<P>\n" .
 698      "</CENTER>\n");
 699
 700
 701 my @time_fmt_days = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
 702 my @time_fmt_months = ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
 703                        "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
 704
 705 # Converts a time_t to a string acceptable to HTTP.
 706 #
 707 sub format_http_time {
 708     my ($time) = @_;
 709     my @t = gmtime($time);
 710     my ($sec, $min, $hour, $mday, $mon, $year, $wday) = @t;
 711     $year += 1900;
 712     $wday = $time_fmt_days[$wday];
 713     $mon = $time_fmt_months[$mon];
 714     return sprintf("%s, %02d %s %d %02d:%02d:%02d GMT",
 715                    $wday, $mday, $mon, $year, $hour, $min, $sec);
 716 }
 717
 718
 719
 720 # Parses exactly the time format that HTTP requires, no more, no less.
 721 #
 722 sub parse_http_time {
 723     ($_) = @_;
 724
 725     if (!m/^[SMTWF][a-z][a-z]+, (\d\d)[- ]([JFMAJSOND][a-z][a-z]+)[- ](\d\d\d?\d?)[- ](\d\d):(\d\d):(\d\d)( GMT)?$/o) {
 726         return undef;
 727     }
 728
 729     my @moy = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
 730     @moy{@moy} = (1..12);
 731
 732     my $t = Time::Local::timegm($6, $5, $4, $1, $moy{$2}-1,
 733                                 ($3 < 100 ? $3 : $3-1900));
 734     return ($t < 0 ? undef : $t);
 735 }
 736
 737
 738 # Given a modification time, returns a time_t to use as the expiration time
 739 # of both the HTML and the JPEG.
 740 #
 741 sub compute_expires_time {
 742     my ($mod_time) = (@_);
 743     my $now = time;
 744     if ($mod_time < $now) { $mod_time = $now; }
 745     return $mod_time + $max_age;
 746 }
 747
 748
 749 # Parse the If-Modified-Since header, and write a response if appropriate.
 750 # If this returns 1, we're done.
 751 #
 752 sub do_ifmod {
 753     # see http://vancouver-webpages.com/proxy/log-tail.pl and
 754     # http://mnot.cbd.net.au/cache_docs/ for clues about how to
 755     # do cacheing properly with CGI-generated documents.
 756     my ($mod_time) = (@_);
 757     if ($ENV{HTTP_IF_MODIFIED_SINCE}) {
 758         my $ims = $ENV{HTTP_IF_MODIFIED_SINCE};
 759         $ims =~ s/;.*// ; # lose trailing "; length=3082"
 760         $ims = parse_http_time($ims);
 761         if ($ims && $mod_time <= $ims) {
 762             print "Status: 304 Not Modified\n\n" ;
 763             return 1;
 764         }
 765     }
 766     return 0;
 767 }
 768
 769
 770 # Returns N urls of images (and the pages on which they were found.)
 771 # Unless there is a significant surplus of URLs in the $pending_file,
 772 # this will spend $url_generation_time seconds generating as many URLs
 773 # as it can.  The first N will be returned, and the rest will be left
 774 # in the file.
 775 #
 776 sub get_image_urls {
 777     my ($count) = @_;
 778
 779     my @urls;
 780     my $body = "";
 781     my $file_count = 0;
 782
 783     local *PEND;
 784
 785     # Open and lock the file (read/write.)
 786     # rewind after locking, in case we had to wait for the lock.
 787     #
 788     open (PEND, "+<$pending_file") || die "couldn't open $pending_file: $!";
 789
 790     if ($DEBUG > 2) { print STDERR "jpeg: opened $pending_file\n"; }
 791
 792     my $flock_wait = time;
 793     flock (PEND, LOCK_EX) || die "couldn't lock $pending_file: $!";
 794     $flock_wait = (time - $flock_wait);
 795
 796     seek (PEND, 0, 0)     || die "couldn't rewind $pending_file: $!";
 797
 798     if ($DEBUG > 2) { print STDERR "jpeg: locked $pending_file\n"; }
 799
 800
 801     # Take N URLs off the top, and leave the rest.
 802     #
 803     while (<PEND>) {
 804         if (--$count >= 0) {
 805             if ($DEBUG > 3) { print STDERR "  <   $_"; }
 806             s/[\r\n]+$//;
 807             $urls[++$#urls] = $_;
 808         } else {
 809             $body .= $_;
 810             if ($DEBUG > 3) { print STDERR "  -   $_"; }
 811             $file_count++;
 812         }
 813     }
 814
 815     # rewind and overwrite the file
 816     seek (PEND, 0, 0)  || die "couldn't rewind $pending_file: $!";
 817     truncate (PEND, 0) || die "couldn't truncate $pending_file: $!";
 818     print PEND $body;
 819
 820
 821     # If there are fewer than 3x as many URLs as we took left in the file,
 822     # then generate as many URLs as we can in N seconds.  Take what we
 823     # need from that, and append the rest to the file.  Note that we are
 824     # still holding a lock on the file.
 825     #
 826     # Count the time spent waiting for flock as time spent gathering URLs.
 827     # Because that means someone else was doing it.
 828     #
 829     $body = "";
 830     if ($file_count < $count * 3) {
 831         my $timeout = $url_generation_time - $flock_wait;
 832         my $start = time;
 833
 834         while (1) {
 835             last if ($timeout <= 0);
 836
 837             if ($DEBUG > 2) { print STDERR "time remaining: $timeout\n"; }
 838             my ($base, $img) = pick_image ($timeout);
 839
 840             if ($img) {
 841                 $img  =~ s/ /%20/g;
 842                 $base =~ s/ /%20/g;
 843                 $_ = "$img $base";
 844                 if ($count-- >= 0) {
 845                     if ($DEBUG > 3) { print STDERR "  <<   $img\n"; }
 846                     $urls[++$#urls] = $_;
 847                 } else {
 848                     if ($DEBUG > 3) { print STDERR "  >>   $img\n"; }
 849                     print PEND "$_\n"; # append to file
 850                     $file_count++;
 851                 }
 852             }
 853
 854             my $now = time;
 855             my $elapsed = $now - $start;
 856             $timeout -= $elapsed;
 857             $start = $now;
 858         }
 859     }
 860
 861     my $of = select(PEND); $| = 1; select($of);         # flush output
 862     print PEND "";
 863
 864     flock (PEND, LOCK_UN) || die "couldn't unlock $pending_file: $!";
 865     close (PEND)          || die "couldn't close $pending_file: $!";
 866
 867     if ($DEBUG > 2) {
 868         print STDERR "jpeg: closed $pending_file; $file_count urls in file;" .
 869             " returning $#urls.\n";
 870     }
 871
 872     return @urls;
 873 }
 874
 875
 876 sub cgi_reset_all_files {
 877     foreach (@all_files) {
 878         my $file = $_;
 879         local *OUT;
 880         open (OUT, "+<$file") || die "couldn't open $file: $!";
 881         flock (OUT, LOCK_EX)  || die "couldn't lock $file: $!";
 882         truncate (OUT, 0)     || die "couldn't truncate $file: $!";
 883         flock (OUT, LOCK_UN)  || die "couldn't unlock $file: $!";
 884         close (OUT)           || die "couldn't close $file: $!";
 885     }
 886
 887     system "ppmmake '#000000' $img_width $img_height > $image_ppm" ||
 888         die "failed to create blank $image_ppm file: $!";
 889     system "cjpeg -progressive $image_ppm > $image_jpg" ||
 890         die "failed to create blank $image_jpg file: $!";
 891 }
 892
 893
 894 # Given the URL of an image and the page on which it was found, this will
 895 # load the image, and paste it at a random spot in $image_ppm and $img_jpg.
 896 # It will also update $map_file to contain the appropriate referer, and
 897 # will limit it to $max_map_entries lines.
 898 #
 899 sub cgi_paste_image {
 900     my ($img, $referer) = @_;
 901
 902     my ( $base, $body ) = get_document ($img, $referer);
 903     return if (!$base || !$body);
 904
 905     my ($iw, $ih) = image_size ($body);
 906     return if (!$iw || !$ih);
 907
 908     if ($DEBUG > 2) { print STDERR "got $base ($iw x $ih)\n"; }
 909
 910     my $cmd;
 911
 912     if ($base =~ m/\.gif$/i) {
 913         $cmd = "giftopnm";
 914     } else {
 915         $cmd = "djpeg";
 916     }
 917
 918     if ($iw > $img_width || $ih > $img_height) {
 919         while ($iw > $img_width || $ih > $img_height) {
 920             $iw = int($iw / 2);
 921             $ih = int($ih / 2);
 922         }
 923         $cmd .= " | pnmscale -xysize $iw $ih";
 924     }
 925
 926     my $x = int (rand() * ($img_width - $iw));
 927     my $y = int (rand() * ($img_height - $ih));
 928
 929     $cmd .= " | pnmpaste - $x $y $image_ppm";
 930
 931
 932     local *MAP;
 933     local *PIPE_OUT;
 934
 935     # Open and lock the map (read/write.)
 936     # rewind after locking, in case we had to wait for the lock.
 937     # This lock doubles as our lock on the image file itself.
 938     #
 939     open (MAP, "+<$map_file") || die "couldn't open $map_file: $!";
 940
 941     if ($DEBUG > 2) { print STDERR "jpeg: opened $map_file\n"; }
 942
 943     flock (MAP, LOCK_EX) || die "couldn't lock $map_file: $!";
 944     seek (MAP, 0, 0)     || die "couldn't rewind $map_file: $!";
 945
 946     if ($DEBUG > 2) { print STDERR "jpeg: locked $map_file\n"; }
 947
 948     # Read in the first hundred lines of the map file.
 949     #
 950     my $map = "";
 951     my $count = 0;
 952     while (<MAP>) {
 953         last if ($count++ > $max_map_entries);
 954         $map .= $_;
 955     }
 956
 957     # Add this entry to the front of the map data.
 958     #
 959     $map = "$x $y $iw $ih $referer\n" . $map;
 960
 961
 962     # Ensure that the $image_ppm file exists and has a ppm in it.
 963     #
 964     my $ppm_size = $img_width * $img_height * 3 * 2;
 965     my $s = (stat($image_ppm))[7];
 966     if ($s < $ppm_size) {
 967
 968         if ( $DEBUG ) {
 969             print STDERR "$image_ppm is $s bytes;" .
 970                 " should be at least $ppm_size\n";
 971             print STDERR "resetting everything.";
 972             cgi_reset_all_files();
 973         }
 974     }
 975
 976     # Paste the bits into the image.  Note that the map file is still locked.
 977     #
 978     local *TMP;
 979     open (TMP, ">$image_tmp") || die "couldn't open $image_tmp: $!";
 980     close (TMP);
 981
 982     if (! $DEBUG ) {
 983         $cmd = "( $cmd ) 2>/dev/null";
 984     }
 985
 986     $cmd .= " > $image_tmp";
 987     if ($DEBUG > 2) { print STDERR "executing $cmd\n"; }
 988
 989     if (open(PIPE_OUT, "| $cmd")) {
 990         print PIPE_OUT $body;
 991         close(PIPE_OUT);
 992
 993         if ($DEBUG > 2) { system "ls -ldF $image_tmp >&2"; }
 994
 995         my @tmp_stat = stat($image_tmp);
 996         if (@tmp_stat && $tmp_stat[7] < 200) {
 997 #            unlink ($image_tmp) || die "couldn't unlink $image_tmp: $!";
 998             open (OUT, ">$image_tmp") || die "$image_tmp unwritable: $!";
 999             close (OUT);
1000             if ($DEBUG > 2) { print STDERR "FAILED writing $image_ppm\n"; }
1001         } else {
1002 #            rename ($image_tmp, $image_ppm) ||
1003 #                die "couldn't rename $image_tmp to $image_ppm: $!";
1004             local *IN;
1005             local *OUT;
1006             open (IN, "+<$image_tmp") || die "$image_tmp unreadable: $!";
1007             open (OUT, ">$image_ppm") || die "$image_ppm unwritable: $!";
1008             while (<IN>) { print OUT $_; }
1009             truncate (IN, 0) || die "couldn't truncate $image_tmp: $!";
1010             close (IN);
1011             close (OUT) || die "couldn't write $image_ppm: $!";
1012             if ($DEBUG > 2) { print STDERR "wrote $image_ppm\n"; }
1013
1014
1015             # Now convert the PPM to a JPEG.
1016             #
1017             system "cjpeg -progressive $image_ppm > $image_tmp 2>/dev/null";
1018
1019             @tmp_stat = stat($image_tmp);
1020             if (@tmp_stat && $tmp_stat[7] < 200) {
1021 #                unlink ($image_tmp) || die "couldn't unlink $image_tmp: $!";
1022                 open (OUT, ">$image_tmp") || die "$image_tmp unwritable: $!";
1023                 close (OUT);
1024                 if ($DEBUG > 2) { print STDERR "FAILED writing $image_jpg\n"; }
1025             } else {
1026 #                rename ($image_tmp, $image_ppm) ||
1027 #                    die "couldn't rename $image_tmp to $image_ppm: $!";
1028                 open (IN, "+<$image_tmp") || die "$image_tmp unreadable: $!";
1029                 open (OUT, ">$image_jpg") || die "$image_jpg unwritable: $!";
1030                 while (<IN>) { print OUT $_; }
1031                 truncate (IN, 0) || die "couldn't truncate $image_tmp: $!";
1032                 close (IN);
1033                 close (OUT) || die "couldn't write $image_jpg: $!";
1034                 if ($DEBUG > 2) { print STDERR "wrote $image_jpg\n"; }
1035             }
1036         }
1037
1038         # Overwrite the map data.
1039         #
1040         seek (MAP, 0, 0)  || die "couldn't rewind $map_file: $!";
1041         truncate (MAP, 0) || die "couldn't truncate $map_file: $!";
1042         print MAP $map;
1043     }
1044
1045     my $of = select(MAP); $| = 1; select($of);          # flush output
1046     print MAP "";
1047
1048     flock (MAP, LOCK_UN) || die "couldn't unlock $map_file: $!";
1049     close (MAP)          || die "couldn't close $map_file: $!";
1050
1051     if ($DEBUG > 2) { print STDERR "jpeg: closed $map_file\n"; }
1052 }
1053
1054
1055 sub cgi_generate_image {
1056
1057     $SIG{PIPE} = 'IGNORE';
1058
1059     my @urls = get_image_urls ($pastes_per_load);
1060     my $end_time = time + $image_retrieval_time;
1061
1062     if ($DEBUG > 2) {
1063         print STDERR "loading $#urls images\n";
1064     }
1065
1066     foreach (@urls) {
1067         my ($img, $referer) = m/^([^ ]+) ([^ ]+)/;
1068         if ($img) {
1069             cgi_paste_image ($img, $referer);
1070         }
1071         last if (time > $end_time);
1072     }
1073 }
1074
1075
1076 sub cgi_sanity_check {
1077     my $error = undef;
1078     foreach (@all_files) {
1079         if (! -e $_) { $error = "$_ does not exist.\n"; }
1080         elsif (! -r $_) { $error = "$_ is unreadable.\n"; }
1081         elsif (! -w $_) { $error = "$_ is unwritable.\n"; }
1082         last if ($error);
1083     }
1084
1085     return unless $error;
1086
1087     print "Content-Type: text/html\n";
1088     print "\n\n<TITLE>Error</TITLE>$body_tag<H1>Error</H1>";
1089     print POSIX::getcwd() . "/" . $error . "<P>\n";
1090
1091     $_ = join("</TT>, <TT>", @all_files);
1092     s/,([^,]*)$/, and$1/;
1093
1094     print "Each of the files: <TT>$_</TT>\n";
1095     print " must exist and be readable and writable by the httpd process\n";
1096     print "(which probably means they must be globally readable and\n";
1097     print "writable, since on most systems, CGI scripts run as the\n";
1098     print "user <I>nobody</I>.)\n<P>\n";
1099
1100     exit (0);
1101 }
1102
1103
1104 # Write the encapsulating HTML document and associated HTTP headers.
1105 # This is fast -- it just writes out the wrapper document corresponding
1106 # to the data currently on disk.  It is the loading of the sub-image
1107 # that does the real work.
1108 #
1109 sub cgi_emit_html_document {
1110
1111     cgi_sanity_check;
1112
1113     my $map_file_date;
1114     my $doc = $html_document;
1115
1116     my $w2 = int ($img_width  * $scale);
1117     my $h2 = int ($img_height * $scale);
1118     $doc =~ s/%%WIDTH%%/$w2/g;
1119     $doc =~ s/%%HEIGHT%%/$h2/g;
1120
1121     local *MAP;
1122     open (MAP, "<$map_file") || die "couldn't open $map_file: $!";
1123     if ($DEBUG > 2) { print STDERR "html: opened $map_file\n"; }
1124
1125     flock (MAP, LOCK_SH) || die "couldn't lock $map_file: $!";
1126     seek (MAP, 0, 0)     || die "couldn't rewind $map_file: $!";
1127     if ($DEBUG > 2) { print STDERR "html: locked $map_file\n"; }
1128
1129     $map_file_date = (stat(MAP))[9];
1130
1131     my $map = "<MAP NAME=\"collage\">\n";
1132     while (<MAP>) {
1133         my ($x, $y, $w, $h, $url) =
1134             m/^([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) (.*)$/;
1135         if ($w && $h) {
1136             $x = int($x * $scale);
1137             $y = int($y * $scale);
1138             $w = int($w * $scale);
1139             $h = int($h * $scale);
1140
1141             # protect against URLs that contain <, >, or ".
1142             $url =~ s/([<>\"])/uc sprintf("%%%02X",ord($1))/eg;
1143
1144             my $x2 = $x + $w;
1145             my $y2 = $y + $h;
1146             $map .=
1147                 "<AREA SHAPE=RECT COORDS=\"$x,$y,$x2,$y2\" HREF=\"$url\">\n";
1148         }
1149     }
1150     $map .= "</MAP>";
1151     flock (MAP, LOCK_UN) || die "couldn't unlock $map_file: $!";
1152     close (MAP)          || die "couldn't close $map_file: $!";
1153
1154     if ($DEBUG > 2) { print STDERR "html: closed $map_file\n"; }
1155
1156     $doc =~ s/%%MAP%%/$map/g;
1157
1158     my $img_name = "current";
1159
1160     $doc =~ s@%%IMAGE%%@images/$img_name.jpg@g;
1161
1162
1163     my $mod_time = $map_file_date;
1164     if ($script_date > $mod_time) { $mod_time = $script_date; }
1165
1166     if (do_ifmod($mod_time)) {
1167         return;
1168     }
1169
1170     my $exp = compute_expires_time($mod_time);
1171
1172     print "Content-Type: text/html\n";
1173     print "Content-Length: " . length($doc) . "\n";
1174     print "Last-Modified: " . format_http_time($mod_time) . "\n";
1175
1176     # This is a suggestion to consider the object invalid after the given
1177     # date.  This is sometimes ignored.
1178     #
1179     print "Expires: " . format_http_time($exp) . "\n";
1180
1181     # This may or may not cause a cacheing proxy to pass this stuff along.
1182     # It's not standardized, but was historically used for... something.
1183     print "Pragma: no-cache\n";
1184
1185     # This says the same thing as the Expires header, but it is a stronger
1186     # assertion that we're serious and should be listened to.
1187     #
1188     my $age = $exp - time;
1189     print "Cache-Control: max-age=$age, must-revalidate\n";
1190
1191     print "\n";
1192     print $doc;
1193 }
1194
1195
1196 # Write the interior JPEG document and associated HTTP headers.
1197 #
1198 sub cgi_emit_jpeg_document {
1199
1200     my $image_data = "";
1201     my $jpg_file_date;
1202     my $do_ims = 0;
1203
1204     # The map file is the means by which we hold write-locks on the image
1205     # file.  So first obtain the lock on that file.
1206     #
1207     local *MAP;
1208     open (MAP, "+<$map_file") || die "couldn't open $map_file: $!";
1209
1210     if ($DEBUG > 2) { print STDERR "jpeg: opened $map_file\n"; }
1211     flock (MAP, LOCK_SH) || die "couldn't lock $map_file: $!";
1212     if ($DEBUG > 2) { print STDERR "jpeg: locked $map_file\n"; }
1213
1214     # Now we have exclusive access to the image file.  Read it.
1215     #
1216     local *IMG;
1217     open (IMG, "<$image_jpg") || die "couldn't open $image_jpg: $!";
1218
1219     $jpg_file_date = (stat(IMG))[9];
1220
1221     if (do_ifmod($jpg_file_date)) {
1222         $do_ims = 1;
1223         if ($DEBUG > 2) {
1224             my $ims = $ENV{HTTP_IF_MODIFIED_SINCE};
1225             $ims =~ s/;.*//;
1226             print STDERR "not-modified-since " .
1227                 localtime(parse_http_time($ims)) . "\n";
1228             print STDERR "jpg date: " . localtime($jpg_file_date) . "\n";
1229         }
1230     }
1231
1232     if (!$do_ims) {
1233         while (<IMG>) { $image_data .= $_; }
1234     }
1235     close (IMG) || die "couldn't close $image_jpg: $!";
1236
1237     # Now free the lock so that others can write to the file.
1238     #
1239     flock (MAP, LOCK_UN) || die "couldn't unlock $map_file: $!";
1240     close (MAP)          || die "couldn't close $map_file: $!";
1241     if ($DEBUG > 2) { print STDERR "jpeg: closed $map_file\n"; }
1242
1243     return if ($do_ims);
1244
1245
1246     # At this point, we have the image data we will be returning.
1247     # However, don't return it yet -- first go off and generate the
1248     # *next* image, then we can return *this* one.  If we don't do it
1249     # in this order, people will jump the gun hitting reload, and no
1250     # image updates will happen.
1251     #
1252     my $type = "image/jpeg";
1253     my $mod_time = $jpg_file_date;
1254     if ($script_date > $mod_time) { $mod_time = $script_date; }
1255
1256     print "Last-Modified: " . format_http_time($mod_time) . "\n";
1257     print "Expires: " . format_http_time(compute_expires_time($mod_time))
1258         . "\n";
1259     print "Content-Type: $type\n";
1260     print "Content-Length: " . length($image_data) . "\n";
1261     print "\n";
1262
1263     # Now, before returning the image data, go catatonic for a minute
1264     # while we load some URLs and make the next image.
1265     #
1266     cgi_generate_image;
1267
1268     # Done setting up for next time -- now finish loading.
1269     #
1270     print $image_data;
1271     $image_data = undef;
1272 }
1273
1274
1275 # Write the source code of this script as a text/plain document.
1276 #
1277 sub cgi_emit_source_document {
1278     my $mod_time = $script_date;
1279
1280     if (do_ifmod($mod_time)) {
1281         return;
1282     }
1283
1284     print "Content-Type: text/plain\n";
1285     print "Last-Modified: " . format_http_time($mod_time) . "\n";
1286     print "\n";
1287     open (IN, "<$argv0") || die "couldn't open $argv0: $!";
1288     while (<IN>) {
1289         print;
1290     }
1291     close (IN);
1292 }
1293
1294
1295 # Parse the various environment variables to decide how we were invoked,
1296 # and then do something about it.
1297 #
1298 sub cgi_main {
1299
1300     $DEBUG=4;
1301
1302     $ENV{PATH} .= ":/usr/local/bin";
1303
1304     # make sure the various programs we execute exist, right up front.
1305     foreach ("ppmmake", "cjpeg", "djpeg", "giftopnm", "pnmpaste", "pnmscale") {
1306         if (!which ($_)) {
1307             print "Content-Type: text/html\n";
1308             print "\n\n<TITLE>Error</TITLE>$body_tag<H1>Error</H1>";
1309             print "The <TT>$_</TT> program was not found on \$PATH.<BR>\n";
1310
1311             my $p = $ENV{PATH};
1312             $p =~ s/%/%25/g; $p =~ s/\&/%26/g;
1313             $p =~ s/</%3C/g; $p =~ s/>/%3E/g;
1314             $p =~ s/:/:<WBR>/g;
1315             print "\$PATH is: <TT>$p</TT><P>\n";
1316             exit (0);
1317         }
1318     }
1319
1320     $script_date = (stat($argv0))[9];
1321
1322     print "Blat: Foop\n";
1323
1324     if ($ENV{REQUEST_METHOD} &&
1325         $ENV{REQUEST_METHOD} ne "GET" &&
1326         $ENV{REQUEST_METHOD} ne "HEAD" ) {
1327         print "Content-Type: text/html\n";
1328         print "\n\n<TITLE>Error</TITLE>$body_tag<H1>Error</H1>";
1329         $_ = $ENV{REQUEST_METHOD};
1330         print "bad request method: <TT>$_</TT>\n";
1331         exit (0);
1332
1333     } elsif ( $ENV{QUERY_STRING} ) {
1334         if ( $ENV{QUERY_STRING} eq "reset" ) {
1335             cgi_reset_all_files;
1336
1337             print "Content-Type: text/html\n";
1338             print "\n\n<TITLE>Collage Reset</TITLE>";
1339             print "$body_tag<H1>Collage Reset</H1><P>\n";
1340             exit (0);
1341
1342         } else {
1343             print "Content-Type: text/html\n";
1344             print "\n\n<TITLE>Error</TITLE>$body_tag<H1>Error</H1>";
1345             $_ = $ENV{QUERY_STRING};
1346             print "malformed URL: <TT>$_</TT>\n";
1347             exit (0);
1348         }
1349
1350     } elsif ( !$ENV{PATH_INFO} || $ENV{PATH_INFO} eq "" ) {
1351         # don't allow /webcollage as a URL -- force it to be /webcollage/
1352         print "Status: 301 Moved Permanently\n";
1353         print "Location: http://" .
1354             ($ENV{HTTP_HOST} ? $ENV{HTTP_HOST} :
1355              $ENV{SERVER_NAME} ? $ENV{SERVER_NAME} : "???") .
1356             ($ENV{REQUEST_URI} ? $ENV{REQUEST_URI} : "") .
1357                 "/\n\n";
1358         exit (0);
1359
1360     } elsif ( $ENV{PATH_INFO} eq "/" ) {
1361         cgi_emit_html_document;
1362
1363     } elsif ( $ENV{PATH_INFO} =~ m@^/images/[^/]+\.jpg$@ ) {
1364         cgi_emit_jpeg_document;
1365
1366     } elsif ( $ENV{PATH_INFO} eq "/webcollage.pl" ) {
1367         cgi_emit_source_document;
1368
1369     } else {
1370         print "Content-Type: text/html\n";
1371         print "\n\n<TITLE>Error</TITLE>$body_tag<H1>Error</H1>";
1372         $_ = $ENV{PATH_INFO};
1373         print "malformed URL: <TT>$_</TT>\n";
1374         exit (0);
1375     }
1376 }
1377
1378
1379 ##############################################################################
1380 #
1381 # Generating a list of urls only
1382 #
1383 ##############################################################################
1384
1385 sub url_only_output {
1386     $| = 1;
1387     do {
1388         my ($base, $img) = pick_image;
1389         if ($img) {
1390             $base =~ s/ /%20/g;
1391             $img  =~ s/ /%20/g;
1392             print "$img $base\n";
1393         }
1394     } while (1);
1395 }
1396
1397 ##############################################################################
1398 #
1399 # Running as an xscreensaver module
1400 #
1401 ##############################################################################
1402
1403 my $image_tmp2;
1404 my $image_tmp3;
1405
1406 sub x_cleanup {
1407     if ($DEBUG > 0) { print STDERR "caught signal\n"; }
1408     unlink $image_ppm, $image_tmp, $image_tmp2, $image_tmp3;
1409     exit 1;
1410 }
1411
1412
1413 sub x_output {
1414
1415     my $win_cmd = $ppm_to_root_window_cmd;
1416     $win_cmd =~ s/^([^ \t\r\n]+).*$/$1/;
1417
1418     # make sure the various programs we execute exist, right up front.
1419     foreach ("ppmmake", "giftopnm", "djpeg", "pnmpaste", "pnmscale",
1420              $win_cmd) {
1421         which ($_) || die "$progname: $_ not found on \$PATH.\n";
1422     }
1423
1424     $SIG{HUP}  = \&x_cleanup;
1425     $SIG{INT}  = \&x_cleanup;
1426     $SIG{QUIT} = \&x_cleanup;
1427     $SIG{ABRT} = \&x_cleanup;
1428     $SIG{KILL} = \&x_cleanup;
1429     $SIG{TERM} = \&x_cleanup;
1430
1431     # Need this so that if giftopnm dies, we don't die.
1432     $SIG{PIPE} = 'IGNORE';
1433
1434     if (!$img_width || !$img_height) {
1435         $_ = "xdpyinfo";
1436         which ($_) || die "$progname: $_ not found on \$PATH.\n";
1437         $_ = `$_`;
1438         ($img_width, $img_height) = m/dimensions: *([0-9]+)x([0-9]+) /;
1439     }
1440
1441     my $bgcolor = "#000000";
1442     my $bgimage = undef;
1443
1444     if ($background) {
1445         if ($background =~ m/^\#[0-9a-f]+$/i) {
1446             $bgcolor = $background;
1447         } elsif (-r $background) {
1448             $bgimage = $background;
1449
1450         } elsif (! $background =~ m@^[-a-z0-9 ]+$@i) {
1451             print STDERR "not a color or readable file: $background\n";
1452             exit 1;
1453         } else {
1454             # default to assuming it's a color
1455             $bgcolor = $background;
1456         }
1457     }
1458
1459     # Create the sold-colored base image.
1460     #
1461     $_ = "ppmmake '$bgcolor' $img_width $img_height";
1462     if ($DEBUG > 1) {
1463         print STDERR "creating base image: $_\n";
1464     }
1465     system "$_ > $image_ppm";
1466
1467     # Paste the default background image in the middle of it.
1468     #
1469     if ($bgimage) {
1470         my ($iw, $ih);
1471         if (open(IMG, "<$bgimage")) {
1472             $_ = <IMG>;
1473             $_ = <IMG>;
1474             ($iw, $ih) = m/^([0-9]+) ([0-9]+)$/;
1475             close (IMG);
1476         }
1477         my $x = int (($img_width - $iw) / 2);
1478         my $y = int (($img_height - $ih) / 2);
1479         if ($DEBUG > 1) {
1480             print STDERR "pasting $bgimage into base image at $x, $y\n";
1481         }
1482         system "pnmpaste $bgimage $x $y $image_ppm > $image_tmp2" .
1483             " && mv $image_tmp2 $image_ppm";
1484     }
1485
1486
1487     do {
1488         my ($base, $img) = pick_image;
1489
1490         my ($headers, $body);
1491         if ($img) {
1492             ($headers, $body) = get_document ($img, $base);
1493         }
1494
1495         if ($body) {
1496
1497             if ($DEBUG > 0) {
1498                 print STDERR "got $img (" . length($body) . ")\n";
1499             }
1500
1501             my $cmd;
1502             if ($img =~ m/\.gif/i) {
1503                 $cmd = "giftopnm";
1504             } else {
1505                 $cmd = "djpeg";
1506             }
1507
1508             if ($DEBUG == 0) {
1509                 $cmd .= " 2>/dev/null";
1510             }
1511
1512             if (open(PIPE, "| $cmd > $image_tmp")) {
1513                 print PIPE $body;
1514                 close PIPE;
1515
1516                 if ($DEBUG > 1) {
1517                     print STDERR "created $image_tmp ($cmd)\n";
1518                 }
1519             }
1520
1521             if (-s $image_tmp) {
1522
1523                 if ($filter_cmd) {
1524                     if ($DEBUG > 1) {
1525                         print STDERR "running $filter_cmd\n";
1526                     }
1527                     system "($filter_cmd) < $image_tmp > $image_tmp3" .
1528                         " && mv $image_tmp3 $image_tmp";
1529                 }
1530
1531                 my ($iw, $ih);
1532                 if (open(IMG, "<$image_tmp")) {
1533                     $_ = <IMG>;
1534                     $_ = <IMG>;
1535                     ($iw, $ih) = m/^([0-9]+) ([0-9]+)$/;
1536                     close (IMG);
1537                 }
1538
1539                 if ($iw && $ih) {
1540
1541                     if ($DEBUG > 1) {
1542                         print STDERR "image size is $iw x $ih\n";
1543                     }
1544
1545                     if ($iw > $img_width || $ih > $img_height) {
1546                         while ($iw > $img_width ||
1547                                $ih > $img_height) {
1548                             $iw = int($iw / 2);
1549                             $ih = int($ih / 2);
1550                         }
1551                         if ($DEBUG > 1) {
1552                             print STDERR "scaling to $iw x $ih\n";
1553                         }
1554                         system "pnmscale -xysize $iw $ih $image_tmp" .
1555                             " > $image_tmp2" .
1556                             " 2>/dev/null && mv $image_tmp2 $image_tmp";
1557                     }
1558
1559                     my $x = int (rand() * ($img_width - $iw));
1560                     my $y = int (rand() * ($img_height - $ih));
1561
1562                     if ($DEBUG > 1) {
1563                         print STDERR "pasting at $x, $y in $image_ppm\n";
1564                     }
1565
1566                     system "pnmpaste $image_tmp $x $y $image_ppm" .
1567                         " > $image_tmp2" .
1568                         " && mv $image_tmp2 $image_ppm";
1569
1570
1571                     my $target = $image_ppm;
1572                     if ($post_filter_cmd) {
1573                         if ($DEBUG > 1) {
1574                             print STDERR "running $post_filter_cmd\n";
1575                         }
1576                         system "($post_filter_cmd) < $image_ppm > $image_tmp3";
1577                         $target = $image_tmp3;
1578                     }
1579
1580                     if (!$no_output_p) {
1581
1582                         my $tsize = (stat($target))[7];
1583                         if ($tsize > 200) {
1584                             $_ = $ppm_to_root_window_cmd;
1585                             s/%%PPM%%/$target/;
1586
1587                             if ($DEBUG > 1) {
1588                                 print STDERR "running $_\n";
1589                             }
1590                             system $_;
1591
1592                         } elsif ($DEBUG > 1) {
1593                             print STDERR "$target size is $tsize\n";
1594                         }
1595                     }
1596                 }
1597             }
1598             unlink $image_tmp, $image_tmp2, $image_tmp3;
1599         }
1600
1601         sleep $delay;
1602
1603     } while (1);
1604 }
1605
1606
1607 sub x_main {
1608
1609     # Unlike CGI, when running in X mode, the various tmp files should be
1610     # in the /tmp directory and should have gensymed names.
1611     #
1612     $image_ppm = ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp") . "/webcollage." . $$;
1613     $image_tmp   = $image_ppm . "-1";
1614     $image_tmp2  = $image_ppm . "-2";
1615     $image_tmp3  = $image_ppm . "-3";
1616
1617     # In X mode, these aren't used.  Set them to undef to error if we try.
1618     #
1619     $data_dir = undef;
1620     $image_jpg = undef;
1621     $pending_file = undef;
1622     $map_file = undef;
1623     $url_generation_time = undef;
1624     $image_retrieval_time = undef;
1625     $max_map_entries = undef;
1626     $pastes_per_load = undef;
1627     $max_age = undef;
1628     $script_date = undef;
1629     @all_files = undef;
1630
1631     # In X mode, these come either from the command line, or from the X server.
1632     $img_width = undef;
1633     $img_height = undef;
1634
1635
1636     my $root_p = 0;
1637
1638     while ($_ = $ARGV[0]) {
1639         shift @ARGV;
1640         if ($_ eq "-display" ||
1641             $_ eq "-displ" ||
1642             $_ eq "-disp" ||
1643             $_ eq "-dis" ||
1644             $_ eq "-dpy" ||
1645             $_ eq "-d") {
1646             $ENV{DISPLAY} = shift @ARGV;
1647         } elsif ($_ eq "-root") {
1648             $root_p = 1;
1649         } elsif ($_ eq "-no-output") {
1650             $no_output_p = 1;
1651         } elsif ($_ eq "-urls-only") {
1652             $urls_only_p = 1;
1653             $no_output_p = 1;
1654         } elsif ($_ eq "-verbose") {
1655             $DEBUG++;
1656         } elsif (m/^-v+$/) {
1657             $DEBUG += length($_)-1;
1658         } elsif ($_ eq "-delay") {
1659             $delay = shift @ARGV;
1660         } elsif ($_ eq "-timeout") {
1661             $http_timeout = shift @ARGV;
1662         } elsif ($_ eq "-filter") {
1663             $filter_cmd = shift @ARGV;
1664         } elsif ($_ eq "-filter2") {
1665             $post_filter_cmd = shift @ARGV;
1666         } elsif ($_ eq "-background" || $_ eq "-bg") {
1667             $background = shift @ARGV;
1668         } elsif ($_ eq "-size") {
1669             $_ = shift @ARGV;
1670             if (m@^([0-9]+)x([0-9]+)$@) {
1671                 $img_width = $1;
1672                 $img_height = $2;
1673             } else {
1674                 die "$progname: argument to \"-size\" must be" .
1675                     " of the form \"640x400\"\n";
1676             }
1677         } else {
1678             die "$copyright\nusage: $progname [-root]" .
1679                 " [-display dpy] [-root] [-verbose] [-timeout secs]\n" .
1680                 "\t\t  [-delay secs] [-filter cmd] [-filter2 cmd]\n";
1681         }
1682     }
1683
1684     if (!$root_p && !$no_output_p) {
1685         die "$copyright" .
1686             "$progname: the -root argument is manditory (for now.)\n";
1687     }
1688
1689     if (!$no_output_p && !$ENV{DISPLAY}) {
1690         die "$progname: \$DISPLAY is not set.\n";
1691     }
1692
1693     if ($urls_only_p) {
1694         url_only_output;
1695     } else {
1696         x_output;
1697     }
1698 }
1699
1700
1701 ##############################################################################
1702 #
1703 # Decide if we're in X or CGI mode, and dispatch.
1704 #
1705 ##############################################################################
1706
1707 sub main {
1708     srand(time ^ $$);
1709     if ( $progname =~ m/\.cgi$/i || $ENV{REQUEST_METHOD} ) {
1710         cgi_main;
1711     } else {
1712         x_main;
1713     }
1714 }
1715
1716 main;
1717 exit (0);