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

   1 #!/usr/bin/perl -w
   2 # Copyright © 2001-2008 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 chooses a random file from under the given directory, and
  13 # prints its name.  The file will be an image file whose dimensions are
  14 # larger than a certain minimum size.
  15 #
  16 # The various xscreensaver hacks that manipulate images ("jigsaw", etc.) get
  17 # the image to manipulate by running the "xscreensaver-getimage" program.
  18 #
  19 # Under X11, the "xscreensaver-getimage" program invokes this script,
  20 # depending on the value of the "chooseRandomImages" and "imageDirectory"
  21 # settings in the ~/.xscreensaver file (or .../app-defaults/XScreenSaver).
  22 #
  23 # Under Cocoa, this script lives inside the .saver bundle, and is invoked
  24 # directly from utils/grabclient.c.
  25 #
  26 # Created: 12-Apr-01.
  27
  28 require 5;
  29 #use diagnostics;       # Fails on some MacOS 10.5 systems
  30 use strict;
  31
  32 use POSIX;
  33 use Fcntl;
  34
  35 use Fcntl ':flock'; # import LOCK_* constants
  36
  37 use POSIX ':fcntl_h';                           # S_ISDIR was here in Perl 5.6
  38 import Fcntl ':mode' unless defined &S_ISDIR;   # but it is here in Perl 5.8
  39
  40 use bytes;  # Larry can take Unicode and shove it up his ass sideways.
  41             # Perl 5.8.0 causes us to start getting incomprehensible
  42             # errors about UTF-8 all over the place without this.
  43
  44 my $progname = $0; $progname =~ s@.*/@@g;
  45 my $version = q{ $Revision: 1.26 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
  46
  47 my $verbose = 0;
  48
  49 # Whether to use MacOS X's Spotlight to generate the list of files.
  50 # When set to -1, uses Spotlight if "mdfind" exists.
  51 #
  52 # (In my experience, this isn't actually any faster, and might not find
  53 # everything if your Spotlight index is out of date, which happens often.)
  54 #
  55 my $use_spotlight_p = 0;
  56
  57 # Whether to cache the results of the last run.
  58 #
  59 my $cache_p = 1;
  60
  61 # Regenerate the cache if it is older than this many seconds.
  62 #
  63 my $cache_max_age = 60 * 60 * 3;   # 3 hours
  64
  65
  66 # This matches files that we are allowed to use as images (case-insensitive.)
  67 # Anything not matching this is ignored.  This is so you can point your
  68 # imageDirectory at directory trees that have things other than images in
  69 # them, but it assumes that you gave your images sensible file extensions.
  70 #
  71 my @good_extensions = ('jpg', 'jpeg', 'pjpeg', 'pjpg', 'png', 'gif',
  72                        'tif', 'tiff', 'xbm', 'xpm');
  73 my $good_file_re = '\.(' . join("|", @good_extensions) . ')$';
  74
  75 # This matches file extensions that might occur in an image directory,
  76 # and that are never used in the name of a subdirectory.  This is an
  77 # optimization that prevents us from having to stat() those files to
  78 # tell whether they are directories or not.  (It speeds things up a
  79 # lot.  Don't give your directories stupid names.)
  80 #
  81 my @nondir_extensions = ('ai', 'bmp', 'bz2', 'cr2', 'crw', 'db',
  82    'dmg', 'eps', 'gz', 'hqx', 'htm', 'html', 'icns', 'ilbm', 'mov',
  83    'nef', 'pbm', 'pdf', 'pl', 'ppm', 'ps', 'psd', 'sea', 'sh', 'shtml',
  84    'tar', 'tgz', 'thb', 'txt', 'xcf', 'xmp', 'Z', 'zip' );
  85 my $nondir_re = '\.(' . join("|", @nondir_extensions) . ')$';
  86
  87
  88 # JPEG, GIF, and PNG files that are are smaller than this are rejected:
  89 # this is so that you can use an image directory that contains both big
  90 # images and thumbnails, and have it only select the big versions.
  91 #
  92 my $min_image_width  = 255;
  93 my $min_image_height = 255;
  94
  95 my @all_files = ();         # list of "good" files we've collected
  96 my %seen_inodes;            # for breaking recursive symlink loops
  97
  98 # For diagnostic messages:
  99 #
 100 my $dir_count = 1;          # number of directories seen
 101 my $stat_count = 0;         # number of files/dirs stat'ed
 102 my $skip_count_unstat = 0;  # number of files skipped without stat'ing
 103 my $skip_count_stat = 0;    # number of files skipped after stat
 104
 105 sub find_all_files {
 106   my ($dir) = @_;
 107
 108   print STDERR "$progname:  + reading dir $dir/...\n" if ($verbose > 1);
 109
 110   local *DIR;
 111   if (! opendir (DIR, $dir)) {
 112     print STDERR "$progname: couldn't open $dir: $!\n" if ($verbose);
 113     return;
 114   }
 115   my @files = readdir (DIR);
 116   closedir (DIR);
 117
 118   my @dirs = ();
 119
 120   foreach my $file (@files) {
 121     next if ($file =~ m/^\./);      # silently ignore dot files/dirs
 122
 123     if ($file =~ m/[~%\#]$/) {      # ignore backup files (and dirs...)
 124       $skip_count_unstat++;
 125       print STDERR "$progname:  - skip file  $file\n" if ($verbose > 1);
 126     }
 127
 128     $file = "$dir/$file";
 129
 130     if ($file =~ m/$good_file_re/io) {
 131       #
 132       # Assume that files ending in .jpg exist and are not directories.
 133       #
 134       push @all_files, $file;
 135       print STDERR "$progname:  - found file $file\n" if ($verbose > 1);
 136
 137     } elsif ($file =~ m/$nondir_re/io) {
 138       #
 139       # Assume that files ending in .html are not directories.
 140       #
 141       $skip_count_unstat++;
 142       print STDERR "$progname: -- skip file  $file\n" if ($verbose > 1);
 143
 144     } else {
 145       #
 146       # Now we need to stat the file to see if it's a subdirectory.
 147       #
 148       # Note: we could use the trick of checking "nlinks" on the parent
 149       # directory to see if this directory contains any subdirectories,
 150       # but that would exclude any symlinks to directories.
 151       #
 152       my @st = stat($file);
 153       my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
 154           $atime,$mtime,$ctime,$blksize,$blocks) = @st;
 155
 156       $stat_count++;
 157
 158       if ($#st == -1) {
 159         if ($verbose) {
 160           my $ll = readlink $file;
 161           if (defined ($ll)) {
 162             print STDERR "$progname: + dangling symlink: $file -> $ll\n";
 163           } else {
 164             print STDERR "$progname: + unreadable: $file\n";
 165           }
 166         }
 167         next;
 168       }
 169
 170       next if ($seen_inodes{"$dev:$ino"}); # break symlink loops
 171       $seen_inodes{"$dev:$ino"} = 1;
 172
 173       if (S_ISDIR($mode)) {
 174         push @dirs, $file;
 175         $dir_count++;
 176         print STDERR "$progname:  + found dir  $file\n" if ($verbose > 1);
 177
 178       } else {
 179         $skip_count_stat++;
 180         print STDERR "$progname:  + skip file  $file\n" if ($verbose > 1);
 181       }
 182     }
 183   }
 184
 185   foreach (@dirs) {
 186     find_all_files ($_);
 187   }
 188 }
 189
 190
 191 sub spotlight_all_files {
 192   my ($dir) = @_;
 193
 194   my @terms = ();
 195   # "public.image" matches all (indexed) images, including Photoshop, etc.
 196 #  push @terms, "kMDItemContentTypeTree == 'public.image'";
 197   foreach (@good_extensions) {
 198
 199     # kMDItemFSName hits the file system every time: much worse than "find".
 200 #    push @terms, "kMDItemFSName == '*.$_'";
 201
 202     # kMDItemDisplayName matches against the name in the Spotlight index,
 203     # but won't find files that (for whatever reason) didn't get indexed.
 204     push @terms, "kMDItemDisplayName == '*.$_'";
 205   }
 206
 207   $dir =~ s@([^-_/a-z\d.,])@\\$1@gsi;  # quote for sh
 208   my $cmd = "mdfind -onlyin $dir \"" . join (' || ', @terms) . "\"";
 209
 210   print STDERR "$progname: executing: $cmd\n" if ($verbose > 1);
 211   @all_files = split (/[\r\n]+/, `$cmd`);
 212 }
 213
 214
 215 # If we're using cacheing, read the cache file and return its contents,
 216 # if any.  This also holds an exclusive lock on the cache file, which
 217 # has the additional benefit that if two copies of this program are
 218 # running at once, one will wait for the other, instead of both of
 219 # them spanking the same file system at the same time.
 220 #
 221 local *CACHE_FILE;
 222 my $cache_file_name = undef;
 223 my $read_cache_p = 0;
 224
 225 sub read_cache($) {
 226   my ($dir) = @_;
 227
 228   return () unless ($cache_p);
 229
 230   my $dd = "$ENV{HOME}/Library/Caches";    # MacOS location
 231   if (-d $dd) {
 232     $cache_file_name = "$dd/org.jwz.xscreensaver.getimage.cache";
 233   } elsif (-d "$ENV{HOME}/tmp") {
 234     $cache_file_name = "$ENV{HOME}/tmp/.xscreensaver-getimage.cache";
 235   } else {
 236     $cache_file_name = "$ENV{HOME}/.xscreensaver-getimage.cache";
 237   }
 238
 239   my $file = $cache_file_name;
 240   open (CACHE_FILE, "+>>$file") || error ("unable to write $file: $!");
 241   flock (CACHE_FILE, LOCK_EX)   || error ("unable to lock $file: $!");
 242   seek (CACHE_FILE, 0, 0)       || error ("unable to rewind $file: $!");
 243
 244   print STDERR "$progname: reading cache $cache_file_name\n"
 245     if ($verbose > 1);
 246
 247   my $mtime = (stat(CACHE_FILE))[9];
 248
 249   if ($mtime + $cache_max_age < time) {
 250     print STDERR "$progname: cache is too old\n" if ($verbose);
 251     return ();
 252   }
 253
 254   my $odir = <CACHE_FILE>;
 255   $odir =~ s/[\r\n]+$//s if defined ($odir);
 256   if (!defined ($odir) || ($dir ne $odir)) {
 257     print STDERR "$progname: cache is for $odir, not $dir\n"
 258       if ($verbose && $odir);
 259     return ();
 260   }
 261
 262   my @files = ();
 263   while (<CACHE_FILE>) {
 264     s/[\r\n]+$//s;
 265     push @files, "$odir/$_";
 266   }
 267
 268   print STDERR "$progname: " . ($#files+1) . " files in cache\n"
 269     if ($verbose);
 270
 271   $read_cache_p = 1;
 272   return @files;
 273 }
 274
 275
 276 sub write_cache($) {
 277   my ($dir) = @_;
 278
 279   return unless ($cache_p);
 280
 281   # If we read the cache, just close it without rewriting it.
 282   # If we didn't read it, then write it now.
 283
 284   if (! $read_cache_p) {
 285
 286     truncate (CACHE_FILE, 0) ||
 287       error ("unable to truncate $cache_file_name: $!");
 288     seek (CACHE_FILE, 0, 0) ||
 289       error ("unable to rewind $cache_file_name: $!");
 290
 291     if ($#all_files >= 0) {
 292       print CACHE_FILE "$dir\n";
 293       my $re = qr/$dir/;
 294       foreach (@all_files) {
 295         my $f = $_; # stupid Perl. do this to avoid modifying @all_files!
 296         $f =~ s@^$re/@@so || die;
 297         print CACHE_FILE "$f\n";
 298       }
 299     }
 300
 301     print STDERR "$progname: cached " . ($#all_files+1) . " files\n"
 302       if ($verbose);
 303   }
 304
 305   flock (CACHE_FILE, LOCK_UN) ||
 306     error ("unable to unlock $cache_file_name: $!");
 307   close (CACHE_FILE);
 308 }
 309
 310
 311 sub find_random_file($) {
 312   my ($dir) = @_;
 313
 314   $dir =~ s@/+$@@g;
 315
 316   if ($use_spotlight_p == -1) {
 317     $use_spotlight_p = 0;
 318     if (-x '/usr/bin/mdfind') {
 319       $use_spotlight_p = 1;
 320     }
 321   }
 322
 323   @all_files = read_cache ($dir);
 324
 325   if ($#all_files >= 0) {
 326     # got it from the cache...
 327
 328   } elsif ($use_spotlight_p) {
 329     print STDERR "$progname: spotlighting $dir...\n" if ($verbose);
 330     spotlight_all_files ($dir);
 331     print STDERR "$progname: found " . ($#all_files+1) .
 332                  " file" . ($#all_files == 0 ? "" : "s") .
 333                  " via Spotlight\n"
 334       if ($verbose);
 335   } else {
 336     print STDERR "$progname: recursively reading $dir...\n" if ($verbose);
 337     find_all_files ($dir);
 338     print STDERR "$progname: " .
 339                  "f=" . ($#all_files+1) . "; " .
 340                  "d=$dir_count; " .
 341                  "s=$stat_count; " .
 342                  "skip=${skip_count_unstat}+$skip_count_stat=" .
 343                   ($skip_count_unstat + $skip_count_stat) .
 344                  ".\n"
 345       if ($verbose);
 346   }
 347
 348   write_cache ($dir);
 349
 350   @all_files = sort(@all_files);
 351
 352   if ($#all_files < 0) {
 353     print STDERR "$progname: no files in $dir\n";
 354     exit 1;
 355   }
 356
 357   my $max_tries = 50;
 358   for (my $i = 0; $i < $max_tries; $i++) {
 359
 360     my $n = int (rand ($#all_files + 1));
 361     my $file = $all_files[$n];
 362     if (large_enough_p ($file)) {
 363       return $file;
 364     }
 365   }
 366
 367   print STDERR "$progname: no suitable images in $dir " .
 368                "(after $max_tries tries)\n";
 369   exit 1;
 370 }
 371
 372
 373 sub large_enough_p {
 374   my ($file) = @_;
 375
 376   my ($w, $h) = image_file_size ($file);
 377
 378   if (!defined ($h)) {
 379     print STDERR "$progname: $file: unable to determine image size\n"
 380       if ($verbose);
 381     # Assume that unknown files are of good sizes: this will happen if
 382     # they matched $good_file_re, but we don't have code to parse them.
 383     # (This will also happen if the file is junk...)
 384     return 1;
 385   }
 386
 387   if ($w < $min_image_width || $h < $min_image_height) {
 388     print STDERR "$progname: $file: too small ($w x $h)\n" if ($verbose);
 389     return 0;
 390   }
 391
 392   print STDERR "$progname: $file: $w x $h\n" if ($verbose);
 393   return 1;
 394 }
 395
 396
 397
 398 # Given the raw body of a GIF document, returns the dimensions of the image.
 399 #
 400 sub gif_size {
 401   my ($body) = @_;
 402   my $type = substr($body, 0, 6);
 403   my $s;
 404   return () unless ($type =~ /GIF8[7,9]a/);
 405   $s = substr ($body, 6, 10);
 406   my ($a,$b,$c,$d) = unpack ("C"x4, $s);
 407   return (($b<<8|$a), ($d<<8|$c));
 408 }
 409
 410 # Given the raw body of a JPEG document, returns the dimensions of the image.
 411 #
 412 sub jpeg_size {
 413   my ($body) = @_;
 414   my $i = 0;
 415   my $L = length($body);
 416
 417   my $c1 = substr($body, $i, 1); $i++;
 418   my $c2 = substr($body, $i, 1); $i++;
 419   return () unless (ord($c1) == 0xFF && ord($c2) == 0xD8);
 420
 421   my $ch = "0";
 422   while (ord($ch) != 0xDA && $i < $L) {
 423     # Find next marker, beginning with 0xFF.
 424     while (ord($ch) != 0xFF) {
 425       return () if (length($body) <= $i);
 426       $ch = substr($body, $i, 1); $i++;
 427     }
 428     # markers can be padded with any number of 0xFF.
 429     while (ord($ch) == 0xFF) {
 430       return () if (length($body) <= $i);
 431       $ch = substr($body, $i, 1); $i++;
 432     }
 433
 434     # $ch contains the value of the marker.
 435     my $marker = ord($ch);
 436
 437     if (($marker >= 0xC0) &&
 438         ($marker <= 0xCF) &&
 439         ($marker != 0xC4) &&
 440         ($marker != 0xCC)) {  # it's a SOFn marker
 441       $i += 3;
 442       return () if (length($body) <= $i);
 443       my $s = substr($body, $i, 4); $i += 4;
 444       my ($a,$b,$c,$d) = unpack("C"x4, $s);
 445       return (($c<<8|$d), ($a<<8|$b));
 446
 447     } else {
 448       # We must skip variables, since FFs in variable names aren't
 449       # valid JPEG markers.
 450       return () if (length($body) <= $i);
 451       my $s = substr($body, $i, 2); $i += 2;
 452       my ($c1, $c2) = unpack ("C"x2, $s);
 453       my $length = ($c1 << 8) | $c2;
 454       return () if ($length < 2);
 455       $i += $length-2;
 456     }
 457   }
 458   return ();
 459 }
 460
 461 # Given the raw body of a PNG document, returns the dimensions of the image.
 462 #
 463 sub png_size {
 464   my ($body) = @_;
 465   return () unless ($body =~ m/^\211PNG\r/s);
 466   my ($bits) = ($body =~ m/^.{12}(.{12})/s);
 467   return () unless defined ($bits);
 468   return () unless ($bits =~ /^IHDR/);
 469   my ($ign, $w, $h) = unpack("a4N2", $bits);
 470   return ($w, $h);
 471 }
 472
 473
 474 # Given the raw body of a GIF, JPEG, or PNG document, returns the dimensions
 475 # of the image.
 476 #
 477 sub image_size {
 478   my ($body) = @_;
 479   return () if (length($body) < 10);
 480   my ($w, $h) = gif_size ($body);
 481   if ($w && $h) { return ($w, $h); }
 482   ($w, $h) = jpeg_size ($body);
 483   if ($w && $h) { return ($w, $h); }
 484   # #### TODO: need image parsers for TIFF, XPM, XBM.
 485   return png_size ($body);
 486 }
 487
 488 # Returns the dimensions of the image file.
 489 #
 490 sub image_file_size {
 491   my ($file) = @_;
 492   local *IN;
 493   if (! open (IN, "<$file")) {
 494     print STDERR "$progname: $file: $!\n" if ($verbose);
 495     return undef;
 496   }
 497   binmode (IN);  # Larry can take Unicode and shove it up his ass sideways.
 498   my $body = '';
 499   sysread (IN, $body, 1024 * 50);   # The first 50k should be enough.
 500   close IN;                         # (It's not for certain huge jpegs...
 501   return image_size ($body);        # but we know they're huge!)
 502 }
 503
 504
 505 sub error($) {
 506   my ($err) = @_;
 507   print STDERR "$progname: $err\n";
 508   exit 1;
 509 }
 510
 511 sub usage {
 512   print STDERR "usage: $progname [--verbose] directory\n" .
 513   "       Prints the name of a randomly-selected image file.  The directory\n" .
 514   "       is searched recursively.  Images smaller than " .
 515          "${min_image_width}x${min_image_height} are excluded.\n";
 516   exit 1;
 517 }
 518
 519 sub main {
 520   my $dir = undef;
 521
 522   while ($_ = $ARGV[0]) {
 523     shift @ARGV;
 524     if ($_ eq "--verbose") { $verbose++; }
 525     elsif (m/^-v+$/) { $verbose += length($_)-1; }
 526     elsif ($_ eq "--name") { }     # ignored, for compatibility
 527     elsif ($_ eq "--spotlight")    { $use_spotlight_p = 1; }
 528     elsif ($_ eq "--no-spotlight") { $use_spotlight_p = 0; }
 529     elsif ($_ eq "--cache")        { $cache_p = 1; }
 530     elsif ($_ eq "--no-cache")     { $cache_p = 0; }
 531     elsif (m/^-./) { usage; }
 532     elsif (!defined($dir)) { $dir = $_; }
 533     else { usage; }
 534   }
 535
 536   usage unless (defined($dir));
 537
 538   $dir =~ s@^~/@$ENV{HOME}/@s;     # allow literal "~/"
 539
 540   if (! -d $dir) {
 541     print STDERR "$progname: $dir: not a directory\n";
 542     usage;
 543   }
 544
 545   my $file = find_random_file ($dir);
 546   print STDOUT "$file\n";
 547 }
 548
 549 main;
 550 exit 0;