add archive analysis command

diff --git a/archive_analysis b/archive_analysis
new file mode 100755 (executable)
index 0000000..a413f99
--- /dev/null
+++ b/archive_analysis
@@ -0,0 +1,150 @@
+#!/usr/bin/perl
+# archive_analysis archives a set of analysis files
+# and is released under the terms of the GNU GPL version 3, or any
+# later version, at your option. See the file README and COPYING for
+# more information.
+# Copyright 2013 by Don Armstrong <don@donarmstrong.com>.
+
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Pod::Usage;
+
+=head1 NAME
+
+archive_analysis - archives a set of analysis files
+
+=head1 SYNOPSIS
+
+archive_analysis [options]
+
+ Options:
+  --debug, -d debugging level (Default 0)
+  --help, -h display this help
+  --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief usage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+archive_analysis
+
+=cut
+
+
+use File::Spec;
+use File::Copy;
+
+use vars qw($DEBUG);
+
+my %options = (debug           => 0,
+              help            => 0,
+              man             => 0,
+              );
+
+GetOptions(\%options,
+           'archive_dir|archive-dir=s@',
+           'git_annex|git-annex!',
+          'debug|d+','help|h|?','man|m');
+
+pod2usage() if $options{help};
+pod2usage({verbose=>2}) if $options{man};
+
+$DEBUG = $options{debug};
+
+# maybe eventually use Config::IniFiles or similar
+my @USAGE_ERRORS;
+if (not defined $options{archive_dir}) {
+    push @USAGE_ERRORS, "You must pass an --archive-dir";
+}
+
+if (not @ARGV) {
+     push @USAGE_ERRORS,"You must give files to archive";
+}
+
+pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
+
+
+for my $file (@ARGV) {
+    if (not -r $file) {
+        fail("file $file does not exist or is not readable.\n");
+    }
+    # figure out which VCS is in use
+    my $vcs = determine_vcs($file);
+    if (not defined $vcs) {
+        fail("Unable to determine which VCS this is");
+    }
+    my $revision = find_vcs_revision($vcs,$file);
+    if (not defined $revision) {
+        fail("Unable to determine which revision this is");
+    }
+    my $new_file = $file;
+    $new_file =~ s{(\.[^\./]{,5}|)$}{_$revision$1};
+    my ($v,$d,$nf) = File::Spec->splitfile($new_file);
+    for my $dir (make_list($options{archive_dir})) {
+        my $loc = File::Spec->join($dir,$nf);
+        copy($file,$loc) or
+            fail("Unable to copy file $file to $loc: $!\n");
+    }
+}
+
+sub determine_vcs {
+    my ($file) = @_;
+
+    my $abs_path = File::Spec->rel2abs($file);
+    my @dirs = File::Spec->splitdir($abs_path);
+    for my $i ($#dirs..0) {
+        my $dir = File::Spec->catdir(@dirs[$i..0]);
+        for my $vcs (qw(git svn bzr)) {
+            if ( -e File::Spec->catdir($dir,'.'.$vcs)) {
+                return $vcs;
+            }
+        }
+    }
+    return undef;
+}
+
+sub find_vcs_revision{
+    my ($vcs,$file) = @_;
+
+    if ($vcs eq 'git') {
+        my $old_dir = getcwd();
+        my $abs_path = File::Spec->rel2abs($file);
+        my ($v,$d,$nf) = File::Spec->splitfile($abs_path);
+        chdir($d);
+        my $branch = qx(git name-rev --name-only HEAD);
+        my $rev = qx(git rev-parse --short HEAD);
+        return $branch.'@'.$rev;
+    } else {
+        fail("vcs $vcs not currently supported");
+    }
+}
+
+
+
+sub fail {
+    print STDERR @_;
+    exit 1;
+}
+
+
+
+__END__