← Back to branch summary

~cyphermox/ubuntu/precise/xscreensaver/merge-5.15-2

« back to all changes in this revision

Viewing changes to driver/xscreensaver-getimage-file

  • Committer: Mathieu Trudel-Lapierre
  • Date: 2011-12-21 15:57:35 UTC
  • mfrom: (1.1.13 upstream)
  • Revision ID: mathieu@canonical.com-20111221155735-m43kxy7824n1p36y
Merging shared upstream rev into target branch.

Show diffs side-by-side

added added

removed removed

Lines of Context:
driver/xscreensaver-getimage-file
13
13
# prints its name.  The file will be an image file whose dimensions are
14
14
# larger than a certain minimum size.
15
15
#
 
16
# If the directory is a URL, it is assumed to be an RSS or Atom feed.
 
17
# The images from that feed will be downloaded, cached, and selected from
 
18
# at random.  The feed will be re-polled periodically, as needed.
 
19
#
16
20
# The various xscreensaver hacks that manipulate images ("jigsaw", etc.) get
17
21
# the image to manipulate by running the "xscreensaver-getimage" program.
18
22
#
45
49
            # Perl 5.8.0 causes us to start getting incomprehensible
46
50
            # errors about UTF-8 all over the place without this.
47
51
 
 
52
use Digest::MD5 qw(md5_base64);
 
53
use LWP::Simple qw($ua);
 
54
 
 
55
 
48
56
my $progname = $0; $progname =~ s@.*/@@g;
49
 
my $version = q{ $Revision: 1.29 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
 
57
my $version = q{ $Revision: 1.30 $ }; $version =~ s/^[^0-9]+([0-9.]+).*$/$1/;
50
58
 
51
59
my $verbose = 0;
52
60
 
66
74
#
67
75
my $cache_max_age = 60 * 60 * 3;   # 3 hours
68
76
 
 
77
# Re-poll RSS/Atom feeds when local copy is older than this many seconds.
 
78
#
 
79
my $feed_max_age = $cache_max_age;
 
80
 
69
81
 
70
82
# This matches files that we are allowed to use as images (case-insensitive.)
71
83
# Anything not matching this is ignored.  This is so you can point your
313
325
}
314
326
 
315
327
 
 
328
# Returns a list of the image enclosures in the RSS or Atom feed.
 
329
# Elements of the list are references, [ "url", "guid" ].
 
330
#
 
331
sub parse_feed($) {
 
332
  my ($url) = @_;
 
333
 
 
334
  $ua->agent ("$progname/$version");
 
335
  $ua->timeout (10);  # bail sooner than the default of 3 minutes
 
336
 
 
337
  my $body = (LWP::Simple::get($url) || '');
 
338
 
 
339
  error ("not an RSS or Atom feed: $url")
 
340
    unless ($body =~ m@^<\?xml\s@si);
 
341
 
 
342
  $body =~ s@(<ENTRY|<ITEM)@\001$1@gsi;
 
343
  my @items = split(/\001/, $body);
 
344
  shift @items;
 
345
 
 
346
  my @imgs = ();
 
347
  my %ids;
 
348
 
 
349
  foreach my $item (@items) {
 
350
    my $iurl = undef;
 
351
    my $id = undef;
 
352
 
 
353
    # First look for <link rel="enclosure" href="...">
 
354
    #
 
355
    if (! $iurl) {
 
356
      $item =~ s!(<LINK[^<>]*>)!{
 
357
        my $link = $1;
 
358
        my ($rel)  = ($link =~ m/\bREL\s*=\s*[\"\']?([^<>\'\"]+)/si);
 
359
        my ($type) = ($link =~ m/\bTYPE\s*=\s*[\"\']?([^<>\'\"]+)/si);
 
360
        my ($href) = ($link =~ m/\bHREF\s*=\s*[\"\']([^<>\'\"]+)/si);
 
361
 
 
362
        if ($rel && lc($rel) eq 'enclosure') {
 
363
          if ($type) {
 
364
            $href = undef unless ($type =~ m@^image/@si);  # omit videos
 
365
          }
 
366
          $iurl = $href if ($href);
 
367
        }
 
368
        $link;
 
369
      }!gsexi;
 
370
    }
 
371
 
 
372
    # Then look for <media:content url="...">
 
373
    #
 
374
    if (! $iurl) {
 
375
      $item =~ s!(<MEDIA:CONTENT[^<>]*>)!{
 
376
        my $link = $1;
 
377
        my ($href) = ($link =~ m/\bURL\s*=\s*[\"\']([^<>\'\"]+)/si);
 
378
        $iurl = $href if $href;
 
379
        $link;
 
380
      }!gsexi;
 
381
    }
 
382
 
 
383
    # Then look for <description>... with an <img href="..."> inside.
 
384
    #
 
385
    if (! $iurl) {
 
386
      $item =~ s!(<description[^<>]*>.*?</description>)!{
 
387
        my $desc = $1;
 
388
        $desc =~ s/&lt;/</gs;
 
389
        $desc =~ s/&gt;/>/gs;
 
390
        $desc =~ s/&quot;/\"/gs;
 
391
        $desc =~ s/&apos;/\'/gs;
 
392
        $desc =~ s/&amp;/&/gs;
 
393
        my ($href) = ($desc =~ m@<IMG[^<>]*\bSRC=[\"\']?([^\"\'<>]+)@si);
 
394
        $iurl = $href if ($href);
 
395
        $desc;
 
396
      }!gsexi;
 
397
    }
 
398
 
 
399
    # Could also do <content:encoded>, but the above probably covers all
 
400
    # of the real-world possibilities.
 
401
 
 
402
 
 
403
    # Find a unique ID for this image, to defeat image farms.
 
404
    # First look for <id>...</id>
 
405
    ($id) = ($item =~ m!<ID\b[^<>]*>\s*([^<>]+?)\s*</ID>!si) unless $id;
 
406
 
 
407
    # Then look for <guid isPermaLink=...> ... </guid>
 
408
    ($id) = ($item =~ m!<GUID\b[^<>]*>\s*([^<>]+?)\s*</GUID>!si) unless $id;
 
409
 
 
410
    # Then look for <link> ... </link>
 
411
    ($id) = ($item =~ m!<LINK\b[^<>]*>\s*([^<>]+?)\s*</LINK>!si) unless $id;
 
412
 
 
413
 
 
414
    if ($iurl) {
 
415
      $id = $iurl unless $id;
 
416
      my $o = $ids{$id};
 
417
      if (! $o) {
 
418
        $ids{$id} = $iurl;
 
419
        my @P = ($iurl, $id);
 
420
        push @imgs, \@P;
 
421
      } elsif ($iurl ne $o) {
 
422
        print STDERR "$progname: WARNING: dup ID \"$id\"" .
 
423
                     " for \"$o\" and \"$iurl\"\n";
 
424
      }
 
425
    }
 
426
  }
 
427
 
 
428
  return @imgs;
 
429
}
 
430
 
 
431
 
 
432
# Like md5_base64 but uses filename-safe characters.
 
433
#
 
434
sub md5_file($) {
 
435
  my ($s) = @_;
 
436
  $s = md5_base64($s);
 
437
  $s =~ s@[/]@_@gs;
 
438
  $s =~ s@[+]@-@gs;
 
439
  return $s;
 
440
}
 
441
 
 
442
 
 
443
# Given the URL of an image, download it into the given directory
 
444
# and return the file name.
 
445
#
 
446
sub download_image($$$) {
 
447
  my ($url, $uid, $dir) = @_;
 
448
 
 
449
  my ($ext) = ($url =~ m@\.([a-z\d]+)$@si);
 
450
  my $file = md5_file ($uid);
 
451
  $file .= '.' . lc($ext) if $ext;
 
452
 
 
453
  # Don't bother doing If-Modified-Since to see if the URL has changed.
 
454
  # If we have already downloaded it, assume it's good.
 
455
  if (-f "$dir/$file") {
 
456
    print STDERR "$progname: exists: $dir/$file for $uid / $url\n" 
 
457
      if ($verbose > 1);
 
458
    return $file;
 
459
  }
 
460
 
 
461
  # Special-case kludge for Flickr:
 
462
  # Their RSS feeds sometimes include only the small versions of the images.
 
463
  # So if the URL ends in "s" (75x75), "t" (100x100) or "m" (240x240),then
 
464
  # munge it to be "b" (1024x1024).
 
465
  #
 
466
  $url =~ s@_[stm](\.[a-z]+)$@_b$1@si
 
467
    if ($url =~ m@^https?://[^/?#&]*?flickr\.com/@si);
 
468
 
 
469
  print STDERR "$progname: downloading: $dir/$file for $uid / $url\n" 
 
470
    if ($verbose > 1);
 
471
  $ua->agent ("$progname/$version");
 
472
  my $status = LWP::Simple::mirror ($url, "$dir/$file");
 
473
  if (!LWP::Simple::is_success ($status)) {
 
474
    print STDERR "$progname: error $status: $url\n";   # keep going
 
475
  }
 
476
 
 
477
  return $file;
 
478
}
 
479
 
 
480
 
 
481
sub mirror_feed($) {
 
482
  my ($url) = @_;
 
483
 
 
484
  if ($url !~ m/^https?:/si) {   # not a URL: local directory.
 
485
    return (undef, $url);
 
486
  }
 
487
 
 
488
  my $dir = "$ENV{HOME}/Library/Caches";    # MacOS location
 
489
  if (-d $dir) {
 
490
    $dir = "$dir/org.jwz.xscreensaver.feeds";
 
491
  } elsif (-d "$ENV{HOME}/tmp") {
 
492
    $dir = "$ENV{HOME}/tmp/.xscreensaver-feeds";
 
493
  } else {
 
494
    $dir = "$ENV{HOME}/.xscreensaver-feeds";
 
495
  }
 
496
 
 
497
  if (! -d $dir) {
 
498
    mkdir ($dir) || error ("mkdir $dir: $!");
 
499
    print STDERR "$progname: mkdir $dir/\n" if ($verbose);
 
500
  }
 
501
 
 
502
  # MD5 for directory name to use for cache of a feed URL.
 
503
  $dir .= '/' . md5_file ($url);
 
504
 
 
505
  if (! -d $dir) {
 
506
    mkdir ($dir) || error ("mkdir $dir: $!");
 
507
    print STDERR "$progname: mkdir $dir/ for $url\n" if ($verbose);
 
508
  }
 
509
 
 
510
  # At this point, we have the directory corresponding to this URL.
 
511
  # Now check to see if the files in it are up to date, and download
 
512
  # them if not.
 
513
 
 
514
  my $stamp = '.timestamp';
 
515
  my $lock = "$dir/$stamp";
 
516
 
 
517
  print STDERR "$progname: awaiting lock: $lock\n"
 
518
    if ($verbose > 1);
 
519
 
 
520
  my $mtime = ((stat($lock))[9]) || 0;
 
521
 
 
522
  my $lock_fd;
 
523
  open ($lock_fd, '+>>', $lock) || error ("unable to write $lock: $!");
 
524
  flock ($lock_fd, LOCK_EX)     || error ("unable to lock $lock: $!");
 
525
  seek ($lock_fd, 0, 0)         || error ("unable to rewind $lock: $!");
 
526
 
 
527
  my $poll_p = ($mtime + $feed_max_age < time);
 
528
 
 
529
  $poll_p = 1 unless ($cache_p);  # poll again now with --no-cache cmd line arg.
 
530
 
 
531
  # Even if the cache is young, let's make sure there are at least
 
532
  # a few files in it, and re-check if not.
 
533
  #
 
534
  if (! $poll_p) {
 
535
    my $count = 0;
 
536
    opendir (my $dirh, $dir) || error ("$dir: $!");
 
537
    foreach my $f (readdir ($dirh)) {
 
538
      next if ($f =~ m/^\./s);
 
539
      $count++;
 
540
      last;
 
541
    }
 
542
    closedir $dirh;
 
543
 
 
544
    if ($count <= 0) {
 
545
      print STDERR "$progname: no files in cache of $url\n" if ($verbose);
 
546
      $poll_p = 1;
 
547
    }
 
548
  }
 
549
 
 
550
  if ($poll_p) {
 
551
 
 
552
    print STDERR "$progname: loading $url\n" if ($verbose);
 
553
 
 
554
    my %files;
 
555
    opendir (my $dirh, $dir) || error ("$dir: $!");
 
556
    foreach my $f (readdir ($dirh)) {
 
557
      next if ($f eq '.' || $f eq '..');
 
558
      $files{$f} = 0;  # 0 means "file exists, should be deleted"
 
559
    }
 
560
    closedir $dirh;
 
561
 
 
562
    $files{$stamp} = 1;
 
563
 
 
564
    # Download each image currently in the feed.
 
565
    #
 
566
    my $count = 0;
 
567
    my @urls = parse_feed ($url);
 
568
    foreach my $p (@urls) {
 
569
      my ($furl, $id) = @$p;
 
570
      my $f = download_image ($furl, $id, $dir);
 
571
      next unless $f;
 
572
      $files{$f} = 1;    # Got it, don't delete
 
573
      $count++;
 
574
    }
 
575
 
 
576
    print STDERR "$progname: empty feed: $url\n" if ($count <= 0);
 
577
 
 
578
    # Now delete any files that are no longer in the feed.
 
579
    # But if there was nothing in the feed (network failure?)
 
580
    # then don't blow away the old files.
 
581
    #
 
582
    my $kept = 0;
 
583
    foreach my $f (keys(%files)) {
 
584
      if ($count <= 0) {
 
585
        $kept++;
 
586
      } elsif ($files{$f}) {
 
587
        $kept++;
 
588
      } else {
 
589
        if (unlink ("$dir/$f")) {
 
590
          print STDERR "$progname: rm $dir/$f\n" if ($verbose > 1);
 
591
        } else {
 
592
          print STDERR "$progname: rm $dir/$f: $!\n";   # don't bail
 
593
        }
 
594
      }
 
595
    }
 
596
 
 
597
    # Both feed and cache are empty. No files at all.
 
598
    error ("empty feed: $url") if ($kept <= 1);
 
599
 
 
600
    $mtime = time();    # update the timestamp
 
601
 
 
602
  } else {
 
603
 
 
604
    # Not yet time to re-check the URL.
 
605
    print STDERR "$progname: using cache: $url\n" if ($verbose);
 
606
 
 
607
  }
 
608
 
 
609
  # Unlock and update the write date on the .timestamp file.
 
610
  #
 
611
  truncate ($lock_fd, 0) || error ("unable to truncate $lock: $!");
 
612
  seek ($lock_fd, 0, 0)  || error ("unable to rewind $lock: $!");
 
613
  utime ($mtime, $mtime, $lock_fd) || error ("unable to touch $lock: $!");
 
614
  flock ($lock_fd, LOCK_UN) || error ("unable to unlock $lock: $!");
 
615
  close ($lock_fd);
 
616
  $lock_fd = undef;
 
617
  print STDERR "$progname: unlocked $lock\n" if ($verbose > 1);
 
618
 
 
619
  # Don't bother using the imageDirectory cache.  We know that this directory
 
620
  # is flat, and we can assume that an RSS feed doesn't contain 100,000 images
 
621
  # like ~/Pictures/ might.
 
622
  #
 
623
  $cache_p = 0;
 
624
 
 
625
  # Return the URL and directory name of the files of that URL's local cache.
 
626
  #
 
627
  return ($url, $dir);
 
628
}
 
629
 
 
630
 
316
631
sub find_random_file($) {
317
632
  my ($dir) = @_;
318
633
 
323
638
    }
324
639
  }
325
640
 
 
641
  my $url;
 
642
  ($url, $dir) = mirror_feed ($dir);
 
643
 
 
644
  if ($url) {
 
645
    $use_spotlight_p = 0;
 
646
    print STDERR "$progname: $dir is cache for $url\n" if ($verbose > 1);
 
647
  }
 
648
 
326
649
  @all_files = read_cache ($dir);
327
650
 
328
651
  if ($#all_files >= 0) {
363
686
    my $n = int (rand ($#all_files + 1));
364
687
    my $file = $all_files[$n];
365
688
    if (large_enough_p ($file)) {
366
 
      $file =~ s@^\Q$dir\L/@@so || die;  # remove $dir from front
 
689
      if (! $url) {
 
690
        $file =~ s@^\Q$dir\L/@@so || die;  # remove $dir from front
 
691
      }
367
692
      return $file;
368
693
    }
369
694
  }
516
841
  print STDERR "usage: $progname [--verbose] directory\n" .
517
842
  "       Prints the name of a randomly-selected image file.  The directory\n" .
518
843
  "       is searched recursively.  Images smaller than " .
519
 
         "${min_image_width}x${min_image_height} are excluded.\n";
 
844
         "${min_image_width}x${min_image_height} are excluded.\n" .
 
845
  "\n" .
 
846
  "       The directory may also be the URL of an RSS/Atom feed.  Enclosed\n" .
 
847
  "       images will be downloaded cached locally.\n" .
 
848
  "\n";
520
849
  exit 1;
521
850
}
522
851
 
539
868
 
540
869
  usage unless (defined($dir));
541
870
 
542
 
  $dir =~ s@^~/@$ENV{HOME}/@s;     # allow literal "~/"
543
 
  $dir =~ s@/+$@@s;                # omit trailing /
544
 
 
545
 
  if (! -d $dir) {
546
 
    print STDERR "$progname: $dir: not a directory\n";
547
 
    usage;
 
871
  $dir =~ s@^feed:@http:@si;
 
872
 
 
873
  if ($dir =~ m/^https?:/si) {
 
874
    # ok
 
875
  } else {
 
876
    $dir =~ s@^~/@$ENV{HOME}/@s;     # allow literal "~/"
 
877
    $dir =~ s@/+$@@s;              # omit trailing /
 
878
 
 
879
    if (! -d $dir) {
 
880
      print STDERR "$progname: $dir: not a directory or URL\n";
 
881
      usage;
 
882
    }
548
883
  }
549
884
 
550
885
  my $file = find_random_file ($dir);