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