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