Project->list_tree implementation becomes an access to Object->tree.
[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;
b36b7e0b 154 my $object = $self->get_object($sha1);
155 return @{$object->tree};
a8a8f8f9 156 }
157
cc88eca5 158=head2 get_object ($sha1)
159
160Return a L<Gitalist::Git::Object> for the given sha1.
161
162=cut
8bb7649b 163 method get_object (NonEmptySimpleStr $sha1) {
894bff59 164 unless ( $self->_is_valid_rev($sha1) ) {
8bb7649b 165 $sha1 = $self->head_hash($sha1);
166 }
77edf882 167 return Object->new(
54368e9d 168 project => $self,
169 sha1 => $sha1,
170 );
171 }
8bb7649b 172
cc88eca5 173=head2 hash_by_path($sha1, $path, $type?)
894bff59 174
cc88eca5 175Returns the sha1 for a given path, optionally limited by type.
176
177=cut
fc11c7f1 178 method hash_by_path ($base, $path = '', $type?) {
54368e9d 179 $path =~ s{/+$}();
32a371cc 180 # FIXME should this really just take the first result?
181 my @paths = $self->run_cmd('ls-tree', $base, '--', $path)
54368e9d 182 or return;
32a371cc 183 my $line = $paths[0];
54368e9d 184
185 #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa panic.c'
186 $line =~ m/^([0-9]+) (.+) ($SHA1RE)\t/;
187 return defined $type && $type ne $2
188 ? ()
189 : $3;
190 }
191
cc88eca5 192=head2 list_revs($sha1, $count?, $skip?, \%search?, $file?)
193
194Returns a list of revs for the given head ($sha1).
195
196=cut
4111e151 197 method list_revs ( NonEmptySimpleStr :$sha1!,
198 Int :$count?,
199 Int :$skip?,
200 HashRef :$search?,
05e8b4d0 201 NonEmptySimpleStr :$file? ) {
4111e151 202 $sha1 = $self->head_hash($sha1)
203 if !$sha1 || $sha1 !~ $SHA1RE;
204
205 my @search_opts;
05e8b4d0 206 if ($search) {
4111e151 207 $search->{type} = 'grep'
208 if $search->{type} eq 'commit';
209 @search_opts = (
210 # This seems a little fragile ...
211 qq[--$search->{type}=$search->{text}],
212 '--regexp-ignore-case',
213 $search->{regexp} ? '--extended-regexp' : '--fixed-strings'
214 );
215 }
216
217 my $output = $self->run_cmd(
218 'rev-list',
219 '--header',
220 (defined $count ? "--max-count=$count" : ()),
221 (defined $skip ? "--skip=$skip" : ()),
222 @search_opts,
223 $sha1,
224 '--',
225 ($file ? $file : ()),
226 );
227 return unless $output;
228
cc88eca5 229 my @revs = $self->_parse_rev_list($output);
4111e151 230
231 return @revs;
232 }
233
cc88eca5 234=head2 diff($commit, $patch?, $parent?, $file?)
235
1501cb4e 236Generate a diff from a given L<Gitalist::Git::Object>.
cc88eca5 237
238=cut
54368e9d 239
cc88eca5 240 method diff ( Gitalist::Git::Object :$commit!,
77edf882 241 Bool :$patch?,
fc948aee 242 Maybe[NonEmptySimpleStr] :$parent?,
1501cb4e 243 NonEmptySimpleStr :$file?
244 ) {
245 return $commit->diff( patch => $patch,
246 parent => $parent,
247 file => $file);
77edf882 248 }
249
cc88eca5 250=head2 reflog(@lorgargs)
77edf882 251
cc88eca5 252Return a list of hashes representing each reflog entry.
77edf882 253
cc88eca5 254FIXME Should this return objects?
54368e9d 255
cc88eca5 256=cut
d8abdf1c 257 method reflog (@logargs) {
258 my @entries
259 = $self->run_cmd(qw(log -g), @logargs)
260 =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg;
261
05e8b4d0 262 # commit 02526fc15beddf2c64798a947fecdd8d11bf993d
263 # Reflog: HEAD@{14} (The Git Server <git@git.dev.venda.com>)
264 # Reflog message: push
265 # Author: Foo Barsby <fbarsby@example.com>
266 # Date: Thu Sep 17 12:26:05 2009 +0100
267 #
268 # Merge branch 'abc123'
d8abdf1c 269
270 return map {
271 # XXX Stuff like this makes me want to switch to Git::PurePerl
272 my($sha1, $type, $author, $date)
273 = m{
274 ^ commit \s+ ($SHA1RE)$
275 .*?
276 Reflog[ ]message: \s+ (.+?)$ \s+
277 Author: \s+ ([^<]+) <.*?$ \s+
278 Date: \s+ (.+?)$
279 }xms;
280
281 pos($_) = index($_, $date) + length $date;
282
283 # Yeah, I just did that.
284 my($msg) = /\G\s+(\S.*)/sg;
285 {
286 hash => $sha1,
287 type => $type,
288 author => $author,
289
290 # XXX Add DateTime goodness.
291 date => $date,
292 message => $msg,
293 }
294 ;
295 } @entries;
296 }
297
cc88eca5 298 ## BUILDERS
32a371cc 299 method _build__util {
300 Gitalist::Git::Util->new(
301 project => $self,
302 );
303 }
304
305 method _build_description {
76c97bf6 306 my $description = "";
5d8568c6 307 eval {
76c97bf6 308 $description = $self->path->file('description')->slurp;
309 chomp $description;
5d8568c6 310 };
76c97bf6 311 return $description;
32a371cc 312 }
313
314 method _build_owner {
315 my ($gecos, $name) = (getpwuid $self->path->stat->uid)[6,0];
316 $gecos =~ s/,+$//;
317 return length($gecos) ? $gecos : $name;
318 }
319
320 method _build_last_change {
321 my $last_change;
322 my $output = $self->run_cmd(
323 qw{ for-each-ref --format=%(committer)
324 --sort=-committerdate --count=1 refs/heads
325 });
326 if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
327 my $dt = DateTime->from_epoch(epoch => $epoch);
328 $dt->set_time_zone($tz);
329 $last_change = $dt;
330 }
331 return $last_change;
332 }
333
cc88eca5 334 method _build_heads {
335 my @revlines = $self->run_cmd_list(qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
336 my @ret;
337 for my $line (@revlines) {
338 my ($rev, $head, $commiter) = split /\0/, $line, 3;
339 $head =~ s!^refs/heads/!!;
340
341 push @ret, { sha1 => $rev, name => $head };
342
343 #FIXME: That isn't the time I'm looking for..
344 if (my ($epoch, $tz) = $line =~ /\s(\d+)\s+([+-]\d+)$/) {
345 my $dt = DateTime->from_epoch(epoch => $epoch);
346 $dt->set_time_zone($tz);
347 $ret[-1]->{last_change} = $dt;
348 }
349 }
350
351 return \@ret;
352 }
353
354 method _build_references {
355 # 5dc01c595e6c6ec9ccda4f6f69c131c0dd945f8c refs/tags/v2.6.11
356 # c39ae07f393806ccf406ef966e9a15afc43cc36a refs/tags/v2.6.11^{}
357 my @reflist = $self->run_cmd_list(qw(show-ref --dereference))
05e8b4d0 358 or return;
cc88eca5 359 my %refs;
05e8b4d0 360 for (@reflist) {
361 push @{$refs{$1}}, $2
362 if m!^($SHA1RE)\srefs/(.*)$!;
363 }
cc88eca5 364
05e8b4d0 365 return \%refs;
cc88eca5 366 }
367
368 ## Private methods
369 method _is_valid_rev (Str $rev) {
370 return ($rev =~ /^($SHA1RE)$/);
371 }
372
373 method _parse_rev_list ($output) {
374 return
375 map $self->get_gpp_object($_),
376 grep $self->_is_valid_rev($_),
377 map split(/\n/, $_, 6), split /\0/, $output;
378 }
379
b5b638f7 380=head1 SEE ALSO
381
382L<Gitalist::Git::Util> L<Gitalist::Git::Object>
383
384=head1 AUTHORS AND COPYRIGHT
385
386 Catalyst application:
387 (C) 2009 Venda Ltd and Dan Brook <dbrook@venda.com>
388
389 Original gitweb.cgi from which this was derived:
390 (C) 2005-2006, Kay Sievers <kay.sievers@vrfy.org>
391 (C) 2005, Christian Gierke
392
393=head1 LICENSE
394
395FIXME - Is this going to be GPLv2 as per gitweb? If so this is broken..
396
397This library is free software. You can redistribute it and/or modify
398it under the same terms as Perl itself.
399
400=cut
401
56b6dbe6 402} # end class