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