File Coverage

blib/lib/GitStore.pm
Criterion Covered Total %
statement 176 176 100.0
branch 37 50 74.0
condition 12 17 70.5
subroutine 31 31 100.0
pod 9 12 75.0
total 265 286 92.6


line stmt bran cond sub pod time code
1             package GitStore;
2             BEGIN {
3 12     12   11820423 $GitStore::AUTHORITY = 'cpan:YANICK';
4             }
5             #ABSTRACT: Git as versioned data store in Perl
6             $GitStore::VERSION = '0.17';
7 12     12   2770 use Moose;
  12         1750917  
  12         88  
8 12     12   61112 use Moose::Util::TypeConstraints;
  12         24  
  12         112  
9 12     12   20092 use Git::PurePerl;
  12         6639611  
  12         325  
10 12     12   63 use Carp;
  12         17  
  12         802  
11              
12 12     12   60 use Path::Class qw/ dir file /;
  12         14  
  12         583  
13 12     12   8904 use Path::Tiny;
  12         106124  
  12         771  
14              
15 12     12   82 use List::Util qw/ first /;
  12         12  
  12         608  
16              
17 12     12   3975 use GitStore::Revision;
  12         31  
  12         491  
18              
19 12     12   86 no warnings qw/ uninitialized /;
  12         16  
  12         25215  
20              
21             subtype 'PurePerlActor' =>
22             as 'Git::PurePerl::Actor';
23              
24             coerce PurePerlActor
25             => from 'Str'
26             => via {
27             s/<(.*?)>//;
28             Git::PurePerl::Actor->new( name => $_, email => $1 );
29             };
30              
31             has 'repo' => ( is => 'ro', isa => 'Str', required => 1 );
32              
33             has 'branch' => ( is => 'rw', isa => 'Str', default => 'master' );
34              
35             has author => (
36             is => 'rw',
37             isa => 'PurePerlActor',
38             default => sub {
39             Git::PurePerl::Actor->new(
40             name => 'anonymous',
41             email => 'anon@127.0.0.1'
42             );
43             } );
44              
45             has serializer => (
46             is => 'ro',
47             default => sub {
48             require Storable;
49             return sub { return Storable::nfreeze($_[2]); }
50             },
51             );
52              
53             has deserializer => (
54             is => 'ro',
55             default => sub {
56             require Storable;
57              
58             return sub {
59             my $data = $_[2];
60              
61             my $magic = eval { Storable::read_magic($data); };
62              
63             return $data unless $magic && $magic->{major} && $magic->{major} >= 2 && $magic->{major} <= 5;
64              
65             my $thawed = eval { Storable::thaw($data) };
66              
67             # false alarm... looked like a Storable, but wasn't.
68             return $@ ? $data : $thawed;
69             }
70             },
71             );
72              
73             has autocommit => (
74             is => 'ro',
75             isa => 'Bool',
76             default => 0,
77             );
78              
79             sub _clean_directories {
80 38     38   63 my ( $self, $dir ) = @_;
81              
82 38   66     686 $dir ||= $self->root;
83              
84 38         38 my $nbr_files = keys %{ $dir->{FILES} };
  38         99  
85              
86 38         48 for my $d ( keys %{ $dir->{DIRS} } ) {
  38         124  
87 14 100       48 if( my $f = $self->_clean_directories( $dir->{DIRS}{$d} ) ) {
88 13         26 $nbr_files += $f;
89             }
90             else {
91 1         4 delete $dir->{DIRS}{$d};
92             }
93             }
94              
95 38         117 return $nbr_files;
96             }
97              
98             sub _expand_directories {
99 50     50   14278 my( $self, $object ) = @_;
100              
101 50         240 my %dir = ( DIRS => {}, FILES => {} );
102              
103 50         99 for my $entry ( map { $_->directory_entries } $object ) {
  50         1625  
104 66 100       1888 if ( $entry->object->isa( 'Git::PurePerl::Object::Tree' ) ) {
105 17         13950 $dir{DIRS}{$entry->filename}
106             = $self->_expand_directories( $entry->object );
107             }
108             else {
109 49         32869 $dir{FILES}{$entry->filename} = $entry->sha1;
110             }
111             }
112              
113 50         5604 return \%dir;
114             }
115              
116             has 'root' => ( is => 'rw', isa => 'HashRef', default => sub { {} } );
117              
118             has 'git' => (
119             is => 'ro',
120             isa => 'Git::PurePerl',
121             lazy => 1,
122             default => sub {
123             my $repo = $_[0]->repo;
124             return Git::PurePerl->new(
125             ( $repo =~ m/\.git$/ ? 'gitdir' : 'directory') => $repo
126             );
127             }
128             );
129              
130             sub BUILD {
131 16     16 0 28 my $self = shift;
132            
133 16         55 $self->load();
134            
135             }
136              
137             sub BUILDARGS {
138 16     16 1 27 my $class = shift;
139              
140 16 100 66     122 if ( @_ == 1 && ! ref $_[0] ) {
141 9         236 return { repo => $_[0] };
142             } else {
143 7         62 return $class->SUPER::BUILDARGS(@_);
144             }
145             }
146              
147             sub branch_head {
148 47     47 0 83 my ( $self, $branch ) = @_;
149 47   33     1519 $branch ||= $self->branch;
150              
151 47         1050 return $self->git->ref_sha1('refs/heads/' . $branch);
152             }
153              
154             sub create {
155 1     1 1 3761 my( $class, $dir ) = @_;
156              
157 1         4 path($dir)->mkpath;
158 1         85 Git::PurePerl->init( directory => $dir );
159              
160 1         53894 return $class->new($dir);
161             }
162              
163             # Load the current head version from repository.
164             sub load {
165 41     41 0 87 my $self = shift;
166            
167 41 100       193 my $head = $self->branch_head or do {
168 10         12232 $self->root({ DIRS => {}, FILES => {} });
169 10         213 return;
170             };
171              
172 31         61302 my $commit = $self->git->get_object($head);
173 31         438648 my $tree = $commit->tree;
174              
175 31         37807 my $root = $self->_expand_directories( $tree );
176 31         1001 $self->root($root);
177              
178             }
179              
180             sub _normalize_path {
181 60     60   121 my ( $self, $path ) = @_;
182              
183 60 100       209 $path = join '/', @$path if ref $path eq 'ARRAY';
184              
185             # Git doesn't like paths prefixed with a '/'
186 60         116 $path =~ s#^/+##;
187              
188 60         218 return $path;
189             }
190              
191             sub get_revision {
192 1     1 1 1695 my ( $self, $path ) = @_;
193              
194 1         6 $path = file( $self->_normalize_path($path) );
195              
196 1 50       42 my $head = $self->branch_head
197             or return;
198              
199 1         2124 my $commit = $self->git->get_object($head);
200 1         2416 my @q = ( $commit );
201              
202 1 50       4 my $file = $self->_find_file( $commit->tree, $path )
203             or return;
204              
205 1         39 my $latest_file_sha1 = $file->object->sha1;
206 1         721 my $last_commit;
207              
208 1         11 while ( @q ) {
209 1         5 push @q, $q[0]->parents;
210 1         38 $last_commit = $commit;
211 1         3 $commit = shift @q;
212              
213 1 50       4 my $f = $self->_find_file( $commit->tree, file($path) )
214             or last;
215              
216 1 50       39 last if $f->object->sha1 ne $latest_file_sha1;
217             }
218              
219 1         676 return GitStore::Revision->new(
220             gitstore => $self,
221             path => $path,
222             sha1 => $last_commit->sha1,
223             );
224             }
225              
226             sub get {
227 18     18 1 3339 my ( $self, $path ) = @_;
228            
229 18         60 $path = file( $self->_normalize_path($path) );
230              
231 18 50       813 my $dir = $self->_cd_dir($path) or return;
232              
233 18 100       75 my $sha1 = $dir->{FILES}{$path->basename} or return;
234              
235 10 50       318 my $object = $self->git->get_object($sha1) or return;
236              
237 10         6051 return $self->deserializer->($self,$path,$object->content);
238             }
239              
240             sub exist {
241 3     3 1 1170 my ( $self, $path ) = @_;
242              
243 3         8 $path = file( $self->_normalize_path($path) );
244              
245 3 50       102 my $dir = $self->_cd_dir($path) or return;
246              
247 3         9 return $dir->{FILES}{$path->basename};
248             }
249              
250              
251             sub set {
252             my ( $self, $path, $content ) = @_;
253            
254             $path = file( $self->_normalize_path($path) );
255              
256             my $dir = $self->_cd_dir($path,1) or return;
257              
258             $content = $self->serializer->( $self, $path, $content ) if ref $content;
259              
260             my $blob = Git::PurePerl::NewObject::Blob->new( content => $content );
261             $self->git->put_object($blob);
262              
263             return $dir->{FILES}{$path->basename} = $blob->sha1;
264             }
265              
266             after [ 'set', 'delete' ] => sub {
267             my $self = shift;
268             $self->commit if $self->autocommit;
269             };
270              
271             *remove = \&delete;
272             sub delete {
273             my ( $self, $path ) = @_;
274            
275             $path = file( $self->_normalize_path($path) );
276              
277             my $dir = $self->_cd_dir($path) or return;
278              
279             return delete $dir->{FILES}{$path->basename};
280             }
281              
282             sub _cd_dir {
283 59     59   97 my( $self, $path, $create ) = @_;
284              
285 59         1542 my $dir = $self->root;
286              
287 59         250 for ( grep { !/^\.$/ } $path->dir->dir_list ) {
  63         2699  
288 17 100       50 if ( $dir->{DIRS}{$_} ) {
289 11         31 $dir = $dir->{DIRS}{$_};
290             }
291             else {
292 6 50       19 return unless $create;
293 6         32 $dir = $dir->{DIRS}{$_} = { DIRS => {}, FILES => {} };
294             }
295             }
296              
297 59         277 return $dir;
298             }
299              
300             sub _build_new_directory_entry {
301 39     39   56 my( $self, $dir ) = @_;
302              
303 39         44 my @children;
304            
305 39         52 while ( my( $filename, $sha1 ) = each %{ $dir->{FILES} } ) {
  74         2293  
306 35         1221 push @children,
307             Git::PurePerl::NewDirectoryEntry->new(
308             mode => '100644',
309             filename => $filename,
310             sha1 => $sha1,
311             );
312             }
313              
314 39         58 while ( my( $dirname, $dir ) = each %{ $dir->{DIRS} } ) {
  54         2250  
315 15         49 my $tree = $self->_build_new_directory_entry($dir);
316 15         461 push @children, Git::PurePerl::NewDirectoryEntry->new(
317             mode => '040000',
318             filename => $dirname,
319             sha1 => $tree->sha1,
320             );
321             }
322              
323 39         1476 my $tree = Git::PurePerl::NewObject::Tree->new(
324             directory_entries => \@children,
325             );
326 39         3266 $self->git->put_object($tree);
327              
328 39         50991 return $tree;
329             }
330              
331             sub commit {
332 24     24 1 580 my ( $self, $message ) = @_;
333              
334 24 100       94 unless ( $self->_clean_directories ) {
335             # TODO surely there's a better way?
336 2         13 $self->set( '.gitignore/dummy', 'dummy file to keep git happy' );
337             }
338            
339             # TODO only commit if there were changes
340            
341 24         824 my $tree = $self->_build_new_directory_entry( $self->root );
342              
343             # there might not be a parent, if it's a new branch
344 24         52 my $parent = eval { $self->git->ref( 'refs/heads/'.$self->branch )->sha1 };
  24         592  
345              
346 24         87032 my $timestamp = DateTime->now;
347 24   100     7971 my $commit = Git::PurePerl::NewObject::Commit->new(
348             ( parent => $parent ) x !!$parent,
349             tree => $tree->sha1,
350             author => $self->author,
351             committer => $self->author,
352             comment => $message||'',
353             authored_time => $timestamp,
354             committed_time => $timestamp,
355             );
356 24         3700 $self->git->put_object($commit);
357              
358             # reload
359 24         65947 $self->load;
360             }
361              
362             sub discard {
363 1     1 1 731 my $self = shift;
364              
365 1         3 $self->load;
366             }
367              
368             sub _find_file {
369 42     42   19940 my( $self, $tree, $path ) = @_;
370              
371 42         97 my @path = grep { !/^\.$/ } $path->dir->dir_list;
  51         1463  
372              
373 42 100       136 if ( my $part = shift @path ) {
374 18 50   23   681 my $entry = first { $_->filename eq $part } $tree->directory_entries
  23         800  
375             or return;
376              
377 18         525 my $object = $self->git->get_object( $entry->sha1 );
378              
379 18 50       13203 return unless ref $object eq 'Git::PurePerl::Object::Tree';
380              
381 18         65 return $self->_find_file( $object, file(@path,$path->basename) );
382             }
383              
384 24     24   998 return first { $_->filename eq $path->basename } $tree->directory_entries;
  24         928  
385             }
386              
387             sub history {
388 3     3 1 570 my ( $self, $path ) = @_;
389              
390 3 50       11 my $head = $self->branch_head
391             or return;
392              
393 3         6443 my @q = ( $self->git->get_object($head) );
394              
395 3         7785 my @commits;
396 3         21 while ( @q ) {
397 16         62 push @q, $q[0]->parents;
398 16         35493 unshift @commits, shift @q;
399             }
400              
401 3         6 my @history_commits;
402             my %sha1_seen;
403              
404 3         20 for my $c ( @commits ) {
405 16 100       9273 my $file = $self->_find_file( $c->tree, file($path) ) or next;
406 14 100       1059 push @history_commits, $c unless $sha1_seen{ $file->object->sha1 }++;
407             }
408              
409 6         272 return map {
410 3         2332 GitStore::Revision->new(
411             path => $path,
412             gitstore => $self,
413             sha1 => $_->sha1,
414             )
415             } @history_commits;
416              
417             }
418              
419             sub list {
420 2     2 1 1633 my( $self, $regex ) = @_;
421              
422 2 50 66     12 croak "'$regex' is not a a regex"
423             if $regex and ref $regex ne 'Regexp';
424              
425 2 50       5 my $head = $self->branch_head or return;
426              
427 2         3551 my $commit = $self->git->get_object($head);
428 2         4479 my $tree = $commit->tree;
429              
430 2         1899 my $root = $self->_expand_directories( $tree );
431              
432 2         13 my @dirs = ( [ '', $root ] );
433 2         3 my @entries;
434              
435 2         8 while( my $dir = shift @dirs ) {
436 2         3 my $path = $dir->[0];
437 2         3 $dir = $dir->[1];
438 2         8 push @dirs, [ "$path/$_" => $dir->{DIRS}{$_} ]
439 2         3 for sort keys %{$dir->{DIRS}};
440              
441 2         4 for ( sort keys %{$dir->{FILES}} ) {
  2         9  
442 4         8 my $f = "$path/$_";
443 4         14 $f =~ s#^/##; # TODO improve this
444 4 100 100     23 next if $regex and $f !~ $regex;
445 3         10 push @entries, $f;
446             }
447             }
448              
449 2         58 return @entries;
450             }
451              
452              
453 12     12   72 no Moose;
  12         16  
  12         77  
454             __PACKAGE__->meta->make_immutable;
455              
456             1;
457              
458             __END__
459              
460             =pod
461              
462             =encoding UTF-8
463              
464             =head1 NAME
465              
466             GitStore - Git as versioned data store in Perl
467              
468             =head1 VERSION
469              
470             version 0.17
471              
472             =head1 SYNOPSIS
473              
474             use GitStore;
475              
476             my $gs = GitStore->new('/path/to/repo');
477             $gs->set( 'users/obj.txt', $obj );
478             $gs->set( ['config', 'wiki.txt'], { hash_ref => 1 } );
479             $gs->commit();
480             $gs->set( 'yyy/xxx.log', 'Log me' );
481             $gs->discard();
482            
483             # later or in another pl
484             my $val = $gs->get( 'user/obj.txt' ); # $val is the same as $obj
485             my $val = $gs->get( 'config/wiki.txt' ); # $val is { hashref => 1 } );
486             my $val = $gs->get( ['yyy', 'xxx.log' ] ); # $val is undef since discard
487              
488             =head1 DESCRIPTION
489              
490             It is inspired by the Python and Ruby binding. check SEE ALSO
491              
492             =head1 CLASS FUNCTIONS
493              
494             =head2 create( $directory )
495              
496             Creates the directory, initialize it as a git repository,
497             and returns its associated C<GitStore> object.
498              
499             my $gs = GitStore->create( '/tmp/mystore' );
500              
501             =head1 METHODS
502              
503             =head2 new
504              
505             GitStore->new('/path/to/repo');
506             GitStore->new( repo => '/path/to/repo', branch => 'mybranch' );
507             GitStore->new( repo => '/path/to/repo', author => 'Someone Unknown <unknown\@what.com>' );
508              
509             =over 4
510              
511             =item repo
512              
513             your git directory or work directory (I<GitStore> will assume it's a work
514             directory if it doesn't end with C<.git>).
515              
516             =item branch
517              
518             your branch name, default is 'master'
519              
520             =item author
521              
522             It is used in the commit info
523              
524             =item serializer
525              
526             Can be used to define a serializing function that will be used if the value to
527             save is a reference. When invoked, the function will be passed a reference to
528             the store object, the path under which the value will be saved, and the value
529             itself. For example, one could do different serialization via:
530              
531             my $store = GitStore->new(
532             repo => '/path/to/repo',
533             serializer => sub {
534             my( $store, $path, $value ) = @_;
535              
536             if ( $path =~ m#^json# ) {
537             return encode_json($value);
538             }
539             else {
540             # defaults to YAML
541             return YAML::Dump($value);
542             }
543             },
544             );
545              
546             The default serializer uses L<Storable/nfreeze>.
547              
548             =item deserializer
549              
550             Called when a value is picked from the store to be (potentially) deserialized.
551             Just like the serializer function, it is passed three arguments: the store
552             object, the path of the value to deserialize and the value itself. To revisit
553             the example for C<serializer>, the full serializer/deserializer dance would
554             be:
555              
556             my $store = GitStore->new(
557             repo => '/path/to/repo',
558             serializer => sub {
559             my( $store, $path, $value ) = @_;
560              
561             return $path =~ m#^json#
562             ? encode_json($value)
563             : YAML::Dump($value)
564             ;
565             },
566             deserializer => sub {
567             my( $store, $path, $value ) = @_;
568            
569             return $path =~ #^json#
570             ?decode_json($value)
571             : YAML::Load($value)
572             ;
573             },
574             );
575              
576             The default deserializer will try to deserialize the value
577             retrieved from the store via L<Storable/thaw> and, if this fails,
578             return the value verbatim.
579              
580             =item autocommit
581              
582             If set to C<true>, any call to C<set()> or C<delete()> will automatically call an
583             implicit C<commit()>. Defaults to C<false>.
584              
585             =back
586              
587             =head2 set($path, $val)
588              
589             $gs->set( 'yyy/xxx.log', 'Log me' );
590             $gs->set( ['config', 'wiki.txt'], { hash_ref => 1 } );
591             $gs->set( 'users/obj.txt', $obj );
592              
593             Store $val as a $path file in Git
594              
595             $path can be String or ArrayRef. Any leading slashes ('/') in the path
596             will be stripped, as to make it a valid Git path. The same
597             grooming is done for the C<get()> and C<delete()> methods.
598              
599             $val can be String or Ref[HashRef|ArrayRef|Ref[Ref]] or blessed Object
600              
601             =head2 get($path)
602              
603             $gs->get( 'user/obj.txt' );
604             $gs->get( ['yyy', 'xxx.log' ] );
605              
606             Get $val from the $path file
607              
608             $path can be String or ArrayRef
609              
610             =head2 get_revision( $path )
611              
612             Like C<get()>, but returns the L<GitStore::Revision> object corresponding to
613             the latest Git revision on the monitored branch for which C<$path> changed.
614              
615             =head2 delete($path)
616              
617             =head2 remove($path)
618              
619             remove $path from Git store
620              
621             =head2 commit
622              
623             $gs->commit();
624             $gs->commit('Your Comments Here');
625              
626             commit the B<set> changes into Git
627              
628             =head2 discard
629              
630             $gs->discard();
631              
632             discard the B<set> changes
633              
634             =head2 exist($path)
635              
636             Returns I<true> if an object exists at the given path.
637              
638             =head2 history($path)
639              
640             Returns a list of L<GitStore::Revision> objects representing the changes
641             brought to the I<$path>. The changes are returned in ascending commit order.
642              
643             =head2 list($regex)
644              
645             @entries = $gs->list( qr/\.txt$/ );
646              
647             Returns a list of all entries in the repository, possibly filtered by the
648             optional I<$regex>.
649              
650             =head1 FAQ
651              
652             =head2 why the files are B<not> there?
653              
654             run
655              
656             git checkout
657              
658             =head2 any example?
659              
660             # if you just need a local repo, that's all you need.
661             mkdir sandbox
662             cd sandbox
663             git init
664             # use GitStore->new('/path/to/this/sandbox')
665             # set something
666             git checkout
667            
668             # follows are for remote git url
669             git remote add origin git@github.com:fayland/sandbox2.git
670             git push origin master
671             # do more GitStore->new('/path/to/this/sandbox') later
672             git checkout
673             git pull origin master
674             git push
675              
676             =head1 KNOWN BUGS
677              
678             If all files are deleted from the repository, a 'dummy' file
679             will be created to keep Git happy.
680              
681             =head1 SEE ALSO
682              
683             =over 4
684              
685             =item Article
686              
687             L<http://www.newartisans.com/2008/05/using-git-as-a-versioned-data-store-in-python.html>
688              
689             =item Python binding
690              
691             L<http://github.com/jwiegley/git-issues/tree/master>
692              
693             =item Ruby binding
694              
695             L<http://github.com/georgi/git_store/tree/master>
696              
697             =back
698              
699             =head1 Git URL
700              
701             L<http://github.com/fayland/perl-git-store/tree/master>
702              
703             =head1 AUTHORS
704              
705             =over 4
706              
707             =item *
708              
709             Fayland Lam <fayland@gmail.com>
710              
711             =item *
712              
713             Yanick Champoux <yanick@cpan.org>
714              
715             =back
716              
717             =head1 COPYRIGHT AND LICENSE
718              
719             This software is copyright (c) 2015 by Fayland Lam <fayland@gmail.com>.
720              
721             This is free software; you can redistribute it and/or modify it under
722             the same terms as the Perl 5 programming language system itself.
723              
724             =cut