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 | |
fbf3eb7e |
8 | use DateTime; |
9 | use Path::Class; |
10 | use Carp qw/croak/; |
11 | use File::Find::Rule; |
12 | use DateTime::Format::Mail; |
13 | use File::Stat::ModeString; |
14 | use List::MoreUtils qw/any/; |
15 | use Scalar::Util qw/blessed/; |
16 | |
04d1d917 |
17 | { |
18 | my $git; |
19 | sub git { |
20 | return $git |
21 | if $git; |
fbf3eb7e |
22 | |
23 | if (my $config_git = Gitalist->config->{git}) { |
24 | $git = $config_git if -x $config_git; |
25 | } |
26 | else { |
27 | require File::Which; |
28 | $git = File::Which::which('git'); |
29 | } |
30 | |
31 | if (!$git) { |
32 | die <<EOR |
33 | Could not find a git executable. |
34 | Please specify the which git executable to use in gitweb.yml |
35 | EOR |
36 | } |
37 | |
38 | return $git; |
04d1d917 |
39 | } |
40 | } |
fbf3eb7e |
41 | |
42 | sub is_git_repo { |
43 | my ($self, $dir) = @_; |
44 | |
45 | #FIXME: Only handles bare repos. Is that enough? |
04d1d917 |
46 | return -f $dir->file('HEAD') or -f $dir->file('.git/HEAD'); |
fbf3eb7e |
47 | } |
48 | |
49 | sub project_info { |
50 | my ($self, $project) = @_; |
51 | |
52 | return { |
53 | name => $project, |
54 | $self->get_project_properties( |
55 | $self->git_dir_from_project_name($project), |
56 | ), |
57 | }; |
58 | } |
59 | |
60 | sub get_project_properties { |
61 | my ($self, $dir) = @_; |
62 | my %props; |
63 | |
64 | eval { |
65 | $props{description} = $dir->file('description')->slurp; |
66 | chomp $props{description}; |
67 | }; |
68 | |
04d1d917 |
69 | if ($props{description} && $props{description} =~ /^Unnamed repository;/) { |
fbf3eb7e |
70 | delete $props{description}; |
71 | } |
72 | |
04d1d917 |
73 | #Carp::cluck "dir is: $dir"; |
fbf3eb7e |
74 | $props{owner} = (getpwuid $dir->stat->uid)[6]; |
75 | |
76 | my $output = $self->run_cmd_in($dir, qw{ |
77 | for-each-ref --format=%(committer) |
78 | --sort=-committerdate --count=1 refs/heads |
79 | }); |
80 | |
81 | if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) { |
82 | my $dt = DateTime->from_epoch(epoch => $epoch); |
83 | $dt->set_time_zone($tz); |
84 | $props{last_change} = $dt; |
85 | } |
86 | |
87 | return %props; |
88 | } |
89 | |
90 | sub list_projects { |
91 | my ($self) = @_; |
92 | |
93 | my $base = dir(Gitalist->config->{repo_dir}); |
94 | |
95 | my @ret; |
96 | my $dh = $base->open; |
97 | while (my $file = $dh->read) { |
98 | next if $file =~ /^.{1,2}$/; |
99 | |
100 | my $obj = $base->subdir($file); |
101 | next unless -d $obj; |
102 | next unless $self->is_git_repo($obj); |
103 | |
104 | push @ret, { |
105 | name => ($obj->dir_list)[-1], |
106 | $self->get_project_properties($obj), |
107 | }; |
108 | } |
109 | |
110 | return \@ret; |
111 | } |
112 | |
113 | sub run_cmd { |
114 | my ($self, @args) = @_; |
115 | |
116 | open my $fh, '-|', __PACKAGE__->git, @args |
117 | or die "failed to run git command"; |
118 | binmode $fh, ':encoding(UTF-8)'; |
119 | |
120 | my $output = do { local $/ = undef; <$fh> }; |
121 | close $fh; |
122 | |
123 | return $output; |
124 | } |
125 | |
126 | sub run_cmd_in { |
127 | my ($self, $project, @args) = @_; |
128 | |
129 | my $path; |
130 | if (blessed($project) && $project->isa('Path::Class::Dir')) { |
131 | $path = $project->stringify; |
132 | } |
133 | else { |
134 | $path = $self->git_dir_from_project_name($project); |
135 | } |
136 | return $self->run_cmd('--git-dir' => $path, @args); |
137 | } |
138 | |
139 | sub git_dir_from_project_name { |
140 | my ($self, $project) = @_; |
141 | |
04d1d917 |
142 | warn 'er, dir - '.dir(Gitalist->config->{repo_dir}); |
143 | warn 'er, subdir - '.dir(Gitalist->config->{repo_dir})->subdir($project); |
fbf3eb7e |
144 | return dir(Gitalist->config->{repo_dir})->subdir($project); |
145 | } |
146 | |
147 | sub get_head_hash { |
148 | my ($self, $project) = @_; |
149 | |
150 | my $output = $self->run_cmd_in($project, qw/rev-parse --verify HEAD/ ); |
151 | return unless defined $output; |
152 | |
153 | my ($head) = $output =~ /^([0-9a-fA-F]{40})$/; |
154 | return $head; |
155 | } |
156 | |
157 | sub list_tree { |
158 | my ($self, $project, $rev) = @_; |
159 | |
160 | $rev ||= $self->get_head_hash($project); |
161 | |
162 | my $output = $self->run_cmd_in($project, qw/ls-tree -z/, $rev); |
163 | return unless defined $output; |
164 | |
165 | my @ret; |
166 | for my $line (split /\0/, $output) { |
167 | my ($mode, $type, $object, $file) = split /\s+/, $line, 4; |
168 | |
169 | push @ret, { |
170 | mode => oct $mode, |
171 | type => $type, |
172 | object => $object, |
173 | file => $file, |
174 | }; |
175 | } |
176 | |
177 | return @ret; |
178 | } |
179 | |
180 | sub get_object_mode_string { |
181 | my ($self, $object) = @_; |
182 | |
183 | return unless $object && $object->{mode}; |
184 | return mode_to_string($object->{mode}); |
185 | } |
186 | |
187 | sub get_object_type { |
188 | my ($self, $project, $object) = @_; |
189 | |
190 | my $output = $self->run_cmd_in($project, qw/cat-file -t/, $object); |
191 | return unless $output; |
192 | |
193 | chomp $output; |
194 | return $output; |
195 | } |
196 | |
197 | sub cat_file { |
198 | my ($self, $project, $object) = @_; |
199 | |
200 | my $type = $self->get_object_type($project, $object); |
201 | die "object `$object' is not a file\n" |
202 | if (!defined $type || $type ne 'blob'); |
203 | |
204 | my $output = $self->run_cmd_in($project, qw/cat-file -p/, $object); |
205 | return unless $output; |
206 | |
207 | return $output; |
208 | } |
209 | |
210 | sub valid_rev { |
211 | my ($self, $rev) = @_; |
212 | |
213 | return unless $rev; |
214 | return ($rev =~ /^([0-9a-fA-F]{40})$/); |
215 | } |
216 | |
217 | sub diff { |
218 | my ($self, $project, @revs) = @_; |
219 | |
220 | croak("Gitalist::Model::Git::diff needs a project and either one or two revisions") |
221 | if scalar @revs < 1 |
222 | || scalar @revs > 2 |
223 | || any { !$self->valid_rev($_) } @revs; |
224 | |
225 | my $output = $self->run_cmd_in($project, 'diff', @revs); |
226 | return unless $output; |
227 | |
228 | return $output; |
229 | } |
230 | |
231 | { |
232 | my $formatter = DateTime::Format::Mail->new; |
233 | |
234 | sub parse_rev_list { |
235 | my ($self, $output) = @_; |
236 | my @ret; |
237 | |
238 | my @revs = split /\0/, $output; |
239 | |
240 | for my $rev (split /\0/, $output) { |
241 | for my $line (split /\n/, $rev, 6) { |
242 | chomp $line; |
243 | next unless $line; |
244 | |
245 | if ($self->valid_rev($line)) { |
246 | push @ret, {rev => $line}; |
247 | next; |
248 | } |
249 | |
250 | if (my ($key, $value) = $line =~ /^(tree|parent)\s+(.*)$/) { |
251 | $ret[-1]->{$key} = $value; |
252 | next; |
253 | } |
254 | |
255 | if (my ($key, $value, $epoch, $tz) = $line =~ /^(author|committer)\s+(.*)\s+(\d+)\s+([+-]\d+)$/) { |
256 | $ret[-1]->{$key} = $value; |
257 | eval { |
258 | $ret[-1]->{ $key . "_datetime" } = DateTime->from_epoch(epoch => $epoch); |
259 | $ret[-1]->{ $key . "_datetime" }->set_time_zone($tz); |
260 | $ret[-1]->{ $key . "_datetime" }->set_formatter($formatter); |
261 | }; |
262 | |
263 | if ($@) { |
264 | $ret[-1]->{ $key . "_datetime" } = "$epoch $tz"; |
265 | } |
266 | |
267 | if (my ($name, $email) = $value =~ /^([^<]+)\s+<([^>]+)>$/) { |
268 | $ret[-1]->{ $key . "_name" } = $name; |
269 | $ret[-1]->{ $key . "_email" } = $email; |
270 | } |
271 | } |
272 | |
273 | $line =~ s/^\n?\s{4}//; |
274 | $ret[-1]->{longmessage} = $line; |
275 | $ret[-1]->{message} = (split /\n/, $line, 2)[0]; |
276 | } |
277 | } |
278 | |
279 | return @ret; |
280 | } |
281 | } |
282 | |
283 | sub list_revs { |
284 | my ($self, $project, %args) = @_; |
285 | |
286 | $args{rev} ||= $self->get_head_hash($project); |
287 | |
288 | my $output = $self->run_cmd_in($project, 'rev-list', |
289 | '--header', |
290 | (defined $args{ count } ? "--max-count=$args{count}" : ()), |
291 | (defined $args{ skip } ? "--skip=$args{skip}" : ()), |
292 | $args{rev}, |
293 | '--', |
294 | ($args{file} || ()), |
295 | ); |
296 | return unless $output; |
297 | |
298 | my @revs = $self->parse_rev_list($output); |
299 | |
300 | return \@revs; |
301 | } |
302 | |
303 | sub rev_info { |
304 | my ($self, $project, $rev) = @_; |
305 | |
306 | return unless $self->valid_rev($rev); |
307 | |
308 | return $self->list_revs($project, rev => $rev, count => 1); |
309 | } |
310 | |
311 | sub get_heads { |
312 | my ($self, $project) = @_; |
313 | |
314 | my $output = $self->run_cmd_in($project, qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads'); |
315 | return unless $output; |
316 | |
317 | my @ret; |
318 | for my $line (split /\n/, $output) { |
319 | my ($rev, $head, $commiter) = split /\0/, $line, 3; |
320 | $head =~ s!^refs/heads/!!; |
321 | |
322 | push @ret, { rev => $rev, name => $head }; |
323 | |
324 | #FIXME: That isn't the time I'm looking for.. |
325 | if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) { |
326 | my $dt = DateTime->from_epoch(epoch => $epoch); |
327 | $dt->set_time_zone($tz); |
328 | $ret[-1]->{last_change} = $dt; |
329 | } |
330 | } |
331 | |
332 | return \@ret; |
333 | } |
334 | |
335 | sub archive { |
336 | my ($self, $project, $rev) = @_; |
337 | |
338 | #FIXME: huge memory consuption |
339 | #TODO: compression |
340 | return $self->run_cmd_in($project, qw/archive --format=tar/, "--prefix=${project}/", $rev); |
341 | } |
342 | |
343 | 1; |
344 | |
345 | __PACKAGE__->meta->make_immutable; |