archive_photos

   1 #!/usr/bin/perl
   2 # archive_photos archives photos into a directory structure
   3 # and is released under the terms of the GNU GPL version 3, or any
   4 # later version, at your option. See the file README and COPYING for
   5 # more information.
   6 # Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
   7
   8
   9 use warnings;
  10 use strict;
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 =head1 NAME
  16
  17 archive_photos - archives photos into a directory structure
  18
  19 =head1 SYNOPSIS
  20
  21 archive_photos [options] path/to/photos [additional photos]
  22
  23  Options:
  24   --recurse, -r recurse into subdirectories (default)
  25   --archive-dir, -a directory to archive into (~/media/photos)
  26   --debug, -d debugging level (Default 0)
  27   --help, -h display this help
  28   --man, -m display manual
  29
  30 =head1 OPTIONS
  31
  32 =over
  33
  34 =item B<--recurse, -r>
  35
  36 Recurse into subdirectories (default; use --no-recurse to disable
  37
  38 =item B<--archive-dir, -a>
  39
  40 Directory to archive to (default is ~/media/photos)
  41
  42 =item B<--debug, -d>
  43
  44 Debug verbosity. (Default 0)
  45
  46 =item B<--help, -h>
  47
  48 Display brief usage information.
  49
  50 =item B<--man, -m>
  51
  52 Display this manual.
  53
  54 =back
  55
  56 =head1 EXAMPLES
  57
  58 archive_photos
  59
  60 =cut
  61
  62
  63 use vars qw($DEBUG);
  64 use User;
  65 use File::Find;
  66 use Image::ExifTool qw(ImageInfo);
  67 use POSIX qw(strftime);
  68 use File::Copy;
  69 use File::Path qw(make_path);
  70 use File::Basename qw(dirname basename);
  71 use Date::Parse qw(str2time);
  72 use IPC::System::Simple qw(capturex);
  73 use Digest::SHA qw(sha256_hex);
  74
  75 my %options = (debug           => 0,
  76                help            => 0,
  77                man             => 0,
  78                archive_dir     => User->Home."/media/photos",
  79                recurse         => 1,
  80               );
  81
  82 GetOptions(\%options,
  83            'archive_dir|archive-dir=s',
  84            'recurse!',
  85            'debug|d+','help|h|?','man|m');
  86
  87 pod2usage() if $options{help};
  88 pod2usage({verbose=>2}) if $options{man};
  89
  90 $DEBUG = $options{debug};
  91
  92 my @USAGE_ERRORS;
  93 if (not @ARGV) {
  94      push @USAGE_ERRORS,"You must give at least one directory";
  95 }
  96
  97 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  98
  99 our @files;
 100
 101 # loads files into @files as appropriate
 102 sub file_pusher {
 103     if (-d $_ and not $options{recurse}) {
 104         $File::Find::prune = 1;
 105         return;
 106     }
 107     if (-f $_ and $_ =~ /\.(?:NEF|JPG|MOV)$/i) {
 108         push @files,$File::Find::name;
 109     }
 110 }
 111
 112 my @dirs;
 113
 114 for my $arg (@ARGV) {
 115     if (-d $arg) {
 116         push @dirs,$arg;
 117     } else {
 118         push @files,$arg;
 119     }
 120 }
 121
 122 # search all of the directories and store the files in @files;
 123 find(\&file_pusher,@dirs) if @dirs;
 124
 125 # find already existing files
 126 my %existing_files;
 127 find(sub { if (-f $_ or -l $_) {$existing_files{$_} = $File::Find::name;} },$options{archive_dir});
 128
 129 for my $file (@files) {
 130     my $file_basename=basename($file);
 131     # find out when the photo was shot
 132     my $info = ImageInfo($file);
 133     if (not defined $info->{CreateDate}) {
 134         print STDERR "No date information for $file\n";
 135         next;
 136     }
 137     my $epoch = str2time($info->{CreateDate});
 138     my $dir = strftime('%Y/%m_%B/%Y_%m_%d/',localtime($epoch));
 139     if (not -d $options{archive_dir}.'/'.$dir) {
 140         make_path($options{archive_dir}.'/'.$dir) or
 141             die "Unable to make dir $!";
 142     }
 143     my $end_location = $options{archive_dir}.'/'.$dir.$file_basename;
 144     if (-e $end_location) {
 145         print STDERR "$file already exists in $end_location\n";
 146     } elsif (exists $existing_files{$file_basename} and
 147              are_the_same_files({name => $existing_files{$file_basename}},
 148                                {name => $file, info => $info})) {
 149         print STDERR "$file already exists in $existing_files{$file_basename}\n";
 150     } else {
 151         print STDERR "copying $file to $end_location\n";
 152         copy($file,$end_location);
 153     }
 154 }
 155
 156 # return true if the files are close enough that we should consider it
 157 # the same picture
 158 sub are_the_same_files{
 159     my ($f1,$f2) = @_;
 160     # load the exif information if we can
 161     for my $f (@_) {
 162         if (-e $f->{name}) {
 163             $f->{exists} = 1;
 164             if (not exists $f->{info} or not defined $f->{info}) {
 165                 $f->{info} = ImageInfo($f->{name});
 166             }
 167         } else {
 168             $f->{exists} = 0;
 169         }
 170     }
 171     # if the files both exist, compare some exif information
 172     if (defined $f1->{info} and $f2->{info}) {
 173         if ($f1->{info}{CreateDate} eq $f2->{info}{CreateDate} and
 174             $f1->{info}{Serial} eq $f2->{info}{Serial}
 175            ) {
 176             return 1;
 177         } else {
 178            return 0;
 179         }
 180     }
 181     # ok; can't compare exif. Compare sha256 sums
 182     for my $f (@_) {
 183         if (-l $f->{name}) {
 184             # this is probably a git annex file
 185             $f->{sha256} = git_annex_sha256($f->{name});
 186         } elsif (-e $f->{name}) {
 187             $f->{sha256} = calc_sha256($f->{name})
 188         }
 189     }
 190     # if the sha256 are equal, they're the same. if not, or if we
 191     # can't compare, assume they're different.
 192     if (defined $f1->{sha256} and
 193         defined $f2->{sha256} and
 194         $f1->{sha256} eq $f2->{sha256}
 195        ) {
 196         return 1;
 197     } else {
 198        return 0;
 199     }
 200 }
 201
 202 sub calc_sha256{
 203     my ($fn) = @_;
 204
 205     my $sha = Digest::SHA->new(256);
 206     $sha->addfile($fn);
 207     return($sha->hexdigest());
 208 }
 209
 210 sub git_annex_sha256 {
 211     my ($fn) = @_;
 212     my $info = capturex('git','-C',dirname($fn),'annex','info',basename($fn));
 213     my ($sha256) = $info =~ /key:.+SHA256E-[^-]+--([^\.]+)/;
 214     return $sha256;
 215 }
 216
 217
 218
 219 __END__