#!/usr/local/bin/perl5 -w
#
# webcollage, for xscreensaver, Copyright (c) 1999 Jamie Zawinski <jwz@jwz.org>
#
# Permission to use, copy, modify, distribute, and sell this software and its
# documentation for any purpose is hereby granted without fee, provided that
# 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 
# implied warranty.
#
#
# This program decorate the screen with random images from the web.


use Socket;

my $progname = "$0";
my $version = "1.0";

$progname =~ s@^.*/([^/]+)$@$1@;

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 $delay = 0;

my $wordlist = "/usr/dict/words";

if (!-r $wordlist) {
    $wordlist = "/usr/share/lib/dict/words";    # irix
}


my $min_width = 50;
my $min_height = 50;

my $DEBUG = 0;


# returns three values: the HTTP response line; the document headers;
# and the document body.
#
sub get_document_1 {
    my ( $url ) = @_;

    if ( $DEBUG > 2 ) {
	print STDERR "get_document_1 $url\n";
    }

    my($dummy, $dummy, $serverstring, $path) = split(/\//, $url, 4);
    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 for $url\n";
            }
            die "alarm\n" };
        alarm $http_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" .
                 "\n");

        my $http = <S>;

        my $head = "";
        my $body = "";
        while (<S>) {
            $head .= $_;
            last if m@^[\r\n]@;
        }
        while (<S>) {
            $body .= $_;
        }

        close S;

        return ( $http, $head, $body );
    };
    die if ($@ && $@ ne "alarm\n");       # propagate errors
    if ($@) {
        # timed out
        return undef;
    } 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 ) = @_;

    do {
	my ( $http, $head, $body ) = get_document_1 $url;

	return undef if ( ! $body );

	if ( $http =~ m@HTTP/[0-9.]+ 30[23]@ ) {
	    $_ = $head;
	    my ( $location ) = m@^location:[ \t]*(.*)$@im;
	    if ( $location ) {

		if ( $DEBUG > 2 ) {
		    print STDERR "redirect from $url to $location\n";
		}
		$url = $location;
	    } else {
		return ( $url, $body );
	    }

        } elsif ( $http =~ m@HTTP/[0-9.]+ [4-9][0-9][0-9]@ ) {
            # http errors -- return nothing.
            return undef;

	} else {

	    return ( $url, $body );
	}

    } while (1);
}


# 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 ) = @_;

    $_ = $base;

    # if there's at least one slash after the host, take off the last
    # pathname component
    if ( m@^http://[^/]+/@io ) {
	( $base = $base ) =~ s@[^/]+$@@go;
    }

    # if there are no slashes after the host at all, put one on the end.
    if ( m@^http://[^/]+$@io ) {
	$base .= "/";
    }

    if ( $DEBUG > 2 ) {
	print STDERR "base is $base\n";
    }


    $_ = $body;

    # strip out newlines, compress whitespace
    s/[\r\n\t ]+/ /go;

    # nuke comments
    s/<!--.*?-->//go;

    my @urls;
    my %unique_urls;

    foreach (split(/ *</)) {
	if ( m/^(img|a) .*(src|href) ?= ?\"? ?(.*?)[ >\"]/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@/\./@/@;
                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 "skip GIF $_\n"; }
#		next;
#	    }

	    # skip really short or really narrow images
	    if ( $width && $width < $min_width) {
		if ( $DEBUG > 2 ) {
		    print STDERR "skip narrow image $_ ($width x $height)\n";
		}
		next;
	    }

	    if ( $height && $height < $min_height) {
		if ( $DEBUG > 2 ) {
		    print STDERR "skip short image $_ ($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}++;

	    # pointers to images are preferable to inlined images
	    if ( ! $was_inline ) {
		$urls[++$#urls] = $url;
	    }
	}
    }

    if ( $#urls == 0 ) {
	if ( $DEBUG > 2 ) {
	    print STDERR "no images on $base\n";
	}
	return undef;
    }

    return undef if ( $#urls < 1 );

    # pick a random element of the table
    my $i = ((rand() * 99999) % $#urls);

    # if the page has several images on it, prefer the later ones most of
    # the time.
    my $fudge = 4;
    if ($#urls > ($fudge * 2) && $i <= $fudge && ((rand() < 0.9))) {
	if ( $DEBUG > 2 ) {
	    print STDERR "skipping first $fudge of $#urls images.\n";
	}
        $i += ($fudge - $i);
    }

    my $url = $urls[$i];

    if ( $DEBUG > 2 ) {
	print STDERR "picked $url\n";
    }

    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 undef if nothing found this time.
#
sub pick_from_url_randomizer {

    if ( $DEBUG > 2 ) {
	print STDERR "\n\npicking from $random_redirector...\n\n";
    }

    my ( $base, $body ) = get_document $random_redirector;

    return if (!$base || !$body);
    my $img = pick_image_from_body ($base, $body);

    if ($img) {
        return ($base, $img);
    } else {
        return undef;
    }
}


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 = <IN>;   # toss partial line
            $word = <IN>;   # keep next line
        }
        close (IN);
    }

    return 0 if (!$word);

    $word =~ s/^[ \t\n\r]+//;
    $word =~ s/[ \t\n\r]+$//;
    $word =~ s/ly$//;
    $word =~ s/ies$/y/;
    $word =~ s/ally$/al/;

    return $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 undef if nothing found this time.
#
sub pick_from_image_randomizer {

    my $words = random_word;
    $words .= "%20" . random_word;
    $words .= "%20" . random_word;

    my $search_url = $image_randomizer . $words;

    if ( $DEBUG > 2 ) {
	print STDERR "\n\npicking from $search_url\n";
    }

    my ( $base, $body ) = get_document $search_url;

    return if (! $body);


    my @subpages;
    my $skipped = 0;

    $_ = $body;
    s/(<A )/\n$1/gi;
    foreach (split(/\n/)) {

        if ( m@<A HREF=([^>]+)><IMG SRC=http://image\.altavista\.com@i ) {

            my $u = $1;
            if (m/^"(.*)"$/) { $u = $1; }

            if (m@\.corbis\.com/@) {
                $skipped = 1;
                if ( $DEBUG > 2 ) {
                    print STDERR "skipping corbis URL: $_\n";
                }
                next;
            } elsif ( $DEBUG > 2 ) {
                print STDERR "sub-page: $1\n";
            }

            $subpages[++$#subpages] = $u;
        }
    }

    if ( $#subpages <= 0 ) {
        if (!$skipped) {
            print STDERR "Found nothing on $base\n";
        }
	return undef;
    }

    # pick a random element of the table
    my $i = ((rand() * 99999) % $#subpages);
    my $subpage = $subpages[$i];

    if ( $DEBUG > 2 ) {
	print STDERR "picked page $subpage\n";
    }



    my ( $base2, $body2 ) = get_document $subpage;

    return undef if (!$base2 || !body2);

    my $img = pick_image_from_body ($base2, $body2);

    if ($img) {
        return ($base2, $img);
    } else {
        return undef;
    }
}


# 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 {
    if (int(rand 5) == 0) {
        return pick_from_url_randomizer;
    } else {
        return pick_from_image_randomizer;
    }
}


# 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;
}



#################################
#
# running as a CGI
#
#################################


sub do_html_output {

    $| = 1;

    if ( $progname =~ m/nph-/o ) {
	print "HTTP/1.0 200 OK\n";
	print "Content-type: text/html\n";
        print "\n";
    }

    print "<TITLE>random images</TITLE>\n";
    print "<BODY BGCOLOR=\"#FFFFFF\" TEXT=\"#000000\"";
    print "  LINK=\"#0000EE\" VLINK=\"#551A8B\" ALINK=\"#FF0000\">\n";
    print "<H1 ALIGN=CENTER>random images</H1><P>\n";
    print "<P><BLOCKQUOTE><BLOCKQUOTE>\n";
    print "These images have been selected randomly from the web,\n";
    print "by using both <A HREF=\"$random_redirector\">\n";
    print "$random_redirector</A> and <A HREF=\"$image_randomizer_a\">\n";
    print "$image_randomizer_a</A> as a source of URLs from which\n";
    print "images are extracted.\n";
    print "<P>\n";
    print "Note: if you leave this running\n";
    print "long enough, your browser will undoubtedly run out of memory\n";
    print "and crash...\n";
    print "</BLOCKQUOTE></BLOCKQUOTE><P><HR><P ALIGN=CENTER>\n";

    do {
        my ($base, $img) = pick_image;
        if ($img) {
            if ($DEBUG > 0) {
                print STDERR "$img\n";
            }
            print "<A HREF=\"$base\">";
            print "<IMG ALIGN=MIDDLE BORDER=0 SRC=\"$img\"></A>\n";
        }

        sleep $delay;

    } while (1);
}


#################################
#
# running as an xscreensaver mode
#
#################################


my $image = ($ENV{TMPDIR} ? $ENV{TMPDIR} : "/tmp") . "/webcollage." . $$;
my $tmp   = $image . "-1";
my $tmp2  = $image . "-2";
my $tmp3  = $image . "-3";

sub x_cleanup {
    if ($DEBUG > 0) { print STDERR "caught signal\n"; }
    unlink $image, $tmp, $tmp2, $tmp3;
    exit 1;
}

my $screen_width = undef;
my $screen_height = undef;

sub do_x_output {

    my $win_cmd = $ppm_to_root_window_cmd;
    $win_cmd =~ s/^([^ \t\r\n]+).*$/$1/;

    # make sure the various programs we execute exist, right up front.
    foreach ("ppmmake", "giftopnm", "djpeg", "pnmpaste", $win_cmd) {
        which ($_) || die "$progname: $_ not found on \$PATH.\n";
    }

    $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 (!$screen_width || !$screen_height) {
        $_ = `xdpyinfo`;
        ($screen_width, $screen_height) = m/dimensions: *([0-9]+)x([0-9]+) /;
    }

    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;
        }
    }

    # Create the sold-colored base image.
    #
    $_ = "ppmmake '$bgcolor' $screen_width $screen_height";
    if ($DEBUG > 1) {
        print STDERR "creating base image: $_\n";
    }
    system "$_ > $image";

    # Paste the default background image in the middle of it.
    #
    if ($bgimage) {
        my ($iw, $ih);
        if (open(IMG, "<$bgimage")) {
            $_ = <IMG>;
            $_ = <IMG>;
            ($iw, $ih) = m/^([0-9]+) ([0-9]+)$/;
            close (IMG);
        }
        my $x = int (($screen_width - $iw) / 2);
        my $y = int (($screen_height - $ih) / 2);
        if ($DEBUG > 1) {
            print STDERR "pasting $bgimage into base image at $x, $y\n";
        }
        system "pnmpaste $bgimage $x $y $image > $tmp2 && mv $tmp2 $image";
    }


    do {
        my ($base, $img) = pick_image;

        my ($headers, $body);
        if ($img) {
            ($headers, $body) = get_document ($img);
        }

        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 > $tmp")) {
                print PIPE $body;
                close PIPE;

                if ($DEBUG > 1) {
                    print STDERR "created $tmp ($cmd)\n";
                }
            }

            if (-s $tmp) {

                if ($filter_cmd) {
                    if ($DEBUG > 1) {
                        print STDERR "running $filter_cmd\n";
                    }
                    system "($filter_cmd) < $tmp > $tmp3 && mv $tmp3 $tmp";
                }

                my ($iw, $ih);
                if (open(IMG, "<$tmp")) {
                    $_ = <IMG>;
                    $_ = <IMG>;
                    ($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 > $screen_width || $ih > $screen_height) {
                        while ($iw > $screen_width ||
                               $ih > $screen_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 $tmp > $tmp2" .
                               " 2>/dev/null && mv $tmp2 $tmp";
                    }

                    my $x = int (rand() * ($screen_width - $iw));
                    my $y = int (rand() * ($screen_height - $ih));

                    if ($DEBUG > 1) {
                        print STDERR "pasting at $x, $y in $image\n";
                    }

                    system "pnmpaste $tmp $x $y $image > $tmp2 " .
                           "&& mv $tmp2 $image";


                    my $target = $image;
                    if ($post_filter_cmd) {
                        if ($DEBUG > 1) {
                            print STDERR "running $post_filter_cmd\n";
                        }
                        system "($post_filter_cmd) < $image > $tmp3";
                        $target = $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 $tmp, $tmp2, $tmp3;
        }

        sleep $delay;

    } while (1);
}


#################################
#
# decide how to run
#
#################################

sub main {
    srand(time ^ $$);

    my $usage ="WebCollage, Copyright (c) 1999" .
        " Jamie Zawinski <jwz\@jwz.org>\n" .
        "            http://www.jwz.org/xscreensaver/\n";

    if ( $progname =~ m/\.cgi$/i ) {
        $#ARGV == -1 || die "$usage\nusage: $progname (no arguments)\n";
        do_html_output;

    } else {
        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 "-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]+)$@) {
                    $screen_width = $1;
                    $screen_height = $2;
                } else {
                    die "$progname: argument to \"-size\" must be" .
                        " of the form \"640x400\"\n";
                }
            } else {
               die "$usage\nusage: $progname [-root]" .
                   " [-display dpy] [-root] [-verbose] [-timeout secs]\n" .
                   "\t\t  [-delay secs] [-filter cmd] [-filter2 cmd]\n";
            }
        }
        if (!$root_p && !$no_output_p) {
            die "$progname: the -root argument is manditory (for now.)\n";
        }

        if (!$no_output_p && !$ENV{DISPLAY}) {
            die "$progname: \$DISPLAY is not set.\n";
        }

        do_x_output;
    }
}

main;
exit 0;