X-Git-Url: http://git.hungrycats.org/cgi-bin/gitweb.cgi?p=xscreensaver;a=blobdiff_plain;f=hacks%2Fwebcollage;h=cd3fa4319bbf911a96d56e7323ed3320f84eb98c;hp=49768c978262200eeb7bbc1883029a47814c4db6;hb=c494fd2e6b3b25582375d62e40f4f5cc984ca424;hpb=df7adbee81405e2849728a24b498ad2117784b1f diff --git a/hacks/webcollage b/hacks/webcollage index 49768c97..cd3fa431 100755 --- a/hacks/webcollage +++ b/hacks/webcollage @@ -1,6 +1,6 @@ -#!/usr/local/bin/perl5 -w +#!/usr/bin/perl -w # -# webcollage, Copyright (c) 1999 by Jamie Zawinski +# webcollage, Copyright (c) 1999-2005 by Jamie Zawinski # This program decorates the screen with random images from the web. # One satisfied customer described it as "a nonstop pop culture brainbath." # @@ -9,105 +9,300 @@ # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation. No representations are made about the suitability of this -# software for any purpose. It is provided "as is" without express or +# software for any purpose. It is provided "as is" without express or # implied warranty. + # To run this as a display mode with xscreensaver, add this to `programs': # -# default-n: webcollage -root \n\ -# default-n: webcollage -root -filter 'vidwhacker -stdin -stdout' \n\ -# -# To run this as a CGI program on a web site, do this (these instructions -# work with Apache 1.3 or newer): -# -# 1: Place this program in your document directory, named "webcollage". -# The name shouldn't end in .cgi or .html, since this CGI behaves like -# a directory. -# 2: Make it world-readable and world-executable. -# 3: Create a ".htaccess" file in the same directory containing these lines: -# -# SetHandler cgi-script -# -# 4: Create these files in the same directory, world-writable, zero-length: -# collage.ppm -# collage.tmp -# collage.jpg -# collage.pending -# collage.map -# -# Now the CGI is ready to go. - -my $copyright = "WebCollage, Copyright (c) 1999" . - " Jamie Zawinski \n" . - " http://www.jwz.org/xscreensaver/\n"; +# webcollage -root +# webcollage -root -filter 'vidwhacker -stdin -stdout' +# +# +# You can see this in action at http://www.jwz.org/webcollage/ -- +# it auto-reloads about once a minute. To make a page similar to +# that on your own system, do this: +# +# webcollage -size '800x600' -imagemap $HOME/www/webcollage/index +# +# +# If you have the "driftnet" program installed, webcollage can display a +# collage of images sniffed off your local ethernet, instead of pulled out +# of search engines: in that way, your screensaver can display the images +# that your co-workers are downloading! +# +# Driftnet is available here: http://www.ex-parrot.com/~chris/driftnet/ +# Use it like so: +# +# webcollage -root -driftnet +# +# Driftnet is the Unix implementation of the MacOS "EtherPEG" program. + + +require 5; +use strict; + +# We can't "use diagnostics" here, because that library malfunctions if +# you signal and catch alarms: it says "Uncaught exception from user code" +# and exits, even though I damned well AM catching it! +#use diagnostics; -my $argv0 = $0; -my $progname = $argv0; $progname =~ s@.*/@@g; -my $version = q{ $Revision: 1.7 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/; use Socket; require Time::Local; require POSIX; use Fcntl ':flock'; # import LOCK_* constants +use POSIX qw(strftime); + +use bytes; # Larry can take Unicode and shove it up his ass sideways. + # Perl 5.8.0 causes us to start getting incomprehensible + # errors about UTF-8 all over the place without this. + + +my $progname = $0; $progname =~ s@.*/@@g; +my $version = q{ $Revision: 1.133 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/; +my $copyright = "WebCollage $version, Copyright (c) 1999-2005" . + " Jamie Zawinski \n" . + " http://www.jwz.org/webcollage/\n"; + + + +my @search_methods = ( 56, "altavista", \&pick_from_alta_vista_random_link, + 11, "livejournal", \&pick_from_livejournal_images, + 5, "yahoorand", \&pick_from_yahoo_random_link, + 10, "googlephotos", \&pick_from_google_image_photos, + 5, "googleimgs", \&pick_from_google_images, + 3, "googlenums", \&pick_from_google_image_numbers, + 2, "flickr_recent", \&pick_from_flickr_recent, + 8, "flickr_random", \&pick_from_flickr_random, + + # In Apr 2002, Google asked me to stop searching them. + # I asked them to add a "random link" url. They said + # "that would be easy, we'll think about it" and then + # never wrote back. Booo Google! Booooo! So, screw + # those turkeys, I've turned Google searching back on. + # I'm sure they can take it. (Jan 2005.) + + # Jan 2005: Yahoo fucked up their search form so that + # it's no longer possible to do "or" searches on news + # images, so we rarely get any hits there any more. + # + # 0, "yahoonews", \&pick_from_yahoo_news_text, + + # Dec 2004: the ircimages guy's server can't take the + # heat, so he started banning the webcollage user agent. + # I tried to convince him to add a lighter-weight page to + # support webcollage better, but he doesn't care. + # + # 0, "ircimages", \&pick_from_ircimages, + + # Dec 2002: Alta Vista has a new "random link" URL now. + # They added it specifically to better support webcollage! + # That was super cool of them. This is how we used to do + # it, before: + # + # 0, "avimages", \&pick_from_alta_vista_images, + # 0, "avtext", \&pick_from_alta_vista_text, + + # This broke in 2004. Eh, Lycos sucks anyway. + # + # 0, "lycos", \&pick_from_lycos_text, + + # This broke in 2003, I think. I suspect Hotbot is + # actually the same search engine data as Lycos. + # + # 0, "hotbot", \&pick_from_hotbot_text, + ); + +# programs we can use to write to the root window (tried in ascending order.) +# +my @root_displayers = ( + "xscreensaver-getimage -root -file", + "chbg -once -xscreensaver -max_size 100", + "xv -root -quit -viewonly +noresetroot -quick24 -rmode 5" . + " -rfg black -rbg black", + "xli -quiet -onroot -center -border black", + "xloadimage -quiet -onroot -center -border black", +# this lame program wasn't built with vroot.h: +# "xsri -scale -keep-aspect -center-horizontal -center-vertical", +); -# CGI Parameters -my $data_dir = ""; # if you want the following files to go in - # some directory below ".", name it here. +# Some sites need cookies to work properly. These are they. +# +my %cookies = ( + "www.altavista.com" => "AV_ALL=1", # request uncensored searches + "web.altavista.com" => "AV_ALL=1", -my $image_ppm = "${data_dir}collage.ppm"; # names of the various data files. -my $image_tmp = "${data_dir}collage.tmp"; -my $image_jpg = "${data_dir}collage.jpg"; -my $pending_file = "${data_dir}collage.pending"; -my $map_file = "${data_dir}collage.map"; + # log in as "cipherpunk" + "www.nytimes.com" => 'NYT-S=18cHMIlJOn2Y1bu5xvEG3Ufuk6E1oJ.' . + 'FMxWaQV0igaB5Yi/Q/guDnLeoL.pe7i1oakSb' . + '/VqfdUdb2Uo27Vzt1jmPn3cpYRlTw9', -my $url_generation_time = 60; # total time to spend getting URLs. -my $image_retrieval_time = 60; # maximum time to spend loading all images. -my $max_map_entries = 100; # how many lines to save in $map_file. -my $pastes_per_load = 3; # how many images to try and paste each time. + "ircimages.com" => 'disclaimer=1', +); -my $max_age = 5 * 60; # minutes before it is considered stale. -my $scale = 1.0; # client-side image expansion. -my $img_width = 800; # size of the image being generated. -my $img_height = 600; +# If this is set, it's a helper program to use for pasting images together: +# this is a lot faster and more efficient than using PPM pipelines, which is +# what we do if this program doesn't exist. (We check for "webcollage-helper" +# on $PATH at startup, and set this variable appropriately.) +# +my $webcollage_helper = undef; -my @all_files = ($image_ppm, $image_tmp, $image_jpg, $pending_file, $map_file); -my $script_date; -# Other Parameters +# If we have the webcollage-helper program, then it will paste the images +# together with transparency! 0.0 is invisible, 1.0 is totally opaque. +# +my $opacity = 0.85; -my $random_redirector = "http://random.yahoo.com/bin/ryl"; -my $image_randomizer_a = "http://image.altavista.com/"; -my $image_randomizer = $image_randomizer_a . "cgi-bin/avncgi" . - "?do=3&verb=no&oshape=n&oorder=" . - "&ophoto=1&oart=1&ocolor=1&obw=1" . - "&stype=simage&oprem=0&query="; -my $http_timeout = 30; -my $ppm_to_root_window_cmd = "xv -root -rmode 5 -viewonly" . - " +noresetroot %%PPM%% -quit"; -my $filter_cmd = undef; -my $post_filter_cmd = undef; -my $background = undef; -my $no_output_p = 0; -my $urls_only_p = 0; -my $delay = 0; +# Some sites have managed to poison the search engines. These are they. +# (We auto-detect sites that have poisoned the search engines via excessive +# keywords or dictionary words, but these are ones that slip through +# anyway.) +# +# This can contain full host names, or 2 or 3 component domains. +# +my %poisoners = ( + "die.net" => 1, # 'l33t h4ck3r d00dz. + "genforum.genealogy.com" => 1, # Cluttering avtext with human names. + "rootsweb.com" => 1, # Cluttering avtext with human names. + "akamai.net" => 1, # Lots of sites have their images on Akamai. + "akamaitech.net" => 1, # But those are pretty much all banners. + # Since Akamai is super-expensive, let's + # go out on a limb and assume that all of + # their customers are rich-and-boring. + "bartleby.com" => 1, # Dictionary, cluttering avtext. + "encyclopedia.com" => 1, # Dictionary, cluttering avtext. + "onlinedictionary.datasegment.com" => 1, # Dictionary, cluttering avtext. + "hotlinkpics.com" => 1, # Porn site that has poisoned avimages + # (I don't see how they did it, though!) + "alwayshotels.com" => 1, # Poisoned Lycos pretty heavily. + "nextag.com" => 1, # Poisoned Alta Vista real good. +); + + +# When verbosity is turned on, we warn about sites that we seem to be hitting +# a lot: usually this means some new poisoner has made it into the search +# engines. But sometimes, the warning is just because that site has a lot +# of stuff on it. So these are the sites that are immune to the "frequent +# site" diagnostic message. +# +my %warningless_sites = ( + "home.earthlink.net" => 1, # Lots of home pages here. + "www.geocities.com" => 1, + "www.angelfire.com" => 1, + "members.aol.com" => 1, + "img.photobucket.com" => 1, + "pics.livejournal.com" => 1, + "tinypic.com" => 1, + "flickr.com" => 1, + + "yimg.com" => 1, # This is where dailynews.yahoo.com stores + "eimg.com" => 1, # its images, so pick_from_yahoo_news_text() + # hits this every time. + + "images.quizfarm.com" => 1, # damn those LJ quizzes... + "images.quizilla.com" => 1, + "images.quizdiva.net" => 1, + + "driftnet" => 1, # builtin... + "local-directory" => 1, # builtin... +); + + +# For decoding HTML-encoded character entities to URLs. +# +my %entity_table = ( + "apos" => '\'', + "quot" => '"', "amp" => '&', "lt" => '<', "gt" => '>', + "nbsp" => ' ', "iexcl" => '¡', "cent" => '¢', "pound" => '£', + "curren" => '¤', "yen" => '¥', "brvbar" => '¦', "sect" => '§', + "uml" => '¨', "copy" => '©', "ordf" => 'ª', "laquo" => '«', + "not" => '¬', "shy" => '­', "reg" => '®', "macr" => '¯', + "deg" => '°', "plusmn" => '±', "sup2" => '²', "sup3" => '³', + "acute" => '´', "micro" => 'µ', "para" => '¶', "middot" => '·', + "cedil" => '¸', "sup1" => '¹', "ordm" => 'º', "raquo" => '»', + "frac14" => '¼', "frac12" => '½', "frac34" => '¾', "iquest" => '¿', + "Agrave" => 'À', "Aacute" => 'Á', "Acirc" => 'Â', "Atilde" => 'Ã', + "Auml" => 'Ä', "Aring" => 'Å', "AElig" => 'Æ', "Ccedil" => 'Ç', + "Egrave" => 'È', "Eacute" => 'É', "Ecirc" => 'Ê', "Euml" => 'Ë', + "Igrave" => 'Ì', "Iacute" => 'Í', "Icirc" => 'Î', "Iuml" => 'Ï', + "ETH" => 'Ð', "Ntilde" => 'Ñ', "Ograve" => 'Ò', "Oacute" => 'Ó', + "Ocirc" => 'Ô', "Otilde" => 'Õ', "Ouml" => 'Ö', "times" => '×', + "Oslash" => 'Ø', "Ugrave" => 'Ù', "Uacute" => 'Ú', "Ucirc" => 'Û', + "Uuml" => 'Ü', "Yacute" => 'Ý', "THORN" => 'Þ', "szlig" => 'ß', + "agrave" => 'à', "aacute" => 'á', "acirc" => 'â', "atilde" => 'ã', + "auml" => 'ä', "aring" => 'å', "aelig" => 'æ', "ccedil" => 'ç', + "egrave" => 'è', "eacute" => 'é', "ecirc" => 'ê', "euml" => 'ë', + "igrave" => 'ì', "iacute" => 'í', "icirc" => 'î', "iuml" => 'ï', + "eth" => 'ð', "ntilde" => 'ñ', "ograve" => 'ò', "oacute" => 'ó', + "ocirc" => 'ô', "otilde" => 'õ', "ouml" => 'ö', "divide" => '÷', + "oslash" => 'ø', "ugrave" => 'ù', "uacute" => 'ú', "ucirc" => 'û', + "uuml" => 'ü', "yacute" => 'ý', "thorn" => 'þ', "yuml" => 'ÿ', + "ndash" => '-', "mdash" => "--" +); -my $wordlist = "/usr/dict/words"; -if (!-r $wordlist) { - $wordlist = "/usr/share/lib/dict/words"; # irix -} +############################################################################## +# +# Various global flags set by command line parameters, or computed +# +############################################################################## + +my $current_state = "???"; # for diagnostics +my $load_method; +my $last_search; +my $image_succeeded = -1; +my $suppress_audit = 0; + +my $verbose_imgmap = 0; # print out rectangles and URLs only (stdout) +my $verbose_warnings = 0; # print out warnings when things go wrong +my $verbose_load = 0; # diagnostics about loading of URLs +my $verbose_filter = 0; # diagnostics about page selection/rejection +my $verbose_net = 0; # diagnostics about network I/O +my $verbose_pbm = 0; # diagnostics about PBM pipelines +my $verbose_http = 0; # diagnostics about all HTTP activity +my $verbose_exec = 0; # diagnostics about executing programs + +my $report_performance_interval = 60 * 15; # print some stats every 15 minutes + +my $http_proxy = undef; +my $http_timeout = 20; +my $cvt_timeout = 10; my $min_width = 50; my $min_height = 50; my $min_ratio = 1/5; -my $DEBUG = 0; +my $min_gif_area = (120 * 120); + +my $no_output_p = 0; +my $urls_only_p = 0; +my $cocoa_p = 0; +my $imagemap_base = undef; + +my @pids_to_kill = (); # forked pids we should kill when we exit, if any. + +my $driftnet_magic = 'driftnet'; +my $driftnet_dir = undef; +my $default_driftnet_cmd = "driftnet -a -m 100"; + +my $local_magic = 'local-directory'; +my $local_dir = undef; + +my $wordlist; + +my %rejected_urls; +my @tripwire_words = ("aberrate", "abode", "amorphous", "antioch", + "arrhenius", "arteriole", "blanket", "brainchild", + "burdensome", "carnival", "cherub", "chord", "clever", + "dedicate", "dilogarithm", "dolan", "dryden", + "eggplant"); ############################################################################## @@ -119,1599 +314,3236 @@ my $DEBUG = 0; # returns three values: the HTTP response line; the document headers; # and the document body. # -sub get_document_1 { - my ( $url, $referer, $timeout ) = @_; +sub get_document_1($$$) { + my ($url, $referer, $timeout) = @_; + + if (!defined($timeout)) { $timeout = $http_timeout; } + if ($timeout > $http_timeout) { $timeout = $http_timeout; } + + if ($timeout <= 0) { + LOG (($verbose_net || $verbose_load), "timed out for $url"); + return (); + } + + LOG ($verbose_net, "get_document_1 $url " . ($referer ? $referer : "")); + + if (! ($url =~ m@^http://@i)) { + LOG ($verbose_net, "not an HTTP URL: $url"); + return (); + } + + my ($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4); + $path = "" unless $path; + + if (!$url_proto || !$serverstring) { + LOG (($verbose_net || $verbose_load), "unparsable URL: $url"); + return (); + } + + my ($them,$port) = split(/:/, $serverstring); + $port = 80 unless $port; + + my $them2 = $them; + my $port2 = $port; + if ($http_proxy) { + $serverstring = $http_proxy if $http_proxy; + $serverstring =~ s@^[a-z]+://@@; + ($them2,$port2) = split(/:/, $serverstring); + $port2 = 80 unless $port2; + } + + my ($remote, $iaddr, $paddr, $proto, $line); + $remote = $them2; + if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') } + if (!$port2) { + LOG (($verbose_net || $verbose_load), "unrecognised port in $url"); + return (); + } + $iaddr = inet_aton($remote); + if (!$iaddr) { + LOG (($verbose_net || $verbose_load), "host not found: $remote"); + return (); + } + $paddr = sockaddr_in($port2, $iaddr); + + + my $head = ""; + my $body = ""; + + @_ = + eval { + local $SIG{ALRM} = sub { + LOG (($verbose_net || $verbose_load), "timed out ($timeout) for $url"); + die "alarm\n"; + }; + alarm $timeout; + + $proto = getprotobyname('tcp'); + if (!socket(S, PF_INET, SOCK_STREAM, $proto)) { + LOG (($verbose_net || $verbose_load), "socket: $!"); + return (); + } + if (!connect(S, $paddr)) { + LOG (($verbose_net || $verbose_load), "connect($serverstring): $!"); + return (); + } + + select(S); $| = 1; select(STDOUT); + + my $cookie = $cookies{$them}; + + my $user_agent = "$progname/$version"; + + if ($url =~ m@^http://www\.altavista\.com/@ || + $url =~ m@^http://random\.yahoo\.com/@ || + $url =~ m@^http://images\.google\.com/@) { + # block this, you turkeys. + $user_agent = "Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7.5)" . + " Gecko/20041111 Firefox/1.0"; + } + + my $hdrs = "GET " . ($http_proxy ? $url : "/$path") . " HTTP/1.0\r\n" . + "Host: $them\r\n" . + "User-Agent: $user_agent\r\n"; + if ($referer) { + $hdrs .= "Referer: $referer\r\n"; + } + if ($cookie) { + my @cc = split(/\r?\n/, $cookie); + $hdrs .= "Cookie: " . join('; ', @cc) . "\r\n"; + } + $hdrs .= "\r\n"; + + foreach (split('\r?\n', $hdrs)) { + LOG ($verbose_http, " ==> $_"); + } + print S $hdrs; + my $http = || ""; + + # Kludge: the Yahoo Random Link is now returning as its first + # line "Status: 301" instead of "HTTP/1.0 301 Found". Fix it... + # + $http =~ s@^Status:\s+(\d+)\b@HTTP/1.0 $1@i; + + $_ = $http; + s/[\r\n]+$//s; + LOG ($verbose_http, " <== $_"); + + while () { + $head .= $_; + s/[\r\n]+$//s; + last if m@^$@; + LOG ($verbose_http, " <== $_"); + + if (m@^Set-cookie:\s*([^;\r\n]+)@i) { + set_cookie($them, $1) + } + } - if (!defined($timeout)) { $timeout = $http_timeout; } - if ($timeout <= 0) { return undef; } - if ($timeout > $http_timeout) { $timeout = $http_timeout; } + my $lines = 0; + while () { + $body .= $_; + $lines++; + } - if ( $DEBUG > 3 ) { - print STDERR "get_document_1 $url " . - ($referer ? $referer : "") . "\n"; - } + LOG ($verbose_http, + " <== [ body ]: $lines lines, " . length($body) . " bytes"); - my($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4); - if (! ($url_proto && $url_proto =~ m/^http:$/i)) { - if ($DEBUG) { print STDERR "not an HTTP URL: $url\n"; } - return undef; - } - my($them,$port) = split(/:/, $serverstring); - $port = 80 unless $port; - my $size=""; - - my ($remote, $iaddr, $paddr, $proto, $line); - $remote = $them; - if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } - return unless $port; - $iaddr = inet_aton($remote) || return; - $paddr = sockaddr_in($port, $iaddr); - - @_ = - eval { - local $SIG{ALRM} = sub { - if ($DEBUG > 0) { - print STDERR "timed out ($timeout) for $url\n"; - } - die "alarm\n" }; - alarm $timeout; - - $proto = getprotobyname('tcp'); - socket(S, PF_INET, SOCK_STREAM, $proto) || return; - connect(S, $paddr) || return; - - select(S); $| = 1; select(STDOUT); - - print S ("GET /$path HTTP/1.0\n" . - "Host: $them\n" . - "User-Agent: $progname/$version\n" . - ($referer ? "Referer: $referer\n" : "") . - "\n"); - - my $http = ; - - my $head = ""; - my $body = ""; - while () { - $head .= $_; - last if m@^[\r\n]@; - } - while () { - $body .= $_; - } + close S; - close S; + if (!$http) { + LOG (($verbose_net || $verbose_load), "null response: $url"); + return (); + } - return ( $http, $head, $body ); + $SIG{ALRM} = 'DEFAULT'; # seem to be suffering a race? + return ( $http, $head, $body ); }; - die if ($@ && $@ ne "alarm\n"); # propagate errors - if ($@) { - # timed out - return undef; - } else { - # didn't - alarm 0; - return @_; - } + die if ($@ && $@ ne "alarm\n"); # propagate errors + + if ($@ && $@ ne "alarm\n") { + print STDERR blurb() . "DIE " . join(" ", $@) . "\n"; + die; + } + + if ($@) { + # timed out + $head = undef; + $body = undef; + $suppress_audit = 1; + return (); + } else { + # didn't + alarm 0; + return @_; + } } # returns two values: the document headers; and the document body. # if the given URL did a redirect, returns the redirected-to document. # -sub get_document { - my ( $url, $referer, $timeout ) = @_; - my $start = time; +sub get_document($$;$) { + my ($url, $referer, $timeout) = @_; + my $start = time; + + if (defined($referer) && $referer eq $driftnet_magic) { + return get_driftnet_file ($url); + } + + if (defined($referer) && $referer eq $local_magic) { + return get_local_file ($url); + } + + my $orig_url = $url; + my $loop_count = 0; + my $max_loop_count = 4; + + do { + if (defined($timeout) && $timeout <= 0) { + LOG (($verbose_net || $verbose_load), "timed out for $url"); + $suppress_audit = 1; + return (); + } - do { - if (defined($timeout) && $timeout <= 0) { return undef; } + my ( $http, $head, $body ) = get_document_1 ($url, $referer, $timeout); - my ( $http, $head, $body ) = get_document_1 ($url, $referer, $timeout); + if (defined ($timeout)) { + my $now = time; + my $elapsed = $now - $start; + $timeout -= $elapsed; + $start = $now; + } - if (defined ($timeout)) { - my $now = time; - my $elapsed = $now - $start; - $timeout -= $elapsed; - $start = $now; - } + return () unless $http; # error message already printed - return undef if ( ! $body ); + $http =~ s/[\r\n]+$//s; - if ( $http =~ m@HTTP/[0-9.]+ 30[23]@ ) { - $_ = $head; - my ( $location ) = m@^location:[ \t]*(.*)$@im; - if ( $location ) { + if ( $http =~ m@^HTTP/[0-9.]+ 30[123]@ ) { + $_ = $head; - if ( $DEBUG > 3 ) { - print STDERR "redirect from $url to $location\n"; - } - $referer = $url; - $url = $location; - } else { - return ( $url, $body ); - } + my ( $location ) = m@^location:[ \t]*(.*)$@im; + if ( $location ) { + $location =~ s/[\r\n]$//; - } elsif ( $http =~ m@HTTP/[0-9.]+ [4-9][0-9][0-9]@ ) { - # http errors -- return nothing. - return undef; + LOG ($verbose_net, "redirect from $url to $location"); + $referer = $url; + $url = $location; - } else { + if ($url =~ m@^/@) { + $referer =~ m@^(http://[^/]+)@i; + $url = $1 . $url; + } elsif (! ($url =~ m@^[a-z]+:@i)) { + $_ = $referer; + s@[^/]+$@@g if m@^http://[^/]+/@i; + $_ .= "/" if m@^http://[^/]+$@i; + $url = $_ . $url; + } - return ( $url, $body ); - } + } else { + LOG ($verbose_net, "no Location with \"$http\""); + return ( $url, $body ); + } - } while (1); -} + if ($loop_count++ > $max_loop_count) { + LOG ($verbose_net, + "too many redirects ($max_loop_count) from $orig_url"); + $body = undef; + return (); + } + } elsif ( $http =~ m@^HTTP/[0-9.]+ ([4-9][0-9][0-9].*)$@ ) { -# given a URL and the body text at that URL, selects and returns a random -# image from it. returns undef if no suitable images found. -# -sub pick_image_from_body { - my ( $base, $body ) = @_; + LOG (($verbose_net || $verbose_load), "failed: $1 ($url)"); - $_ = $base; + # http errors -- return nothing. + $body = undef; + return (); - # if there's at least one slash after the host, take off the last - # pathname component - if ( m@^http://[^/]+/@io ) { - ( $base = $base ) =~ s@[^/]+$@@go; - } + } elsif (!$body) { - # if there are no slashes after the host at all, put one on the end. - if ( m@^http://[^/]+$@io ) { - $base .= "/"; - } + LOG (($verbose_net || $verbose_load), "document contains no data: $url"); + return (); + + } else { - if ( $DEBUG > 3 ) { - print STDERR "base is $base\n"; + # ok! + return ( $url, $body ); } + } while (1); +} - $_ = $body; - - # strip out newlines, compress whitespace - s/[\r\n\t ]+/ /go; - - # nuke comments - s///go; - - my @urls; - my %unique_urls; - - foreach (split(/ *\"]/io ) { - - my $was_inline = ( "$1" eq "a" || "$1" eq "A" ); - my $link = $3; - my ( $width ) = m/width ?=[ \"]*([0-9]+)/oi; - my ( $height ) = m/height ?=[ \"]*([0-9]+)/oi; - $_ = $link; - - if ( m@^/@o ) { - my $site; - ( $site = $base ) =~ s@^(http://[^/]*).*@$1@gio; - $_ = "$site$link"; - } elsif ( ! m@^[^/:?]+:@ ) { - $_ = "$base$link"; - s@/\./@/@g; - while (s@/\.\./@/@g) { - } - } - - # skip non-http - if ( ! m@^http://@io ) { - next; - } - - # skip non-image - if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg)$@io ) { - next; - } - -# # skip GIF? -# if ( m@[.](gif)@io ) { -## if ( $DEBUG > 2 ) { print STDERR "skip GIF $_\n"; } -# next; -# } - - # skip really short or really narrow images - if ( $width && $width < $min_width) { - if ( $DEBUG > 2 ) { - if (!$height) { $height = "?"; } - print STDERR "skip narrow image $_ ($width x $height)\n"; - } - next; - } - - if ( $height && $height < $min_height) { - if ( $DEBUG > 2 ) { - if (!$width) { $width = "?"; } - print STDERR "skip short image $_ ($width x $height)\n"; - } - next; - } - - # skip images with ratios that make them look like banners. - if ( $min_ratio && $width && $height && - ($width * $min_ratio ) > $height ) { - if ( $DEBUG > 2 ) { - if (!$height) { $height = "?"; } - print STDERR "skip bad ratio $_ ($width x $height)\n"; - } - next; - } - - my $url = $_; - - if ( $unique_urls{$url} ) { - if ( $DEBUG > 2 ) { print STDERR "skip duplicate image $_\n"; } - next; - } - - if ( $DEBUG > 2 ) { - print STDERR "got $url" . - ($width && $height ? " (${width}x${height})" : "") . - ($was_inline ? " (inline)" : "") . "\n"; - } - - $urls[++$#urls] = $url; - $unique_urls{$url}++; - - # jpegs are preferable to gifs. - $_ = $url; - if ( ! m@[.]gif$@io ) { - $urls[++$#urls] = $url; - } - - # pointers to images are preferable to inlined images. - if ( ! $was_inline ) { - $urls[++$#urls] = $url; - $urls[++$#urls] = $url; - } - } - } +# If we already have a cookie defined for this site, and the site is trying +# to overwrite that very same cookie, let it do so. This is because nytimes +# expires its cookies - it lets you upgrade to a new cookie without logging +# in again, but you have to present the old cookie to get the new cookie. +# So, by doing this, the built-in cypherpunks cookie will never go "stale". +# +sub set_cookie($$) { + my ($host, $cookie) = @_; + my $oc = $cookies{$host}; + return unless $oc; + $_ = $oc; + my ($oc_name, $oc_value) = m@^([^= \t\r\n]+)=(.*)$@; + $_ = $cookie; + my ($nc_name, $nc_value) = m@^([^= \t\r\n]+)=(.*)$@; + + if ($oc_name eq $nc_name && + $oc_value ne $nc_value) { + $cookies{$host} = $cookie; + LOG ($verbose_net, "overwrote ${host}'s $oc_name cookie"); + } +} - if ( $#urls == 0 ) { - if ( $DEBUG > 2 ) { - print STDERR "no images on $base\n"; - } - return undef; + +############################################################################ +# +# Extracting image URLs from HTML +# +############################################################################ + +# given a URL and the body text at that URL, selects and returns a random +# image from it. returns () if no suitable images found. +# +sub pick_image_from_body($$) { + my ($url, $body) = @_; + + my $base = $url; + $_ = $url; + + # if there's at least one slash after the host, take off the last + # pathname component + if ( m@^http://[^/]+/@io ) { + $base =~ s@[^/]+$@@go; + } + + # if there are no slashes after the host at all, put one on the end. + if ( m@^http://[^/]+$@io ) { + $base .= "/"; + } + + $_ = $body; + + # strip out newlines, compress whitespace + s/[\r\n\t ]+/ /go; + + # nuke comments + s///go; + + + # There are certain web sites that list huge numbers of dictionary + # words in their bodies or in their tags (surprise! + # Porn sites tend not to be reputable!) + # + # I do not want webcollage to filter on content: I want it to select + # randomly from the set of images on the web. All the logic here for + # rejecting some images is really a set of heuristics for rejecting + # images that are not really images: for rejecting *text* that is in + # GIF/JPEG/PNG form. I don't want text, I want pictures, and I want + # the content of the pictures to be randomly selected from among all + # the available content. + # + # So, filtering out "dirty" pictures by looking for "dirty" keywords + # would be wrong: dirty pictures exist, like it or not, so webcollage + # should be able to select them. + # + # However, picking a random URL is a hard thing to do. The mechanism I'm + # using is to search for a selection of random words. This is not + # perfect, but works ok most of the time. The way it breaks down is when + # some URLs get precedence because their pages list *every word* as + # related -- those URLs come up more often than others. + # + # So, after we've retrieved a URL, if it has too many keywords, reject + # it. We reject it not on the basis of what those keywords are, but on + # the basis that by having so many, the page has gotten an unfair + # advantage against our randomizer. + # + my $trip_count = 0; + foreach my $trip (@tripwire_words) { + $trip_count++ if m/$trip/i; + } + + if ($trip_count >= $#tripwire_words - 2) { + LOG (($verbose_filter || $verbose_load), + "there is probably a dictionary in \"$url\": rejecting."); + $rejected_urls{$url} = -1; + $body = undef; + $_ = undef; + return (); + } + + + my @urls; + my %unique_urls; + + foreach (split(/ * 1000) { + LOG (($verbose_filter || $verbose_load), + "excessive keywords ($L bytes) in $url: rejecting."); + $rejected_urls{$url} = $L; + $body = undef; + $_ = undef; + return (); + } else { + LOG ($verbose_filter, " keywords ($L bytes) in $url (ok)"); + } + } + + } elsif ( m/^(img|a) .*(src|href) ?= ?\"? ?(.*?)[ >\"]/io ) { + + my $was_inline = (! ( "$1" eq "a" || "$1" eq "A" )); + my $link = $3; + my ( $width ) = m/width ?=[ \"]*(\d+)/oi; + my ( $height ) = m/height ?=[ \"]*(\d+)/oi; + $_ = $link; + + if ( m@^/@o ) { + my $site; + ( $site = $base ) =~ s@^(http://[^/]*).*@$1@gio; + $_ = "$site$link"; + } elsif ( ! m@^[^/:?]+:@ ) { + $_ = "$base$link"; + s@/\./@/@g; + 1 while (s@/[^/]+/\.\./@/@g); + } + + # skip non-http + if ( ! m@^http://@io ) { + next; + } + + # skip non-image + if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg|png)$@io ) { + next; + } + + # skip really short or really narrow images + if ( $width && $width < $min_width) { + if (!$height) { $height = "?"; } + LOG ($verbose_filter, " skip narrow image $_ (${width}x$height)"); + next; + } + + if ( $height && $height < $min_height) { + if (!$width) { $width = "?"; } + LOG ($verbose_filter, " skip short image $_ (${width}x$height)"); + next; + } + + # skip images with ratios that make them look like banners. + if ($min_ratio && $width && $height && + ($width * $min_ratio ) > $height) { + if (!$height) { $height = "?"; } + LOG ($verbose_filter, " skip bad ratio $_ (${width}x$height)"); + next; + } + + # skip GIFs with a small number of pixels -- those usually suck. + if ($width && $height && + m/\.gif$/io && + ($width * $height) < $min_gif_area) { + LOG ($verbose_filter, " skip small GIF $_ (${width}x$height)"); + next; + } + + # skip images with a URL that indicates a Yahoo thumbnail. + if (m@\.yimg\.com/.*/t/@) { + if (!$width) { $width = "?"; } + if (!$height) { $height = "?"; } + LOG ($verbose_filter, " skip yahoo thumb $_ (${width}x$height)"); + next; + } + + my $url = $_; + + if ($unique_urls{$url}) { + LOG ($verbose_filter, " skip duplicate image $_"); + next; + } + + LOG ($verbose_filter, + " image $url" . + ($width && $height ? " (${width}x${height})" : "") . + ($was_inline ? " (inline)" : "")); + + $urls[++$#urls] = $url; + $unique_urls{$url}++; + + # JPEGs are preferable to GIFs and PNGs. + $_ = $url; + if ( ! m@[.](gif|png)$@io ) { + $urls[++$#urls] = $url; + } + + # pointers to images are preferable to inlined images. + if ( ! $was_inline ) { + $urls[++$#urls] = $url; + $urls[++$#urls] = $url; + } } + } - return undef if ( $#urls < 1 ); + my $fsp = ($body =~ m@ 2 ) { - print STDERR "picked $url\n"; - } + @urls = depoison (@urls); + + if ( $#urls < 0 ) { + LOG ($verbose_load, "no images on $base" . ($fsp ? " (frameset)" : "")); + return (); + } + + # pick a random element of the table + my $i = int(rand($#urls+1)); + $url = $urls[$i]; + + LOG ($verbose_load, "picked image " .($i+1) . "/" . ($#urls+1) . ": $url"); - return $url; + return $url; } +# Given a URL and the RSS feed from that URL, pick a random image from +# the feed. This is a lot simpler than extracting images out of a page: +# we already know we have reasonable images, so we just pick one. +# Returns: the real URL of the page (preferably not the RSS version), +# and the image. + +sub pick_image_from_rss($$) { + my ( $url, $body ) = @_; + my @suitable = ($body =~ m/([^<>]+)@i); + $base = $url unless $base; + + # pick a random element of the table + if (@suitable) { + my $i = int(rand(scalar @suitable)); + my $url = $suitable[$i]; + LOG ($verbose_load, "picked image " .($i+1) . "/" . + ($#suitable+1) . ": $url"); + return ($base, $url); + } + return; +} -# Using the URL-randomizer, picks a random image on a random page, and -# returns two URLs: the page containing the image, and the image. -# Returns undef if nothing found this time. + +############################################################################ # -sub pick_from_url_randomizer { - my ( $timeout ) = @_; +# Subroutines for getting pages and images out of search engines +# +############################################################################ + - if ( $DEBUG > 3 ) { - print STDERR "\n\npicking from $random_redirector...\n\n"; +sub pick_dictionary() { + my @dicts = ("/usr/dict/words", + "/usr/share/dict/words", + "/usr/share/lib/dict/words"); + foreach my $f (@dicts) { + if (-f $f) { + $wordlist = $f; + last; } + } + error ("$dicts[0] does not exist") unless defined($wordlist); +} - my ( $base, $body ) = get_document ($random_redirector, undef, $timeout); +# returns a random word from the dictionary +# +sub random_word() { - return if (!$base || !$body); - my $img = pick_image_from_body ($base, $body); + local *IN; + if (! open (IN, "<$wordlist")) { + return undef; + } - if ($img) { - return ($base, $img); - } else { - return undef; + my $size = (stat(IN))[7]; + my $word = undef; + my $count = 0; + + while (1) { + error ("looping ($count) while reading $wordlist") + if (++$count > 100); + + my $pos = int (rand ($size)); + if (seek (IN, $pos, 0)) { + $word = ; # toss partial line + $word = ; # keep next line } + + next unless ($word); + next if ($word =~ m/^[-\']/); + + $word = lc($word); + $word =~ s/^.*-//s; + $word =~ s/^[^a-z]+//s; + $word =~ s/[^a-z]+$//s; + $word =~ s/\'s$//s; + $word =~ s/ys$/y/s; + $word =~ s/ally$//s; + $word =~ s/ly$//s; + $word =~ s/ies$/y/s; + $word =~ s/ally$/al/s; + $word =~ s/izes$/ize/s; + $word =~ s/esses$/ess/s; + $word =~ s/(.{5})ing$/$1/s; + + next if (length ($word) > 14); + last if ($word); + } + + close (IN); + + if ( $word =~ s/\s/\+/gs ) { # convert intra-word spaces to "+". + $word = "\%22$word\%22"; # And put quotes (%22) around it. + } + + return $word; } -sub random_word { - - my $word = 0; - if (open (IN, "<$wordlist")) { - my $size = (stat(IN))[7]; - my $pos = rand $size; - if (seek (IN, $pos, 0)) { - $word = ; # toss partial line - $word = ; # keep next line - } - close (IN); - } +sub random_words($) { + my ($or_p) = @_; + my $sep = ($or_p ? "%20OR%20" : "%20"); + return (random_word . $sep . + random_word . $sep . + random_word . $sep . + random_word . $sep . + random_word); +} + - return 0 if (!$word); +sub url_quote($) { + my ($s) = @_; + $s =~ s|([^-a-zA-Z0-9.\@/_\r\n])|sprintf("%%%02X", ord($1))|ge; + return $s; +} - $word =~ s/^[ \t\n\r]+//; - $word =~ s/[ \t\n\r]+$//; - $word =~ s/ys$/y/; - $word =~ s/ally$//; - $word =~ s/ly$//; - $word =~ s/ies$/y/; - $word =~ s/ally$/al/; - $word =~ s/izes$/ize/; - $word =~ tr/A-Z/a-z/; +sub url_unquote($) { + my ($s) = @_; + $s =~ s/[+]/ /g; + $s =~ s/%([a-z0-9]{2})/chr(hex($1))/ige; + return $s; +} - return $word; +sub html_quote($) { + my ($s) = @_; + $s =~ s/&/&/gi; + $s =~ s//>/gi; + $s =~ s/\"/"/gi; + return $s; } +sub html_unquote($) { + my ($s) = @_; + $s =~ s/(&([a-z]+);)/{ $entity_table{$2} || $1; }/gexi; # e.g., ' + $s =~ s/(&\#(\d+);)/{ chr($2) }/gexi; # e.g., ' + return $s; +} -# Using the image-randomizer, picks a random image on a random page, and -# returns two URLs: the page containing the image, and the image. -# Returns undef if nothing found this time. +# Loads the given URL (a search on some search engine) and returns: +# - the total number of hits the search engine claimed it had; +# - a list of URLs from the page that the search engine returned; +# Note that this list contains all kinds of internal search engine +# junk URLs too -- caller must prune them. # -sub pick_from_image_randomizer { - my ( $timeout ) = @_; +sub pick_from_search_engine($$$) { + my ( $timeout, $search_url, $words ) = @_; - my $words = random_word; - $words .= "%20" . random_word; - $words .= "%20" . random_word; - $words .= "%20" . random_word; - $words .= "%20" . random_word; + $_ = $words; + s/%20/ /g; - my $search_url = $image_randomizer . $words; + print STDERR "\n\n" if ($verbose_load); - if ( $DEBUG > 3 ) { - $_ = $words; s/%20/ /g; print STDERR "search words: $_\n"; - } + LOG ($verbose_load, "words: $_"); + LOG ($verbose_load, "URL: $search_url"); - if ( $DEBUG > 3 ) { - print STDERR "\n\npicking from $search_url\n"; - } + $last_search = $search_url; # for warnings - my $start = time; - my ( $base, $body ) = get_document ($search_url, undef, $timeout); - if (defined ($timeout)) { - $timeout -= (time - $start); - return undef if ($timeout <= 0); + my $start = time; + my ( $base, $body ) = get_document ($search_url, undef, $timeout); + if (defined ($timeout)) { + $timeout -= (time - $start); + if ($timeout <= 0) { + $body = undef; + LOG (($verbose_net || $verbose_load), + "timed out (late) for $search_url"); + $suppress_audit = 1; + return (); + } + } + + return () if (! $body); + + + my @subpages; + + my $search_count = "?"; + if ($body =~ m@found (approximately |about )?()?(\d+)()? image@) { + $search_count = $3; + } elsif ($body =~ m@((\d{1,3})(,\d{3})*) @i) { + $search_count = $1; + } elsif ($body =~ m@found ((\d{1,3})(,\d{3})*|\d+) Web p@) { + $search_count = $1; + } elsif ($body =~ m@found about ((\d{1,3})(,\d{3})*|\d+) results@) { + $search_count = $1; + } elsif ($body =~ m@\b\d+ - \d+ of (\d+)\b@i) { # avimages + $search_count = $1; + } elsif ($body =~ m@About ((\d{1,3})(,\d{3})*) images@i) { # avimages + $search_count = $1; + } elsif ($body =~ m@We found ((\d{1,3})(,\d{3})*|\d+) results@i) { # *vista + $search_count = $1; + } elsif ($body =~ m@ of about ((\d{1,3})(,\d{3})*)<@i) { # googleimages + $search_count = $1; + } elsif ($body =~ m@((\d{1,3})(,\d{3})*) Web sites were found@i) { + $search_count = $1; # lycos + } elsif ($body =~ m@WEB.*?RESULTS.*?\b((\d{1,3})(,\d{3})*)\b.*?Matches@i) { + $search_count = $1; # hotbot + } elsif ($body =~ m@no photos were found containing@i) { # avimages + $search_count = "0"; + } elsif ($body =~ m@found no document matching@i) { # avtext + $search_count = "0"; + } + 1 while ($search_count =~ s/^(\d+)(\d{3})/$1,$2/); + +# if ($search_count eq "?" || $search_count eq "0") { +# local *OUT; +# my $file = "/tmp/wc.html"; +# open(OUT, ">$file") || error ("writing $file: $!"); +# print OUT $body; +# close OUT; +# print STDERR blurb() . "###### wrote $file\n"; +# } + + + my $length = length($body); + my $href_count = 0; + + $_ = $body; + + s/[\r\n\t ]+/ /g; + + + s/(]+)>@i; + next unless $u; + + if ($u =~ m/^\"([^\"]*)\"/) { $u = $1; } # quoted string + elsif ($u =~ m/^([^\s]*)\s/) { $u = $1; } # or token + + if ( $rejected_urls{$u} ) { + LOG ($verbose_filter, " pre-rejecting candidate: $u"); + next; } - return undef if (! $body); + LOG ($verbose_http, " HREF: $u"); + $subpages[++$#subpages] = $u; + } - my @subpages; - my $skipped = 0; + if ( $#subpages < 0 ) { + LOG ($verbose_filter, + "found nothing on $base ($length bytes, $href_count links)."); + return (); + } - $_ = $body; - s/(]+)> 3 ) { - print STDERR "skipping corbis URL: $_\n"; - } - next; - } elsif ( $DEBUG > 3 ) { - print STDERR "sub-page: $1\n"; - } +sub depoison(@) { + my (@urls) = @_; + my @urls2 = (); + foreach (@urls) { + my ($h) = m@^http://([^/: \t\r\n]+)@i; - $subpages[++$#subpages] = $u; - } - } + next unless defined($h); - if ( $#subpages <= 0 ) { - if (!$skipped) { - print STDERR "Found nothing on $base\n"; - } - return undef; + if ($poisoners{$h}) { + LOG (($verbose_filter), " rejecting poisoner: $_"); + next; + } + if ($h =~ m@([^.]+\.[^.]+\.[^.]+)$@ && + $poisoners{$1}) { + LOG (($verbose_filter), " rejecting poisoner: $_"); + next; + } + if ($h =~ m@([^.]+\.[^.]+)$@ && + $poisoners{$1}) { + LOG (($verbose_filter), " rejecting poisoner: $_"); + next; } - # pick a random element of the table - my $i = ((rand() * 99999) % $#subpages); - my $subpage = $subpages[$i]; + push @urls2, $_; + } + return @urls2; +} - if ( $DEBUG > 3 ) { - print STDERR "picked page $subpage\n"; - } +# given a list of URLs, picks one at random; loads it; and returns a +# random image from it. +# returns the url of the page loaded; the url of the image chosen. +# +sub pick_image_from_pages($$$$@) { + my ($base, $total_hit_count, $unfiltered_link_count, $timeout, @pages) = @_; + $total_hit_count = "?" unless defined($total_hit_count); - my ( $base2, $body2 ) = get_document ($subpage, $base, $timeout); + @pages = depoison (@pages); + LOG ($verbose_load, + "" . ($#pages+1) . " candidates of $unfiltered_link_count links" . + " ($total_hit_count total)"); - return undef if (!$base2 || !body2); + return () if ($#pages < 0); - my $img = pick_image_from_body ($base2, $body2); + my $i = int(rand($#pages+1)); + my $page = $pages[$i]; - if ($img) { - return ($base2, $img); - } else { - return undef; - } -} + LOG ($verbose_load, "picked page $page"); + $suppress_audit = 1; -# Picks a random image on a random page, and returns two URLs: -# the page containing the image, and the image. -# Returns undef if nothing found this time. -# Uses the url-randomizer 1 time in 5, else the image randomizer. -# -sub pick_image { - my ( $timeout ) = @_; + my ( $base2, $body2 ) = get_document ($page, $base, $timeout); - if (int(rand 5) == 0) { - return pick_from_url_randomizer ($timeout); - } else { - return pick_from_image_randomizer ($timeout); - } -} + if (!$base2 || !$body2) { + $body2 = undef; + return (); + } + my $img = pick_image_from_body ($base2, $body2); + $body2 = undef; -# Given the raw body of a GIF document, returns the dimensions of the image. -# -sub gif_size { - my ($body) = @_; - my $type = substr($body, 0, 6); - my $s; - return undef unless ($type =~ /GIF8[7,9]a/); - $s = substr ($body, 6, 10); - my ($a,$b,$c,$d) = unpack ("C"x4, $s); - return (($b<<8|$a), ($d<<8|$c)); + if ($img) { + return ($base2, $img); + } else { + return (); + } } -# Given the raw body of a JPEG document, returns the dimensions of the image. + +############################################################################ # -sub jpeg_size { - my ($body) = @_; - my $i = 0; - my $L = length($body); - - $c1 = substr($body, $i, 1); $i++; - $c2 = substr($body, $i, 1); $i++; - return undef unless (ord($c1) == 0xFF && ord($c2) == 0xD8); - - my $ch = "0"; - while (ord($ch) != 0xDA && $i < $L) { - # Find next marker, beginning with 0xFF. - while (ord($ch) != 0xFF) { - $ch = substr($body, $i, 1); $i++; - } - # markers can be padded with any number of 0xFF. - while (ord($ch) == 0xFF) { - $ch = substr($body, $i, 1); $i++; - } - - # $ch contains the value of the marker. - my $marker = ord($ch); +# Pick images from random pages returned by the Yahoo Random Link +# +############################################################################ - if (($marker >= 0xC0) && - ($marker <= 0xCF) && - ($marker != 0xC4) && - ($marker != 0xCC)) { # it's a SOFn marker - $i += 3; - my $s = substr($body, $i, 4); $i += 4; - my ($a,$b,$c,$d) = unpack("C"x4, $s); - return (($c<<8|$d), ($a<<8|$b)); +# yahoorand +my $yahoo_random_link = "http://random.yahoo.com/fast/ryl"; - } else { - # We must skip variables, since FFs in variable names aren't - # valid JPEG markers. - my $s = substr($body, $i, 2); $i += 2; - my ($c1, $c2) = unpack ("C"x2, $s); - my $length = ($c1 << 8) | $c2; - return undef if ($length < 2); - $i += $length-2; - } - } - return undef; -} -# Given the raw body of a GIF or JPEG document, returns the dimensions of -# the image. +# Picks a random page; picks a random image on that page; +# returns two URLs: the page containing the image, and the image. +# Returns () if nothing found this time. # -sub image_size { - my ($body) = @_; - my ($w, $h) = gif_size ($body); - if ($w && $h) { return ($w, $h); } - return jpeg_size ($body); -} +sub pick_from_yahoo_random_link($) { + my ($timeout) = @_; + print STDERR "\n\n" if ($verbose_load); + LOG ($verbose_load, "URL: $yahoo_random_link"); -# returns the full path of the named program, or undef. -# -sub which { - my ($prog) = @_; - foreach (split (/:/, $ENV{PATH})) { - if (-x "$_/$prog") { - return $prog; - } - } - return undef; -} + $last_search = $yahoo_random_link; # for warnings -############################################################################## -# -# Running as a CGI -# -############################################################################## + $suppress_audit = 1; -my $body_tag = "\n"; - -my $html_document = - ("" . - "\n" . - "\n" . - " WebCollage\n" . - "\n" . - "\n" . - $body_tag . - "\n" . - "

" . - "\n" . - " \n" . - " \n" . - " \n" . - " \n" . - " \n" . - " \n" . - " \n" . - "
\n" . - " WebCollage: \n" . - "
by\n" . - " Jamie Zawinski\n" . - "
\n" . - "\n" . - "

Exterminate All Rational Thought.\n" . - " \n" . - "
This program creates collages out of random images\n" . - " found on the Web.\n" . - "

More images are being added to the\n" . - " collage now: please wait for the image below to load.\n" . - " This will take a minute or two, since it has to contact\n" . - " other web sites to retrieve the images before it can construct\n" . - " the collage. Once the image below is loaded, you can reload\n" . - " this page to do it again.\n" . - "

If you enjoy this, you might also enjoy\n" . - " DadaDodo.\n" . - " WebCollage also works as a screen saver, for those of you\n" . - " using Unix: it is included with the\n" . - " XScreenSaver\n" . - " package.

\n" . - "

\n" . - " \n" . - "
\n" . - " %%MAP%%\n" . - " \n" . - "
\n" . - "

\n" . - "

\n"); - - -my @time_fmt_days = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"); -my @time_fmt_months = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"); - -# Converts a time_t to a string acceptable to HTTP. -# -sub format_http_time { - my ($time) = @_; - my @t = gmtime($time); - my ($sec, $min, $hour, $mday, $mon, $year, $wday) = @t; - $year += 1900; - $wday = $time_fmt_days[$wday]; - $mon = $time_fmt_months[$mon]; - return sprintf("%s, %02d %s %d %02d:%02d:%02d GMT", - $wday, $mday, $mon, $year, $hour, $min, $sec); -} - - - -# Parses exactly the time format that HTTP requires, no more, no less. -# -sub parse_http_time { - ($_) = @_; - - 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) { - return undef; - } + my ( $base, $body ) = get_document ($yahoo_random_link, undef, $timeout); + if (!$base || !$body) { + $body = undef; + return; + } - my @moy = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); - @moy{@moy} = (1..12); + LOG ($verbose_load, "redirected to: $base"); - my $t = Time::Local::timegm($6, $5, $4, $1, $moy{$2}-1, - ($3 < 100 ? $3 : $3-1900)); - return ($t < 0 ? undef : $t); -} + my $img = pick_image_from_body ($base, $body); + $body = undef; + if ($img) { + return ($base, $img); + } else { + return (); + } +} -# Given a modification time, returns a time_t to use as the expiration time -# of both the HTML and the JPEG. + +############################################################################ # -sub compute_expires_time { - my ($mod_time) = (@_); - my $now = time; - if ($mod_time < $now) { $mod_time = $now; } - return $mod_time + $max_age; -} +# Pick images from random pages returned by the Alta Vista Random Link +# +############################################################################ + +# altavista +my $alta_vista_random_link = "http://www.altavista.com/image/randomlink"; -# Parse the If-Modified-Since header, and write a response if appropriate. -# If this returns 1, we're done. +# Picks a random page; picks a random image on that page; +# returns two URLs: the page containing the image, and the image. +# Returns () if nothing found this time. # -sub do_ifmod { - # see http://vancouver-webpages.com/proxy/log-tail.pl and - # http://mnot.cbd.net.au/cache_docs/ for clues about how to - # do cacheing properly with CGI-generated documents. - my ($mod_time) = (@_); - if ($ENV{HTTP_IF_MODIFIED_SINCE}) { - my $ims = $ENV{HTTP_IF_MODIFIED_SINCE}; - $ims =~ s/;.*// ; # lose trailing "; length=3082" - $ims = parse_http_time($ims); - if ($ims && $mod_time <= $ims) { - print "Status: 304 Not Modified\n\n" ; - return 1; - } - } - return 0; -} +sub pick_from_alta_vista_random_link($) { + my ($timeout) = @_; + print STDERR "\n\n" if ($verbose_load); + LOG ($verbose_load, "URL: $alta_vista_random_link"); -# Returns N urls of images (and the pages on which they were found.) -# Unless there is a significant surplus of URLs in the $pending_file, -# this will spend $url_generation_time seconds generating as many URLs -# as it can. The first N will be returned, and the rest will be left -# in the file. -# -sub get_image_urls { - my ($count) = @_; + $last_search = $alta_vista_random_link; # for warnings - my @urls; - my $body = ""; - my $file_count = 0; + $suppress_audit = 1; - local *PEND; + my ( $base, $body ) = get_document ($alta_vista_random_link, + undef, $timeout); + if (!$base || !$body) { + $body = undef; + return; + } - # Open and lock the file (read/write.) - # rewind after locking, in case we had to wait for the lock. - # - open (PEND, "+<$pending_file") || die "couldn't open $pending_file: $!"; + LOG ($verbose_load, "redirected to: $base"); - if ($DEBUG > 2) { print STDERR "jpeg: opened $pending_file\n"; } + my $img = pick_image_from_body ($base, $body); + $body = undef; - my $flock_wait = time; - flock (PEND, LOCK_EX) || die "couldn't lock $pending_file: $!"; - $flock_wait = (time - $flock_wait); + if ($img) { + return ($base, $img); + } else { + return (); + } +} - seek (PEND, 0, 0) || die "couldn't rewind $pending_file: $!"; + +############################################################################ +# +# Pick images by feeding random words into Alta Vista Image Search +# +############################################################################ - if ($DEBUG > 2) { print STDERR "jpeg: locked $pending_file\n"; } +my $alta_vista_images_url = "http://www.altavista.com/image/results" . + "?ipht=1" . # photos + "&igrph=1" . # graphics + "&iclr=1" . # color + "&ibw=1" . # b&w + "&micat=1" . # no partner sites + "&sc=on" . # "site collapse" + "&q="; - # Take N URLs off the top, and leave the rest. - # - while () { - if (--$count >= 0) { - if ($DEBUG > 3) { print STDERR " < $_"; } - s/[\r\n]+$//; - $urls[++$#urls] = $_; - } else { - $body .= $_; - if ($DEBUG > 3) { print STDERR " - $_"; } - $file_count++; - } - } +# avimages +sub pick_from_alta_vista_images($) { + my ($timeout) = @_; - # rewind and overwrite the file - seek (PEND, 0, 0) || die "couldn't rewind $pending_file: $!"; - truncate (PEND, 0) || die "couldn't truncate $pending_file: $!"; - print PEND $body; + my $words = random_word(); + my $page = (int(rand(9)) + 1); + my $search_url = $alta_vista_images_url . $words; + if ($page > 1) { + $search_url .= "&pgno=" . $page; # page number + $search_url .= "&stq=" . (($page-1) * 12); # first hit result on page + } - # If there are fewer than 3x as many URLs as we took left in the file, - # then generate as many URLs as we can in N seconds. Take what we - # need from that, and append the rest to the file. Note that we are - # still holding a lock on the file. - # - # Count the time spent waiting for flock as time spent gathering URLs. - # Because that means someone else was doing it. - # - $body = ""; - if ($file_count < $count * 3) { - my $timeout = $url_generation_time - $flock_wait; - my $start = time; - - while (1) { - last if ($timeout <= 0); - - if ($DEBUG > 2) { print STDERR "time remaining: $timeout\n"; } - my ($base, $img) = pick_image ($timeout); - - if ($img) { - $img =~ s/ /%20/g; - $base =~ s/ /%20/g; - $_ = "$img $base"; - if ($count-- >= 0) { - if ($DEBUG > 3) { print STDERR " << $img\n"; } - $urls[++$#urls] = $_; - } else { - if ($DEBUG > 3) { print STDERR " >> $img\n"; } - print PEND "$_\n"; # append to file - $file_count++; - } - } - - my $now = time; - my $elapsed = $now - $start; - $timeout -= $elapsed; - $start = $now; - } - } + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); - my $of = select(PEND); $| = 1; select($of); # flush output - print PEND ""; + my @candidates = (); + foreach my $u (@subpages) { - flock (PEND, LOCK_UN) || die "couldn't unlock $pending_file: $!"; - close (PEND) || die "couldn't close $pending_file: $!"; + # avimages is encoding their URLs now. + next unless ($u =~ s/^.*\*\*(http%3a.*$)/$1/gsi); + $u = url_unquote($u); - if ($DEBUG > 2) { - print STDERR "jpeg: closed $pending_file; $file_count urls in file;" . - " returning $#urls.\n"; - } + next unless ($u =~ m@^http://@i); # skip non-HTTP or relative URLs + next if ($u =~ m@[/.]altavista\.com\b@i); # skip altavista builtins + next if ($u =~ m@[/.]yahoo\.com\b@i); # yahoo and av in cahoots? + next if ($u =~ m@[/.]doubleclick\.net\b@i); # you cretins + next if ($u =~ m@[/.]clicktomarket\.com\b@i); # more cretins + + next if ($u =~ m@[/.]viewimages\.com\b@i); # stacked deck + next if ($u =~ m@[/.]gettyimages\.com\b@i); - return @urls; + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); } -sub cgi_reset_all_files { - foreach (@all_files) { - my $file = $_; - local *OUT; - open (OUT, "+<$file") || die "couldn't open $file: $!"; - flock (OUT, LOCK_EX) || die "couldn't lock $file: $!"; - truncate (OUT, 0) || die "couldn't truncate $file: $!"; - flock (OUT, LOCK_UN) || die "couldn't unlock $file: $!"; - close (OUT) || die "couldn't close $file: $!"; + +############################################################################ +# +# Pick images by feeding random words into Google Image Search. +# By Charles Gales +# +############################################################################ + + +my $google_images_url = "http://images.google.com/images" . + "?site=images" . # photos + "&btnG=Search" . # graphics + "&safe=off" . # no screening + "&imgsafe=off" . + "&q="; + +# googleimgs +sub pick_from_google_images($;$$) { + my ($timeout, $words, $max_page) = @_; + + if (!defined($words)) { + $words = random_word; # only one word for Google + } + + my $page = (int(rand(9)) + 1); + my $num = 20; # 20 images per page + my $search_url = $google_images_url . $words; + + if ($page > 1) { + $search_url .= "&start=" . $page*$num; # page number + $search_url .= "&num=" . $num; #images per page + } + + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + + my @candidates = (); + my %referers; + foreach my $u (@subpages) { + next unless ($u =~ m@imgres\?imgurl@i); # All pics start with this + next if ($u =~ m@[/.]google\.com\b@i); # skip google builtins + + if ($u =~ m@^/imgres\?imgurl=(.*?)\&imgrefurl=(.*?)\&@) { + my $ref = $2; + my $img = $1; + $img = "http://$img" unless ($img =~ m/^http:/i); + + LOG ($verbose_filter, " candidate: $ref"); + push @candidates, $img; + $referers{$img} = $ref; } + } + + @candidates = depoison (@candidates); + return () if ($#candidates < 0); + my $i = int(rand($#candidates+1)); + my $img = $candidates[$i]; + my $ref = $referers{$img}; - system "ppmmake '#000000' $img_width $img_height > $image_ppm" || - die "failed to create blank $image_ppm file: $!"; - system "cjpeg -progressive $image_ppm > $image_jpg" || - die "failed to create blank $image_jpg file: $!"; + LOG ($verbose_load, "picked image " . ($i+1) . ": $img (on $ref)"); + return ($ref, $img); } -# Given the URL of an image and the page on which it was found, this will -# load the image, and paste it at a random spot in $image_ppm and $img_jpg. -# It will also update $map_file to contain the appropriate referer, and -# will limit it to $max_map_entries lines. + +############################################################################ # -sub cgi_paste_image { - my ($img, $referer) = @_; +# Pick images by feeding random numbers into Google Image Search. +# By jwz, suggested by Ian O'Donnell. +# +############################################################################ - my ( $base, $body ) = get_document ($img, $referer); - return if (!$base || !$body); - my ($iw, $ih) = image_size ($body); - return if (!$iw || !$ih); +# googlenums +sub pick_from_google_image_numbers($) { + my ($timeout) = @_; - if ($DEBUG > 2) { print STDERR "got $base ($iw x $ih)\n"; } + my $max = 9999; + my $number = int(rand($max)); - my $cmd; + $number = sprintf("%04d", $number) + if (rand() < 0.3); - if ($base =~ m/\.gif$/i) { - $cmd = "giftopnm"; - } else { - $cmd = "djpeg"; - } + pick_from_google_images ($timeout, "$number"); +} + + + +############################################################################ +# +# Pick images by feeding random digital camera file names into +# Google Image Search. +# By jwz, inspired by the excellent Random Personal Picture Finder +# at http://www.diddly.com/random/ +# +############################################################################ + +my @photomakers = ( + # + # Common digital camera file name formats, as described at + # http://www.diddly.com/random/about.html + # + sub { sprintf ("dcp%05d.jpg", int(rand(4000))); }, # Kodak + sub { sprintf ("dsc%05d.jpg", int(rand(4000))); }, # Nikon + sub { sprintf ("dscn%04d.jpg", int(rand(4000))); }, # Nikon + sub { sprintf ("mvc-%03d.jpg", int(rand(999))); }, # Sony Mavica + sub { sprintf ("mvc%05d.jpg", int(rand(9999))); }, # Sony Mavica + sub { sprintf ("P101%04d.jpg", int(rand(9999))); }, # Olympus w/ date=101 + sub { sprintf ("P%x%02d%04d.jpg", # Olympus + int(rand(0xC)), int(rand(30))+1, + rand(9999)); }, + sub { sprintf ("IMG_%03d.jpg", int(rand(999))); }, # ? + sub { sprintf ("IMAG%04d.jpg", int(rand(9999))); }, # RCA and Samsung + sub { my $n = int(rand(9999)); # Canon + sprintf ("1%02d-%04d.jpg", int($n/100), $n); }, + sub { my $n = int(rand(9999)); # Canon + sprintf ("1%02d-%04d_IMG.jpg", + int($n/100), $n); }, + sub { sprintf ("IMG_%04d.jpg", int(rand(9999))); }, # Canon + sub { sprintf ("dscf%04d.jpg", int(rand(9999))); }, # Fuji Finepix + sub { sprintf ("pdrm%04d.jpg", int(rand(9999))); }, # Toshiba PDR + sub { sprintf ("IM%06d.jpg", int(rand(9999))); }, # HP Photosmart + sub { sprintf ("EX%06d.jpg", int(rand(9999))); }, # HP Photosmart +# sub { my $n = int(rand(3)); # Kodak DC-40,50,120 +# sprintf ("DC%04d%s.jpg", int(rand(9999)), +# $n == 0 ? 'S' : $n == 1 ? 'M' : 'L'); }, + sub { sprintf ("pict%04d.jpg", int(rand(9999))); }, # Minolta Dimage + sub { sprintf ("P%07d.jpg", int(rand(9999))); }, # Kodak DC290 +# sub { sprintf ("%02d%02d%04d.jpg", # Casio QV3000, QV4000 +# int(rand(12))+1, int(rand(31))+1, +# int(rand(999))); }, +# sub { sprintf ("%02d%x%02d%04d.jpg", # Casio QV7000 +# int(rand(6)), # year +# int(rand(12))+1, int(rand(31))+1, +# int(rand(999))); }, + sub { sprintf ("IMGP%04d.jpg", int(rand(9999))); }, # Pentax Optio S + sub { sprintf ("PANA%04d.jpg", int(rand(9999))); }, # Panasonic vid still + sub { sprintf ("HPIM%04d.jpg", int(rand(9999))); }, # HP Photosmart + sub { sprintf ("PCDV%04d.jpg", int(rand(9999))); }, # ? + ); + + +# googlephotos +sub pick_from_google_image_photos($) { + my ($timeout) = @_; + + my $i = int(rand($#photomakers + 1)); + my $fn = $photomakers[$i]; + my $file = &$fn; + my $words .= $file . "%20filetype:jpg"; + + pick_from_google_images ($timeout, $words); +} - if ($iw > $img_width || $ih > $img_height) { - while ($iw > $img_width || $ih > $img_height) { - $iw = int($iw / 2); - $ih = int($ih / 2); - } - $cmd .= " | pnmscale -xysize $iw $ih"; - } - my $x = int (rand() * ($img_width - $iw)); - my $y = int (rand() * ($img_height - $ih)); + +############################################################################ +# +# Pick images by feeding random words into Alta Vista Text Search +# +############################################################################ - $cmd .= " | pnmpaste - $x $y $image_ppm"; +my $alta_vista_url = "http://www.altavista.com/web/results" . + "?pg=aq" . + "&aqmode=s" . + "&filetype=html" . + "&sc=on" . # "site collapse" + "&nbq=50" . + "&aqo="; - local *MAP; - local *PIPE_OUT; +# avtext +sub pick_from_alta_vista_text($) { + my ($timeout) = @_; - # Open and lock the map (read/write.) - # rewind after locking, in case we had to wait for the lock. - # This lock doubles as our lock on the image file itself. - # - open (MAP, "+<$map_file") || die "couldn't open $map_file: $!"; + my $words = random_words(0); + my $page = (int(rand(9)) + 1); + my $search_url = $alta_vista_url . $words; - if ($DEBUG > 2) { print STDERR "jpeg: opened $map_file\n"; } + if ($page > 1) { + $search_url .= "&pgno=" . $page; + $search_url .= "&stq=" . (($page-1) * 10); + } - flock (MAP, LOCK_EX) || die "couldn't lock $map_file: $!"; - seek (MAP, 0, 0) || die "couldn't rewind $map_file: $!"; + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); - if ($DEBUG > 2) { print STDERR "jpeg: locked $map_file\n"; } + my @candidates = (); + foreach my $u (@subpages) { - # Read in the first hundred lines of the map file. + # Those altavista fuckers are playing really nasty redirection games + # these days: the filter your clicks through their site, but use + # onMouseOver to make it look like they're not! Well, it makes it + # easier for us to identify search results... # - my $map = ""; - my $count = 0; - while () { - last if ($count++ > $max_map_entries); - $map .= $_; - } + next unless ($u =~ s/^.*\*\*(http%3a.*$)/$1/gsi); + $u = url_unquote($u); - # Add this entry to the front of the map data. - # - $map = "$x $y $iw $ih $referer\n" . $map; + next unless ($u =~ m@^http://@i); # skip non-HTTP or relative URLs + next if ($u =~ m@[/.]altavista\.com\b@i); # skip altavista builtins + next if ($u =~ m@[/.]yahoo\.com\b@i); # yahoo and av in cahoots? + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } - # Ensure that the $image_ppm file exists and has a ppm in it. - # - my $ppm_size = $img_width * $img_height * 3 * 2; - my $s = (stat($image_ppm))[7]; - if ($s < $ppm_size) { - - if ( $DEBUG ) { - print STDERR "$image_ppm is $s bytes;" . - " should be at least $ppm_size\n"; - print STDERR "resetting everything."; - cgi_reset_all_files(); - } - } + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); +} - # Paste the bits into the image. Note that the map file is still locked. - # - local *TMP; - open (TMP, ">$image_tmp") || die "couldn't open $image_tmp: $!"; - close (TMP); - if (! $DEBUG ) { - $cmd = "( $cmd ) 2>/dev/null"; - } + +############################################################################ +# +# Pick images by feeding random words into Hotbot +# +############################################################################ + +my $hotbot_search_url =("http://hotbot.lycos.com/default.asp" . + "?ca=w" . + "&descriptiontype=0" . + "&imagetoggle=1" . + "&matchmode=any" . + "&nummod=2" . + "&recordcount=50" . + "&sitegroup=1" . + "&stem=1" . + "&cobrand=undefined" . + "&query="); + +sub pick_from_hotbot_text($) { + my ($timeout) = @_; + + $last_search = $hotbot_search_url; # for warnings + + # lycos seems to always give us back dictionaries and word lists if + # we search for more than one word... + # + my $words = random_word(); + + my $start = int(rand(8)) * 10 + 1; + my $search_url = $hotbot_search_url . $words . "&first=$start&page=more"; + + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + + my @candidates = (); + foreach my $u (@subpages) { + + # Hotbot plays redirection games too + # (not any more?) +# next unless ($u =~ m@/director.asp\?.*\btarget=([^&]+)@); +# $u = url_decode($1); + + next unless ($u =~ m@^http://@i); # skip non-HTTP or relative URLs + next if ($u =~ m@[/.]hotbot\.com\b@i); # skip hotbot builtins + next if ($u =~ m@[/.]lycos\.com\b@i); # skip hotbot builtins + next if ($u =~ m@[/.]inktomi\.com\b@i); # skip hotbot builtins + + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); +} - $cmd .= " > $image_tmp"; - if ($DEBUG > 2) { print STDERR "executing $cmd\n"; } - if (open(PIPE_OUT, "| $cmd")) { - print PIPE_OUT $body; - close(PIPE_OUT); + +############################################################################ +# +# Pick images by feeding random words into Lycos +# +############################################################################ - if ($DEBUG > 2) { system "ls -ldF $image_tmp >&2"; } +my $lycos_search_url = "http://search.lycos.com/default.asp" . + "?lpv=1" . + "&loc=searchhp" . + "&tab=web" . + "&query="; - my @tmp_stat = stat($image_tmp); - if (@tmp_stat && $tmp_stat[7] < 200) { -# unlink ($image_tmp) || die "couldn't unlink $image_tmp: $!"; - open (OUT, ">$image_tmp") || die "$image_tmp unwritable: $!"; - close (OUT); - if ($DEBUG > 2) { print STDERR "FAILED writing $image_ppm\n"; } - } else { -# rename ($image_tmp, $image_ppm) || -# die "couldn't rename $image_tmp to $image_ppm: $!"; - local *IN; - local *OUT; - open (IN, "+<$image_tmp") || die "$image_tmp unreadable: $!"; - open (OUT, ">$image_ppm") || die "$image_ppm unwritable: $!"; - while () { print OUT $_; } - truncate (IN, 0) || die "couldn't truncate $image_tmp: $!"; - close (IN); - close (OUT) || die "couldn't write $image_ppm: $!"; - if ($DEBUG > 2) { print STDERR "wrote $image_ppm\n"; } - - - # Now convert the PPM to a JPEG. - # - system "cjpeg -progressive $image_ppm > $image_tmp 2>/dev/null"; - - @tmp_stat = stat($image_tmp); - if (@tmp_stat && $tmp_stat[7] < 200) { -# unlink ($image_tmp) || die "couldn't unlink $image_tmp: $!"; - open (OUT, ">$image_tmp") || die "$image_tmp unwritable: $!"; - close (OUT); - if ($DEBUG > 2) { print STDERR "FAILED writing $image_jpg\n"; } - } else { -# rename ($image_tmp, $image_ppm) || -# die "couldn't rename $image_tmp to $image_ppm: $!"; - open (IN, "+<$image_tmp") || die "$image_tmp unreadable: $!"; - open (OUT, ">$image_jpg") || die "$image_jpg unwritable: $!"; - while () { print OUT $_; } - truncate (IN, 0) || die "couldn't truncate $image_tmp: $!"; - close (IN); - close (OUT) || die "couldn't write $image_jpg: $!"; - if ($DEBUG > 2) { print STDERR "wrote $image_jpg\n"; } - } - } +sub pick_from_lycos_text($) { + my ($timeout) = @_; - # Overwrite the map data. - # - seek (MAP, 0, 0) || die "couldn't rewind $map_file: $!"; - truncate (MAP, 0) || die "couldn't truncate $map_file: $!"; - print MAP $map; - } + $last_search = $lycos_search_url; # for warnings - my $of = select(MAP); $| = 1; select($of); # flush output - print MAP ""; + # lycos seems to always give us back dictionaries and word lists if + # we search for more than one word... + # + my $words = random_word(); - flock (MAP, LOCK_UN) || die "couldn't unlock $map_file: $!"; - close (MAP) || die "couldn't close $map_file: $!"; + my $start = int(rand(8)) * 10 + 1; + my $search_url = $lycos_search_url . $words . "&first=$start&page=more"; - if ($DEBUG > 2) { print STDERR "jpeg: closed $map_file\n"; } -} + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + my @candidates = (); + foreach my $u (@subpages) { -sub cgi_generate_image { + # Lycos plays redirection games. + # (not any more?) +# next unless ($u =~ m@^http://click.lycos.com/director.asp +# .* +# \btarget=([^&]+) +# .* +# @x); +# $u = url_decode($1); - $SIG{PIPE} = 'IGNORE'; + next unless ($u =~ m@^http://@i); # skip non-HTTP or relative URLs + next if ($u =~ m@[/.]hotbot\.com\b@i); # skip lycos builtins + next if ($u =~ m@[/.]lycos\.com\b@i); # skip lycos builtins + next if ($u =~ m@[/.]terralycos\.com\b@i); # skip lycos builtins + next if ($u =~ m@[/.]inktomi\.com\b@i); # skip lycos builtins - my @urls = get_image_urls ($pastes_per_load); - my $end_time = time + $image_retrieval_time; - if ($DEBUG > 2) { - print STDERR "loading $#urls images\n"; - } + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } - foreach (@urls) { - my ($img, $referer) = m/^([^ ]+) ([^ ]+)/; - if ($img) { - cgi_paste_image ($img, $referer); - } - last if (time > $end_time); - } + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); } -sub cgi_sanity_check { - my $error = undef; - foreach (@all_files) { - if (! -e $_) { $error = "$_ does not exist.\n"; } - elsif (! -r $_) { $error = "$_ is unreadable.\n"; } - elsif (! -w $_) { $error = "$_ is unwritable.\n"; } - last if ($error); - } + +############################################################################ +# +# Pick images by feeding random words into news.yahoo.com +# +############################################################################ + +my $yahoo_news_url = "http://news.search.yahoo.com/search/news" . + "?c=news_photos" . + "&p="; + +# yahoonews +sub pick_from_yahoo_news_text($) { + my ($timeout) = @_; - return unless $error; + $last_search = $yahoo_news_url; # for warnings - print "Content-Type: text/html\n"; - print "\n\nError$body_tag

Error

"; - print POSIX::getcwd() . "/" . $error . "

\n"; + my $words = random_word(); + my $search_url = $yahoo_news_url . $words; - $_ = join(", ", @all_files); - s/,([^,]*)$/, and$1/; + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); - print "Each of the files: $_\n"; - print " must exist and be readable and writable by the httpd process\n"; - print "(which probably means they must be globally readable and\n"; - print "writable, since on most systems, CGI scripts run as the\n"; - print "user nobody.)\n

\n"; + my @candidates = (); + foreach my $u (@subpages) { - exit (0); + # de-redirectize the URLs + $u =~ s@^http://rds\.yahoo\.com/.*-http%3A@http:@s; + + # only accept URLs on Yahoo's news site + next unless ($u =~ m@^http://dailynews\.yahoo\.com/@i || + $u =~ m@^http://story\.news\.yahoo\.com/@i); + next unless ($u =~ m@&u=/@); + + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); } -# Write the encapsulating HTML document and associated HTTP headers. -# This is fast -- it just writes out the wrapper document corresponding -# to the data currently on disk. It is the loading of the sub-image -# that does the real work. + +############################################################################ +# +# Pick images from LiveJournal's list of recently-posted images. # -sub cgi_emit_html_document { +############################################################################ - cgi_sanity_check; +my $livejournal_img_url = "http://www.livejournal.com/stats/latest-img.bml"; - my $map_file_date; - my $doc = $html_document; +# With most of our image sources, we get a random page and then select +# from the images on it. However, in the case of LiveJournal, the page +# of images tends to update slowly; so we'll remember the last N entries +# on it and randomly select from those, to get a wider variety each time. - my $w2 = int ($img_width * $scale); - my $h2 = int ($img_height * $scale); - $doc =~ s/%%WIDTH%%/$w2/g; - $doc =~ s/%%HEIGHT%%/$h2/g; +my $lj_cache_size = 1000; +my @lj_cache = (); # fifo, for ordering by age +my %lj_cache = (); # hash, for detecting dups - local *MAP; - open (MAP, "<$map_file") || die "couldn't open $map_file: $!"; - if ($DEBUG > 2) { print STDERR "html: opened $map_file\n"; } +# livejournal +sub pick_from_livejournal_images($) { + my ($timeout) = @_; - flock (MAP, LOCK_SH) || die "couldn't lock $map_file: $!"; - seek (MAP, 0, 0) || die "couldn't rewind $map_file: $!"; - if ($DEBUG > 2) { print STDERR "html: locked $map_file\n"; } + $last_search = $livejournal_img_url; # for warnings - $map_file_date = (stat(MAP))[9]; + my ( $base, $body ) = get_document ($livejournal_img_url, undef, $timeout); + return () unless $body; - my $map = "\n"; - while () { - my ($x, $y, $w, $h, $url) = - m/^([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) (.*)$/; - if ($w && $h) { - $x = int($x * $scale); - $y = int($y * $scale); - $w = int($w * $scale); - $h = int($h * $scale); + $body =~ s/\n/ /gs; + $body =~ s/(, or ". - $url =~ s/([<>\"])/uc sprintf("%%%02X",ord($1))/eg; + foreach (split (/\n/, $body)) { + next unless (m/^\n"; - } - } - $map .= ""; - flock (MAP, LOCK_UN) || die "couldn't unlock $map_file: $!"; - close (MAP) || die "couldn't close $map_file: $!"; + next if ($lj_cache{$img}); # already have it - if ($DEBUG > 2) { print STDERR "html: closed $map_file\n"; } + next unless (m/\bURL=[\'\"]([^\'\"]+)[\'\"]/si); + my $page = html_unquote ($1); + my @pair = ($img, $page); + LOG ($verbose_filter, " candidate: $img"); + push @lj_cache, \@pair; + $lj_cache{$img} = \@pair; + } - $doc =~ s/%%MAP%%/$map/g; + return () if ($#lj_cache == -1); - my $img_name = "current"; + my $n = $#lj_cache+1; + my $i = int(rand($n)); + my ($img, $page) = @{$lj_cache[$i]}; - $doc =~ s@%%IMAGE%%@images/$img_name.jpg@g; + # delete this one from @lj_cache and from %lj_cache. + # + @lj_cache = ( @lj_cache[0 .. $i-1], + @lj_cache[$i+1 .. $#lj_cache] ); + delete $lj_cache{$img}; + # Keep the size of the cache under the limit by nuking older entries + # + while ($#lj_cache >= $lj_cache_size) { + my $pairP = shift @lj_cache; + my $img = $pairP->[0]; + delete $lj_cache{$img}; + } - my $mod_time = $map_file_date; - if ($script_date > $mod_time) { $mod_time = $script_date; } + LOG ($verbose_load, "picked image " .($i+1) . "/$n: $img"); - if (do_ifmod($mod_time)) { - return; - } + return ($page, $img); +} - my $exp = compute_expires_time($mod_time); + +############################################################################ +# +# Pick images from ircimages.com (images that have been in the /topic of +# various IRC channels.) +# +############################################################################ - print "Content-Type: text/html\n"; - print "Content-Length: " . length($doc) . "\n"; - print "Last-Modified: " . format_http_time($mod_time) . "\n"; +my $ircimages_url = "http://ircimages.com/"; - # This is a suggestion to consider the object invalid after the given - # date. This is sometimes ignored. - # - print "Expires: " . format_http_time($exp) . "\n"; +# ircimages +sub pick_from_ircimages($) { + my ($timeout) = @_; - # This may or may not cause a cacheing proxy to pass this stuff along. - # It's not standardized, but was historically used for... something. - print "Pragma: no-cache\n"; + $last_search = $ircimages_url; # for warnings - # This says the same thing as the Expires header, but it is a stronger - # assertion that we're serious and should be listened to. - # - my $age = $exp - time; - print "Cache-Control: max-age=$age, must-revalidate\n"; + my $n = int(rand(2900)); + my $search_url = $ircimages_url . "page-$n"; - print "\n"; - print $doc; -} + my ( $base, $body ) = get_document ($search_url, undef, $timeout); + return () unless $body; + my @candidates = (); -# Write the interior JPEG document and associated HTTP headers. -# -sub cgi_emit_jpeg_document { + $body =~ s/\n/ /gs; + $body =~ s/(]+)>@i; + next unless $u; - if ($DEBUG > 2) { print STDERR "jpeg: opened $map_file\n"; } - flock (MAP, LOCK_SH) || die "couldn't lock $map_file: $!"; - if ($DEBUG > 2) { print STDERR "jpeg: locked $map_file\n"; } + if ($u =~ m/^\"([^\"]*)\"/) { $u = $1; } # quoted string + elsif ($u =~ m/^([^\s]*)\s/) { $u = $1; } # or token - # Now we have exclusive access to the image file. Read it. - # - local *IMG; - open (IMG, "<$image_jpg") || die "couldn't open $image_jpg: $!"; - - $jpg_file_date = (stat(IMG))[9]; - - if (do_ifmod($jpg_file_date)) { - $do_ims = 1; - if ($DEBUG > 2) { - my $ims = $ENV{HTTP_IF_MODIFIED_SINCE}; - $ims =~ s/;.*//; - print STDERR "not-modified-since " . - localtime(parse_http_time($ims)) . "\n"; - print STDERR "jpg date: " . localtime($jpg_file_date) . "\n"; - } - } + next unless ($u =~ m/^http:/i); + next if ($u =~ m@^http://(searchirc\.com\|ircimages\.com)@i); + next unless ($u =~ m@[.](gif|jpg|jpeg|pjpg|pjpeg|png)$@i); - if (!$do_ims) { - while () { $image_data .= $_; } - } - close (IMG) || die "couldn't close $image_jpg: $!"; + LOG ($verbose_http, " HREF: $u"); + push @candidates, $u; + } - # Now free the lock so that others can write to the file. - # - flock (MAP, LOCK_UN) || die "couldn't unlock $map_file: $!"; - close (MAP) || die "couldn't close $map_file: $!"; - if ($DEBUG > 2) { print STDERR "jpeg: closed $map_file\n"; } + LOG ($verbose_filter, "" . $#candidates+1 . " links on $search_url"); - return if ($do_ims); + return () if ($#candidates == -1); + my $i = int(rand($#candidates+1)); + my $img = $candidates[$i]; - # At this point, we have the image data we will be returning. - # However, don't return it yet -- first go off and generate the - # *next* image, then we can return *this* one. If we don't do it - # in this order, people will jump the gun hitting reload, and no - # image updates will happen. - # - my $type = "image/jpeg"; - my $mod_time = $jpg_file_date; - if ($script_date > $mod_time) { $mod_time = $script_date; } - - print "Last-Modified: " . format_http_time($mod_time) . "\n"; - print "Expires: " . format_http_time(compute_expires_time($mod_time)) - . "\n"; - print "Content-Type: $type\n"; - print "Content-Length: " . length($image_data) . "\n"; - print "\n"; - - # Now, before returning the image data, go catatonic for a minute - # while we load some URLs and make the next image. - # - cgi_generate_image; + LOG ($verbose_load, "picked image " .($i+1) . "/" . ($#candidates+1) . + ": $img"); - # Done setting up for next time -- now finish loading. - # - print $image_data; - $image_data = undef; + $search_url = $img; # hmm... + return ($search_url, $img); } - -# Write the source code of this script as a text/plain document. + +############################################################################ # -sub cgi_emit_source_document { - my $mod_time = $script_date; +# Pick images from Flickr's page of recently-posted photos. +# +############################################################################ - if (do_ifmod($mod_time)) { - return; - } +my $flickr_img_url = "http://www.flickr.com/photos/"; - print "Content-Type: text/plain\n"; - print "Last-Modified: " . format_http_time($mod_time) . "\n"; - print "\n"; - open (IN, "<$argv0") || die "couldn't open $argv0: $!"; - while () { - print; - } - close (IN); -} +# Like LiveJournal, the Flickr page of images tends to update slowly, +# so remember the last N entries on it and randomly select from those. +# I know that Flickr has an API (http://www.flickr.com/services/api/) +# but it was easy enough to scrape the HTML, so I didn't bother exploring. -# Parse the various environment variables to decide how we were invoked, -# and then do something about it. -# -sub cgi_main { +my $flickr_cache_size = 1000; +my @flickr_cache = (); # fifo, for ordering by age +my %flickr_cache = (); # hash, for detecting dups - $DEBUG=4; - $ENV{PATH} .= ":/usr/local/bin"; +# flickr_recent +sub pick_from_flickr_recent($) { + my ($timeout) = @_; - # make sure the various programs we execute exist, right up front. - foreach ("ppmmake", "cjpeg", "djpeg", "giftopnm", "pnmpaste", "pnmscale") { - if (!which ($_)) { - print "Content-Type: text/html\n"; - print "\n\nError$body_tag

Error

"; - print "The $_ program was not found on \$PATH.
\n"; + my $start = 16 * int(rand(100)); - my $p = $ENV{PATH}; - $p =~ s/%/%25/g; $p =~ s/\&/%26/g; - $p =~ s//%3E/g; - $p =~ s/:/:/g; - print "\$PATH is: $p

\n"; - exit (0); - } - } + $last_search = $flickr_img_url; # for warnings + $last_search .= "?start=$start" if ($start > 0); - $script_date = (stat($argv0))[9]; + my ( $base, $body ) = get_document ($last_search, undef, $timeout); + return () unless $body; - print "Blat: Foop\n"; + $body =~ s/[\r\n]/ /gs; + $body =~ s/(Error$body_tag

Error

"; - $_ = $ENV{REQUEST_METHOD}; - print "bad request method: $_\n"; - exit (0); + my $count = 0; + my $count2 = 0; + foreach (split (/\n/, $body)) { + my ($page, $thumb) = m@
]* \b HREF=\"([^<>\"]+)\" [^<>]* > \s* + ]* \b SRC=\"([^<>\"]+)\" @xsi; + next unless defined ($thumb); + $page = html_unquote ($page); + $thumb = html_unquote ($thumb); - } elsif ( $ENV{QUERY_STRING} ) { - if ( $ENV{QUERY_STRING} eq "reset" ) { - cgi_reset_all_files; + next unless ($thumb =~ m@^http://photos\d*\.flickr\.com/@); - print "Content-Type: text/html\n"; - print "\n\nCollage Reset"; - print "$body_tag

Collage Reset

\n"; - exit (0); + my $base = "http://www.flickr.com/"; + $page =~ s@^/@$base@; + $thumb =~ s@^/@$base@; - } else { - print "Content-Type: text/html\n"; - print "\n\nError$body_tag

Error

"; - $_ = $ENV{QUERY_STRING}; - print "malformed URL: $_\n"; - exit (0); - } + my $img = $thumb; + $img =~ s/_[a-z](\.[a-z\d]+)$/$1/si; # take off "thumb" suffix - } elsif ( !$ENV{PATH_INFO} || $ENV{PATH_INFO} eq "" ) { - # don't allow /webcollage as a URL -- force it to be /webcollage/ - print "Status: 301 Moved Permanently\n"; - print "Location: http://" . - ($ENV{HTTP_HOST} ? $ENV{HTTP_HOST} : - $ENV{SERVER_NAME} ? $ENV{SERVER_NAME} : "???") . - ($ENV{REQUEST_URI} ? $ENV{REQUEST_URI} : "") . - "/\n\n"; - exit (0); + $count++; + next if ($flickr_cache{$img}); # already have it - } elsif ( $ENV{PATH_INFO} eq "/" ) { - cgi_emit_html_document; + my @pair = ($img, $page, $start); + LOG ($verbose_filter, " candidate: $img"); + push @flickr_cache, \@pair; + $flickr_cache{$img} = \@pair; + $count2++; + } - } elsif ( $ENV{PATH_INFO} =~ m@^/images/[^/]+\.jpg$@ ) { - cgi_emit_jpeg_document; + return () if ($#flickr_cache == -1); - } elsif ( $ENV{PATH_INFO} eq "/webcollage.pl" ) { - cgi_emit_source_document; + my $n = $#flickr_cache+1; + my $i = int(rand($n)); + my ($img, $page) = @{$flickr_cache[$i]}; + + # delete this one from @flickr_cache and from %flickr_cache. + # + @flickr_cache = ( @flickr_cache[0 .. $i-1], + @flickr_cache[$i+1 .. $#flickr_cache] ); + delete $flickr_cache{$img}; + + # Keep the size of the cache under the limit by nuking older entries + # + while ($#flickr_cache >= $flickr_cache_size) { + my $pairP = shift @flickr_cache; + my $img = $pairP->[0]; + delete $flickr_cache{$img}; + } + + LOG ($verbose_load, "picked image " .($i+1) . "/$n: $img"); + + return ($page, $img); +} + + +############################################################################ +# +# Pick images from a random RSS feed on Flickr. +# +############################################################################ + +my $flickr_rss_base = ("http://www.flickr.com/services/feeds/photos_public.gne" . + "?format=rss_200_enc&tags="); + +# Picks a random RSS feed; picks a random image from that feed; +# returns 2 URLs: the page containing the image, and the image. +# Mostly by Joe Mcmahon +# +# flickr_random +sub pick_from_flickr_random($) { + my $timeout = shift; + + my $rss = $flickr_rss_base . random_word(); + $last_search = $rss; + + print STDERR "\n\n" if ($verbose_load); + LOG ($verbose_load, "URL: $last_search"); + + $suppress_audit = 1; + + my ( $base, $body ) = get_document ($last_search, undef, $timeout); + if (!$base || !$body) { + $body = undef; + return; + } + + my $img; + ($base, $img) = pick_image_from_rss ($base, $body); + $body = undef; + return () unless defined ($img); + + LOG ($verbose_load, "redirected to: $base"); + return ($base, $img); +} + + +############################################################################ +# +# Pick images by waiting for driftnet to populate a temp dir with files. +# Requires driftnet version 0.1.5 or later. +# (Driftnet is a program by Chris Lightfoot that sniffs your local ethernet +# for images being downloaded by others.) +# Driftnet/webcollage integration by jwz. +# +############################################################################ + +# driftnet +sub pick_from_driftnet($) { + my ($timeout) = @_; + + my $id = $driftnet_magic; + my $dir = $driftnet_dir; + my $start = time; + my $now; + + error ("\$driftnet_dir unset?") unless ($dir); + $dir =~ s@/+$@@; + + error ("$dir unreadable") unless (-d "$dir/."); + + $timeout = $http_timeout unless ($timeout); + $last_search = $id; + + while ($now = time, $now < $start + $timeout) { + local *DIR; + opendir (DIR, $dir) || error ("$dir: $!"); + while (my $file = readdir(DIR)) { + next if ($file =~ m/^\./); + $file = "$dir/$file"; + closedir DIR; + LOG ($verbose_load, "picked file $file ($id)"); + return ($id, $file); + } + closedir DIR; + } + LOG (($verbose_net || $verbose_load), "timed out for $id"); + return (); +} + + +sub get_driftnet_file($) { + my ($file) = @_; + + error ("\$driftnet_dir unset?") unless ($driftnet_dir); + + my $id = $driftnet_magic; + my $re = qr/$driftnet_dir/; + error ("$id: $file not in $driftnet_dir?") + unless ($file =~ m@^$re@o); + + local *IN; + open (IN, $file) || error ("$id: $file: $!"); + my $body = ''; + while () { $body .= $_; } + close IN || error ("$id: $file: $!"); + unlink ($file) || error ("$id: $file: rm: $!"); + return ($id, $body); +} + + +sub spawn_driftnet($) { + my ($cmd) = @_; + + # make a directory to use. + while (1) { + my $tmp = $ENV{TEMPDIR} || "/tmp"; + $driftnet_dir = sprintf ("$tmp/driftcollage-%08x", rand(0xffffffff)); + LOG ($verbose_exec, "mkdir $driftnet_dir"); + last if mkdir ($driftnet_dir, 0700); + } + + if (! ($cmd =~ m/\s/)) { + # if the command didn't have any arguments in it, then it must be just + # a pointer to the executable. Append the default args to it. + my $dargs = $default_driftnet_cmd; + $dargs =~ s/^[^\s]+//; + $cmd .= $dargs; + } + + # point the driftnet command at our newly-minted private directory. + # + $cmd .= " -d $driftnet_dir"; + $cmd .= ">/dev/null" unless ($verbose_exec); + + my $pid = fork(); + if ($pid < 0) { error ("fork: $!\n"); } + if ($pid) { + # parent fork + push @pids_to_kill, $pid; + LOG ($verbose_exec, "forked for \"$cmd\""); + } else { + # child fork + nontrapping_system ($cmd) || error ("exec: $!"); + } + + # wait a bit, then make sure the process actually started up. + # + sleep (1); + error ("pid $pid failed to start \"$cmd\"") + unless (1 == kill (0, $pid)); +} + +# local-directory +sub pick_from_local_dir { + my ( $timeout ) = @_; + + my $id = $local_magic; + $last_search = $id; + + my $dir = $local_dir; + error ("\$local_dir unset?") unless ($dir); + $dir =~ s@/+$@@; + + error ("$dir unreadable") unless (-d "$dir/."); + + my $v = ($verbose_exec ? "-v" : ""); + my $pick = `xscreensaver-getimage-file $v "$dir"`; + + LOG ($verbose_load, "picked file $pick ($id)"); + return ($id, $pick); +} + + +sub get_local_file { + my ($file) = @_; + + error ("\$local_dir unset?") unless ($local_dir); + + my $id = $local_magic; + my $re = qr/$local_dir/; + error ("$id: $file not in $local_dir?") + unless ($file =~ m@^$re@o); + + local *IN; + open (IN, $file) || error ("$id: $file: $!"); + my $body = ''; + while () { $body .= $_; } + close IN || error ("$id: $file: $!"); + return ($id, $body); +} + + + +############################################################################ +# +# Pick a random image in a random way +# +############################################################################ + + +# Picks a random image on a random page, and returns two URLs: +# the page containing the image, and the image. +# Returns () if nothing found this time. +# + +sub pick_image(;$) { + my ($timeout) = @_; + + $current_state = "select"; + $load_method = "none"; + + my $n = int(rand(100)); + my $fn = undef; + my $total = 0; + my @rest = @search_methods; + + while (@rest) { + my $pct = shift @rest; + my $name = shift @rest; + my $tfn = shift @rest; + $total += $pct; + if ($total > $n && !defined($fn)) { + $fn = $tfn; + $current_state = $name; + $load_method = $current_state; + } + } + + if ($total != 100) { + error ("internal error: \@search_methods totals to $total%!"); + } + + record_attempt ($current_state); + return $fn->($timeout); +} + + + +############################################################################ +# +# Statistics and logging +# +############################################################################ + +sub timestr() { + return strftime ("%H:%M:%S: ", localtime); +} + +sub blurb() { + return "$progname: " . timestr() . "$current_state: "; +} + +sub error($) { + my ($err) = @_; + print STDERR blurb() . "$err\n"; + exit 1; +} + +sub stacktrace() { + my $i = 1; + print STDERR "$progname: stack trace:\n"; + while (1) { + my ($package, $filename, $line, $subroutine) = caller($i++); + last unless defined($package); + $filename =~ s@^.*/@@; + print STDERR " $filename#$line, $subroutine\n"; + } +} + + +my $lastlog = ""; + +sub clearlog() { + $lastlog = ""; +} + +sub showlog() { + my $head = "$progname: DEBUG: "; + foreach (split (/\n/, $lastlog)) { + print STDERR "$head$_\n"; + } + $lastlog = ""; +} + +sub LOG($$) { + my ($print, $msg) = @_; + my $blurb = timestr() . "$current_state: "; + $lastlog .= "$blurb$msg\n"; + print STDERR "$progname: $blurb$msg\n" if $print; +} + + +my %stats_attempts; +my %stats_successes; +my %stats_elapsed; + +my $last_state = undef; +sub record_attempt($) { + my ($name) = @_; + + if ($last_state) { + record_failure($last_state) unless ($image_succeeded > 0); + } + $last_state = $name; + + clearlog(); + report_performance(); + + start_timer($name); + $image_succeeded = 0; + $suppress_audit = 0; +} + +sub record_success($$$) { + my ($name, $url, $base) = @_; + if (defined($stats_successes{$name})) { + $stats_successes{$name}++; + } else { + $stats_successes{$name} = 1; + } + + stop_timer ($name, 1); + my $o = $current_state; + $current_state = $name; + save_recent_url ($url, $base); + $current_state = $o; + $image_succeeded = 1; + clearlog(); +} + + +sub record_failure($) { + my ($name) = @_; + + return if $image_succeeded; + + stop_timer ($name, 0); + if ($verbose_load && !$verbose_exec) { + + if ($suppress_audit) { + print STDERR "$progname: " . timestr() . "(audit log suppressed)\n"; + return; + } + + my $o = $current_state; + $current_state = "DEBUG"; + + my $line = "#" x 78; + print STDERR "\n\n\n"; + print STDERR ("#" x 78) . "\n"; + print STDERR blurb() . "failed to get an image. Full audit log:\n"; + print STDERR "\n"; + showlog(); + print STDERR ("-" x 78) . "\n"; + print STDERR "\n\n"; + + $current_state = $o; + } + $image_succeeded = 0; +} + + + +sub stats_of($) { + my ($name) = @_; + my $i = $stats_successes{$name}; + my $j = $stats_attempts{$name}; + $i = 0 unless $i; + $j = 0 unless $j; + return "" . ($j ? int($i * 100 / $j) : "0") . "%"; +} + + +my $current_start_time = 0; + +sub start_timer($) { + my ($name) = @_; + $current_start_time = time; + + if (defined($stats_attempts{$name})) { + $stats_attempts{$name}++; + } else { + $stats_attempts{$name} = 1; + } + if (!defined($stats_elapsed{$name})) { + $stats_elapsed{$name} = 0; + } +} + +sub stop_timer($$) { + my ($name, $success) = @_; + $stats_elapsed{$name} += time - $current_start_time; +} + + +my $last_report_time = 0; +sub report_performance() { + + return unless $verbose_warnings; + + my $now = time; + return unless ($now >= $last_report_time + $report_performance_interval); + my $ot = $last_report_time; + $last_report_time = $now; + + return if ($ot == 0); + + my $blurb = "$progname: " . timestr(); + + print STDERR "\n"; + print STDERR "${blurb}Current standings:\n"; + + foreach my $name (sort keys (%stats_attempts)) { + my $try = $stats_attempts{$name}; + my $suc = $stats_successes{$name} || 0; + my $pct = int($suc * 100 / $try); + my $secs = $stats_elapsed{$name}; + my $secs_link = int($secs / $try); + print STDERR sprintf ("$blurb %-12s %4s (%d/%d);\t %2d secs/link\n", + "$name:", "$pct%", $suc, $try, $secs_link); + } +} + + + +my $max_recent_images = 400; +my $max_recent_sites = 20; +my @recent_images = (); +my @recent_sites = (); + +sub save_recent_url($$) { + my ($url, $base) = @_; + + return unless ($verbose_warnings); + + $_ = $url; + my ($site) = m@^http://([^ \t\n\r/:]+)@; + return unless defined ($site); + + if ($base eq $driftnet_magic || $base eq $local_magic) { + $site = $base; + @recent_images = (); + } + + my $done = 0; + foreach (@recent_images) { + if ($_ eq $url) { + print STDERR blurb() . "WARNING: recently-duplicated image: $url" . + " (on $base via $last_search)\n"; + $done = 1; + last; + } + } + + # suppress "duplicate site" warning via %warningless_sites. + # + if ($warningless_sites{$site}) { + $done = 1; + } elsif ($site =~ m@([^.]+\.[^.]+\.[^.]+)$@ && + $warningless_sites{$1}) { + $done = 1; + } elsif ($site =~ m@([^.]+\.[^.]+)$@ && + $warningless_sites{$1}) { + $done = 1; + } + + if (!$done) { + foreach (@recent_sites) { + if ($_ eq $site) { + print STDERR blurb() . "WARNING: recently-duplicated site: $site" . + " ($url on $base via $last_search)\n"; + last; + } + } + } + + push @recent_images, $url; + push @recent_sites, $site; + shift @recent_images if ($#recent_images >= $max_recent_images); + shift @recent_sites if ($#recent_sites >= $max_recent_sites); +} + + + +############################################################################## +# +# other utilities +# +############################################################################## + +# Does %-decoding. +# +sub url_decode($) { + ($_) = @_; + tr/+/ /; + s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; + return $_; +} + + +# Given the raw body of a GIF document, returns the dimensions of the image. +# +sub gif_size($) { + my ($body) = @_; + my $type = substr($body, 0, 6); + my $s; + return () unless ($type =~ /GIF8[7,9]a/); + $s = substr ($body, 6, 10); + my ($a,$b,$c,$d) = unpack ("C"x4, $s); + return () unless defined ($d); + return (($b<<8|$a), ($d<<8|$c)); +} + +# Given the raw body of a JPEG document, returns the dimensions of the image. +# +sub jpeg_size($) { + my ($body) = @_; + my $i = 0; + my $L = length($body); + + my $c1 = substr($body, $i, 1); $i++; + my $c2 = substr($body, $i, 1); $i++; + return () unless (ord($c1) == 0xFF && ord($c2) == 0xD8); + + my $ch = "0"; + while (ord($ch) != 0xDA && $i < $L) { + # Find next marker, beginning with 0xFF. + while (ord($ch) != 0xFF) { + return () if (length($body) <= $i); + $ch = substr($body, $i, 1); $i++; + } + # markers can be padded with any number of 0xFF. + while (ord($ch) == 0xFF) { + return () if (length($body) <= $i); + $ch = substr($body, $i, 1); $i++; + } + + # $ch contains the value of the marker. + my $marker = ord($ch); + + if (($marker >= 0xC0) && + ($marker <= 0xCF) && + ($marker != 0xC4) && + ($marker != 0xCC)) { # it's a SOFn marker + $i += 3; + return () if (length($body) <= $i); + my $s = substr($body, $i, 4); $i += 4; + my ($a,$b,$c,$d) = unpack("C"x4, $s); + return (($c<<8|$d), ($a<<8|$b)); } else { - print "Content-Type: text/html\n"; - print "\n\nError$body_tag

Error

"; - $_ = $ENV{PATH_INFO}; - print "malformed URL: $_\n"; - exit (0); + # We must skip variables, since FFs in variable names aren't + # valid JPEG markers. + return () if (length($body) <= $i); + my $s = substr($body, $i, 2); $i += 2; + my ($c1, $c2) = unpack ("C"x2, $s); + my $length = ($c1 << 8) | $c2; + return () if ($length < 2); + $i += $length-2; + } + } + return (); +} + +# Given the raw body of a PNG document, returns the dimensions of the image. +# +sub png_size($) { + my ($body) = @_; + return () unless ($body =~ m/^\211PNG\r/); + my ($bits) = ($body =~ m/^.{12}(.{12})/s); + return () unless defined ($bits); + return () unless ($bits =~ /^IHDR/); + my ($ign, $w, $h) = unpack("a4N2", $bits); + return ($w, $h); +} + + +# Given the raw body of a GIF, JPEG, or PNG document, returns the dimensions +# of the image. +# +sub image_size($) { + my ($body) = @_; + my ($w, $h) = gif_size ($body); + if ($w && $h) { return ($w, $h); } + ($w, $h) = jpeg_size ($body); + if ($w && $h) { return ($w, $h); } + return png_size ($body); +} + + +# returns the full path of the named program, or undef. +# +sub which($) { + my ($prog) = @_; + foreach (split (/:/, $ENV{PATH})) { + if (-x "$_/$prog") { + return $prog; } + } + return undef; +} + + +# Like rand(), but chooses numbers with a bell curve distribution. +sub bellrand(;$) { + ($_) = @_; + $_ = 1.0 unless defined($_); + $_ /= 3.0; + return (rand($_) + rand($_) + rand($_)); +} + + +sub exit_cleanup() { + x_cleanup(); + print STDERR "$progname: exiting\n" if ($verbose_warnings); + if (@pids_to_kill) { + print STDERR blurb() . "killing: " . join(' ', @pids_to_kill) . "\n"; + kill ('TERM', @pids_to_kill); + } +} + +sub signal_cleanup($) { + my ($sig) = @_; + print STDERR blurb() . (defined($sig) + ? "caught signal $sig." + : "exiting.") + . "\n" + if ($verbose_exec || $verbose_warnings); + exit 1; } + ############################################################################## # # Generating a list of urls only # ############################################################################## -sub url_only_output { - $| = 1; - do { - my ($base, $img) = pick_image; - if ($img) { - $base =~ s/ /%20/g; - $img =~ s/ /%20/g; - print "$img $base\n"; - } - } while (1); +sub url_only_output() { + do { + my ($base, $img) = pick_image; + if ($img) { + $base =~ s/ /%20/g; + $img =~ s/ /%20/g; + print "$img $base\n"; + } + } while (1); } ############################################################################## # -# Running as an xscreensaver module +# Running as an xscreensaver module, or as a web page imagemap # ############################################################################## -my $image_tmp2; -my $image_tmp3; +my $image_ppm = sprintf ("%s/webcollage-%08x", + ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp"), + rand(0xFFFFFFFF)); +my $image_tmp1 = sprintf ("%s/webcollage-1-%08x", + ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp"), + rand(0xFFFFFFFF)); +my $image_tmp2 = sprintf ("%s/webcollage-2-%08x", + ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp"), + rand(0xFFFFFFFF)); -sub x_cleanup { - if ($DEBUG > 0) { print STDERR "caught signal\n"; } - unlink $image_ppm, $image_tmp, $image_tmp2, $image_tmp3; - exit 1; +my $filter_cmd = undef; +my $post_filter_cmd = undef; +my $background = undef; + +my @imagemap_areas = (); +my $imagemap_html_tmp = undef; +my $imagemap_jpg_tmp = undef; + + +my $img_width; # size of the image being generated. +my $img_height; + +my $delay = 2; + +sub x_cleanup() { + unlink $image_ppm, $image_tmp1, $image_tmp2; + unlink $imagemap_html_tmp, $imagemap_jpg_tmp + if (defined ($imagemap_html_tmp)); } -sub x_output { +# Like system, but prints status about exit codes, and kills this process +# with whatever signal killed the sub-process, if any. +# +sub nontrapping_system(@) { + $! = 0; + + $_ = join(" ", @_); + s/\"[^\"]+\"/\"...\"/g; - my $win_cmd = $ppm_to_root_window_cmd; - $win_cmd =~ s/^([^ \t\r\n]+).*$/$1/; + LOG ($verbose_exec, "executing \"$_\""); - # make sure the various programs we execute exist, right up front. - foreach ("ppmmake", "giftopnm", "djpeg", "pnmpaste", "pnmscale", - $win_cmd) { - which ($_) || die "$progname: $_ not found on \$PATH.\n"; + my $rc = system @_; + + if ($rc == 0) { + LOG ($verbose_exec, "subproc exited normally."); + } elsif (($rc & 0xff) == 0) { + $rc >>= 8; + LOG ($verbose_exec, "subproc exited with status $rc."); + } else { + if ($rc & 0x80) { + LOG ($verbose_exec, "subproc dumped core."); + $rc &= ~0x80; } + LOG ($verbose_exec, "subproc died with signal $rc."); + # die that way ourselves. + kill $rc, $$; + } + + return $rc; +} - $SIG{HUP} = \&x_cleanup; - $SIG{INT} = \&x_cleanup; - $SIG{QUIT} = \&x_cleanup; - $SIG{ABRT} = \&x_cleanup; - $SIG{KILL} = \&x_cleanup; - $SIG{TERM} = \&x_cleanup; - - # Need this so that if giftopnm dies, we don't die. - $SIG{PIPE} = 'IGNORE'; - - if (!$img_width || !$img_height) { - $_ = "xdpyinfo"; - which ($_) || die "$progname: $_ not found on \$PATH.\n"; - $_ = `$_`; - ($img_width, $img_height) = m/dimensions: *([0-9]+)x([0-9]+) /; + +# Given the URL of a GIF, JPEG, or PNG image, and the body of that image, +# writes a PPM to the given output file. Returns the width/height of the +# image if successful. +# +sub image_to_pnm($$$) { + my ($url, $body, $output) = @_; + my ($cmd, $cmd2, $w, $h); + + if ((@_ = gif_size ($body))) { + ($w, $h) = @_; + $cmd = "giftopnm"; + } elsif ((@_ = jpeg_size ($body))) { + ($w, $h) = @_; + $cmd = "djpeg"; + } elsif ((@_ = png_size ($body))) { + ($w, $h) = @_; + $cmd = "pngtopnm"; + } else { + LOG (($verbose_pbm || $verbose_load), + "not a GIF, JPG, or PNG" . + (($body =~ m@<(base|html|head|body|script|table|a href)\b@i) + ? " (looks like HTML)" : "") . + ": $url"); + $suppress_audit = 1; + return (); + } + + $cmd2 = "exec $cmd"; # yes, this really is necessary. if we don't + # do this, the process doesn't die properly. + if (!$verbose_pbm) { + # + # We get a "giftopnm: got a 'Application Extension' extension" + # warning any time it's an animgif. + # + # Note that "giftopnm: EOF / read error on image data" is not + # always a fatal error -- sometimes the image looks fine anyway. + # + $cmd2 .= " 2>/dev/null"; + } + + # There exist corrupted GIF and JPEG files that can make giftopnm and + # djpeg lose their minds and go into a loop. So this gives those programs + # a small timeout -- if they don't complete in time, kill them. + # + my $pid; + @_ = eval { + my $timed_out; + + local $SIG{ALRM} = sub { + LOG ($verbose_pbm, + "timed out ($cvt_timeout) for $cmd on \"$url\" in pid $pid"); + kill ('TERM', $pid) if ($pid); + $timed_out = 1; + $body = undef; + }; + + if (($pid = open(PIPE, "| $cmd2 > $output"))) { + $timed_out = 0; + alarm $cvt_timeout; + print PIPE $body; + $body = undef; + close PIPE; + + LOG ($verbose_exec, "awaiting $pid"); + waitpid ($pid, 0); + LOG ($verbose_exec, "$pid completed"); + + my $size = (stat($output))[7]; + $size = -1 unless defined($size); + if ($size < 5) { + LOG ($verbose_pbm, "$cmd on ${w}x$h \"$url\" failed ($size bytes)"); + return (); + } + + LOG ($verbose_pbm, "created ${w}x$h $output ($cmd)"); + return ($w, $h); + } else { + print STDERR blurb() . "$cmd failed: $!\n"; + return (); } + }; + die if ($@ && $@ ne "alarm\n"); # propagate errors + if ($@) { + # timed out + $body = undef; + return (); + } else { + # didn't + alarm 0; + $body = undef; + return @_; + } +} - my $bgcolor = "#000000"; - my $bgimage = undef; - - if ($background) { - if ($background =~ m/^\#[0-9a-f]+$/i) { - $bgcolor = $background; - } elsif (-r $background) { - $bgimage = $background; - - } elsif (! $background =~ m@^[-a-z0-9 ]+$@i) { - print STDERR "not a color or readable file: $background\n"; - exit 1; - } else { - # default to assuming it's a color - $bgcolor = $background; - } + +# Same as the "ppmmake" command: creates a solid-colored PPM. +# Does not understand the rgb.txt color names except "black" and "white". +# +sub ppmmake($$$$) { + my ($outfile, $bgcolor, $w, $h) = @_; + + my ($r, $g, $b); + if ($bgcolor =~ m/^\#?([\dA-F][\dA-F])([\dA-F][\dA-F])([\dA-F][\dA-F])$/i || + $bgcolor =~ m/^\#?([\dA-F])([\dA-F])([\dA-F])$/i) { + ($r, $g, $b) = (hex($1), hex($2), hex($3)); + } elsif ($bgcolor =~ m/^black$/i) { + ($r, $g, $b) = (0, 0, 0); + } elsif ($bgcolor =~ m/^white$/i) { + ($r, $g, $b) = (0xFF, 0xFF, 0xFF); + } else { + error ("unparsable color name: $bgcolor"); + } + + my $pixel = pack('CCC', $r, $g, $b); + my $bits = "P6\n$w $h\n255\n" . ($pixel x ($w * $h)); + + local *OUT; + open (OUT, ">$outfile") || error ("$outfile: $!"); + print OUT $bits; + close OUT; +} + + +sub pick_root_displayer() { + my @names = (); + + if ($cocoa_p) { + # see "xscreensaver/hacks/webcollage-cocoa.m" + return "echo COCOA LOAD "; + } + + foreach my $cmd (@root_displayers) { + $_ = $cmd; + my ($name) = m/^([^ ]+)/; + push @names, "\"$name\""; + LOG ($verbose_exec, "looking for $name..."); + foreach my $dir (split (/:/, $ENV{PATH})) { + LOG ($verbose_exec, " checking $dir/$name"); + return $cmd if (-x "$dir/$name"); } + } - # Create the sold-colored base image. - # - $_ = "ppmmake '$bgcolor' $img_width $img_height"; - if ($DEBUG > 1) { - print STDERR "creating base image: $_\n"; + $names[$#names] = "or " . $names[$#names]; + error "none of: " . join (", ", @names) . " were found on \$PATH."; +} + + +my $ppm_to_root_window_cmd = undef; + + +sub x_or_pbm_output($) { + my ($window_id) = @_; + + # Check for our helper program, to see whether we need to use PPM pipelines. + # + $_ = "webcollage-helper"; + if (defined ($webcollage_helper) || which ($_)) { + $webcollage_helper = $_ unless (defined($webcollage_helper)); + LOG ($verbose_pbm, "found \"$webcollage_helper\""); + $webcollage_helper .= " -v"; + } else { + LOG (($verbose_pbm || $verbose_load), "no $_ program"); + } + + if ($cocoa_p && !defined ($webcollage_helper)) { + error ("webcollage-helper not found in Cocoa-mode!"); + } + + + # make sure the various programs we execute exist, right up front. + # + my @progs = (); + + if (!defined($webcollage_helper)) { + # Only need these others if we don't have the helper. + @progs = (@progs, + "giftopnm", "pngtopnm", "djpeg", + "pnmpaste", "pnmscale", "pnmcut"); + } + + foreach (@progs) { + which ($_) || error "$_ not found on \$PATH."; + } + + # find a root-window displayer program. + # + $ppm_to_root_window_cmd = pick_root_displayer(); + + if (defined ($window_id)) { + error ("-window-id only works if xscreensaver-getimage is installed") + unless ($ppm_to_root_window_cmd =~ m/^xscreensaver-getimage\b/); + + error ("unparsable window id: $window_id") + unless ($window_id =~ m/^\d+$|^0x[\da-f]+$/i); + $ppm_to_root_window_cmd =~ s/--?root\b/$window_id/ || + error ("unable to munge displayer: $ppm_to_root_window_cmd"); + } + + if (!$img_width || !$img_height) { + + if (!defined ($window_id) && + defined ($ENV{XSCREENSAVER_WINDOW})) { + $window_id = $ENV{XSCREENSAVER_WINDOW}; } - system "$_ > $image_ppm"; - # Paste the default background image in the middle of it. - # - if ($bgimage) { - my ($iw, $ih); - if (open(IMG, "<$bgimage")) { - $_ = ; - $_ = ; - ($iw, $ih) = m/^([0-9]+) ([0-9]+)$/; - close (IMG); - } - my $x = int (($img_width - $iw) / 2); - my $y = int (($img_height - $ih) / 2); - if ($DEBUG > 1) { - print STDERR "pasting $bgimage into base image at $x, $y\n"; - } - system "pnmpaste $bgimage $x $y $image_ppm > $image_tmp2" . - " && mv $image_tmp2 $image_ppm"; + if (!defined ($window_id)) { + $_ = "xdpyinfo"; + which ($_) || error "$_ not found on \$PATH."; + $_ = `$_`; + ($img_width, $img_height) = m/dimensions: *(\d+)x(\d+) /; + if (!defined($img_height)) { + error "xdpyinfo failed."; + } + } else { # we have a window id + $_ = "xwininfo"; + which ($_) || error "$_ not found on \$PATH."; + $_ .= " -id $window_id"; + $_ = `$_`; + ($img_width, $img_height) = m/^\s*Width:\s*(\d+)\n\s*Height:\s*(\d+)\n/m; + + if (!defined($img_height)) { + error "xwininfo failed."; + } } + } + my $bgcolor = "#000000"; + my $bgimage = undef; - do { - my ($base, $img) = pick_image; + if ($background) { + if ($background =~ m/^\#[0-9a-f]+$/i) { + $bgcolor = $background; - my ($headers, $body); - if ($img) { - ($headers, $body) = get_document ($img, $base); - } + } elsif (-r $background) { + $bgimage = $background; - if ($body) { - - if ($DEBUG > 0) { - print STDERR "got $img (" . length($body) . ")\n"; - } - - my $cmd; - if ($img =~ m/\.gif/i) { - $cmd = "giftopnm"; - } else { - $cmd = "djpeg"; - } - - if ($DEBUG == 0) { - $cmd .= " 2>/dev/null"; - } - - if (open(PIPE, "| $cmd > $image_tmp")) { - print PIPE $body; - close PIPE; - - if ($DEBUG > 1) { - print STDERR "created $image_tmp ($cmd)\n"; - } - } - - if (-s $image_tmp) { - - if ($filter_cmd) { - if ($DEBUG > 1) { - print STDERR "running $filter_cmd\n"; - } - system "($filter_cmd) < $image_tmp > $image_tmp3" . - " && mv $image_tmp3 $image_tmp"; - } - - my ($iw, $ih); - if (open(IMG, "<$image_tmp")) { - $_ = ; - $_ = ; - ($iw, $ih) = m/^([0-9]+) ([0-9]+)$/; - close (IMG); - } - - if ($iw && $ih) { - - if ($DEBUG > 1) { - print STDERR "image size is $iw x $ih\n"; - } - - if ($iw > $img_width || $ih > $img_height) { - while ($iw > $img_width || - $ih > $img_height) { - $iw = int($iw / 2); - $ih = int($ih / 2); - } - if ($DEBUG > 1) { - print STDERR "scaling to $iw x $ih\n"; - } - system "pnmscale -xysize $iw $ih $image_tmp" . - " > $image_tmp2" . - " 2>/dev/null && mv $image_tmp2 $image_tmp"; - } - - my $x = int (rand() * ($img_width - $iw)); - my $y = int (rand() * ($img_height - $ih)); - - if ($DEBUG > 1) { - print STDERR "pasting at $x, $y in $image_ppm\n"; - } - - system "pnmpaste $image_tmp $x $y $image_ppm" . - " > $image_tmp2" . - " && mv $image_tmp2 $image_ppm"; - - - my $target = $image_ppm; - if ($post_filter_cmd) { - if ($DEBUG > 1) { - print STDERR "running $post_filter_cmd\n"; - } - system "($post_filter_cmd) < $image_ppm > $image_tmp3"; - $target = $image_tmp3; - } - - if (!$no_output_p) { - - my $tsize = (stat($target))[7]; - if ($tsize > 200) { - $_ = $ppm_to_root_window_cmd; - s/%%PPM%%/$target/; - - if ($DEBUG > 1) { - print STDERR "running $_\n"; - } - system $_; - - } elsif ($DEBUG > 1) { - print STDERR "$target size is $tsize\n"; - } - } - } - } - unlink $image_tmp, $image_tmp2, $image_tmp3; - } + } elsif (! $background =~ m@^[-a-z0-9 ]+$@i) { + error "not a color or readable file: $background"; + + } else { + # default to assuming it's a color + $bgcolor = $background; + } + } + + # Create the sold-colored base image. + # + LOG ($verbose_pbm, "creating base image: ${img_width}x${img_height}"); + $_ = ppmmake ($image_ppm, $bgcolor, $img_width, $img_height); - sleep $delay; + # Paste the default background image in the middle of it. + # + if ($bgimage) { + my ($iw, $ih); - } while (1); + my $body = ""; + local *IMG; + open(IMG, "<$bgimage") || error "couldn't open $bgimage: $!"; + my $cmd; + while () { $body .= $_; } + close (IMG); + + if ((@_ = gif_size ($body))) { + ($iw, $ih) = @_; + $cmd = "giftopnm |"; + + } elsif ((@_ = jpeg_size ($body))) { + ($iw, $ih) = @_; + $cmd = "djpeg |"; + + } elsif ((@_ = png_size ($body))) { + ($iw, $ih) = @_; + $cmd = "pngtopnm |"; + + } elsif ($body =~ m/^P\d\n(\d+) (\d+)\n/) { + $iw = $1; + $ih = $2; + $cmd = ""; + + } else { + error "$bgimage is not a GIF, JPEG, PNG, or PPM."; + } + + my $x = int (($img_width - $iw) / 2); + my $y = int (($img_height - $ih) / 2); + LOG ($verbose_pbm, + "pasting $bgimage (${iw}x$ih) into base image at $x,$y"); + + $cmd .= "pnmpaste - $x $y $image_ppm > $image_tmp1"; + open (IMG, "| $cmd") || error "running $cmd: $!"; + print IMG $body; + $body = undef; + close (IMG); + LOG ($verbose_exec, "subproc exited normally."); + rename ($image_tmp1, $image_ppm) || + error "renaming $image_tmp1 to $image_ppm: $!"; + } + + clearlog(); + + while (1) { + my ($base, $img) = pick_image(); + my $source = $current_state; + $current_state = "loadimage"; + if ($img) { + my ($headers, $body) = get_document ($img, $base); + if ($body) { + paste_image ($base, $img, $body, $source); + $body = undef; + } + } + $current_state = "idle"; + $load_method = "none"; + + unlink $image_tmp1, $image_tmp2; + sleep $delay; + } } +sub paste_image($$$$) { + my ($base, $img, $body, $source) = @_; -sub x_main { + $current_state = "paste"; - # Unlike CGI, when running in X mode, the various tmp files should be - # in the /tmp directory and should have gensymed names. - # - $image_ppm = ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp") . "/webcollage." . $$; - $image_tmp = $image_ppm . "-1"; - $image_tmp2 = $image_ppm . "-2"; - $image_tmp3 = $image_ppm . "-3"; + $suppress_audit = 0; - # In X mode, these aren't used. Set them to undef to error if we try. - # - $data_dir = undef; - $image_jpg = undef; - $pending_file = undef; - $map_file = undef; - $url_generation_time = undef; - $image_retrieval_time = undef; - $max_map_entries = undef; - $pastes_per_load = undef; - $max_age = undef; - $script_date = undef; - @all_files = undef; - - # In X mode, these come either from the command line, or from the X server. - $img_width = undef; - $img_height = undef; - - - my $root_p = 0; - - while ($_ = $ARGV[0]) { - shift @ARGV; - if ($_ eq "-display" || - $_ eq "-displ" || - $_ eq "-disp" || - $_ eq "-dis" || - $_ eq "-dpy" || - $_ eq "-d") { - $ENV{DISPLAY} = shift @ARGV; - } elsif ($_ eq "-root") { - $root_p = 1; - } elsif ($_ eq "-no-output") { - $no_output_p = 1; - } elsif ($_ eq "-urls-only") { - $urls_only_p = 1; - $no_output_p = 1; - } elsif ($_ eq "-verbose") { - $DEBUG++; - } elsif (m/^-v+$/) { - $DEBUG += length($_)-1; - } elsif ($_ eq "-delay") { - $delay = shift @ARGV; - } elsif ($_ eq "-timeout") { - $http_timeout = shift @ARGV; - } elsif ($_ eq "-filter") { - $filter_cmd = shift @ARGV; - } elsif ($_ eq "-filter2") { - $post_filter_cmd = shift @ARGV; - } elsif ($_ eq "-background" || $_ eq "-bg") { - $background = shift @ARGV; - } elsif ($_ eq "-size") { - $_ = shift @ARGV; - if (m@^([0-9]+)x([0-9]+)$@) { - $img_width = $1; - $img_height = $2; - } else { - die "$progname: argument to \"-size\" must be" . - " of the form \"640x400\"\n"; - } - } else { - die "$copyright\nusage: $progname [-root]" . - " [-display dpy] [-root] [-verbose] [-timeout secs]\n" . - "\t\t [-delay secs] [-filter cmd] [-filter2 cmd]\n"; - } + LOG ($verbose_pbm, "got $img (" . length($body) . ")"); + + my ($iw, $ih); + + # If we are using the webcollage-helper, then we do not need to convert this + # image to a PPM. But, if we're using a filter command, we still must, since + # that's what the filters expect (webcollage-helper can read PPMs, so that's + # fine.) + # + if (defined ($webcollage_helper) && + !defined ($filter_cmd)) { + + ($iw, $ih) = image_size ($body); + if (!$iw || !$ih) { + LOG (($verbose_pbm || $verbose_load), + "not a GIF, JPG, or PNG" . + (($body =~ m@<(base|html|head|body|script|table|a href)>@i) + ? " (looks like HTML)" : "") . + ": $img"); + $suppress_audit = 1; + $body = undef; + return 0; + } + + local *OUT; + open (OUT, ">$image_tmp1") || error ("writing $image_tmp1: $!"); + print OUT $body || error ("writing $image_tmp1: $!"); + close OUT || error ("writing $image_tmp1: $!"); + + } else { + ($iw, $ih) = image_to_pnm ($img, $body, $image_tmp1); + $body = undef; + if (!$iw || !$ih) { + LOG ($verbose_pbm, "unable to make PBM from $img"); + return 0; + } + } + + record_success ($load_method, $img, $base); + + + my $ow = $iw; # used only for error messages + my $oh = $ih; + + # don't just tack this onto the front of the pipeline -- we want it to + # be able to change the size of the input image. + # + if ($filter_cmd) { + LOG ($verbose_pbm, "running $filter_cmd"); + + my $rc = nontrapping_system "($filter_cmd) < $image_tmp1 >$image_tmp2"; + if ($rc != 0) { + LOG(($verbose_pbm || $verbose_load), "failed command: \"$filter_cmd\""); + LOG(($verbose_pbm || $verbose_load), "failed URL: \"$img\" (${ow}x$oh)"); + return; + } + rename ($image_tmp2, $image_tmp1); + + # re-get the width/height in case the filter resized it. + local *IMG; + open(IMG, "<$image_tmp1") || return 0; + $_ = ; + $_ = ; + ($iw, $ih) = m/^(\d+) (\d+)$/; + close (IMG); + return 0 unless ($iw && $ih); + } + + my $target_w = $img_width; # max rectangle into which the image must fit + my $target_h = $img_height; + + my $cmd = ""; + my $scale = 1.0; + + + # Usually scale the image to fit on the screen -- but sometimes scale it + # to fit on half or a quarter of the screen. (We do this by reducing the + # size of the target rectangle.) Note that the image is not merely scaled + # to fit; we instead cut the image in half repeatedly until it fits in the + # target rectangle -- that gives a wider distribution of sizes. + # + if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; } # reduce target rect + if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; } + + if ($iw > $target_w || $ih > $target_h) { + while ($iw > $target_w || + $ih > $target_h) { + $iw = int($iw / 2); + $ih = int($ih / 2); + $scale /= 2; + } + if ($iw <= 10 || $ih <= 10) { + LOG ($verbose_pbm, "scaling to ${iw}x$ih would have been bogus."); + return 0; + } + + LOG ($verbose_pbm, "scaling to ${iw}x$ih ($scale)"); + + $cmd .= " | pnmscale -xsize $iw -ysize $ih"; + } + + + my $src = $image_tmp1; + + my $crop_x = 0; # the sub-rectangle of the image + my $crop_y = 0; # that we will actually paste. + my $crop_w = $iw; + my $crop_h = $ih; + + # The chance that we will randomly crop out a section of an image starts + # out fairly low, but goes up for images that are very large, or images + # that have ratios that make them look like banners (we try to avoid + # banner images entirely, but they slip through when the IMG tags didn't + # have WIDTH and HEIGHT specified.) + # + my $crop_chance = 0.2; + if ($iw > $img_width * 0.4 || $ih > $img_height * 0.4) { + $crop_chance += 0.2; + } + if ($iw > $img_width * 0.7 || $ih > $img_height * 0.7) { + $crop_chance += 0.2; + } + if ($min_ratio && ($iw * $min_ratio) > $ih) { + $crop_chance += 0.7; + } + + if ($crop_chance > 0.1) { + LOG ($verbose_pbm, "crop chance: $crop_chance"); + } + + if (rand() < $crop_chance) { + + my $ow = $crop_w; + my $oh = $crop_h; + + if ($crop_w > $min_width) { + # if it's a banner, select the width linearly. + # otherwise, select a bell. + my $r = (($min_ratio && ($iw * $min_ratio) > $ih) + ? rand() + : bellrand()); + $crop_w = $min_width + int ($r * ($crop_w - $min_width)); + $crop_x = int (rand() * ($ow - $crop_w)); + } + if ($crop_h > $min_height) { + # height always selects as a bell. + $crop_h = $min_height + int (bellrand() * ($crop_h - $min_height)); + $crop_y = int (rand() * ($oh - $crop_h)); + } + + if ($crop_x != 0 || $crop_y != 0 || + $crop_w != $iw || $crop_h != $ih) { + LOG ($verbose_pbm, + "randomly cropping to ${crop_w}x$crop_h \@ $crop_x,$crop_y"); } + } + + # Where the image should logically land -- this might be negative. + # + my $x = int((rand() * ($img_width + $crop_w/2)) - $crop_w*3/4); + my $y = int((rand() * ($img_height + $crop_h/2)) - $crop_h*3/4); + + # if we have chosen to paste the image outside of the rectangle of the + # screen, then we need to crop it. + # + if ($x < 0 || + $y < 0 || + $x + $crop_w > $img_width || + $y + $crop_h > $img_height) { + + LOG ($verbose_pbm, + "cropping for effective paste of ${crop_w}x$crop_h \@ $x,$y"); + + if ($x < 0) { $crop_x -= $x; $crop_w += $x; $x = 0; } + if ($y < 0) { $crop_y -= $y; $crop_h += $y; $y = 0; } + + if ($x + $crop_w >= $img_width) { $crop_w = $img_width - $x - 1; } + if ($y + $crop_h >= $img_height) { $crop_h = $img_height - $y - 1; } + } + + # If any cropping needs to happen, add pnmcut. + # + if ($crop_x != 0 || $crop_y != 0 || + $crop_w != $iw || $crop_h != $ih) { + $iw = $crop_w; + $ih = $crop_h; + $cmd .= " | pnmcut $crop_x $crop_y $iw $ih"; + LOG ($verbose_pbm, "cropping to ${crop_w}x$crop_h \@ $crop_x,$crop_y"); + } + + LOG ($verbose_pbm, "pasting ${iw}x$ih \@ $x,$y in $image_ppm"); + + $cmd .= " | pnmpaste - $x $y $image_ppm"; + + $cmd =~ s@^ *\| *@@; + + if (defined ($webcollage_helper)) { + $cmd = "$webcollage_helper $image_tmp1 $image_ppm " . + "$scale $opacity " . + "$crop_x $crop_y $x $y " . + "$iw $ih"; + $_ = $cmd; + + } else { + # use a PPM pipeline + $_ = "($cmd)"; + $_ .= " < $image_tmp1 > $image_tmp2"; + } + + if ($verbose_pbm) { + $_ = "($_) 2>&1 | sed s'/^/" . blurb() . "/'"; + } else { + $_ .= " 2> /dev/null"; + } + + my $rc = nontrapping_system ($_); + + if (defined ($webcollage_helper) && -z $image_ppm) { + LOG (1, "failed command: \"$cmd\""); + print STDERR "\naudit log:\n\n\n"; + print STDERR ("#" x 78) . "\n"; + print STDERR blurb() . "$image_ppm has zero size\n"; + showlog(); + print STDERR "\n\n"; + exit (1); + } + + if ($rc != 0) { + LOG (($verbose_pbm || $verbose_load), "failed command: \"$cmd\""); + LOG (($verbose_pbm || $verbose_load), "failed URL: \"$img\" (${ow}x$oh)"); + return; + } + + if (!defined ($webcollage_helper)) { + rename ($image_tmp2, $image_ppm) || return; + } + + my $target = "$image_ppm"; + + # don't just tack this onto the end of the pipeline -- we don't want it + # to end up in $image_ppm, because we don't want the results to be + # cumulative. + # + if ($post_filter_cmd) { - if (!$root_p && !$no_output_p) { - die "$copyright" . - "$progname: the -root argument is manditory (for now.)\n"; + my $cmd; + + $target = $image_tmp1; + if (!defined ($webcollage_helper)) { + $cmd = "($post_filter_cmd) < $image_ppm > $target"; + } else { + # Blah, my scripts need the JPEG data, but some other folks need + # the PPM data -- what to do? Ignore the problem, that's what! +# $cmd = "djpeg < $image_ppm | ($post_filter_cmd) > $target"; + $cmd = "($post_filter_cmd) < $image_ppm > $target"; } - if (!$no_output_p && !$ENV{DISPLAY}) { - die "$progname: \$DISPLAY is not set.\n"; + $rc = nontrapping_system ($cmd); + if ($rc != 0) { + LOG ($verbose_pbm, "filter failed: \"$post_filter_cmd\"\n"); + return; } + } + + if (!$no_output_p) { + my $tsize = (stat($target))[7]; + if ($tsize > 200) { + $cmd = "$ppm_to_root_window_cmd $target"; + + # xv seems to hate being killed. it tends to forget to clean + # up after itself, and leaves windows around and colors allocated. + # I had this same problem with vidwhacker, and I'm not entirely + # sure what I did to fix it. But, let's try this: launch xv + # in the background, so that killing this process doesn't kill it. + # it will die of its own accord soon enough. So this means we + # start pumping bits to the root window in parallel with starting + # the next network retrieval, which is probably a better thing + # to do anyway. + # + $cmd .= " &"; + + $rc = nontrapping_system ($cmd); + + if ($rc != 0) { + LOG (($verbose_pbm || $verbose_load), "display failed: \"$cmd\""); + return; + } - if ($urls_only_p) { - url_only_output; } else { - x_output; + LOG ($verbose_pbm, "$target size is $tsize"); } + } + + $source .= "-" . stats_of($source); + print STDOUT "image: ${iw}x${ih} @ $x,$y $base $source\n" + if ($verbose_imgmap); + if ($imagemap_base) { + update_imagemap ($base, $x, $y, $iw, $ih, + $image_ppm, $img_width, $img_height); + } + + clearlog(); + + return 1; } -############################################################################## -# -# Decide if we're in X or CGI mode, and dispatch. -# -############################################################################## +sub update_imagemap($$$$$$$$) { + my ($url, $x, $y, $w, $h, $image_ppm, $image_width, $image_height) = @_; + + $current_state = "imagemap"; + + my $max_areas = 200; + + $url = html_quote ($url); + my $x2 = $x + $w; + my $y2 = $y + $h; + my $area = ""; + unshift @imagemap_areas, $area; # put one on the front + if ($#imagemap_areas >= $max_areas) { + pop @imagemap_areas; # take one off the back. + } + + LOG ($verbose_pbm, "area: $x,$y,$x2,$y2 (${w}x$h)"); + + my $map_name = $imagemap_base; + $map_name =~ s@^.*/@@; + $map_name = 'collage' if ($map_name eq ''); + + my $imagemap_html = $imagemap_base . ".html"; + my $imagemap_jpg = $imagemap_base . ".jpg"; + + if (!defined ($imagemap_html_tmp)) { + $imagemap_html_tmp = $imagemap_html . sprintf (".%08x", rand(0xffffffff)); + $imagemap_jpg_tmp = $imagemap_jpg . sprintf (".%08x", rand(0xffffffff)); + } + + # Read the imagemap html file (if any) to get a template. + # + my $template_html = ''; + { + local *IN; + if (open (IN, "<$imagemap_html")) { + while () { $template_html .= $_; } + close IN; + LOG ($verbose_pbm, "read template $imagemap_html"); + } + + if ($template_html =~ m/^\s*$/s) { + $template_html = ("\n" . + "\n"); + LOG ($verbose_pbm, "created dummy template"); + } + } + + # Write the jpg to a tmp file + # + { + my $cmd; + if (defined ($webcollage_helper)) { + $cmd = "cp -p $image_ppm $imagemap_jpg_tmp"; + } else { + $cmd = "cjpeg < $image_ppm > $imagemap_jpg_tmp"; + } + my $rc = nontrapping_system ($cmd); + if ($rc != 0) { + error ("imagemap jpeg failed: \"$cmd\"\n"); + } + } + + # Write the html to a tmp file + # + { + my $body = $template_html; + my $areas = join ("\n\t", @imagemap_areas); + my $map = ("\n\t$areas\n"); + my $img = (""); + $body =~ s@().*?()@$map@is; + $body =~ s@]*\bUSEMAP\b[^<>]*>@$img@is; + + # if there are magic webcollage spans in the html, update those too. + # + { + my @st = stat ($imagemap_jpg_tmp); + my $date = strftime("%d-%b-%Y %l:%M:%S %p %Z", localtime($st[9])); + my $size = int(($st[7] / 1024) + 0.5) . "K"; + $body =~ s@().*?()@$1$date$2@si; + $body =~ s@().*?()@$1$size$2@si; + } + + local *OUT; + open (OUT, ">$imagemap_html_tmp") || error ("$imagemap_html_tmp: $!"); + print OUT $body || error ("$imagemap_html_tmp: $!"); + close OUT || error ("$imagemap_html_tmp: $!"); + LOG ($verbose_pbm, "wrote $imagemap_html_tmp"); + } + + # Rename the two tmp files to the real files + # + rename ($imagemap_html_tmp, $imagemap_html) || + error "renaming $imagemap_html_tmp to $imagemap_html"; + LOG ($verbose_pbm, "wrote $imagemap_html"); + rename ($imagemap_jpg_tmp, $imagemap_jpg) || + error "renaming $imagemap_jpg_tmp to $imagemap_jpg"; + LOG ($verbose_pbm, "wrote $imagemap_jpg"); +} + + +sub init_signals() { + + $SIG{HUP} = \&signal_cleanup; + $SIG{INT} = \&signal_cleanup; + $SIG{QUIT} = \&signal_cleanup; + $SIG{ABRT} = \&signal_cleanup; + $SIG{KILL} = \&signal_cleanup; + $SIG{TERM} = \&signal_cleanup; + + # Need this so that if giftopnm dies, we don't die. + $SIG{PIPE} = 'IGNORE'; +} + +END { exit_cleanup(); } + + +sub main() { + $| = 1; + srand(time ^ $$); + + my $verbose = 0; + my $dict; + my $driftnet_cmd = 0; + + $current_state = "init"; + $load_method = "none"; + + my $root_p = 0; + my $window_id = undef; + + # historical suckage: the environment variable name is lower case. + $http_proxy = $ENV{http_proxy} || $ENV{HTTP_PROXY}; + + while ($_ = $ARGV[0]) { + shift @ARGV; + if ($_ eq "-display" || + $_ eq "-displ" || + $_ eq "-disp" || + $_ eq "-dis" || + $_ eq "-dpy" || + $_ eq "-d") { + $ENV{DISPLAY} = shift @ARGV; + } elsif ($_ eq "-root") { + $root_p = 1; + } elsif ($_ eq "-window-id" || $_ eq "--window-id") { + $window_id = shift @ARGV; + $root_p = 1; + } elsif ($_ eq "-no-output") { + $no_output_p = 1; + } elsif ($_ eq "-urls-only") { + $urls_only_p = 1; + $no_output_p = 1; + } elsif ($_ eq "-cocoa") { + $cocoa_p = 1; + } elsif ($_ eq "-imagemap") { + $imagemap_base = shift @ARGV; + $no_output_p = 1; + } elsif ($_ eq "-verbose") { + $verbose++; + } elsif (m/^-v+$/) { + $verbose += length($_)-1; + } elsif ($_ eq "-delay") { + $delay = shift @ARGV; + } elsif ($_ eq "-timeout") { + $http_timeout = shift @ARGV; + } elsif ($_ eq "-filter") { + $filter_cmd = shift @ARGV; + } elsif ($_ eq "-filter2") { + $post_filter_cmd = shift @ARGV; + } elsif ($_ eq "-background" || $_ eq "-bg") { + $background = shift @ARGV; + } elsif ($_ eq "-size") { + $_ = shift @ARGV; + if (m@^(\d+)x(\d+)$@) { + $img_width = $1; + $img_height = $2; + } else { + error "argument to \"-size\" must be of the form \"640x400\""; + } + } elsif ($_ eq "-proxy" || $_ eq "-http-proxy") { + $http_proxy = shift @ARGV; + } elsif ($_ eq "-dictionary" || $_ eq "-dict") { + $dict = shift @ARGV; + } elsif ($_ eq "-opacity") { + $opacity = shift @ARGV; + error ("opacity must be between 0.0 and 1.0") + if ($opacity <= 0 || $opacity > 1); + } elsif ($_ eq "-driftnet" || $_ eq "--driftnet") { + @search_methods = ( 100, "driftnet", \&pick_from_driftnet ); + if (! ($ARGV[0] =~ m/^-/)) { + $driftnet_cmd = shift @ARGV; + } else { + $driftnet_cmd = $default_driftnet_cmd; + } + } elsif ($_ eq "-directory" || $_ eq "--directory") { + @search_methods = ( 100, "local", \&pick_from_local_dir ); + if (! ($ARGV[0] =~ m/^-/)) { + $local_dir = shift @ARGV; + } else { + error ("local directory path must be set") + } + } elsif ($_ eq "-debug" || $_ eq "--debug") { + my $which = shift @ARGV; + my @rest = @search_methods; + my $ok = 0; + while (@rest) { + my $pct = shift @rest; + my $name = shift @rest; + my $tfn = shift @rest; + + if ($name eq $which) { + @search_methods = (100, $name, $tfn); + $ok = 1; + last; + } + } + error "no such search method as \"$which\"" unless ($ok); + LOG (1, "DEBUG: using only \"$which\""); -sub main { - srand(time ^ $$); - if ( $progname =~ m/\.cgi$/i || $ENV{REQUEST_METHOD} ) { - cgi_main; } else { - x_main; + print STDERR "$copyright\nusage: $progname " . + "[-root] [-display dpy] [-verbose] [-debug which]\n" . + "\t\t [-timeout secs] [-delay secs] [-size WxH]\n" . + "\t\t [-no-output] [-urls-only] [-imagemap filename]\n" . + "\t\t [-filter cmd] [-filter2 cmd] [-background color]\n" . + "\t\t [-dictionary dictionary-file] [-http-proxy host[:port]]\n" . + "\t\t [-driftnet [driftnet-program-and-args]]\n" . + "\t\t [-directory local-image-directory]\n" . + "\n"; + exit 1; } + } + + if ($http_proxy && $http_proxy eq "") { + $http_proxy = undef; + } + if ($http_proxy && $http_proxy =~ m@^http://([^/]*)/?$@ ) { + # historical suckage: allow "http://host:port" as well as "host:port". + $http_proxy = $1; + } + + if (!$root_p && !$no_output_p && !$cocoa_p) { + print STDERR $copyright; + error "the -root argument is mandatory (for now.)"; + } + + if (!$no_output_p && !$cocoa_p && !$ENV{DISPLAY}) { + error "\$DISPLAY is not set."; + } + + + if ($verbose == 1) { + $verbose_imgmap = 1; + $verbose_warnings = 1; + + } elsif ($verbose == 2) { + $verbose_imgmap = 1; + $verbose_warnings = 1; + $verbose_load = 1; + + } elsif ($verbose == 3) { + $verbose_imgmap = 1; + $verbose_warnings = 1; + $verbose_load = 1; + $verbose_filter = 1; + + } elsif ($verbose == 4) { + $verbose_imgmap = 1; + $verbose_warnings = 1; + $verbose_load = 1; + $verbose_filter = 1; + $verbose_net = 1; + + } elsif ($verbose == 5) { + $verbose_imgmap = 1; + $verbose_warnings = 1; + $verbose_load = 1; + $verbose_filter = 1; + $verbose_net = 1; + $verbose_pbm = 1; + + } elsif ($verbose == 6) { + $verbose_imgmap = 1; + $verbose_warnings = 1; + $verbose_load = 1; + $verbose_filter = 1; + $verbose_net = 1; + $verbose_pbm = 1; + $verbose_http = 1; + + } elsif ($verbose >= 7) { + $verbose_imgmap = 1; + $verbose_warnings = 1; + $verbose_load = 1; + $verbose_filter = 1; + $verbose_net = 1; + $verbose_pbm = 1; + $verbose_http = 1; + $verbose_exec = 1; + } + + if ($dict) { + error ("$dict does not exist") unless (-f $dict); + $wordlist = $dict; + } else { + pick_dictionary(); + } + + if ($imagemap_base && !($img_width && $img_height)) { + error ("-size WxH is required with -imagemap"); + } + + if (defined ($local_dir)) { + $_ = "xscreensaver-getimage-file"; + which ($_) || error "$_ not found on \$PATH."; + } + + init_signals(); + + spawn_driftnet ($driftnet_cmd) if ($driftnet_cmd); + + if ($urls_only_p) { + url_only_output (); + } else { + x_or_pbm_output ($window_id); + } } -main; +main(); exit (0);