File Coverage

blib/lib/Git/PurePerl.pm
Criterion Covered Total %
statement 288 308 93.5
branch 46 76 60.5
condition 18 48 37.5
subroutine 64 66 96.9
pod 7 23 30.4
total 423 521 81.1


line stmt bran cond sub pod time code
1             package Git::PurePerl;
2 4     4   136107 use Moose;
  4         1174510  
  4         19  
3 4     4   19664 use MooseX::StrictConstructor;
  4         74844  
  4         12  
4 4     4   24342 use MooseX::Types::Path::Class;
  4         345896  
  4         17  
5 4     4   4750 use Compress::Zlib qw(uncompress);
  4         155735  
  4         261  
6 4     4   1666 use Data::Stream::Bulk;
  4         312727  
  4         115  
7 4     4   1987 use Data::Stream::Bulk::Array;
  4         57473  
  4         126  
8 4     4   2088 use Data::Stream::Bulk::Path::Class;
  4         107798  
  4         131  
9 4     4   3487 use DateTime;
  4         1017658  
  4         169  
10 4     4   2352 use Digest::SHA;
  4         8018  
  4         152  
11 4     4   1783 use File::Find::Rule;
  4         21884  
  4         22  
12 4     4   1427 use Git::PurePerl::Actor;
  4         11  
  4         149  
13 4     4   1765 use Git::PurePerl::Config;
  4         8  
  4         121  
14 4     4   1379 use Git::PurePerl::DirectoryEntry;
  4         1014  
  4         115  
15 4     4   1768 use Git::PurePerl::Loose;
  4         1162  
  4         110  
16 4     4   1553 use Git::PurePerl::Object;
  4         10  
  4         120  
17 4     4   1718 use Git::PurePerl::NewDirectoryEntry;
  4         10  
  4         126  
18 4     4   1616 use Git::PurePerl::NewObject;
  4         1058  
  4         123  
19 4     4   1811 use Git::PurePerl::NewObject::Blob;
  4         8  
  4         119  
20 4     4   1769 use Git::PurePerl::NewObject::Commit;
  4         1042  
  4         126  
21 4     4   1791 use Git::PurePerl::NewObject::Tag;
  4         7  
  4         119  
22 4     4   1767 use Git::PurePerl::NewObject::Tree;
  4         984  
  4         147  
23 4     4   1723 use Git::PurePerl::Object::Tree;
  4         965  
  4         119  
24 4     4   1672 use Git::PurePerl::Object::Blob;
  4         10  
  4         109  
25 4     4   1627 use Git::PurePerl::Object::Commit;
  4         1112  
  4         131  
26 4     4   1805 use Git::PurePerl::Object::Tag;
  4         992  
  4         148  
27 4     4   44 use Git::PurePerl::Object::Tree;
  4         5  
  4         74  
28 4     4   1766 use Git::PurePerl::Pack;
  4         914  
  4         128  
29 4     4   1659 use Git::PurePerl::Pack::WithIndex;
  4         1018  
  4         119  
30 4     4   1724 use Git::PurePerl::Pack::WithoutIndex;
  4         943  
  4         120  
31 4     4   1706 use Git::PurePerl::PackIndex;
  4         1146  
  4         136  
32 4     4   2073 use Git::PurePerl::PackIndex::Version1;
  4         1112  
  4         134  
33 4     4   1974 use Git::PurePerl::PackIndex::Version2;
  4         1068  
  4         135  
34 4     4   1851 use Git::PurePerl::Protocol;
  4         963  
  4         112  
35 4     4   1959 use IO::Digest;
  4         9188  
  4         91  
36 4     4   1736 use IO::Socket::INET;
  4         36068  
  4         21  
37 4     4   1393 use Path::Class;
  4         9  
  4         228  
38 4     4   18 use namespace::autoclean;
  4         5  
  4         70  
39              
40             our $VERSION = '0.53';
41             $VERSION = eval $VERSION;
42              
43             has 'directory' => (
44             is => 'ro',
45             isa => 'Path::Class::Dir',
46             required => 0,
47             coerce => 1
48             );
49              
50             has 'gitdir' => (
51             is => 'ro',
52             isa => 'Path::Class::Dir',
53             required => 1,
54             coerce => 1
55             );
56              
57             has 'loose' => (
58             is => 'rw',
59             isa => 'Git::PurePerl::Loose',
60             required => 0,
61             lazy_build => 1,
62             );
63              
64             has 'packs' => (
65             is => 'rw',
66             isa => 'ArrayRef[Git::PurePerl::Pack]',
67             required => 0,
68             auto_deref => 1,
69             lazy_build => 1,
70             );
71              
72             has 'description' => (
73             is => 'rw',
74             isa => 'Str',
75             lazy => 1,
76             default => sub {
77             my $self = shift;
78             file( $self->gitdir, 'description' )->slurp( chomp => 1 );
79             }
80             );
81              
82             has 'config' => (
83             is => 'ro',
84             isa => 'Git::PurePerl::Config',
85             lazy => 1,
86             default => sub {
87             my $self = shift;
88             Git::PurePerl::Config->new(git => $self);
89             }
90             );
91              
92             __PACKAGE__->meta->make_immutable;
93              
94             sub BUILDARGS {
95 9     9 1 53 my $class = shift;
96 9         103 my $params = $class->SUPER::BUILDARGS(@_);
97              
98 9   66     134 $params->{'gitdir'} ||= dir( $params->{'directory'}, '.git' );
99 9         578 return $params;
100             }
101              
102             sub BUILD {
103 9     9 0 12 my $self = shift;
104              
105 9 50       240 unless ( -d $self->gitdir ) {
106 0         0 confess $self->gitdir . ' is not a directory';
107             }
108 9 50 66     550 unless ( not defined $self->directory or -d $self->directory ) {
109 0         0 confess $self->directory . ' is not a directory';
110             }
111             }
112              
113             sub _build_loose {
114 9     9   19 my $self = shift;
115 9         196 my $loose_dir = dir( $self->gitdir, 'objects' );
116 9         544 return Git::PurePerl::Loose->new( directory => $loose_dir );
117             }
118              
119             sub _build_packs {
120 9     9   16 my $self = shift;
121 9         197 my $pack_dir = dir( $self->gitdir, 'objects', 'pack' );
122 9         320 my @packs;
123 9         253 foreach my $filename ( $pack_dir->children ) {
124 6 100       1087 next unless $filename =~ /\.pack$/;
125 3         170 push @packs,
126             Git::PurePerl::Pack::WithIndex->new( filename => $filename );
127             }
128 9         1166 return \@packs;
129             }
130              
131             sub _ref_names_recursive {
132 22     22   27 my ( $dir, $base, $names ) = @_;
133              
134 22         53 foreach my $file ( $dir->children ) {
135 5 50       973 if ( -d $file ) {
136 0         0 my $reldir = $file->relative($dir);
137 0         0 my $subbase = $base . $reldir . "/";
138 0         0 _ref_names_recursive( $file, $subbase, $names );
139             } else {
140 5         150 push @$names, $base . $file->basename;
141             }
142             }
143             }
144              
145             sub ref_names {
146 11     11 0 7941 my $self = shift;
147 11         14 my @names;
148 11         26 foreach my $type (qw(heads remotes tags)) {
149 33         1665 my $dir = dir( $self->gitdir, 'refs', $type );
150 33 100       1181 next unless -d $dir;
151 22         537 my $base = "refs/$type/";
152 22         48 _ref_names_recursive( $dir, $base, \@names );
153             }
154 11         1222 my $packed_refs = file( $self->gitdir, 'packed-refs' );
155 11 100       589 if ( -f $packed_refs ) {
156 6         184 foreach my $line ( $packed_refs->slurp( chomp => 1 ) ) {
157 12 100       741 next if $line =~ /^#/;
158 6 50       10 next if $line =~ /^\^/;
159 6         17 my ( $sha1, $name ) = split ' ', $line;
160 6         14 push @names, $name;
161             }
162             }
163 11         219 return @names;
164             }
165              
166             sub refs_sha1 {
167 3     3 0 6 my $self = shift;
168 3         5 return map { $self->ref_sha1($_) } $self->ref_names;
  3         9  
169             }
170              
171             sub refs {
172 3     3 0 4 my $self = shift;
173 3         5 return map { $self->ref($_) } $self->ref_names;
  3         7  
174             }
175              
176             sub ref_sha1 {
177 30     30 0 44 my ( $self, $wantref ) = @_;
178 30         792 my $dir = dir( $self->gitdir, 'refs' );
179 30 50       1088 return unless -d $dir;
180              
181 30 50       771 if ($wantref eq "HEAD") {
182 0         0 my $file = file($self->gitdir, 'HEAD');
183 0   0     0 my $sha1 = file($file)->slurp
184             || confess("Error reading $file: $!");
185 0         0 chomp $sha1;
186 0         0 return _ensure_sha1_is_sha1( $self, $sha1 );
187             }
188              
189 30         206 foreach my $file ( File::Find::Rule->new->file->in($dir) ) {
190 16         14291 my $ref = 'refs/' . file($file)->relative($dir)->as_foreign('Unix');
191 16 50       6321 if ( $ref eq $wantref ) {
192 16   33     42 my $sha1 = file($file)->slurp
193             || confess("Error reading $file: $!");
194 16         3024 chomp $sha1;
195 16         45 return _ensure_sha1_is_sha1( $self, $sha1 );
196             }
197             }
198              
199 14         11250 my $packed_refs = file( $self->gitdir, 'packed-refs' );
200 14 50       706 if ( -f $packed_refs ) {
201 14         400 my $last_name;
202             my $last_sha1;
203 14         43 foreach my $line ( $packed_refs->slurp( chomp => 1 ) ) {
204 28 100       1807 next if $line =~ /^#/;
205 14         38 my ( $sha1, $name ) = split ' ', $line;
206 14         20 $sha1 =~ s/^\^//;
207 14   33     23 $name ||= $last_name;
208              
209 14 0 33     30 return _ensure_sha1_is_sha1( $self, $last_sha1 ) if $last_name and $last_name eq $wantref and $name ne $wantref;
      33        
210              
211 14         12 $last_name = $name;
212 14         19 $last_sha1 = $sha1;
213             }
214 14 50       38 return _ensure_sha1_is_sha1( $self, $last_sha1 ) if $last_name eq $wantref;
215             }
216 0         0 return undef;
217             }
218              
219             sub _ensure_sha1_is_sha1 {
220 30     30   36 my ( $self, $sha1 ) = @_;
221 30 50       78 return $self->ref_sha1($1) if $sha1 =~ /^ref: (.*)/;
222 30         159 return $sha1;
223             }
224              
225             sub ref {
226 21     21 0 34 my ( $self, $wantref ) = @_;
227 21         50 return $self->get_object( $self->ref_sha1($wantref) );
228             }
229              
230             sub master_sha1 {
231 3     3 0 12 my $self = shift;
232 3         7 return $self->ref_sha1('refs/heads/master');
233             }
234              
235             sub master {
236 9     9 1 20 my $self = shift;
237 9         30 return $self->ref('refs/heads/master');
238             }
239              
240             sub head_sha1 {
241 0     0 0 0 my $self = shift;
242 0         0 return $self->ref_sha1('HEAD');
243             }
244              
245             sub head {
246 0     0 0 0 my $self = shift;
247 0         0 return $self->ref('HEAD');
248             }
249              
250             sub get_object {
251 869     869 1 1120 my ( $self, $sha1 ) = @_;
252 869 100       1298 return unless $sha1;
253 866   66     1285 return $self->get_object_packed($sha1) || $self->get_object_loose($sha1);
254             }
255              
256             sub get_objects {
257 11     11 0 63 my ( $self, @sha1s ) = @_;
258 11         27 return map { $self->get_object($_) } @sha1s;
  801         1477  
259             }
260              
261             sub get_object_packed {
262 866     866 1 794 my ( $self, $sha1 ) = @_;
263              
264 866         19252 foreach my $pack ( $self->packs ) {
265 798         2122 my ( $kind, $size, $content ) = $pack->get_object($sha1);
266 798 50 33     4203 if ( defined($kind) && defined($size) && defined($content) ) {
      33        
267 798         1654 return $self->create_object( $sha1, $kind, $size, $content );
268             }
269             }
270             }
271              
272             sub get_object_loose {
273 68     68 1 77 my ( $self, $sha1 ) = @_;
274              
275 68         1478 my ( $kind, $size, $content ) = $self->loose->get_object($sha1);
276 68 50 33     479 if ( defined($kind) && defined($size) && defined($content) ) {
      33        
277 68         169 return $self->create_object( $sha1, $kind, $size, $content );
278             }
279             }
280              
281             sub create_object {
282 866     866 1 1005 my ( $self, $sha1, $kind, $size, $content ) = @_;
283 866 100       1925 if ( $kind eq 'commit' ) {
    100          
    50          
    0          
284 155         5066 return Git::PurePerl::Object::Commit->new(
285             sha1 => $sha1,
286             kind => $kind,
287             size => $size,
288             content => $content,
289             git => $self,
290             );
291             } elsif ( $kind eq 'tree' ) {
292 403         12220 return Git::PurePerl::Object::Tree->new(
293             sha1 => $sha1,
294             kind => $kind,
295             size => $size,
296             content => $content,
297             git => $self,
298             );
299             } elsif ( $kind eq 'blob' ) {
300 308         9527 return Git::PurePerl::Object::Blob->new(
301             sha1 => $sha1,
302             kind => $kind,
303             size => $size,
304             content => $content,
305             git => $self,
306             );
307             } elsif ( $kind eq 'tag' ) {
308 0         0 return Git::PurePerl::Object::Tag->new(
309             sha1 => $sha1,
310             kind => $kind,
311             size => $size,
312             content => $content,
313             git => $self,
314             );
315             } else {
316 0         0 confess "unknown kind $kind: $content";
317             }
318             }
319              
320             sub all_sha1s {
321 20     20 1 284 my $self = shift;
322 20         536 my $dir = dir( $self->gitdir, 'objects' );
323              
324 20         765 my @streams;
325 20         485 push @streams, $self->loose->all_sha1s;
326              
327 20         4030 foreach my $pack ( $self->packs ) {
328 6         26 push @streams, $pack->all_sha1s;
329             }
330              
331 20         709 return Data::Stream::Bulk::Cat->new( streams => \@streams );
332             }
333              
334             sub all_objects {
335 10     10 0 9514 my $self = shift;
336 10         29 my $stream = $self->all_sha1s;
337             return Data::Stream::Bulk::Filter->new(
338 11     11   1338 filter => sub { return [ $self->get_objects(@$_) ] },
339 10         1469 stream => $stream,
340             );
341             }
342              
343             sub put_object {
344 14     14 0 44 my ( $self, $object, $ref ) = @_;
345 14         358 $self->loose->put_object($object);
346              
347 14 100       926 if ( $object->kind eq 'commit' ) {
348 4 50       14 $ref = 'master' unless $ref;
349 4         93 $self->update_ref( $ref, $object->sha1 );
350             }
351             }
352              
353             sub update_ref {
354 5     5 0 14 my ( $self, $refname, $sha1 ) = @_;
355 5         114 my $ref = file( $self->gitdir, 'refs', 'heads', $refname );
356 5         341 $ref->parent->mkpath;
357 5         484 my $ref_fh = $ref->openw;
358 5 50       760 $ref_fh->print($sha1) || die "Error writing to $ref";
359              
360             # FIXME is this always what we want?
361 5         172 my $head = file( $self->gitdir, 'HEAD' );
362 5         249 my $head_fh = $head->openw;
363 5 50       682 $head_fh->print("ref: refs/heads/$refname")
364             || die "Error writing to $head";
365             }
366              
367             sub init {
368 3     3 0 88390 my ( $class, %arguments ) = @_;
369              
370 3         10 my $directory = $arguments{directory};
371 3         5 my $git_dir;
372              
373 3 100       14 unless ( defined $directory ) {
374             $git_dir = $arguments{gitdir}
375 1   33     5 || confess
376             "init() needs either a 'directory' or a 'gitdir' argument";
377             } else {
378 2 50       14 if ( not defined $arguments{gitdir} ) {
379 2         9 $git_dir = $arguments{gitdir} = dir( $directory, '.git' );
380             }
381 2         91 dir($directory)->mkpath;
382             }
383              
384 3         529 dir($git_dir)->mkpath;
385 3         495 dir( $git_dir, 'refs', 'tags' )->mkpath;
386 3         635 dir( $git_dir, 'objects', 'info' )->mkpath;
387 3         595 dir( $git_dir, 'objects', 'pack' )->mkpath;
388 3         414 dir( $git_dir, 'branches' )->mkpath;
389 3         431 dir( $git_dir, 'hooks' )->mkpath;
390              
391 3 100       396 my $bare = defined($directory) ? 'false' : 'true';
392 3         15 $class->_add_file(
393             file( $git_dir, 'config' ),
394             "[core]\n\trepositoryformatversion = 0\n\tfilemode = true\n\tbare = $bare\n\tlogallrefupdates = true\n"
395             );
396 3         177 $class->_add_file( file( $git_dir, 'description' ),
397             "Unnamed repository; edit this file to name it for gitweb.\n" );
398 3         108 $class->_add_file(
399             file( $git_dir, 'hooks', 'applypatch-msg' ),
400             "# add shell script and make executable to enable\n"
401             );
402 3         103 $class->_add_file( file( $git_dir, 'hooks', 'post-commit' ),
403             "# add shell script and make executable to enable\n" );
404 3         106 $class->_add_file(
405             file( $git_dir, 'hooks', 'post-receive' ),
406             "# add shell script and make executable to enable\n"
407             );
408 3         103 $class->_add_file( file( $git_dir, 'hooks', 'post-update' ),
409             "# add shell script and make executable to enable\n" );
410 3         106 $class->_add_file(
411             file( $git_dir, 'hooks', 'pre-applypatch' ),
412             "# add shell script and make executable to enable\n"
413             );
414 3         99 $class->_add_file( file( $git_dir, 'hooks', 'pre-commit' ),
415             "# add shell script and make executable to enable\n" );
416 3         96 $class->_add_file( file( $git_dir, 'hooks', 'pre-rebase' ),
417             "# add shell script and make executable to enable\n" );
418 3         97 $class->_add_file( file( $git_dir, 'hooks', 'update' ),
419             "# add shell script and make executable to enable\n" );
420              
421 3         109 dir( $git_dir, 'info' )->mkpath;
422 3         488 $class->_add_file( file( $git_dir, 'info', 'exclude' ),
423             "# *.[oa]\n# *~\n" );
424              
425 3         232 return $class->new(%arguments);
426             }
427              
428             sub checkout {
429 4     4 0 3965 my ( $self, $directory, $tree ) = @_;
430 4   33     22 $directory ||= $self->directory;
431 4   33     43 $tree ||= $self->master->tree;
432 4 50       101 confess("Missing tree") unless $tree;
433 4         103 foreach my $directory_entry ( $tree->directory_entries ) {
434 5         133 my $filename = file( $directory, $directory_entry->filename );
435 5         395 my $sha1 = $directory_entry->sha1;
436 5         123 my $mode = $directory_entry->mode;
437 5         13 my $object = $self->get_object($sha1);
438 5 50       132 if ( $object->kind eq 'blob' ) {
    0          
439 5         114 $self->_add_file( $filename, $object->content );
440 5 50       195 chmod( oct( '0' . $mode ), $filename )
441             || die "Error chmoding $filename to $mode: $!";
442             } elsif ( $object->kind eq 'tree' ) {
443 0         0 dir($filename)->mkpath;
444 0         0 $self->checkout( $filename, $object );
445             } else {
446 0         0 die $object->kind;
447             }
448             }
449             }
450              
451             sub clone {
452 1     1 0 727 my $self = shift;
453              
454 1         2 my $remote;
455 1 50       6 if (@_ == 2) {
456             # For backwards compatibility
457 1         4 $remote = "git://$_[0]";
458 1 50       8 $remote .= "/" unless $_[1] =~ m{^/};
459 1         3 $remote .= $_[1];
460             } else {
461 0         0 $remote = shift;
462             }
463              
464 1         54 my $protocol = Git::PurePerl::Protocol->new(
465             remote => $remote,
466             );
467              
468 1         7 my $sha1s = $protocol->connect;
469 1         2 my $head = $sha1s->{HEAD};
470 1         21 my $data = $protocol->fetch_pack($head);
471              
472 1         32 my $filename
473             = file( $self->gitdir, 'objects', 'pack', 'pack-' . $head . '.pack' );
474 1         142 $self->_add_file( $filename, $data );
475              
476 1         79 my $pack
477             = Git::PurePerl::Pack::WithoutIndex->new( filename => $filename );
478 1         6 $pack->create_index();
479              
480 1         184 $self->update_ref( master => $head );
481             }
482              
483             sub _add_file {
484 39     39   2319 my ( $class, $filename, $contents ) = @_;
485 39   33     104 my $fh = $filename->openw || confess "Error opening to $filename: $!";
486 39         5865 binmode($fh); #important for Win32
487 39 50       134 $fh->print($contents) || confess "Error writing to $filename: $!";
488 39 50       904 $fh->close || confess "Error closing $filename: $!";
489             }
490              
491             1;
492              
493             __END__
494              
495             =head1 NAME
496              
497             Git::PurePerl - A Pure Perl interface to Git repositories
498              
499             =head1 SYNOPSIS
500              
501             my $git = Git::PurePerl->new(
502             directory => '/path/to/git/'
503             );
504             $git->master->committer;
505             $git->master->comment;
506             $git->get_object($git->master->tree);
507              
508             =head1 DESCRIPTION
509              
510             This module is a Pure Perl interface to Git repositories.
511              
512             It was mostly based on Grit L<http://grit.rubyforge.org/>.
513              
514             =head1 METHODS
515              
516             =over 4
517              
518             =item master
519              
520             =item get_object
521              
522             =item get_object_packed
523              
524             =item get_object_loose
525              
526             =item create_object
527              
528             =item all_sha1s
529              
530             =back
531              
532             =head1 MAINTAINANCE
533              
534             This module is maintained in git at L<http://github.com/broquaint/git-pureperl/>.
535              
536             Patches are welcome, please come speak to one of the L<Gitalist> team
537             on C<< #gitalist >>.
538              
539             =head1 AUTHOR
540              
541             Leon Brocard <acme@astray.com>
542              
543             =head1 CONTRIBUTORS
544              
545             =over 4
546              
547             =item Chris Reinhardt
548              
549             =item Tomas (t0m) Doran
550              
551             =item Dan (broquaint) Brook
552              
553             =item Alex Vandiver
554              
555             =item Dagfinn Ilmari MannsE<aring>ker
556              
557             =back
558              
559             =head1 COPYRIGHT
560              
561             Copyright (C) 2008, Leon Brocard and the above mentioned contributors.
562              
563             =head1 LICENSE
564              
565             This module is free software; you can redistribute it or
566             modify it under the same terms as Perl itself.
567              
568             =cut