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