Add ::Object::Blob.
[catagits/Gitalist.git] / lib / Gitalist / Git / Project.pm
CommitLineData
56b6dbe6 1use MooseX::Declare;
2
b5b638f7 3=head1 NAME
4
894bff59 5Gitalist::Git::Project - Model of a git repository
b5b638f7 6
7=head1 SYNOPSIS
8
561a3f14 9 my $gitrepo = dir('/repo/base/Gitalist');
10 my $project = Gitalist::Git::Project->new($gitrepo);
11 $project->name; # 'Gitalist'
12 $project->path; # '/repo/base/Gitalist/.git'
13 $project->description; # 'Unnamed repository.'
b5b638f7 14
15=head1 DESCRIPTION
16
17This class models a git repository, referred to in Gitalist
18as a "Project".
19
20=cut
21
38b9e5c8 22class Gitalist::Git::Project with Gitalist::Git::HasUtils {
56b6dbe6 23 # FIXME, use Types::Path::Class and coerce
24 use MooseX::Types::Common::String qw/NonEmptySimpleStr/;
84f31a44 25 use MooseX::Types::Path::Class qw/Dir/;
829d41ed 26 use MooseX::Types::Moose qw/Str Maybe Bool HashRef ArrayRef/;
77edf882 27 use List::MoreUtils qw/any zip/;
b5b638f7 28 use DateTime;
e1307124 29 use Gitalist::Git::Object::Commit;
f3083570 30 use Gitalist::Git::Object::Blob;
a8a8f8f9 31 use aliased 'Gitalist::Git::Object';
56b6dbe6 32
32a371cc 33 our $SHA1RE = qr/[0-9a-fA-F]{40}/;
34
35 around BUILDARGS (ClassName $class: Dir $dir) {
4b6bcf44 36 # Allows us to be called as Project->new($dir)
37 # Last path component becomes $self->name
38 # Full path to git objects becomes $self->path
32a371cc 39 my $name = $dir->dir_list(-1);
40 $dir = $dir->subdir('.git') if (-f $dir->file('.git', 'HEAD'));
41 confess("Can't find a git repository at " . $dir)
42 unless ( -f $dir->file('HEAD') );
43 return $class->$orig(name => $name,
44 path => $dir);
45 }
46
b5b638f7 47=head1 ATTRIBUTES
48
49=head2 name
50
cc88eca5 51The name of the Project. By default, this is derived from the path to the git repository.
29debefd 52
cc88eca5 53=cut
56b6dbe6 54 has name => ( isa => NonEmptySimpleStr,
01ced85b 55 is => 'ro', required => 1 );
b5b638f7 56
57=head2 path
58
59L<Path::Class:Dir> for the location of the git repository.
60
61=cut
84f31a44 62 has path => ( isa => Dir,
01ced85b 63 is => 'ro', required => 1);
56b6dbe6 64
b5b638f7 65=head2 description
66
67String containing .git/description
68
69=cut
0617cbd0 70 has description => ( isa => Str,
56b6dbe6 71 is => 'ro',
72 lazy_build => 1,
73 );
b5b638f7 74
75=head2 owner
76
77Owner of the files on disk.
78
79=cut
56b6dbe6 80 has owner => ( isa => NonEmptySimpleStr,
81 is => 'ro',
82 lazy_build => 1,
83 );
b5b638f7 84
85=head2 last_change
86
87L<DateTime> for the time of the last update.
88undef if the repository has never been used.
89
90=cut
0617cbd0 91 has last_change => ( isa => Maybe['DateTime'],
56b6dbe6 92 is => 'ro',
93 lazy_build => 1,
94 );
95
b5b638f7 96=head2 is_bare
97
98Bool indicating whether this Project is bare.
99
100=cut
b5b638f7 101 has is_bare => ( isa => Bool,
102 is => 'ro',
103 lazy => 1,
104 default => sub {
105 -d $_[0]->path->parent->subdir->($_[0]->name)
106 ? 1 : 0
107 },
108 );
84f31a44 109
cc88eca5 110=head2 heads
111
112ArrayRef of hashes containing the name and sha1 of all heads.
113
114=cut
115 has heads => ( isa => ArrayRef[HashRef],
116 is => 'ro',
117 lazy_build => 1);
118
119=head2 references
120
121Hashref of ArrayRefs for each reference.
122
123=cut
124 has references => ( isa => HashRef[ArrayRef[Str]],
125 is => 'ro',
126 lazy_build => 1 );
127
01ced85b 128 method BUILD {
38b9e5c8 129 $self->$_() for qw/last_change owner description/; # Ensure to build early.
01ced85b 130 }
131
32a371cc 132=head1 METHODS
8dbe8024 133
cc88eca5 134=head2 head_hash ($head?)
894bff59 135
32a371cc 136Return the sha1 for HEAD, or any specified head.
894bff59 137
32a371cc 138=cut
32a371cc 139 method head_hash (Str $head?) {
140 my $output = $self->run_cmd(qw/rev-parse --verify/, $head || 'HEAD' );
141 confess("No such head: " . $head) unless defined $output;
29debefd 142
32a371cc 143 my($sha1) = $output =~ /^($SHA1RE)$/;
144 return $sha1;
56b6dbe6 145 }
146
cc88eca5 147=head2 list_tree ($sha1?)
a8a8f8f9 148
149Return an array of contents for a given tree.
150The tree is specified by sha1, and defaults to HEAD.
cc88eca5 151Each item is a L<Gitalist::Git::Object>.
a8a8f8f9 152
153=cut
a8a8f8f9 154 method list_tree (Str $sha1?) {
155 $sha1 ||= $self->head_hash;
b36b7e0b 156 my $object = $self->get_object($sha1);
157 return @{$object->tree};
a8a8f8f9 158 }
159
cc88eca5 160=head2 get_object ($sha1)
161
162Return a L<Gitalist::Git::Object> for the given sha1.
163
164=cut
8bb7649b 165 method get_object (NonEmptySimpleStr $sha1) {
894bff59 166 unless ( $self->_is_valid_rev($sha1) ) {
8bb7649b 167 $sha1 = $self->head_hash($sha1);
168 }
e1307124 169 my $type = $self->run_cmd('cat-file', '-t', $sha1);
170 chomp($type);
171 my $class = 'Gitalist::Git::Object';
f3083570 172 use Moose::Autobox;
173 if ($type eq ['commit', 'blob']->any) {
e1307124 174 $class .= '::' . ucfirst($type);
175 };
176 return $class->new(
54368e9d 177 project => $self,
178 sha1 => $sha1,
f3083570 179 type => $type,
54368e9d 180 );
181 }
8bb7649b 182
cc88eca5 183=head2 hash_by_path($sha1, $path, $type?)
894bff59 184
cc88eca5 185Returns the sha1 for a given path, optionally limited by type.
186
187=cut
fc11c7f1 188 method hash_by_path ($base, $path = '', $type?) {
54368e9d 189 $path =~ s{/+$}();
32a371cc 190 # FIXME should this really just take the first result?
191 my @paths = $self->run_cmd('ls-tree', $base, '--', $path)
54368e9d 192 or return;
32a371cc 193 my $line = $paths[0];
54368e9d 194
195 #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa panic.c'
196 $line =~ m/^([0-9]+) (.+) ($SHA1RE)\t/;
197 return defined $type && $type ne $2
198 ? ()
199 : $3;
200 }
201
cc88eca5 202=head2 list_revs($sha1, $count?, $skip?, \%search?, $file?)
203
204Returns a list of revs for the given head ($sha1).
205
206=cut
4111e151 207 method list_revs ( NonEmptySimpleStr :$sha1!,
208 Int :$count?,
209 Int :$skip?,
210 HashRef :$search?,
05e8b4d0 211 NonEmptySimpleStr :$file? ) {
4111e151 212 $sha1 = $self->head_hash($sha1)
213 if !$sha1 || $sha1 !~ $SHA1RE;
214
215 my @search_opts;
05e8b4d0 216 if ($search) {
4111e151 217 $search->{type} = 'grep'
218 if $search->{type} eq 'commit';
219 @search_opts = (
220 # This seems a little fragile ...
221 qq[--$search->{type}=$search->{text}],
222 '--regexp-ignore-case',
223 $search->{regexp} ? '--extended-regexp' : '--fixed-strings'
224 );
225 }
226
227 my $output = $self->run_cmd(
228 'rev-list',
229 '--header',
230 (defined $count ? "--max-count=$count" : ()),
231 (defined $skip ? "--skip=$skip" : ()),
232 @search_opts,
233 $sha1,
234 '--',
235 ($file ? $file : ()),
236 );
237 return unless $output;
238
cc88eca5 239 my @revs = $self->_parse_rev_list($output);
4111e151 240
241 return @revs;
242 }
243
cc88eca5 244=head2 diff($commit, $patch?, $parent?, $file?)
245
1501cb4e 246Generate a diff from a given L<Gitalist::Git::Object>.
cc88eca5 247
248=cut
54368e9d 249
cc88eca5 250 method diff ( Gitalist::Git::Object :$commit!,
77edf882 251 Bool :$patch?,
fc948aee 252 Maybe[NonEmptySimpleStr] :$parent?,
1501cb4e 253 NonEmptySimpleStr :$file?
254 ) {
255 return $commit->diff( patch => $patch,
256 parent => $parent,
257 file => $file);
77edf882 258 }
259
cc88eca5 260=head2 reflog(@lorgargs)
77edf882 261
cc88eca5 262Return a list of hashes representing each reflog entry.
77edf882 263
cc88eca5 264FIXME Should this return objects?
54368e9d 265
cc88eca5 266=cut
d8abdf1c 267 method reflog (@logargs) {
268 my @entries
269 = $self->run_cmd(qw(log -g), @logargs)
270 =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg;
271
05e8b4d0 272 # commit 02526fc15beddf2c64798a947fecdd8d11bf993d
273 # Reflog: HEAD@{14} (The Git Server <git@git.dev.venda.com>)
274 # Reflog message: push
275 # Author: Foo Barsby <fbarsby@example.com>
276 # Date: Thu Sep 17 12:26:05 2009 +0100
277 #
278 # Merge branch 'abc123'
d8abdf1c 279
280 return map {
281 # XXX Stuff like this makes me want to switch to Git::PurePerl
282 my($sha1, $type, $author, $date)
283 = m{
284 ^ commit \s+ ($SHA1RE)$
285 .*?
286 Reflog[ ]message: \s+ (.+?)$ \s+
287 Author: \s+ ([^<]+) <.*?$ \s+
288 Date: \s+ (.+?)$
289 }xms;
290
291 pos($_) = index($_, $date) + length $date;
292
293 # Yeah, I just did that.
294 my($msg) = /\G\s+(\S.*)/sg;
295 {
296 hash => $sha1,
297 type => $type,
298 author => $author,
299
300 # XXX Add DateTime goodness.
301 date => $date,
302 message => $msg,
303 }
304 ;
305 } @entries;
306 }
307
cc88eca5 308 ## BUILDERS
32a371cc 309 method _build__util {
310 Gitalist::Git::Util->new(
311 project => $self,
312 );
313 }
314
315 method _build_description {
76c97bf6 316 my $description = "";
5d8568c6 317 eval {
76c97bf6 318 $description = $self->path->file('description')->slurp;
319 chomp $description;
5d8568c6 320 };
76c97bf6 321 return $description;
32a371cc 322 }
323
324 method _build_owner {
325 my ($gecos, $name) = (getpwuid $self->path->stat->uid)[6,0];
326 $gecos =~ s/,+$//;
327 return length($gecos) ? $gecos : $name;
328 }
329
330 method _build_last_change {
331 my $last_change;
332 my $output = $self->run_cmd(
333 qw{ for-each-ref --format=%(committer)
334 --sort=-committerdate --count=1 refs/heads
335 });
336 if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
337 my $dt = DateTime->from_epoch(epoch => $epoch);
338 $dt->set_time_zone($tz);
339 $last_change = $dt;
340 }
341 return $last_change;
342 }
343
cc88eca5 344 method _build_heads {
345 my @revlines = $self->run_cmd_list(qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
346 my @ret;
347 for my $line (@revlines) {
348 my ($rev, $head, $commiter) = split /\0/, $line, 3;
349 $head =~ s!^refs/heads/!!;
350
351 push @ret, { sha1 => $rev, name => $head };
352
353 #FIXME: That isn't the time I'm looking for..
354 if (my ($epoch, $tz) = $line =~ /\s(\d+)\s+([+-]\d+)$/) {
355 my $dt = DateTime->from_epoch(epoch => $epoch);
356 $dt->set_time_zone($tz);
357 $ret[-1]->{last_change} = $dt;
358 }
359 }
360
361 return \@ret;
362 }
363
364 method _build_references {
365 # 5dc01c595e6c6ec9ccda4f6f69c131c0dd945f8c refs/tags/v2.6.11
366 # c39ae07f393806ccf406ef966e9a15afc43cc36a refs/tags/v2.6.11^{}
367 my @reflist = $self->run_cmd_list(qw(show-ref --dereference))
05e8b4d0 368 or return;
cc88eca5 369 my %refs;
05e8b4d0 370 for (@reflist) {
371 push @{$refs{$1}}, $2
372 if m!^($SHA1RE)\srefs/(.*)$!;
373 }
cc88eca5 374
05e8b4d0 375 return \%refs;
cc88eca5 376 }
377
378 ## Private methods
379 method _is_valid_rev (Str $rev) {
380 return ($rev =~ /^($SHA1RE)$/);
381 }
382
383 method _parse_rev_list ($output) {
384 return
385 map $self->get_gpp_object($_),
386 grep $self->_is_valid_rev($_),
387 map split(/\n/, $_, 6), split /\0/, $output;
388 }
389
b5b638f7 390=head1 SEE ALSO
391
392L<Gitalist::Git::Util> L<Gitalist::Git::Object>
393
394=head1 AUTHORS AND COPYRIGHT
395
396 Catalyst application:
397 (C) 2009 Venda Ltd and Dan Brook <dbrook@venda.com>
398
399 Original gitweb.cgi from which this was derived:
400 (C) 2005-2006, Kay Sievers <kay.sievers@vrfy.org>
401 (C) 2005, Christian Gierke
402
403=head1 LICENSE
404
405FIXME - Is this going to be GPLv2 as per gitweb? If so this is broken..
406
407This library is free software. You can redistribute it and/or modify
408it under the same terms as Perl itself.
409
410=cut
411
56b6dbe6 412} # end class