archive_analysis

   1 #!/usr/bin/perl
   2 # archive_analysis archives a set of analysis files
   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_analysis - archives a set of analysis files
  18
  19 =head1 SYNOPSIS
  20
  21 archive_analysis [options]
  22
  23  Options:
  24   --debug, -d debugging level (Default 0)
  25   --help, -h display this help
  26   --man, -m display manual
  27
  28 =head1 OPTIONS
  29
  30 =over
  31
  32 =item B<--debug, -d>
  33
  34 Debug verbosity. (Default 0)
  35
  36 =item B<--help, -h>
  37
  38 Display brief usage information.
  39
  40 =item B<--man, -m>
  41
  42 Display this manual.
  43
  44 =back
  45
  46 =head1 EXAMPLES
  47
  48 archive_analysis
  49
  50 =cut
  51
  52
  53 use File::Spec;
  54 use File::Copy;
  55
  56 use vars qw($DEBUG);
  57
  58 my %options = (debug           => 0,
  59                help            => 0,
  60                man             => 0,
  61                );
  62
  63 GetOptions(\%options,
  64            'archive_dir|archive-dir=s@',
  65            'git_annex|git-annex!',
  66            'debug|d+','help|h|?','man|m');
  67
  68 pod2usage() if $options{help};
  69 pod2usage({verbose=>2}) if $options{man};
  70
  71 $DEBUG = $options{debug};
  72
  73 # maybe eventually use Config::IniFiles or similar
  74 my @USAGE_ERRORS;
  75 if (not defined $options{archive_dir}) {
  76     push @USAGE_ERRORS, "You must pass an --archive-dir";
  77 }
  78
  79 if (not @ARGV) {
  80      push @USAGE_ERRORS,"You must give files to archive";
  81 }
  82
  83 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
  84
  85
  86 for my $file (@ARGV) {
  87     if (not -r $file) {
  88         fail("file $file does not exist or is not readable.\n");
  89     }
  90     # figure out which VCS is in use
  91     my $vcs = determine_vcs($file);
  92     if (not defined $vcs) {
  93         fail("Unable to determine which VCS this is");
  94     }
  95     my $revision = find_vcs_revision($vcs,$file);
  96     if (not defined $revision) {
  97         fail("Unable to determine which revision this is");
  98     }
  99     my $new_file = $file;
 100     $new_file =~ s{(\.[^\./]{,5}|)$}{_$revision$1};
 101     my ($v,$d,$nf) = File::Spec->splitfile($new_file);
 102     for my $dir (make_list($options{archive_dir})) {
 103         my $loc = File::Spec->join($dir,$nf);
 104         copy($file,$loc) or
 105             fail("Unable to copy file $file to $loc: $!\n");
 106     }
 107 }
 108
 109 sub determine_vcs {
 110     my ($file) = @_;
 111
 112     my $abs_path = File::Spec->rel2abs($file);
 113     my @dirs = File::Spec->splitdir($abs_path);
 114     for my $i ($#dirs..0) {
 115         my $dir = File::Spec->catdir(@dirs[$i..0]);
 116         for my $vcs (qw(git svn bzr)) {
 117             if ( -e File::Spec->catdir($dir,'.'.$vcs)) {
 118                 return $vcs;
 119             }
 120         }
 121     }
 122     return undef;
 123 }
 124
 125 sub find_vcs_revision{
 126     my ($vcs,$file) = @_;
 127
 128     if ($vcs eq 'git') {
 129         my $old_dir = getcwd();
 130         my $abs_path = File::Spec->rel2abs($file);
 131         my ($v,$d,$nf) = File::Spec->splitfile($abs_path);
 132         chdir($d);
 133         my $branch = qx(git name-rev --name-only HEAD);
 134         my $rev = qx(git rev-parse --short HEAD);
 135         return $branch.'@'.$rev;
 136     } else {
 137         fail("vcs $vcs not currently supported");
 138     }
 139 }
 140
 141
 142
 143 sub fail {
 144     print STDERR @_;
 145     exit 1;
 146 }
 147
 148
 149
 150 __END__