Commit | Line | Data |
fbf3eb7e |
1 | package Gitalist::Model::Git; |
2 | |
3 | use Moose; |
4 | use namespace::autoclean; |
5 | |
86382b95 |
6 | BEGIN { extends 'Catalyst::Model' } |
7 | |
d7c9a32f |
8 | use Git::PurePerl; |
9 | |
fbf3eb7e |
10 | use DateTime; |
11 | use Path::Class; |
12 | use Carp qw/croak/; |
13 | use File::Find::Rule; |
14 | use DateTime::Format::Mail; |
15 | use File::Stat::ModeString; |
16 | use List::MoreUtils qw/any/; |
17 | use Scalar::Util qw/blessed/; |
18 | |
04d1d917 |
19 | { |
d7c9a32f |
20 | my $git; |
21 | sub git_bin { |
22 | return $git |
23 | if $git; |
24 | |
25 | if (my $config_git = Gitalist->config->{git}) { |
26 | $git = $config_git if -x $config_git; |
27 | } |
28 | else { |
29 | require File::Which; |
30 | $git = File::Which::which('git'); |
31 | } |
32 | |
33 | if (!$git) { |
34 | die <<EOR |
fbf3eb7e |
35 | Could not find a git executable. |
36 | Please specify the which git executable to use in gitweb.yml |
37 | EOR |
d7c9a32f |
38 | } |
fbf3eb7e |
39 | |
d7c9a32f |
40 | return $git; |
41 | } |
04d1d917 |
42 | } |
fbf3eb7e |
43 | |
d7c9a32f |
44 | has project => (is => 'rw', isa => 'Str'); |
45 | |
fbf3eb7e |
46 | sub is_git_repo { |
d7c9a32f |
47 | my ($self, $dir) = @_; |
fbf3eb7e |
48 | |
d7c9a32f |
49 | return -f $dir->file('HEAD') || -f $dir->file('.git/HEAD'); |
fbf3eb7e |
50 | } |
51 | |
52 | sub project_info { |
d7c9a32f |
53 | my ($self, $project) = @_; |
fbf3eb7e |
54 | |
d7c9a32f |
55 | return { |
56 | name => $project, |
57 | $self->get_project_properties( |
58 | $self->git_dir_from_project_name($project), |
59 | ), |
fbf3eb7e |
60 | }; |
61 | } |
62 | |
63 | sub get_project_properties { |
d7c9a32f |
64 | my ($self, $dir) = @_; |
65 | my %props; |
fbf3eb7e |
66 | |
d7c9a32f |
67 | eval { |
68 | $props{description} = $dir->file('description')->slurp; |
69 | chomp $props{description}; |
fbf3eb7e |
70 | }; |
71 | |
d7c9a32f |
72 | if ($props{description} && $props{description} =~ /^Unnamed repository;/) { |
73 | delete $props{description}; |
74 | } |
fbf3eb7e |
75 | |
d7c9a32f |
76 | ($props{owner} = (getpwuid $dir->stat->uid)[6]) =~ s/,+$//; |
fbf3eb7e |
77 | |
d7c9a32f |
78 | my $output = $self->run_cmd_in($dir, qw{ |
79 | for-each-ref --format=%(committer) |
80 | --sort=-committerdate --count=1 refs/heads |
81 | }); |
fbf3eb7e |
82 | |
d7c9a32f |
83 | if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) { |
84 | my $dt = DateTime->from_epoch(epoch => $epoch); |
85 | $dt->set_time_zone($tz); |
86 | $props{last_change} = $dt; |
87 | } |
fbf3eb7e |
88 | |
d7c9a32f |
89 | return %props; |
fbf3eb7e |
90 | } |
91 | |
92 | sub list_projects { |
d7c9a32f |
93 | my ($self) = @_; |
fbf3eb7e |
94 | |
d7c9a32f |
95 | my $base = dir(Gitalist->config->{repo_dir}); |
fbf3eb7e |
96 | |
d7c9a32f |
97 | my @ret; |
98 | my $dh = $base->open; |
99 | while (my $file = $dh->read) { |
100 | next if $file =~ /^.{1,2}$/; |
101 | |
102 | my $obj = $base->subdir($file); |
103 | next unless -d $obj; |
104 | next unless $self->is_git_repo($obj); |
fbf3eb7e |
105 | |
d7c9a32f |
106 | # XXX Leaky abstraction alert! |
107 | my $is_bare = !-d $obj->subdir('.git'); |
108 | |
109 | my $name = (File::Spec->splitdir($obj))[-1]; |
110 | push @ret, { |
111 | name => ($name . ( $is_bare ? '.git' : '/.git' )), |
112 | $self->get_project_properties( |
113 | $is_bare ? $obj : $obj->subdir('.git') |
114 | ), |
115 | }; |
116 | } |
117 | |
118 | return [sort { $a->{name} cmp $b->{name} } @ret]; |
fbf3eb7e |
119 | } |
120 | |
121 | sub run_cmd { |
d7c9a32f |
122 | my ($self, @args) = @_; |
fbf3eb7e |
123 | |
d7c9a32f |
124 | open my $fh, '-|', __PACKAGE__->git_bin, @args |
125 | or die "failed to run git command"; |
126 | binmode $fh, ':encoding(UTF-8)'; |
fbf3eb7e |
127 | |
d7c9a32f |
128 | print STDERR "RAN - git @_[1..$#_]\n"; |
c5065c66 |
129 | |
d7c9a32f |
130 | my $output = do { local $/ = undef; <$fh> }; |
131 | close $fh; |
fbf3eb7e |
132 | |
d7c9a32f |
133 | return $output; |
134 | } |
135 | |
136 | sub project_dir { |
137 | my($self, $project) = @_; |
138 | |
139 | my $dir = blessed($project) && $project->isa('Path::Class::Dir') |
140 | ? $project->stringify |
141 | : $self->git_dir_from_project_name($project); |
142 | |
143 | $dir =~ s/\.git$//; |
144 | |
145 | return $dir; |
fbf3eb7e |
146 | } |
147 | |
148 | sub run_cmd_in { |
d7c9a32f |
149 | my ($self, $project, @args) = @_; |
fbf3eb7e |
150 | |
d7c9a32f |
151 | return $self->run_cmd('--git-dir' => $self->project_dir($project), @args); |
fbf3eb7e |
152 | } |
153 | |
154 | sub git_dir_from_project_name { |
d7c9a32f |
155 | my ($self, $project) = @_; |
fbf3eb7e |
156 | |
d7c9a32f |
157 | return dir(Gitalist->config->{repo_dir})->subdir($project); |
fbf3eb7e |
158 | } |
159 | |
160 | sub get_head_hash { |
d7c9a32f |
161 | my ($self, $project) = @_; |
fbf3eb7e |
162 | |
d7c9a32f |
163 | my $output = $self->run_cmd_in($self->project, qw/rev-parse --verify HEAD/ ); |
164 | return unless defined $output; |
fbf3eb7e |
165 | |
d7c9a32f |
166 | my ($head) = $output =~ /^([0-9a-fA-F]{40})$/; |
167 | return $head; |
fbf3eb7e |
168 | } |
169 | |
170 | sub list_tree { |
d7c9a32f |
171 | my ($self, $project, $rev) = @_; |
fbf3eb7e |
172 | |
d7c9a32f |
173 | $rev ||= $self->get_head_hash($project); |
fbf3eb7e |
174 | |
d7c9a32f |
175 | my $output = $self->run_cmd_in($project, qw/ls-tree -z/, $rev); |
176 | return unless defined $output; |
fbf3eb7e |
177 | |
d7c9a32f |
178 | my @ret; |
179 | for my $line (split /\0/, $output) { |
180 | my ($mode, $type, $object, $file) = split /\s+/, $line, 4; |
fbf3eb7e |
181 | |
d7c9a32f |
182 | push @ret, { |
183 | mode => oct $mode, |
184 | type => $type, |
185 | object => $object, |
186 | file => $file, |
187 | }; |
188 | } |
189 | |
190 | return @ret; |
fbf3eb7e |
191 | } |
192 | |
193 | sub get_object_mode_string { |
d7c9a32f |
194 | my ($self, $object) = @_; |
fbf3eb7e |
195 | |
d7c9a32f |
196 | return unless $object && $object->{mode}; |
197 | return mode_to_string($object->{mode}); |
fbf3eb7e |
198 | } |
199 | |
200 | sub get_object_type { |
d7c9a32f |
201 | my ($self, $project, $object) = @_; |
fbf3eb7e |
202 | |
d7c9a32f |
203 | my $output = $self->run_cmd_in($project, qw/cat-file -t/, $object); |
204 | return unless $output; |
fbf3eb7e |
205 | |
d7c9a32f |
206 | chomp $output; |
207 | return $output; |
fbf3eb7e |
208 | } |
209 | |
295c9703 |
210 | sub get_hash_by_path { |
d7c9a32f |
211 | my($self, $base, $path, $type) = @_; |
295c9703 |
212 | |
d7c9a32f |
213 | $path =~ s{/+$}(); |
295c9703 |
214 | |
d7c9a32f |
215 | my $line = $self->run_cmd_in($self->project, 'ls-tree', $base, '--', $path) |
295c9703 |
216 | or return; |
217 | |
d7c9a32f |
218 | #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa panic.c' |
219 | $line =~ m/^([0-9]+) (.+) ([0-9a-fA-F]{40})\t/; |
220 | return defined $type && $type ne $2 |
221 | ? () |
222 | : return $3; |
295c9703 |
223 | } |
224 | |
fbf3eb7e |
225 | sub cat_file { |
d7c9a32f |
226 | my ($self, $object) = @_; |
fbf3eb7e |
227 | |
d7c9a32f |
228 | my $type = $self->get_object_type($self->project, $object); |
229 | die "object `$object' is not a file\n" |
230 | if (!defined $type || $type ne 'blob'); |
fbf3eb7e |
231 | |
d7c9a32f |
232 | my $output = $self->run_cmd_in($self->project, qw/cat-file -p/, $object); |
233 | return unless $output; |
fbf3eb7e |
234 | |
d7c9a32f |
235 | return $output; |
fbf3eb7e |
236 | } |
237 | |
238 | sub valid_rev { |
d7c9a32f |
239 | my ($self, $rev) = @_; |
fbf3eb7e |
240 | |
d7c9a32f |
241 | return unless $rev; |
242 | return ($rev =~ /^([0-9a-fA-F]{40})$/); |
fbf3eb7e |
243 | } |
244 | |
245 | sub diff { |
d7c9a32f |
246 | my ($self, $project, @revs) = @_; |
fbf3eb7e |
247 | |
d7c9a32f |
248 | croak("Gitalist::Model::Git::diff needs a project and either one or two revisions") |
249 | if scalar @revs < 1 |
250 | || scalar @revs > 2 |
251 | || any { !$self->valid_rev($_) } @revs; |
fbf3eb7e |
252 | |
d7c9a32f |
253 | my $output = $self->run_cmd_in($project, 'diff', @revs); |
254 | return unless $output; |
fbf3eb7e |
255 | |
d7c9a32f |
256 | return $output; |
fbf3eb7e |
257 | } |
258 | |
259 | { |
d7c9a32f |
260 | my $formatter = DateTime::Format::Mail->new; |
261 | |
262 | sub parse_rev_list { |
263 | my ($self, $output) = @_; |
264 | my @ret; |
265 | |
266 | my @revs = split /\0/, $output; |
267 | |
268 | for my $rev (split /\0/, $output) { |
269 | for my $line (split /\n/, $rev, 6) { |
270 | chomp $line; |
271 | next unless $line; |
272 | |
273 | if ($self->valid_rev($line)) { |
274 | push @ret, {rev => $line}; |
275 | next; |
276 | } |
277 | |
278 | if (my ($key, $value) = $line =~ /^(tree|parent)\s+(.*)$/) { |
279 | $ret[-1]->{$key} = $value; |
280 | next; |
fbf3eb7e |
281 | } |
282 | |
d7c9a32f |
283 | if (my ($key, $value, $epoch, $tz) = $line =~ /^(author|committer)\s+(.*)\s+(\d+)\s+([+-]\d+)$/) { |
284 | $ret[-1]->{$key} = $value; |
285 | eval { |
286 | $ret[-1]->{ $key . "_datetime" } = DateTime->from_epoch(epoch => $epoch); |
287 | $ret[-1]->{ $key . "_datetime" }->set_time_zone($tz); |
288 | $ret[-1]->{ $key . "_datetime" }->set_formatter($formatter); |
289 | }; |
290 | |
291 | if ($@) { |
292 | $ret[-1]->{ $key . "_datetime" } = "$epoch $tz"; |
293 | } |
294 | |
295 | if (my ($name, $email) = $value =~ /^([^<]+)\s+<([^>]+)>$/) { |
296 | $ret[-1]->{ $key . "_name" } = $name; |
297 | $ret[-1]->{ $key . "_email" } = $email; |
298 | } |
299 | } |
300 | |
301 | $line =~ s/^\n?\s{4}//; |
302 | $ret[-1]->{longmessage} = $line; |
303 | $ret[-1]->{message} = (split /\n/, $line, 2)[0]; |
304 | } |
fbf3eb7e |
305 | } |
d7c9a32f |
306 | |
307 | return @ret; |
308 | } |
fbf3eb7e |
309 | } |
310 | |
311 | sub list_revs { |
d7c9a32f |
312 | my ($self, $project, %args) = @_; |
fbf3eb7e |
313 | |
d7c9a32f |
314 | $args{rev} ||= $self->get_head_hash($project); |
fbf3eb7e |
315 | |
d7c9a32f |
316 | my $output = $self->run_cmd_in($project, 'rev-list', |
317 | '--header', |
318 | (defined $args{ count } ? "--max-count=$args{count}" : ()), |
319 | (defined $args{ skip } ? "--skip=$args{skip}" : ()), |
320 | $args{rev}, |
321 | '--', |
322 | ($args{file} || ()), |
fbf3eb7e |
323 | ); |
d7c9a32f |
324 | return unless $output; |
fbf3eb7e |
325 | |
d7c9a32f |
326 | my @revs = $self->parse_rev_list($output); |
fbf3eb7e |
327 | |
d7c9a32f |
328 | return \@revs; |
fbf3eb7e |
329 | } |
330 | |
331 | sub rev_info { |
d7c9a32f |
332 | my ($self, $project, $rev) = @_; |
fbf3eb7e |
333 | |
d7c9a32f |
334 | return unless $self->valid_rev($rev); |
fbf3eb7e |
335 | |
d7c9a32f |
336 | return $self->list_revs($project, rev => $rev, count => 1); |
fbf3eb7e |
337 | } |
338 | |
c5065c66 |
339 | sub reflog { |
d7c9a32f |
340 | my ($self, @logargs) = @_; |
c5065c66 |
341 | |
d7c9a32f |
342 | my @entries |
343 | = $self->run_cmd_in($self->project, qw(log -g), @logargs) |
344 | =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg; |
c5065c66 |
345 | |
346 | =begin |
347 | |
348 | commit 02526fc15beddf2c64798a947fecdd8d11bf993d |
349 | Reflog: HEAD@{14} (The Git Server <git@git.dev.venda.com>) |
350 | Reflog message: push |
351 | Author: Iain Loasby <iloasby@rowlf.of-2.uk.venda.com> |
352 | Date: Thu Sep 17 12:26:05 2009 +0100 |
353 | |
354 | Merge branch 'rt125181 |
355 | =cut |
d7c9a32f |
356 | |
357 | return map { |
358 | |
359 | # XXX Stuff like this makes me want to switch to Git::PurePerl |
360 | my($sha1, $type, $author, $date) |
361 | = m{ |
c5065c66 |
362 | ^ commit \s+ ([0-9a-f]+)$ |
363 | .*? |
364 | Reflog[ ]message: \s+ (.+?)$ \s+ |
365 | Author: \s+ ([^<]+) <.*?$ \s+ |
366 | Date: \s+ (.+?)$ |
d7c9a32f |
367 | }xms; |
c5065c66 |
368 | |
d7c9a32f |
369 | pos($_) = index($_, $date) + length $date; |
c5065c66 |
370 | |
d7c9a32f |
371 | # Yeah, I just did that. |
c5065c66 |
372 | |
d7c9a32f |
373 | my($msg) = /\G\s+(\S.*)/sg; |
374 | |
375 | { |
376 | hash => $sha1, |
377 | type => $type, |
378 | author => $author, |
379 | |
380 | # XXX Add DateTime goodness. |
381 | date => $date, |
382 | message => $msg, |
383 | }; |
c5065c66 |
384 | } @entries; |
385 | } |
386 | |
fbf3eb7e |
387 | sub get_heads { |
d7c9a32f |
388 | my ($self, $project) = @_; |
fbf3eb7e |
389 | |
d7c9a32f |
390 | my $output = $self->run_cmd_in($project, qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads'); |
391 | return unless $output; |
fbf3eb7e |
392 | |
d7c9a32f |
393 | my @ret; |
394 | for my $line (split /\n/, $output) { |
395 | my ($rev, $head, $commiter) = split /\0/, $line, 3; |
396 | $head =~ s!^refs/heads/!!; |
fbf3eb7e |
397 | |
d7c9a32f |
398 | push @ret, { rev => $rev, name => $head }; |
fbf3eb7e |
399 | |
d7c9a32f |
400 | #FIXME: That isn't the time I'm looking for.. |
401 | if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) { |
402 | my $dt = DateTime->from_epoch(epoch => $epoch); |
403 | $dt->set_time_zone($tz); |
404 | $ret[-1]->{last_change} = $dt; |
fbf3eb7e |
405 | } |
d7c9a32f |
406 | } |
fbf3eb7e |
407 | |
d7c9a32f |
408 | return \@ret; |
fbf3eb7e |
409 | } |
410 | |
411 | sub archive { |
d7c9a32f |
412 | my ($self, $project, $rev) = @_; |
fbf3eb7e |
413 | |
d7c9a32f |
414 | #FIXME: huge memory consuption |
415 | #TODO: compression |
416 | return $self->run_cmd_in($project, qw/archive --format=tar/, "--prefix=${project}/", $rev); |
fbf3eb7e |
417 | } |
418 | |
419 | 1; |
420 | |
421 | __PACKAGE__->meta->make_immutable; |