Commit | Line | Data |
b353fa6d |
1 | # most of this was sponsored by socialflow.com |
cd8f4814 |
2 | |
52185ab8 |
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'); |
19119660 |
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"'); |
52185ab8 |
64 | return 1; |
65 | } |
66 | |
67 | sub _has_changes { |
68 | my ($self) = @_; |
69 | my $path = $self->storage_path; |
e47d4988 |
70 | my $cmd = qq{cd $path && git status --porcelain}; |
3e82afa2 |
71 | CORE::open my $handle, '-|', $cmd |
72 | or die "Unable to find changes in ($cmd): $!\n"; |
73 | my @changes = <$handle>; |
52185ab8 |
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 .'); |
aff04a36 |
95 | return 1 |
96 | unless $self->_has_changes; |
52185ab8 |
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; |
ed0958d7 |
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 | |
b353fa6d |
215 | =head1 AUTHOR |
216 | |
217 | phaylon - Robert Sedlacek (cpan:PHAYLON) <r.sedlacek@shadowcat.co.uk> |
218 | |
219 | =head1 CONTRIBUTORS |
220 | |
221 | mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk> |
222 | |
223 | =head1 SPONSORS |
7bc85892 |
224 | |
225 | The development of this module was sponsored by L<http://socialflow.com/>. |
226 | |
b353fa6d |
227 | =head1 COPYRIGHT |
228 | |
229 | Copyright (c) 2012 the File::Tree::Snapshot L</AUTHOR>, L</CONTRIBUTORS> |
230 | and L</SPONSORS> as listed above. |
231 | |
232 | =head1 LICENSE |
233 | |
234 | This library is free software and may be distributed under the same terms |
235 | as perl itself. |
236 | |
ed0958d7 |
237 | =cut |