lib/File/Tree/Snapshot.pm

   1 # lots of this stuff was sponsored by socialflow.com
   2
   3 package File::Tree::Snapshot;
   4 use Moo;
   5 use File::Path;
   6 use File::Basename;
   7
   8 our $VERSION = '0.000001';
   9 $VERSION = eval $VERSION;
  10
  11 has storage_path => (is => 'ro', required => 1);
  12
  13 has allow_empty => (is => 'ro');
  14
  15 sub file { join '/', (shift)->storage_path, @_}
  16
  17 sub open {
  18     my ($self, $mode, $file, %opt) = @_;
  19     $file = $self->file($file)
  20         unless $opt{is_absolute};
  21     $self->_mkpath(dirname $file)
  22         if $opt{mkpath};
  23     open my $fh, $mode, $file
  24         or die "Unable to write '$file': $!\n";
  25     return $fh;
  26 }
  27
  28 sub _mkpath {
  29     my ($self, $dir) = @_;
  30     mkpath($dir, { error => \(my $err) });
  31     if (@$err) {
  32         warn "Error while attempting to create '$dir': $_\n"
  33             for map { (values %$_) } @$err;
  34     }
  35     return 1;
  36 }
  37
  38 sub _exec {
  39     my ($self, $cmd) = @_;
  40     system($cmd) and die "Error during ($cmd)\n";
  41     return 1;
  42 }
  43
  44 sub _git_exec {
  45     my ($self, @cmd) = @_;
  46     my $path = $self->storage_path;
  47     #local $ENV{GIT_DIR} = "$path/.git";
  48     return $self->_exec(
  49         sprintf q{cd %s && git %s},
  50             $path,
  51             join ' ', @cmd,
  52     );
  53 }
  54
  55 sub create {
  56     my ($self) = @_;
  57     my $path = $self->storage_path;
  58     $self->_mkpath($path);
  59     $self->_git_exec('init');
  60     CORE::open my $fh, '>', "$path/.gitignore"
  61       or die "Unable to write .gitignore in '$path': $!\n";
  62     $self->_git_exec('add', '.gitignore');
  63     $self->_git_exec('commit', '-m', '"Initial commit"');
  64     return 1;
  65 }
  66
  67 sub _has_changes {
  68     my ($self) = @_;
  69     my $path = $self->storage_path;
  70     my $cmd = qq{cd $path && git status --porcelain};
  71     CORE::open my $handle, '-|', $cmd
  72       or die "Unable to find changes in ($cmd): $!\n";
  73     my @changes = <$handle>;
  74     return scalar @changes;
  75 }
  76
  77 sub commit {
  78     my ($self) = @_;
  79     $self->_git_exec('add .');
  80     unless ($self->_has_changes) {
  81         print "No changes\n";
  82         return 1;
  83     }
  84     $self->_git_exec('commit',
  85         '--all',
  86         ($self->allow_empty ? '--allow-empty' : ()),
  87         '-m' => sprintf('"Updated on %s"', scalar localtime),
  88     );
  89     return 1;
  90 }
  91
  92 sub reset {
  93     my ($self) = @_;
  94     $self->_git_exec('add .');
  95     return 1
  96         unless $self->_has_changes;
  97     $self->_git_exec('checkout -f');
  98     return 1;
  99 }
 100
 101 sub exists {
 102     my ($self) = @_;
 103     return -e join '/', $self->storage_path, '.git';
 104 }
 105
 106 sub find_files {
 107     my ($self, $ext, @path) = @_;
 108     my $root = $self->file(@path);
 109     my @files = `find $root -name '*.$ext' -type f`;
 110     chomp @files;
 111     return @files;
 112 }
 113
 114 1;
 115
 116 =head1 NAME
 117
 118 File::Tree::Snapshot - Snapshot files in a git repository
 119
 120 =head1 SYNOPSIS
 121
 122     use File::Tree::Snapshot;
 123
 124     my $tree = File::Tree::Snapshot->new(
 125         storage_path => '/path/to/tree',
 126     );
 127
 128     $tree->create
 129         unless $tree->exists;
 130
 131     # modify files, see methods below
 132
 133     $tree->commit;
 134     # or
 135     $tree->reset;
 136
 137 =head1 DESCRIPTION
 138
 139 This module manages snapshots of file system trees by wrapping the C<git>
 140 command line interface. It currently only manages generating the snapshots.
 141
 142 The directories are standard Git repositories and can be accessed in the
 143 usual ways.
 144
 145 =head1 ATTRIBUTES
 146
 147 =head2 storage_path
 148
 149 The path to the tree that should hold the files that are snapshot. This
 150 attribute is required.
 151
 152 =head2 allow_empty
 153
 154 If this attribute is set to true, commits will be created even if no changes
 155 were registered.
 156
 157 =head1 METHODS
 158
 159 =head2 new
 160
 161     my $tree = File::Tree::Snapshot->new(%attributes);
 162
 163 Constructor. See L</ATTRIBUTES> for possible parameters.
 164
 165 =head2 file
 166
 167     my $path = $tree->file(@relative_path_parts_to_file);
 168
 169 Takes a set of path parts and returns the path to the file inside the
 170 storage.
 171
 172 =head2 open
 173
 174     my $fh = $tree->open($mode, $file, %options);
 175
 176 Opens a file within the storage. C<$mode> is passed straight to
 177 L<perlfunc/open>. The C<$file> is a relative path inside the storage.
 178
 179 Possible options are:
 180
 181 =over
 182
 183 =item * C<is_absolute>
 184
 185 If set to true the C<$file> will be assumed to already be an absolute
 186 path as returned by L</file>, instead of a path relative to the storage.
 187
 188 =item * C<mkpath>
 189
 190 Create the path to the file if it doesn't already exist.
 191
 192 =back
 193
 194 =head2 create
 195
 196     $tree->create;
 197
 198 Create the directory (if it doesn't exist yet) and initialize it as a
 199 Git repository.
 200
 201 =head2 exists
 202
 203     my $does_exist = $tree->exists;
 204
 205 Returns true if the storage is an initialized Git repository.
 206
 207 =head2 commit
 208
 209 Will commit the changes made to the tree to the Git repository.
 210
 211 =head2 reset
 212
 213 Rolls back the changes since the last snapshot.
 214
 215 =head1 SPONSORED
 216
 217 The development of this module was sponsored by L<http://socialflow.com/>.
 218
 219 =cut