X-Git-Url: http://git.hungrycats.org/cgi-bin/gitweb.cgi?p=xscreensaver;a=blobdiff_plain;f=hacks%2Fwebcollage;h=f77c6153500a83fdfacf12671d7e118390083077;hp=5461ac318582609d279dca92e65b5feeb7b9c21e;hb=3c58fb6311db49c46f1670922933b27c6ea0c065;hpb=585e1a6717d1dd9b90fbb53acaaae82106354d33 diff --git a/hacks/webcollage b/hacks/webcollage index 5461ac31..f77c6153 100755 --- a/hacks/webcollage +++ b/hacks/webcollage @@ -1,6 +1,6 @@ #!/usr/bin/perl -w # -# webcollage, Copyright (c) 1999, 2000 by Jamie Zawinski +# webcollage, Copyright (c) 1999-2001 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." # @@ -14,13 +14,19 @@ # 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\ +# default-n: webcollage -root \n\ +# default-n: webcollage -root -filter 'vidwhacker -stdin -stdout' \n\ + require 5; -#use diagnostics; 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; + + use Socket; require Time::Local; require POSIX; @@ -28,88 +34,137 @@ use Fcntl ':flock'; # import LOCK_* constants use POSIX qw(strftime); -my $version = q{ $Revision: 1.65 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/; -my $copyright = "WebCollage $version, Copyright (c) 1999" . +my $progname = $0; $progname =~ s@.*/@@g; +my $version = q{ $Revision: 1.77 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/; +my $copyright = "WebCollage $version, Copyright (c) 1999-2001" . " Jamie Zawinski \n" . " http://www.jwz.org/xscreensaver/\n"; -my $argv0 = $0; -my $progname = $argv0; $progname =~ s@.*/@@g; - -my $random_redirector = "http://random.yahoo.com/bin/ryl"; -my $image_randomizer_1 = "http://www.altavista.com/query" . - "?mmdo=3" . - "&nbq=12" . - "&stype=simage" . - "&iclr=1" . - "&ibw=1" . - "&iexc=1" . - "&what=web" . - "&q="; -my $image_randomizer_2 = "http://www.hotbot.com/?clickSrc=search" . - "&submit=SEARCH&SM=SC&LG=any" . - "&AM0=MC&AT0=words&AW0=" . - "&AM1=MN&AT1=words&AW1=" . - "&savenummod=2&date=within" . - "&DV=0&DR=newer&DM=1&DD=1&DY=99&FVI=1&FS=&RD=RG" . - "&RG=all&Domain=&PS=A&PD=&STEM=1&DC=50&DE=0&_v=2" . - "&OPs=MDRTP&NUMMOD=2" . - "&MT="; -my $image_randomizer_3 = "http://www.altavista.com/cgi-bin/query?pg=q" . - "&text=yes&kl=XX&stype=stext&q="; -my $image_randomizer_4 = "http://search.news.yahoo.com/search/news_photos?" . - "&z=&n=100&o=o&2=&3=&p="; - -# I guess Photopoint got wise to me, because now they are doing error -# checking on the user ("u=") and album ("a=") parameters. Oh well. + + +my @search_methods = ( 35, "imagevista", \&pick_from_alta_vista_images, + 33, "altavista", \&pick_from_alta_vista_text, + 20, "yahoorand", \&pick_from_yahoo_random_link, + 2, "yahoonews", \&pick_from_yahoo_news_text, + 10, "lycos", \&pick_from_lycos_text, + + # Hotbot gives me "no matches" just about every time. + # Then I try the same URL again, and it works. I guess + # it caches searches, and webcollage always busts its + # cache and time out? Or it just sucks. + # 0, "hotbot", \&pick_from_hotbot_text, + ); + +#@search_methods=(100, "lycos", \&pick_from_lycos_text); + +# programs we can use to write to the root window (tried in ascending order.) # -#my $photo_randomizer = "http://albums.photopoint.com/j/View?u=1&a=1&p="; -#my $photo_randomizer_lo = 10000001; -#my $photo_randomizer_hi = 12400000; +my @root_displayers = ( + "xloadimage -quiet -onroot -center -border black", + "xli -quiet -onroot -center -border black", + "xv -root -quit -viewonly +noresetroot -rmode 5" . + " -rfg black -rbg black", + "chbg -once -xscreensaver", -my $image_ppm = ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp") . "/webcollage." . $$; -my $image_tmp1 = $image_ppm . "-1"; -my $image_tmp2 = $image_ppm . "-2"; +# this lame program wasn't built with vroot.h: +# "xsri -scale -keep-aspect -center-horizontal -center-vertical", +); -my $img_width; # size of the image being generated. -my $img_height; + +# 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", + + # log in as "cpunks" + "www.nytimes.com" => "NYT-S=104nv1sChNnnWAvTLGx6eiDhzQcbSoN" . + "6zOMB7s0Qm8MlMaa8It.2/BlXTrpbBk" . + "jinV68IcqxOvAABDyKdciIJ8O000", +); + + +# 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 altavista with human names. + "rootsweb.com" => 1, # Cluttering altavista with human names. + "akamai.net" => 1, # Lots of sites have their images on Akamai. + # 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. +); + + +# 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, + + "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. +); + + +############################################################################## +# +# 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 = 30; my $cvt_timeout = 10; -# programs we can use to write to the root window (tried in ascending order.) -my $ppm_to_root_window_cmd_1 = "xloadimage -onroot -quiet %%PPM%%"; -my $ppm_to_root_window_cmd_2 = "xli -quiet -onroot -center" . - " -border black %%PPM%%"; -my $ppm_to_root_window_cmd_3 = "xv -root -rmode 5 -viewonly" . - " +noresetroot %%PPM%% -quit"; - -my $ppm_to_root_window_cmd = undef; # initialized by x_output() +my $min_width = 50; +my $min_height = 50; +my $min_ratio = 1/5; -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; my $wordlist = "/usr/dict/words"; if (!-r $wordlist) { - $wordlist = "/usr/share/dict/words"; # BSD + $wordlist = "/usr/share/dict/words"; # BSD } if (!-r $wordlist) { - $wordlist = "/usr/share/lib/dict/words"; # Irix + $wordlist = "/usr/share/lib/dict/words"; # Irix } -die "$wordlist doesn't exist!\n" unless (-r $wordlist); - - -my $min_width = 50; -my $min_height = 50; -my $min_ratio = 1/5; - -my $verbose = 0; +die "$progname: $wordlist doesn't exist!\n" unless (-r $wordlist); my %rejected_urls; my @tripwire_words = ("aberrate", "abode", "amorphous", "antioch", @@ -119,11 +174,6 @@ my @tripwire_words = ("aberrate", "abode", "amorphous", "antioch", "eggplant"); -sub blurb { - return "$progname: " . strftime ("%H:%M:%S: ", localtime); -} - - ############################################################################## # # Retrieving URLs @@ -134,111 +184,141 @@ sub blurb { # and the document body. # sub get_document_1 { - my ( $url, $referer, $timeout ) = @_; - - if (!defined($timeout)) { $timeout = $http_timeout; } - if ($timeout <= 0) { return (); } - if ($timeout > $http_timeout) { $timeout = $http_timeout; } + my ( $url, $referer, $timeout ) = @_; - if ( $verbose > 3 ) { - print STDERR blurb() . "get_document_1 $url " . - ($referer ? $referer : "") . "\n"; - } + if (!defined($timeout)) { $timeout = $http_timeout; } + if ($timeout > $http_timeout) { $timeout = $http_timeout; } - my($url_proto, $dummy, $serverstring, $path) = split(/\//, $url, 4); - if (! ($url_proto && $url_proto =~ m/^http:$/i)) { - if ($verbose) { print STDERR blurb() . "not an HTTP URL: $url\n"; } - return (); - } - - $path = "" unless $path; + if ($timeout <= 0) { + LOG (($verbose_net || $verbose_load), "timed out for $url"); + return (); + } - my($them,$port) = split(/:/, $serverstring); - $port = 80 unless $port; + LOG ($verbose_net, "get_document_1 $url " . ($referer ? $referer : "")); - my $them2 = $them; - my $port2 = $port; - if ($http_proxy) { - $serverstring = $http_proxy if $http_proxy; - ($them2,$port2) = split(/:/, $serverstring); - $port2 = 80 unless $port2; - } - - my ($remote, $iaddr, $paddr, $proto, $line); - $remote = $them2; - if ($port2 =~ /\D/) { $port2 = getservbyname($port2, 'tcp') } - return unless $port2; - $iaddr = inet_aton($remote) || return; - $paddr = sockaddr_in($port2, $iaddr); + 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; + + my ($them,$port) = split(/:/, $serverstring); + $port = 80 unless $port; + + my $them2 = $them; + my $port2 = $port; + if ($http_proxy) { + $serverstring = $http_proxy if $http_proxy; + ($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 = ""; + my $head = ""; + my $body = ""; - @_ = + @_ = eval { - local $SIG{ALRM} = sub { - if ($verbose > 0) { - print STDERR blurb() . "timed out ($timeout) for $url\n"; - } - die "alarm\n" - }; - alarm $timeout; - - $proto = getprotobyname('tcp'); - if (!socket(S, PF_INET, SOCK_STREAM, $proto)) { - print STDERR blurb() . "socket: $!\n" if ($verbose); - return; - } - if (!connect(S, $paddr)) { - print STDERR blurb() . "connect($serverstring): $!\n" - if ($verbose); - return; - } + 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); + select(S); $| = 1; select(STDOUT); - my $cookie; - if ($remote =~ m/\baltavista\.com$/i) { - # kludge to tell the various altavista sites to be uncensored. - $cookie = "AV_ALL=1"; - } + my $cookie = $cookies{$them}; - print S ("GET " . ($http_proxy ? $url : "/$path") . " HTTP/1.0\r\n" . + my $hdrs = "GET " . ($http_proxy ? $url : "/$path") . " HTTP/1.0\r\n" . "Host: $them\r\n" . - "User-Agent: $progname/$version\r\n" . - ($referer ? "Referer: $referer\r\n" : "") . - ($cookie ? "Cookie: $cookie\r\n" : "") . - "\r\n"); - my $http = ; - - while () { - $head .= $_; - last if m@^[\r\n]@; + "User-Agent: $progname/$version\r\n"; + if ($referer) { + $hdrs .= "Referer: $referer\r\n"; + } + if ($cookie) { + foreach (split(/\r?\n/, $cookie)) { + $hdrs .= "Cookie: $_\r\n"; } - while () { - $body .= $_; + } + $hdrs .= "\r\n"; + + foreach (split('\r?\n', $hdrs)) { + LOG ($verbose_http, " ==> $_"); + } + print S $hdrs; + my $http = ; + + $_ = $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) } + } - close S; + my $lines = 0; + while () { + $body .= $_; + $lines++; + } - if ( $verbose > 3 ) { - print STDERR blurb() . " ==> $http\n"; - } + LOG ($verbose_http, + " <== [ body ]: $lines lines, " . length($body) . " bytes"); - return ( $http, $head, $body ); - }; - die if ($@ && $@ ne "alarm\n"); # propagate errors - if ($@) { - # timed out - $head = undef; - $body = undef; + close S; + + if (!$http) { + LOG (($verbose_net || $verbose_load), "null response: $url"); return (); - } else { - # didn't - alarm 0; - return @_; - } + } + + return ( $http, $head, $body ); + }; + die if ($@ && $@ ne "alarm\n"); # propagate errors + if ($@) { + # timed out + $head = undef; + $body = undef; + $suppress_audit = 1; + return (); + } else { + # didn't + alarm 0; + return @_; + } } @@ -246,324 +326,322 @@ sub get_document_1 { # if the given URL did a redirect, returns the redirected-to document. # sub get_document { - my ( $url, $referer, $timeout ) = @_; - my $start = time; + my ( $url, $referer, $timeout ) = @_; + my $start = time; - my $orig_url = $url; - my $loop_count = 0; - my $max_loop_count = 4; + my $orig_url = $url; + my $loop_count = 0; + my $max_loop_count = 4; - do { - if (defined($timeout) && $timeout <= 0) { return (); } + do { + if (defined($timeout) && $timeout <= 0) { + LOG (($verbose_net || $verbose_load), "timed out for $url"); + $suppress_audit = 1; + return (); + } - 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 + + $http =~ s/[\r\n]+$//s; + + if ( $http =~ m@^HTTP/[0-9.]+ 30[123]@ ) { + $_ = $head; + my ( $location ) = m@^location:[ \t]*(.*)$@im; + if ( $location ) { + $location =~ s/[\r\n]$//; + + LOG ($verbose_net, "redirect from $url to $location"); + $referer = $url; + $url = $location; + + 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 () if ( ! $body ); - - if ( $http =~ m@HTTP/[0-9.]+ 30[23]@ ) { - $_ = $head; - my ( $location ) = m@^location:[ \t]*(.*)$@im; - if ( $location ) { - $location =~ s/[\r\n]$//; - - if ( $verbose > 3 ) { - print STDERR blurb() . "redirect from " . - "$url to $location\n"; - } - $referer = $url; - $url = $location; - - 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; - } - - } else { - return ( $url, $body ); - } - - if ($loop_count++ > $max_loop_count) { - if ( $verbose > 1 ) { - print STDERR blurb() . "too many redirects " . - "($max_loop_count) from $orig_url\n"; - } - $body = undef; - return (); - } - - } elsif ( $http =~ m@HTTP/[0-9.]+ [4-9][0-9][0-9]@ ) { - # http errors -- return nothing. - $body = undef; - return (); - - } else { - - return ( $url, $body ); - } - - } while (1); -} - + } else { + LOG ($verbose_net, "no Location with \"$http\""); + return ( $url, $body ); + } -# 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 ) = @_; + if ($loop_count++ > $max_loop_count) { + LOG ($verbose_net, + "too many redirects ($max_loop_count) from $orig_url"); + $body = undef; + return (); + } - my $base = $url; - $_ = $url; + } elsif ( $http =~ m@^HTTP/[0-9.]+ ([4-9][0-9][0-9].*)$@ ) { - # if there's at least one slash after the host, take off the last - # pathname component - if ( m@^http://[^/]+/@io ) { - $base =~ s@[^/]+$@@go; - } + LOG (($verbose_net || $verbose_load), "failed: $1 ($url)"); - # if there are no slashes after the host at all, put one on the end. - if ( m@^http://[^/]+$@io ) { - $base .= "/"; - } - - if ( $verbose > 3 ) { - print STDERR blurb() . "base is $base\n"; - } + # http errors -- return nothing. + $body = undef; + return (); + } elsif (!$body) { - $_ = $body; + LOG (($verbose_net || $verbose_load), "document contains no data: $url"); + return (); - # strip out newlines, compress whitespace - s/[\r\n\t ]+/ /go; + } else { - # nuke comments - s///go; + # ok! + return ( $url, $body ); + } + } while (1); +} - # 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 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) { - if ($verbose > 1) { - print STDERR blurb() . "there is probably a dictionary in" . - " \"$url\": rejecting.\n"; - } - $rejected_urls{$url} = -1; - $body = undef; - $_ = undef; - return (); - } +# 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"); + } +} - my @urls; - my %unique_urls; - - foreach (split(/ * 1000) { - if ($verbose > 1) { - print STDERR blurb() . "keywords of" . - " length $L in $url: rejecting.\n"; - } - $rejected_urls{$url} = $L; - $body = undef; - $_ = undef; - return (); - } elsif ( $verbose > 2 ) { - print STDERR blurb() . "keywords of length $L" . - " in $url (ok.)\n"; - } - } - - } 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; - while (s@/\.\./@/@g) { - } - } - - # skip non-http - if ( ! m@^http://@io ) { - next; - } - - # skip non-image - if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg)$@io ) { - next; - } - - # skip really short or really narrow images - if ( $width && $width < $min_width) { - if ( $verbose > 2 ) { - if (!$height) { $height = "?"; } - print STDERR blurb() . "skip narrow image " . - "$_ (${width}x$height)\n"; - } - next; - } - - if ( $height && $height < $min_height) { - if ( $verbose > 2 ) { - if (!$width) { $width = "?"; } - print STDERR blurb() . "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 ( $verbose > 2 ) { - if (!$height) { $height = "?"; } - print STDERR blurb() . "skip bad ratio " . - "$_ (${width}x$height)\n"; - } - next; - } - - my $url = $_; - - if ( $unique_urls{$url} ) { - if ( $verbose > 2 ) { - print STDERR blurb() . "skip duplicate image $_\n"; - } - next; - } - - if ( $verbose > 2 ) { - print STDERR blurb() . "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; - } - } - } +############################################################################ +# +# Extracting image URLs from HTML +# +############################################################################ - $_ = undef; +# 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 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; + while (s@/\.\./@/@g) { + } + } + + # skip non-http + if ( ! m@^http://@io ) { + next; + } + + # skip non-image + if ( ! m@[.](gif|jpg|jpeg|pjpg|pjpeg)$@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; + } + + 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. + $_ = $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; + } + } + } + + my $fsp = ($body =~ m@ 2 ) { - print STDERR blurb() . "no images on $base\n"; - } - return (); - } + @urls = depoison (@urls); - return () if ( $#urls < 1 ); + # pick a random element of the table + my $i = int(rand($#urls+1)); + $url = $urls[$i]; - # pick a random element of the table - my $i = ((rand() * 99999) % $#urls); - $url = $urls[$i]; + LOG ($verbose_load, "picked image " .($i+1) . "/" . ($#urls+1) . ": $url"); - if ( $verbose > 2 ) { - print STDERR blurb() . "picked $url\n"; - } - - return $url; + return $url; } -# 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 () if nothing found this time. + +############################################################################ # -sub pick_from_url_randomizer { - my ( $timeout ) = @_; - - if ( $verbose > 3 ) { - print STDERR "\n\n$progname: picking from $random_redirector...\n\n"; - } - - my ( $base, $body ) = get_document ($random_redirector, undef, $timeout); - - if (!$base || !$body) { - $body = undef; - return; - } - my $img = pick_image_from_body ($base, $body); - $body = undef; - - if ($img) { - return ($base, $img, "yahoo"); - } else { - return (); - } -} +# Subroutines for getting pages and images out of search engines +# +############################################################################ +# returns a random word from the dictionary +# sub random_word { my $word = 0; @@ -574,10 +652,10 @@ sub random_word { $word = ; # toss partial line $word = ; # keep next line } - if (!$word) { + if (!$word) { seek( IN, 0, 0 ); $word = ; - } + } close (IN); } @@ -594,212 +672,469 @@ sub random_word { $word =~ tr/A-Z/a-z/; if ( $word =~ s/[ \t\n\r]/\+/g ) { # convert intra-word spaces to "+". - $word = "\%22$word\%22"; # And put quotes (%22) around it. + $word = "\%22$word\%22"; # And put quotes (%22) around it. } return $word; } +sub random_words { + return (random_word . "%20" . + random_word . "%20" . + random_word . "%20" . + random_word . "%20" . + random_word); +} -# 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 () 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, $which ) = @_; - - my $words = random_word; - $words .= "%20" . random_word; - $words .= "%20" . random_word; - $words .= "%20" . random_word; - $words .= "%20" . random_word; - - my $search_url = ($which == 0 ? $image_randomizer_1 : - $which == 1 ? $image_randomizer_2 : - $which == 2 ? $image_randomizer_3 : - $image_randomizer_4) . - $words; - - # Pick a random search-result page instead of always taking the first. - # This assumes there are at least 10 pages... - if ($which == 0) { - $search_url .= "&pgno=" . (int(rand(9)) + 1); - } elsif ($which == 2) { - $search_url .= "&stq=" . (10 * (int(rand(9)) + 1)); - } +sub pick_from_search_engine { + my ( $timeout, $search_url, $words ) = @_; - if ( $verbose > 3 ) { - $_ = $words; s/%20/ /g; print STDERR blurb() . "search words: $_\n"; - } + $_ = $words; + s/%20/ /g; - if ( $verbose > 3 ) { - print STDERR "\n\n$progname: picking from $search_url\n"; - } + print STDERR "\n\n" if ($verbose_load); - my $start = time; - my ( $base, $body ) = get_document ($search_url, undef, $timeout); - if (defined ($timeout)) { - $timeout -= (time - $start); - if ($timeout <= 0) { - $body = undef; - return (); - } + LOG ($verbose_load, "words: $_"); + LOG ($verbose_load, "URL: $search_url"); + + $last_search = $search_url; # for warnings + + 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); + return () if (! $body); - my @subpages; - my $skipped = 0; + my @subpages; - my $search_count = "?"; - if ($which == 0 && - $body =~ m@found (approximately |about )?()?(\d+)()? image@) { - $search_count = $3; - } elsif ($which == 1 && $body =~ m@((\d{1,3})(,\d{3})*) @i) { - $search_count = $1; - } elsif ($which == 2 && $body =~ m@found ((\d{1,3})(,\d{3})*|\d+) Web p@) { - $search_count = $1; - } - 1 while ($search_count =~ s/^(\d+)(\d{3})/$1,$2/); + 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) { # imagevista + $search_count = $1; + } elsif ($body =~ m@About ((\d{1,3})(,\d{3})*) images@i) { # imagevista + $search_count = $1; + } 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) { # imagevista + $search_count = "0"; + } elsif ($body =~ m@found no document matching@i) { # altavista + $search_count = "0"; + } + 1 while ($search_count =~ s/^(\d+)(\d{3})/$1,$2/); - my $length = length($body); - my $href_count = 0; +# 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"; +# } - $_ = $body; -# s/Result [Pp]ages:.*$//s; # trim off page footer -# s/^.*?IMAGE RESULTS//s; # trim off page header + my $length = length($body); + my $href_count = 0; - s/Have you tried these resources.*//s; # let's try it again + $_ = $body; - s/[\r\n\t ]+/ /g; + 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 ($which == 1) { - # Kludge to decode HotBot pages - next unless ($u =~ m@/director\.asp\?target=(http%3A[^&>]+)@); - $u = url_decode($1); - } + s/(]+)>@i; + next unless $u; - next unless ($u =~ m@^http://@i); # skip non-http and relative urls. - - next if ($u =~ m@[/.]altavista\.com\b@i); # skip altavista builtins - next if ($u =~ m@[/.]altavista\.[a-z]{2}\b@i); # altavista.fr, etc - next if ($u =~ m@[/.]av\.com\b@i); - next if ($u =~ m@[/.]virage\.com\b@i); - next if ($u =~ m@[/.]photoloft\.com\b@i); - next if ($u =~ m@[/.]shopping\.com\b@i); - next if ($u =~ m@[/.]thetrip\.com\b@i); - next if ($u =~ m@[/.]cmgi\.com\b@i); - next if ($u =~ m@[/.]intelihealth\.com\b@i); - next if ($u =~ m@[/.]wildweb\.com\b@i); - next if ($u =~ m@[/.]digital\.com\b@i); - next if ($u =~ m@[/.]doubleclick\.net\b@i); - next if ($u =~ m@[/.]freeim\.org\b@i); - next if ($u =~ m@[/.]clicktomarket\.com\b@i); # you cretins - next if ($u =~ m@[/.]teragram\.com\b@i); - - # must lose this one for altavista, even though it loses images of - # every single customer of akamai. Oh well, those people have lots - # of money, and so their images are probably boring anyway. - next if ($u =~ m@[/.]akamai\.net@i); - - if ($which == 0 && $u =~ m@[/.]corbis\.com@) { - $skipped = 1; - if ( $verbose > 3 ) { - print STDERR blurb() . "skipping corbis URL: $u\n"; - } - next; - - } elsif ($which == 3 && - ($u =~ m@^http://[^/]+$@ || # no slashes - $u =~ m@/$@ || # ends in / - ! ($u =~ m@dailynews\.yahoo\.com@))) { # not dailynews -# $skipped = 1; - if ( $verbose > 3 ) { - print STDERR blurb() . "skipping non-AP URL: $u\n"; - } - next; - - } elsif ( $rejected_urls{$u} ) { - if ( $verbose > 3 ) { - my $L = $rejected_urls{$u}; - print STDERR blurb() . "pre-rejecting sub-page: $u\n"; - } - next; - - } elsif ( $verbose > 3 ) { - print STDERR blurb() . "sub-page: $u\n"; - } + if ($u =~ m/^\"([^\"]*)\"/) { $u = $1; } # quoted string + elsif ($u =~ m/^([^\s]*)\s/) { $u = $1; } # or token - $subpages[++$#subpages] = $u; + if ( $rejected_urls{$u} ) { + LOG ($verbose_filter, " pre-rejecting candidate: $u"); + next; } - if ( $#subpages < 0 ) { - if (!$skipped && $verbose > 1) { - print STDERR blurb() . "found nothing on $base " . - "($length bytes, $href_count links).\n"; - } - $body = undef; - $_ = undef; - return (); - } + LOG ($verbose_http, " HREF: $u"); - # pick a random element of the table - my $i = ((rand() * 99999) % ($#subpages + 1)); - my $subpage = $subpages[$i]; + $subpages[++$#subpages] = $u; + } - if ( $verbose > 3 ) { - print STDERR blurb() . "picked page $subpage\n"; - } + if ( $#subpages < 0 ) { + LOG ($verbose_filter, + "found nothing on $base ($length bytes, $href_count links)."); + return (); + } + LOG ($verbose_filter, "" . $#subpages+1 . " links on $search_url"); - $body = undef; - $_ = undef; + return ($search_count, @subpages); +} - my ( $base2, $body2 ) = get_document ($subpage, $base, $timeout); - if (!$base2 || !$body2) { - $body2 = undef; - return (); +sub depoison { + my (@urls) = @_; + my @urls2 = (); + foreach (@urls) { + my ($h) = m@^http://([^/: \t\r\n]+)@i; + + next unless defined($h); + + 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; } - my $img = pick_image_from_body ($base2, $body2); + push @urls2, $_; + } + return @urls2; +} + + +# 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; +# and a debugging description string. +# +sub pick_image_from_pages { + my ($base, $total_hit_count, $unfiltered_link_count, $timeout, @pages) = @_; + + $total_hit_count = "?" unless defined($total_hit_count); + + @pages = depoison (@pages); + LOG ($verbose_load, + "" . ($#pages+1) . " candidates of $unfiltered_link_count links" . + " ($total_hit_count total)"); + + return () if ($#pages < 0); + + my $i = int(rand($#pages+1)); + my $page = $pages[$i]; + + LOG ($verbose_load, "picked page $page"); + + $suppress_audit = 1; + + my ( $base2, $body2 ) = get_document ($page, $base, $timeout); + + if (!$base2 || !$body2) { $body2 = undef; + return (); + } - if ($img) { - return ($base2, $img, - ($which == 0 ? "imagevista" : - $which == 1 ? "hotbot" : - $which == 2 ? "altavista" : - "ap") . - "/$search_count"); - } else { - return (); - } + my $img = pick_image_from_body ($base2, $body2); + $body2 = undef; + + if ($img) { + return ($base2, $img); + } else { + return (); + } } + +############################################################################ +# +# Pick images from random pages returned by the Yahoo Random Link +# +############################################################################ + +# yahoorand +my $yahoo_random_link = "http://random.yahoo.com/bin/ryl"; -# Using the photo site, generate a random URL that will hopefully point -# to an image. Returns two URLs, both of which are the URL 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 pick_from_photo_randomizer { -# my ( $timeout ) = @_; -# my $n = ($photo_randomizer_lo + -# int(rand() * ($photo_randomizer_hi - $photo_randomizer_lo))); -# my $url = $photo_randomizer . $n; -# return ( $url, $url, "photopoint" ); -#} +sub pick_from_yahoo_random_link { + my ( $timeout ) = @_; + + print STDERR "\n\n" if ($verbose_load); + LOG ($verbose_load, "URL: $yahoo_random_link"); + + $last_search = $yahoo_random_link; # for warnings + + $suppress_audit = 1; + + my ( $base, $body ) = get_document ($yahoo_random_link, undef, $timeout); + if (!$base || !$body) { + $body = undef; + return; + } + + LOG ($verbose_load, "redirected to: $base"); + + my $img = pick_image_from_body ($base, $body); + $body = undef; + + if ($img) { + return ($base, $img); + } else { + return (); + } +} + + +############################################################################ +# +# Pick images by feeding random words into Alta Vista Image Search +# +############################################################################ + + +my $alta_vista_images_url = "http://www.altavista.com/cgi-bin/query" . + "?ipht=1" . # photos + "&igrph=1" . # graphics + "&iclr=1" . # color + "&ibw=1" . # b&w + "&micat=1" . # no partner sites + "&imgset=1" . # no partner sites + "&stype=simage" . # do image search + "&mmW=1" . # unknown, but required + "&q="; + + +# imagevista +sub pick_from_alta_vista_images { + my ( $timeout ) = @_; + + my $words = random_words; + 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 + } + + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + + my @candidates = (); + foreach my $u (@subpages) { + 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@[/.]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); + + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); +} + + + +############################################################################ +# +# Pick images by feeding random words into Alta Vista Text Search +# +############################################################################ + + +my $alta_vista_url = "http://www.altavista.com/cgi-bin/query?pg=q" . + "&text=yes&kl=XX&stype=stext&q="; + +# altavista +sub pick_from_alta_vista_text { + my ( $timeout ) = @_; + + my $words = random_words; + my $page = (int(rand(9)) + 1); + my $search_url = $alta_vista_url . $words; + + if ($page > 1) { + $search_url .= "&pgno=" . $page; + $search_url .= "&stq=" . (($page-1) * 10); + } + + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + + my @candidates = (); + foreach my $u (@subpages) { + + # 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... + # + next unless ($u =~ m@^/r\?ck_sm=[a-zA-Z0-9]+\&ref=[a-zA-Z0-9]+\&r=(.*)@); + $u = $1; + + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); +} + + + +############################################################################ +# +# Pick images by feeding random words into Hotbot +# +############################################################################ + +my $hotbot_search_url = "http://hotbot.lycos.com/" . + "?SM=SC" . + "&DV=0" . + "&LG=any" . + "&FVI=1" . + "&DC=100" . + "&DE=0" . + "&SQ=1" . + "&TR=13" . + "&AM1=MC" . + "&MT="; + +sub pick_from_hotbot_text { + my ( $timeout ) = @_; + + my $words = random_words; + my $search_url = $hotbot_search_url . $words; + + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + + my @candidates = (); + foreach my $u (@subpages) { + + # Hotbot plays redirection games too + next unless ($u =~ m@^/director.asp\?target=([^&]+)@); + $u = url_decode($1); + + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); +} + + + +############################################################################ +# +# Pick images by feeding random words into Lycos +# +############################################################################ + +my $lycos_search_url = "http://lycospro.lycos.com/srchpro/" . + "?lpv=1" . + "&t=any" . + "&query="; + +sub pick_from_lycos_text { + my ( $timeout ) = @_; + + my $words = random_words; + my $start = int(rand(8)) * 10 + 1; + my $search_url = $lycos_search_url . $words . "&start=$start"; + + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + + my @candidates = (); + foreach my $u (@subpages) { + + # Lycos plays exact the same redirection game as hotbot. + # Note that "id=0" is used for internal advertising links, + # and 1+ are used for search results. + next unless ($u =~ m@^http://click.hotbot.com/director.asp\?id=[1-9]\d*&target=([^&]+)@); + $u = url_decode($1); + + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); +} + + + +############################################################################ +# +# Pick images by feeding random words into news.yahoo.com +# +############################################################################ + +my $yahoo_news_url = "http://search.news.yahoo.com/search/news_photos?" . + "&z=&n=100&o=o&2=&3=&p="; + +# yahoonews +sub pick_from_yahoo_news_text { + my ( $timeout ) = @_; + + my $words = random_words; + my $search_url = $yahoo_news_url . $words; + + my ($search_hit_count, @subpages) = + pick_from_search_engine ($timeout, $search_url, $words); + + my @candidates = (); + foreach my $u (@subpages) { + # only accept URLs on Yahoo's news site + next unless ($u =~ m@^http://dailynews.yahoo.com/@i); + + LOG ($verbose_filter, " candidate: $u"); + push @candidates, $u; + } + + return pick_image_from_pages ($search_url, $search_hit_count, $#subpages+1, + $timeout, @candidates); +} + + + + +############################################################################ +# +# Pick a random image in a random way +# +############################################################################ # Picks a random image on a random page, and returns two URLs: @@ -807,165 +1142,374 @@ sub pick_from_image_randomizer { # Returns () if nothing found this time. # Uses the url-randomizer 1 time in 5, else the image randomizer. # -my $total_0 = 0; -my $total_1 = 0; -my $total_2 = 0; -my $total_3 = 0; -my $total_4 = 0; -my $count_0 = 0; -my $count_1 = 0; -my $count_2 = 0; -my $count_3 = 0; -my $count_4 = 0; sub pick_image { - my ( $timeout ) = @_; - my $r = int(rand(100)); - - my ($base, $img, $source, $total, $count); - - if ($r < 20) { - ($base, $img, $source) = pick_from_url_randomizer ($timeout); - $total = ++$total_0; - $count = ++$count_0 if $img; - - } elsif ($r < 60) { - ($base, $img, $source) = pick_from_image_randomizer ($timeout, 0); - $total = ++$total_1; - $count = ++$count_1 if $img; - - } elsif ($r < 65) { - ($base, $img, $source) = pick_from_image_randomizer ($timeout, 3); - $total = ++$total_4; - $count = ++$count_4 if $img; - -# } elsif ($r < 70) { -# ($base, $img, $source) = pick_from_photo_randomizer ($timeout); -# $total = ++$total_4; -# $count = ++$count_4 if $img; - -# } elsif ($r < 80) { -# # HotBot sucks: 98% of the time, it says "no pages match your -# # search", and then if I load the URL again by hand, it works. -# # I don't understand what's going wrong here, but we're not getting -# # any good data back from them, so forget it for now. + 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 # -# ($base, $img, $source) = pick_from_image_randomizer ($timeout, 1); -# $total = ++$total_2; -# $count = ++$count_2 if $img; +############################################################################ - } else { - ($base, $img, $source) = pick_from_image_randomizer ($timeout, 2); - $total = ++$total_3; - $count = ++$count_3 if $img; - } +sub timestr { + return strftime ("%H:%M:%S: ", localtime); +} + +sub blurb { + return "$progname: " . timestr() . "$current_state: "; +} - if ($source && $total > 0) { - $source .= " " . int(($count / $total) * 100) . "%"; +sub error { + ($_) = @_; + print STDERR blurb() . "$_\n"; + exit 1; +} + + +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; } - return ($base, $img, $source); + + 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/:]+)@; + + 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 $_; + ($_) = @_; + 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 (($b<<8|$a), ($d<<8|$c)); + 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 (($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) { - $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); + my ($body) = @_; + my $i = 0; + my $L = length($body); - 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)); + my $c1 = substr($body, $i, 1); $i++; + my $c2 = substr($body, $i, 1); $i++; + return () unless (ord($c1) == 0xFF && ord($c2) == 0xD8); - } 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 () if ($length < 2); - $i += $length-2; - } + 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++; } - return (); + # 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); + + 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)); + + } 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 () if ($length < 2); + $i += $length-2; + } + } + return (); } # Given the raw body of a GIF or JPEG document, returns the dimensions of # the image. # sub image_size { - my ($body) = @_; - my ($w, $h) = gif_size ($body); - if ($w && $h) { return ($w, $h); } - return jpeg_size ($body); + my ($body) = @_; + my ($w, $h) = gif_size ($body); + if ($w && $h) { return ($w, $h); } + return jpeg_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; - } + my ($prog) = @_; + foreach (split (/:/, $ENV{PATH})) { + if (-x "$_/$prog") { + return $prog; } - return undef; + } + return undef; } # Like rand(), but chooses numbers with a bell curve distribution. sub bellrand { - ($_) = @_; - $_ = 1.0 unless defined($_); - $_ /= 3.0; - return (rand($_) + rand($_) + rand($_)); + ($_) = @_; + $_ = 1.0 unless defined($_); + $_ /= 3.0; + return (rand($_) + rand($_) + rand($_)); } @@ -976,14 +1520,14 @@ sub bellrand { ############################################################################## 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); + do { + my ($base, $img) = pick_image; + if ($img) { + $base =~ s/ /%20/g; + $img =~ s/ /%20/g; + print "$img $base\n"; + } + } while (1); } ############################################################################## @@ -992,11 +1536,25 @@ sub url_only_output { # ############################################################################## +my $image_ppm = ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp") . "/webcollage." . $$; +my $image_tmp1 = $image_ppm . "-1"; +my $image_tmp2 = $image_ppm . "-2"; + +my $filter_cmd = undef; +my $post_filter_cmd = undef; +my $background = undef; + +my $img_width; # size of the image being generated. +my $img_height; + +my $delay = 0; + + sub x_cleanup { - my ($sig) = @_; - if ($verbose > 0) { print STDERR blurb() . "caught signal $sig.\n"; } - unlink $image_ppm, $image_tmp1, $image_tmp2; - exit 1; + my ($sig) = @_; + print STDERR blurb() . "caught signal $sig.\n" if ($verbose_exec); + unlink $image_ppm, $image_tmp1, $image_tmp2; + exit 1; } @@ -1004,40 +1562,31 @@ sub x_cleanup { # with whatever signal killed the sub-process, if any. # sub nontrapping_system { - $! = 0; + $! = 0; - if ($verbose > 1) { - $_ = join(" ", @_); - s/\"[^\"]+\"/\"...\"/g; - print STDERR blurb() . "executing \"$_\"\n"; - } + $_ = join(" ", @_); + s/\"[^\"]+\"/\"...\"/g; - my $rc = system @_; + LOG ($verbose_exec, "executing \"$_\""); - if ($rc == 0) { - if ($verbose > 1) { - print STDERR blurb() . "subproc exited normally.\n"; - } - } elsif (($rc & 0xff) == 0) { - $rc >>= 8; - if ($verbose) { - print blurb() . "subproc exited with status $rc.\n"; - } - } else { - if ($rc & 0x80) { - if ($verbose) { - print blurb() . "subproc dumped core.\n"; - } - $rc &= ~0x80; - } - if ($verbose) { - print blurb() . "subproc died with signal $rc.\n"; - } - # die that way ourselves. - kill $rc, $$; + 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; + return $rc; } @@ -1046,552 +1595,617 @@ sub nontrapping_system { # 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"; - } else { - return (); - } - - $cmd2 = "exec $cmd"; # yes, this really is necessary. if we don't - # do this, the process doesn't die properly. - if ($verbose <= 1) { - # - # 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"; - } + 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"; + } else { + LOG (($verbose_pbm || $verbose_load), + "not a GIF or JPG" . + (($body =~ m@<(base|html|head|body|script|table|a href)>@i) + ? " (looks like HTML)" : "") . + ": $url"); + $suppress_audit = 1; + return (); + } - # 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. + $cmd2 = "exec $cmd"; # yes, this really is necessary. if we don't + # do this, the process doesn't die properly. + if (!$verbose_pbm) { # - my $pid; - @_ = eval { - my $timed_out; - - local $SIG{ALRM} = sub { - if ($verbose > 0) { - print STDERR blurb() . "timed out ($cvt_timeout) for " . - "$cmd on \"$url\" in pid $pid\n"; - } - 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; - - if ($verbose > 3) { print STDERR blurb() . "awaiting $pid\n"; } - waitpid ($pid, 0); - if ($verbose > 3) { print STDERR blurb() . "$pid completed\n"; } - - - my $size = (stat($output))[7]; - if ($size < 5) { - if ($verbose) { - print STDERR blurb() . "$cmd on ${w}x$h \"$url\" failed" . - " ($size bytes)\n"; - } - return (); - } - - if ($verbose > 1) { - print STDERR blurb() . "created ${w}x$h $output ($cmd)\n"; - } - return ($w, $h); - } else { - print STDERR blurb() . "$cmd failed: $!\n"; - return (); - } + # 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; }; - die if ($@ && $@ ne "alarm\n"); # propagate errors - if ($@) { - # timed out - $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 { - # didn't - alarm 0; - $body = undef; - return @_; + 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 @_; + } } -sub x_output { +sub pick_root_displayer { + my @names = (); - my $win_cmd_1 = $ppm_to_root_window_cmd_1; - my $win_cmd_2 = $ppm_to_root_window_cmd_2; - my $win_cmd_3 = $ppm_to_root_window_cmd_3; - $win_cmd_1 =~ s/^([^ \t\r\n]+).*$/$1/; - $win_cmd_2 =~ s/^([^ \t\r\n]+).*$/$1/; - $win_cmd_3 =~ s/^([^ \t\r\n]+).*$/$1/; - - # make sure the various programs we execute exist, right up front. - foreach ("ppmmake", "giftopnm", "djpeg", "pnmpaste", "pnmscale", - "pnmcut") { - which ($_) || die blurb() . "$_ not found on \$PATH.\n"; + 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"); } + } - if (which($win_cmd_1)) { - $ppm_to_root_window_cmd = $ppm_to_root_window_cmd_1; - } elsif (which($win_cmd_2)) { - $ppm_to_root_window_cmd = $ppm_to_root_window_cmd_2; - } elsif (which($win_cmd_3)) { - $ppm_to_root_window_cmd = $ppm_to_root_window_cmd_3; - } else { - die blurb() . "didn't find $win_cmd_1, $win_cmd_2, or $win_cmd_3 on \$PATH.\n"; - } + $names[$#names] = "or " . $names[$#names]; + error "none of: " . join (", ", @names) . " were found on \$PATH."; +} - $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 blurb() . "$_ not found on \$PATH.\n"; - $_ = `$_`; - ($img_width, $img_height) = m/dimensions: *(\d+)x(\d+) /; - if (!defined($img_height)) { - die blurb() . "xdpyinfo failed.\n"; - } - } - 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 blurb() . "not a color or readable file: " . - "$background\n"; - exit 1; - } else { - # default to assuming it's a color - $bgcolor = $background; - } - } +my $ppm_to_root_window_cmd = undef; - # Create the sold-colored base image. - # - $_ = "ppmmake '$bgcolor' $img_width $img_height"; - if ($verbose > 1) { - print STDERR blurb() . "creating base image: $_\n"; - } - nontrapping_system "$_ > $image_ppm"; - # Paste the default background image in the middle of it. - # - if ($bgimage) { - my ($iw, $ih); - - my $body = ""; - local *IMG; - open(IMG, "<$bgimage") || die ("couldn't open $bgimage: $!\n"); - my $cmd; - while () { $body .= $_; } - close (IMG); - if ((@_ = gif_size ($body))) { - ($iw, $ih) = @_; - $cmd = "giftopnm |"; - } elsif ((@_ = jpeg_size ($body))) { - ($iw, $ih) = @_; - $cmd = "djpeg |"; - } elsif ($body =~ m/^P\d\n(\d+) (\d+)\n/) { - $iw = $1; - $ih = $2; - $cmd = ""; - } else { - die blurb() . "$bgimage is not a GIF, JPEG, or PPM.\n"; - } +sub x_or_pbm_output { - my $x = int (($img_width - $iw) / 2); - my $y = int (($img_height - $ih) / 2); - if ($verbose > 1) { - print STDERR blurb() . "pasting $bgimage (${iw}x$ih) into base ". - "image at $x,$y\n"; - } + # make sure the various programs we execute exist, right up front. + # + foreach ("ppmmake", "giftopnm", "djpeg", "pnmpaste", "pnmscale", "pnmcut") { + which ($_) || error "$_ not found on \$PATH."; + } - $cmd .= "pnmpaste - $x $y $image_ppm > $image_tmp1"; - open (IMG, "| $cmd") || die ("running $cmd: $!\n"); - print IMG $body; - $body = undef; - close (IMG); - if ($verbose > 1) { - print STDERR blurb() . "subproc exited normally.\n"; - } - rename ($image_tmp1, $image_ppm) || - die ("renaming $image_tmp1 to $image_ppm: $!\n"); - } + # find a root-window displayer program. + # + $ppm_to_root_window_cmd = pick_root_displayer(); - while (1) { - my ($base, $img, $source) = pick_image(); - if ($img) { - my ($headers, $body) = get_document ($img, $base); - if ($body) { - handle_image ($base, $img, $body, $source); - $body = undef; - } - } - unlink $image_tmp1, $image_tmp2; - sleep $delay; - } -} -sub handle_image { - my ($base, $img, $body, $source) = @_; + $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 ($verbose > 1) { - print STDERR blurb() . "got $img (" . length($body) . ")\n"; + if (!$img_width || !$img_height) { + $_ = "xdpyinfo"; + which ($_) || error "$_ not found on \$PATH."; + $_ = `$_`; + ($img_width, $img_height) = m/dimensions: *(\d+)x(\d+) /; + if (!defined($img_height)) { + error "xdpyinfo failed."; } + } - my ($iw, $ih) = image_to_pnm ($img, $body, $image_tmp1); - $body = undef; - return 0 unless ($iw && $ih); + my $bgcolor = "#000000"; + my $bgimage = undef; - my $ow = $iw; # used only for error messages - my $oh = $ih; + if ($background) { + if ($background =~ m/^\#[0-9a-f]+$/i) { + $bgcolor = $background; - # 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) { - if ($verbose > 1) { - print STDERR blurb() . "running $filter_cmd\n"; - } + } elsif (-r $background) { + $bgimage = $background; - my $rc = nontrapping_system "($filter_cmd) < $image_tmp1 >$image_tmp2"; - if ($rc != 0) { - if ($verbose) { - print STDERR blurb() . "failed command: \"$filter_cmd\"\n"; - print STDERR blurb() . "failed url: \"$img\" (${ow}x$oh)\n"; - } - 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); + } 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; } + } - my $target_w = $img_width; - my $target_h = $img_height; + # Create the sold-colored base image. + # + $_ = "ppmmake '$bgcolor' $img_width $img_height"; + LOG ($verbose_pbm, "creating base image: $_"); + nontrapping_system "$_ > $image_ppm"; - my $cmd = ""; + # Paste the default background image in the middle of it. + # + if ($bgimage) { + my ($iw, $ih); + my $body = ""; + local *IMG; + open(IMG, "<$bgimage") || error "couldn't open $bgimage: $!"; + my $cmd; + while () { $body .= $_; } + close (IMG); - # Usually scale the image to fit on the screen -- but sometimes scale it - # to fit on half or a quarter of the screen. Note that we don't merely - # scale it to fit, we instead cut it in half until it fits -- that should - # give a wider distribution of sizes. - # - if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; } - 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); - } - if ($iw <= 10 || $ih <= 10) { - if ($verbose > 1) { - print STDERR blurb() . "scaling to ${iw}x$ih would " . - "have been bogus.\n"; - } - return 0; - } + if ((@_ = gif_size ($body))) { + ($iw, $ih) = @_; + $cmd = "giftopnm |"; - if ($verbose > 1) { - print STDERR blurb() . "scaling to ${iw}x$ih\n"; - } + } elsif ((@_ = jpeg_size ($body))) { + ($iw, $ih) = @_; + $cmd = "djpeg |"; - $cmd .= " | pnmscale -xsize $iw -ysize $ih"; + } elsif ($body =~ m/^P\d\n(\d+) (\d+)\n/) { + $iw = $1; + $ih = $2; + $cmd = ""; + + } else { + error "$bgimage is not a GIF, JPEG, 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"); - my $src = $image_tmp1; + $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"; - 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; + unlink $image_tmp1, $image_tmp2; + sleep $delay; + } +} - # 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; - } +sub paste_image { + my ($base, $img, $body, $source) = @_; - if ($verbose > 2 && $crop_chance > 0.1) { - print STDERR blurb() . "crop chance: $crop_chance\n"; - } + $current_state = "paste"; - if (rand() < $crop_chance) { + $suppress_audit = 0; - my $ow = $crop_w; - my $oh = $crop_h; + LOG ($verbose_pbm, "got $img (" . length($body) . ")"); - 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)); - } + my ($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; + } - if ($verbose > 1 && - ($crop_x != 0 || $crop_y != 0 || - $crop_w != $iw || $crop_h != $ih)) { - print STDERR blurb() . "randomly cropping to " . - "${crop_w}x$crop_h \@ $crop_x,$crop_y\n"; - } - } + record_success ($load_method, $img, $base); - # 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) { - - if ($verbose > 1) { - print STDERR blurb() . "cropping for effective paste of " . - "${crop_w}x$crop_h \@ $x,$y\n"; - } + my $ow = $iw; # used only for error messages + my $oh = $ih; - if ($x < 0) { $crop_x -= $x; $crop_w += $x; $x = 0; } - if ($y < 0) { $crop_y -= $y; $crop_h += $y; $y = 0; } + # 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"); - if ($x + $crop_w >= $img_width) { $crop_w = $img_width - $x - 1; } - if ($y + $crop_h >= $img_height) { $crop_h = $img_height - $y - 1; } - } + 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); + } - # 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"; - if ($verbose > 1) { - print STDERR blurb() . "cropping to ${crop_w}x$crop_h \@ " . - "$crop_x,$crop_y\n"; - } - } + my $target_w = $img_width; + my $target_h = $img_height; - if ($verbose > 1) { - print STDERR blurb() . "pasting ${iw}x$ih \@ $x,$y in $image_ppm\n"; - } + my $cmd = ""; - $cmd .= " | pnmpaste - $x $y $image_ppm"; - $cmd =~ s@^ *\| *@@; - my $rc = nontrapping_system "($cmd) < $image_tmp1 > $image_tmp2"; + # Usually scale the image to fit on the screen -- but sometimes scale it + # to fit on half or a quarter of the screen. Note that we don't merely + # scale it to fit, we instead cut it in half until it fits -- that should + # give a wider distribution of sizes. + # + if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; } + if (rand() < 0.3) { $target_w /= 2; $target_h /= 2; } - if ($rc != 0) { - if ($verbose) { - print STDERR blurb() . "failed command: \"$cmd\"\n"; - print STDERR blurb() . "failed url: \"$img\" (${ow}x$oh)\n"; - } - return; + if ($iw > $target_w || $ih > $target_h) { + while ($iw > $target_w || + $ih > $target_h) { + $iw = int($iw / 2); + $ih = int($ih / 2); + } + if ($iw <= 10 || $ih <= 10) { + LOG ($verbose_pbm, "scaling to ${iw}x$ih would have been bogus."); + return 0; } - rename ($image_tmp2, $image_ppm) || return; + LOG ($verbose_pbm, "scaling to ${iw}x$ih"); - my $target = "$image_ppm"; + $cmd .= " | pnmscale -xsize $iw -ysize $ih"; + } - # 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) { - $target = $image_tmp1; - $rc = nontrapping_system "($post_filter_cmd) < $image_ppm > $target"; - if ($rc != 0) { - if ($verbose) { - print STDERR blurb() . "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; - $cmd =~ s/%%PPM%%/$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) { - if ($verbose) { - print STDERR blurb() . "display failed: \"$cmd\"\n"; - } - return; - } - - } elsif ($verbose > 1) { - print STDERR blurb() . "$target size is $tsize\n"; - } - } + my $src = $image_tmp1; - if ($verbose > 0) { - print STDOUT "image: ${iw}x${ih} @ $x,$y $base $source\n"; - } + 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; - return 1; -} + # 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"); + } -sub main { - $| = 1; - srand(time ^ $$); - - my $root_p = 0; - - # 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 "-no-output") { - $no_output_p = 1; - } elsif ($_ eq "-urls-only") { - $urls_only_p = 1; - $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 { - die blurb() . "argument to \"-size\" must be" . - " of the form \"640x400\"\n"; - } - } elsif ($_ eq "-proxy" || $_ eq "-http-proxy") { - $http_proxy = shift @ARGV; - } else { - die "$copyright\nusage: $progname [-root]" . - " [-display dpy] [-root] [-verbose] [-timeout secs]\n" . - "\t\t [-delay secs] [-filter cmd] [-filter2 cmd]\n" . - "\t\t [-http-proxy host[:port]]\n"; - } + 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 ($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 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"); + } - if (!$root_p && !$no_output_p) { - die "$copyright" . - blurb() . "the -root argument is mandatory (for now.)\n"; - } + LOG ($verbose_pbm, "pasting ${iw}x$ih \@ $x,$y in $image_ppm"); - if (!$no_output_p && !$ENV{DISPLAY}) { - die blurb() . "\$DISPLAY is not set.\n"; - } + $cmd .= " | pnmpaste - $x $y $image_ppm"; + + $cmd =~ s@^ *\| *@@; - if ($urls_only_p) { - url_only_output; + $_ = "($cmd)"; + $_ .= " < $image_tmp1 > $image_tmp2"; + + if ($verbose_pbm) { + $_ = "($_) 2>&1 | sed s'/^/" . blurb() . "/'"; + } else { + $_ .= " 2> /dev/null"; + } + my $rc = nontrapping_system ($_); + + if ($rc != 0) { + LOG (($verbose_pbm || $verbose_load), "failed command: \"$cmd\""); + LOG (($verbose_pbm || $verbose_load), "failed URL: \"$img\" (${ow}x$oh)"); + return; + } + + 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) { + $target = $image_tmp1; + $rc = nontrapping_system "($post_filter_cmd) < $image_ppm > $target"; + 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; + } + } 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); + + clearlog(); + + return 1; +} + + +sub main { + $| = 1; + srand(time ^ $$); + + my $verbose = 0; + + $current_state = "init"; + $load_method = "none"; + + my $root_p = 0; + + # 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 "-no-output") { + $no_output_p = 1; + } elsif ($_ eq "-urls-only") { + $urls_only_p = 1; + $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; + } else { + print STDERR "$copyright\nusage: $progname [-root]" . + " [-display dpy] [-root] [-verbose] [-timeout secs]\n" . + "\t\t [-delay secs] [-filter cmd] [-filter2 cmd]\n" . + "\t\t [-http-proxy host[:port]]\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) { + print STDERR $copyright; + error "the -root argument is mandatory (for now.)"; + } + + if (!$no_output_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 ($urls_only_p) { + url_only_output; + } else { + x_or_pbm_output; + } } main;