git.hungrycats.org Git - xscreensaver/blob - driver/xscreensaver-getimage-file

   1 #!/usr/bin/perl -w
   2 # Copyright © 2001, 2002, 2003, 2004 Jamie Zawinski <jwz@jwz.org>.
   3 #
   4 # Permission to use, copy, modify, distribute, and sell this software and its
   5 # documentation for any purpose is hereby granted without fee, provided that
   6 # the above copyright notice appear in all copies and that both that
   7 # copyright notice and this permission notice appear in supporting
   8 # documentation.  No representations are made about the suitability of this
   9 # software for any purpose.  It is provided "as is" without express or
  10 # implied warranty.
  11 #
  12 # This program attempts to locate a random image from the specified directory,
  13 # and load it on to the root window, using some other program that can decode
  14 # image files.  (It attempts to find such a program.)
  15 #
  16 # The various xscreensaver hacks that manipulate images ("slidescreen",
  17 # "jigsaw", etc.) get the image to manipulate by running the
  18 # "xscreensaver-getimage" program.
  19 #
  20 # "xscreensaver-getimage" will invoke this program, depending on the
  21 # value of the "chooseRandomImages" and "imageDirectory" settings in
  22 # the ~/.xscreensaver file (or /usr/lib/X11/app-defaults/XScreenSaver).
  23 #
  24 # Created: 12-Apr-01.
  25
  26 require 5;
  27 use diagnostics;
  28 use strict;
  29
  30 use POSIX;
  31 use Fcntl;
  32
  33 use POSIX ':fcntl_h';                           # S_ISLNK was here in Perl 5.6
  34 import Fcntl ':mode' unless defined &S_ISLNK;   # but it is here in Perl 5.8
  35
  36 use bytes;  # Larry can take Unicode and shove it up his ass sideways.
  37             # Perl 5.8.0 causes us to start getting incomprehensible
  38             # errors about UTF-8 all over the place without this.
  39
  40 my $progname = $0; $progname =~ s@.*/@@g;
  41 my $version = q{ $Revision: 1.18 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
  42
  43 my $verbose = 0;
  44
  45 # This matches files that we are allowed to use as images (case-insensitive.)
  46 # Anything not matching this is ignored.  This is so you can point your
  47 # imageDirectory at directory trees that have things other than images in
  48 # them, but it assumes that you gave your images sensible file extensions.
  49 #
  50 my $good_file_re = '\.(gif|p?jpe?g|png|tiff?|xbm|xpm)$';
  51
  52 # JPEG, GIF, and PNG files that are are smaller than this size in either
  53 # direction are rejected: this is so that you can use an image directory
  54 # that contains both big images and thumbnails, and have it only select
  55 # the big versions.
  56 #
  57 my $min_image_width  = 255;
  58 my $min_image_height = 255;
  59
  60
  61 # These are programs that can be used to put an image file on the root
  62 # window (including virtual root windows.)  The first one of these programs
  63 # that exists on $PATH will be used (with the file name as the last arg.)
  64 #
  65 # Generally this isn't used any more; when "xscreensaver-getimage" invokes
  66 # this program, it does so with the "-file" argument (meaning that we just
  67 # return the file name) and then xscreensaver-getimage loads that file
  68 # directly.  However, if you invoke "xscreensaver-getimage-file" directly,
  69 # without "-file", this will be used to actually load the image.
  70 #
  71 my @programs = (
  72   "chbg       -once -xscreensaver -max_grow 4 -max_size 100",
  73   "xv         -root -quit -viewonly -maxpect +noresetroot -quick24 -rmode 5" .
  74   "           -rfg black -rbg black",
  75   "xli        -quiet -fullscreen -onroot -center -border black",
  76   "xloadimage -quiet -fullscreen -onroot -center -border black",
  77
  78 # this lame program wasn't built with vroot.h:
  79 # "xsri       -scale -keep-aspect -center-horizontal -center-vertical",
  80 );
  81
  82
  83 sub pick_displayer {
  84   my @names = ();
  85
  86   foreach my $cmd (@programs) {
  87     $_ = $cmd;
  88     my ($name) = m/^([^ ]+)/;
  89     push @names, "\"$name\"";
  90     print STDERR "$progname: looking for $name...\n" if ($verbose > 2);
  91     foreach my $dir (split (/:/, $ENV{PATH})) {
  92       print STDERR "$progname:   checking $dir/$name\n" if ($verbose > 3);
  93       return $cmd if (-x "$dir/$name");
  94     }
  95   }
  96
  97   $names[$#names] = "or " . $names[$#names];
  98   printf STDERR "$progname: none of: " . join (", ", @names) .
  99                 " were found on \$PATH.\n";
 100   exit 1;
 101 }
 102
 103
 104 my @all_files = ();     # list of "good" files we've collected
 105 my %seen_inodes;        # for breaking recursive symlink loops
 106 my $skip_count = 0;     # number of files skipped, for diagnostic messages
 107 my $dir_count = 1;      # number of directories seen, for diagnostic messages
 108
 109 sub find_all_files {
 110   my ($dir) = @_;
 111
 112   print STDERR "$progname: reading dir $dir/...\n" if ($verbose > 2);
 113
 114   local *DIR;
 115   if (! opendir (DIR, $dir)) {
 116     print STDERR "$progname: couldn't open $dir: $!\n" if ($verbose);
 117     return;
 118   }
 119   my @files = readdir (DIR);
 120   closedir (DIR);
 121
 122   my @dirs = ();
 123
 124   foreach my $file (@files) {
 125     next if ($file =~ m/^\./);      # ignore dot files/dirs
 126
 127     $file = "$dir/$file";
 128     my @st = stat($file);
 129     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 130         $atime,$mtime,$ctime,$blksize,$blocks) = @st;
 131
 132     if ($#st == -1) {
 133       if ($verbose) {
 134         my $ll = readlink $file;
 135         if (defined ($ll)) {
 136           print STDERR "$progname: dangling symlink: $file -> $ll\n";
 137         } else {
 138           print STDERR "$progname: unreadable: $file\n";
 139         }
 140       }
 141       next;
 142     }
 143
 144     next if ($seen_inodes{"$dev:$ino"}); # break symlink loops
 145     $seen_inodes{"$dev:$ino"} = 1;
 146
 147     if (S_ISDIR($mode)) {
 148       push @dirs, $file;
 149       $dir_count++;
 150       print STDERR "$progname:   found dir  $file\n" if ($verbose > 2);
 151     } elsif (S_ISREG($mode) || S_ISLNK($mode)) {
 152
 153       if ($file =~ m/[~%\#]$/ ||               # backup file, or
 154           ! ($file =~ m/$good_file_re/io)) {   # no image extension
 155         $skip_count++;
 156         print STDERR "$progname:   skip file $file\n" if ($verbose > 2);
 157       } else {
 158         push @all_files, $file;
 159         print STDERR "$progname:   found file $file\n" if ($verbose > 2);
 160       }
 161     } elsif ($verbose > 2) {
 162       print STDERR "$progname:   nonreg $file\n";
 163     }
 164   }
 165
 166   foreach (@dirs) {
 167     find_all_files ($_);
 168   }
 169 }
 170
 171
 172 sub find_random_file {
 173   my ($dir) = @_;
 174
 175   $dir =~ s@/+$@@g;
 176
 177   print STDERR "$progname: recursively reading $dir...\n" if ($verbose > 1);
 178   find_all_files ($dir);
 179   print STDERR "$progname: found " . ($#all_files+1) .
 180                " file" . ($#all_files == 0 ? "" : "s") .
 181                " in $dir_count dir" . ($dir_count == 1 ? "" : "s") .
 182                "; skipped $skip_count file" . ($skip_count == 1 ? "" : "s") .
 183                ".\n"
 184     if ($verbose > 1);
 185
 186   @all_files = sort(@all_files);
 187
 188   if ($#all_files < 0) {
 189     print STDERR "$progname: no files in $dir\n";
 190     exit 1;
 191   }
 192
 193   my $max_tries = 50;
 194   for (my $i = 0; $i < $max_tries; $i++) {
 195
 196     my $n = int (rand ($#all_files + 1));
 197     my $file = $all_files[$n];
 198     if (large_enough_p ($file)) {
 199       return $file;
 200     }
 201   }
 202
 203   print STDERR "$progname: no suitable images in $dir " .
 204                "(after $max_tries tries)\n";
 205   exit 1;
 206 }
 207
 208
 209 sub display_file {
 210   my ($file, $displayer) = @_;
 211
 212   if (!defined($displayer)) {
 213     print STDOUT "$file\n";
 214   }  else {
 215     my @cmd = split (/ +/, $displayer);
 216     push @cmd, $file;   # do it this way to allow file names with spaces.
 217     print STDERR "$progname: executing \"" . join(" ", @cmd) . "\"\n"
 218       if ($verbose);
 219     exec (@cmd) || die;
 220   }
 221 }
 222
 223
 224 sub find_and_display {
 225   my ($dir, $displayer) = @_;
 226   my $file = find_random_file ($dir);
 227   display_file ($file, $displayer);
 228 }
 229
 230
 231 sub large_enough_p {
 232   my ($file) = @_;
 233
 234   my ($w, $h) = image_file_size ($file);
 235
 236   if (!defined ($h)) {
 237     print STDERR "$progname: $file: unable to determine image size\n"
 238       if ($verbose);
 239     # Assume that unknown files are of good sizes: this will happen if
 240     # they matched $good_file_re, but we don't have code to parse them.
 241     # (This will also happen if the file is junk...)
 242     return 1;
 243   }
 244
 245   if ($w < $min_image_width || $h < $min_image_height) {
 246     print STDERR "$progname: $file: too small ($w x $h)\n" if ($verbose > 1);
 247     return 0;
 248   }
 249
 250   print STDERR "$progname: $file: $w x $h\n" if ($verbose > 1);
 251   return 1;
 252 }
 253
 254
 255
 256 # Given the raw body of a GIF document, returns the dimensions of the image.
 257 #
 258 sub gif_size {
 259   my ($body) = @_;
 260   my $type = substr($body, 0, 6);
 261   my $s;
 262   return () unless ($type =~ /GIF8[7,9]a/);
 263   $s = substr ($body, 6, 10);
 264   my ($a,$b,$c,$d) = unpack ("C"x4, $s);
 265   return (($b<<8|$a), ($d<<8|$c));
 266 }
 267
 268 # Given the raw body of a JPEG document, returns the dimensions of the image.
 269 #
 270 sub jpeg_size {
 271   my ($body) = @_;
 272   my $i = 0;
 273   my $L = length($body);
 274
 275   my $c1 = substr($body, $i, 1); $i++;
 276   my $c2 = substr($body, $i, 1); $i++;
 277   return () unless (ord($c1) == 0xFF && ord($c2) == 0xD8);
 278
 279   my $ch = "0";
 280   while (ord($ch) != 0xDA && $i < $L) {
 281     # Find next marker, beginning with 0xFF.
 282     while (ord($ch) != 0xFF) {
 283       return () if (length($body) <= $i);
 284       $ch = substr($body, $i, 1); $i++;
 285     }
 286     # markers can be padded with any number of 0xFF.
 287     while (ord($ch) == 0xFF) {
 288       return () if (length($body) <= $i);
 289       $ch = substr($body, $i, 1); $i++;
 290     }
 291
 292     # $ch contains the value of the marker.
 293     my $marker = ord($ch);
 294
 295     if (($marker >= 0xC0) &&
 296         ($marker <= 0xCF) &&
 297         ($marker != 0xC4) &&
 298         ($marker != 0xCC)) {  # it's a SOFn marker
 299       $i += 3;
 300       return () if (length($body) <= $i);
 301       my $s = substr($body, $i, 4); $i += 4;
 302       my ($a,$b,$c,$d) = unpack("C"x4, $s);
 303       return (($c<<8|$d), ($a<<8|$b));
 304
 305     } else {
 306       # We must skip variables, since FFs in variable names aren't
 307       # valid JPEG markers.
 308       return () if (length($body) <= $i);
 309       my $s = substr($body, $i, 2); $i += 2;
 310       my ($c1, $c2) = unpack ("C"x2, $s);
 311       my $length = ($c1 << 8) | $c2;
 312       return () if ($length < 2);
 313       $i += $length-2;
 314     }
 315   }
 316   return ();
 317 }
 318
 319 # Given the raw body of a PNG document, returns the dimensions of the image.
 320 #
 321 sub png_size {
 322   my ($body) = @_;
 323   return () unless ($body =~ m/^\211PNG\r/s);
 324   my ($bits) = ($body =~ m/^.{12}(.{12})/s);
 325   return () unless defined ($bits);
 326   return () unless ($bits =~ /^IHDR/);
 327   my ($ign, $w, $h) = unpack("a4N2", $bits);
 328   return ($w, $h);
 329 }
 330
 331
 332 # Given the raw body of a GIF, JPEG, or PNG document, returns the dimensions
 333 # of the image.
 334 #
 335 sub image_size {
 336   my ($body) = @_;
 337   my ($w, $h) = gif_size ($body);
 338   if ($w && $h) { return ($w, $h); }
 339   ($w, $h) = jpeg_size ($body);
 340   if ($w && $h) { return ($w, $h); }
 341   # #### TODO: need image parsers for TIFF, XPM, XBM.
 342   return png_size ($body);
 343 }
 344
 345 # Returns the dimensions of the image file.
 346 #
 347 sub image_file_size {
 348   my ($file) = @_;
 349   my $body = '';
 350   local *IN;
 351   if (! open (IN, "<$file")) {
 352     print STDERR "$progname: $file: $!\n" if ($verbose);
 353     return undef;
 354   }
 355   binmode (IN);  # Larry can take Unicode and shove it up his ass sideways.
 356   while (<IN>) {
 357     $body .= $_;
 358     last if (length($body) > 1024 * 100);  # the first 100k should be enough
 359   }
 360   close IN;
 361   return image_size ($body);
 362 }
 363
 364
 365 sub usage {
 366   print STDERR "usage: $progname [--verbose] [--name] file-or-directory\n\n" .
 367   "       Puts the given image file (or a randomly selected image from the\n" .
 368   "       given directory) on the root window.  If --name is specified,\n" .
 369   "       just prints the selected filename to stdout instead.\n\n";
 370   exit 1;
 371 }
 372
 373 sub main {
 374   my $dir = undef;
 375   my $do_name = 0;
 376
 377   while ($_ = $ARGV[0]) {
 378     shift @ARGV;
 379     if ($_ eq "--verbose") { $verbose++; }
 380     elsif (m/^-v+$/) { $verbose += length($_)-1; }
 381     elsif ($_ eq "--name") { $do_name++; }
 382     elsif (m/^-./) { usage; }
 383     elsif (!defined($dir)) { $dir = $_; }
 384     else { usage; }
 385   }
 386
 387   usage unless (defined($dir));
 388   my $displayer = undef;
 389
 390   $displayer = pick_displayer() unless $do_name;
 391
 392   if (-d $dir) {
 393     find_and_display ($dir, $displayer);
 394   } elsif (-f $dir) {
 395     display_file ($dir, $displayer);
 396   } else {
 397     print STDERR "$progname: $dir does not exist\n";
 398     usage();
 399   }
 400 }
 401
 402 main;
 403 exit 0;