Fleshed out the /tree action and fixed paging.
[catagits/Gitalist.git] / lib / Gitalist / Model / Git.pm
CommitLineData
fbf3eb7e 1package Gitalist::Model::Git;
2
3use Moose;
4use namespace::autoclean;
5
37997f11 6extends 'Catalyst::Model';
7with 'Catalyst::Component::InstancePerContext';
86382b95 8
fbf3eb7e 9use DateTime;
10use Path::Class;
1feb3d6b 11use File::Which;
fbf3eb7e 12use Carp qw/croak/;
13use File::Find::Rule;
14use DateTime::Format::Mail;
15use File::Stat::ModeString;
ad8884fc 16use List::MoreUtils qw/any zip/;
1feb3d6b 17use Scalar::Util qw/blessed/;
18use MooseX::Types::Common::String qw/NonEmptySimpleStr/; # FIXME, use Types::Path::Class and coerce
fbf3eb7e 19
a7cc1ede 20use Git::PurePerl;
21
27e05d7b 22=head1 NAME
23
24Gitalist::Model::Git - the model for git interactions
25
26=head1 DESCRIPTION
27
28[enter your description here]
29
30=head1 METHODS
31
32=cut
33
b3ad9e63 34# Should these live in a separate module? Or perhaps extended Regexp::Common?
35our $SHA1RE = qr/[0-9a-fA-F]{40}/;
36
a7cc1ede 37# These are static and only need to be setup on app start.
8c032474 38has repo_dir => ( isa => NonEmptySimpleStr, is => 'ro', lazy_build => 1 ); # Fixme - path::class
39has git => ( isa => NonEmptySimpleStr, is => 'ro', lazy_build => 1 );
a7cc1ede 40# These are dynamic and can be different from one request to the next.
41has project => ( isa => NonEmptySimpleStr, is => 'rw');
42has gpp => ( isa => 'Git::PurePerl', is => 'rw', lazy_build => 1 );
43
37997f11 44sub build_per_context_instance {
a7cc1ede 45 my ( $self, $c ) = @_;
46
47 $self->project( $c->req->param('p') );
48
49 (my $pd = $self->project_dir( $self->project )) =~ s{/\.git$}();
50 $self->gpp( Git::PurePerl->new(directory => $pd) );
51
52 return $self;
53}
1feb3d6b 54
27e05d7b 55=head2 BUILD
56
57=cut
58
8c032474 59sub BUILD {
60 my ($self) = @_;
61 $self->git; # Cause lazy value build.
1feb3d6b 62 $self->repo_dir;
8c032474 63}
64
65sub _build_git {
1feb3d6b 66 my $git = File::Which::which('git');
d7c9a32f 67
1feb3d6b 68 if (!$git) {
69 die <<EOR;
fbf3eb7e 70Could not find a git executable.
71Please specify the which git executable to use in gitweb.yml
72EOR
1feb3d6b 73 }
fbf3eb7e 74
1feb3d6b 75 return $git;
04d1d917 76}
1feb3d6b 77
8c032474 78sub _build_repo_dir {
1ef8dc7d 79 return Gitalist->config->{repo_dir};
80}
81
27e05d7b 82=head2 get_object
83
84A wrapper for the equivalent L<Git::PurePerl> method.
85
86=cut
87
1ef8dc7d 88sub get_object {
a7cc1ede 89 my($self, $sha1) = @_;
90
9dc3b9a5 91 # We either want an object or undef, *not* an empty list.
a7cc1ede 92 return $self->gpp->get_object($sha1) || undef;
8c032474 93}
d7c9a32f 94
27e05d7b 95=head2 is_git_repo
96
97Determine whether a given directory (as a L<Path::Class::Dir> object) is a
98C<git> repo.
99
100=cut
101
fbf3eb7e 102sub is_git_repo {
1feb3d6b 103 my ($self, $dir) = @_;
fbf3eb7e 104
1feb3d6b 105 return -f $dir->file('HEAD') || -f $dir->file('.git/HEAD');
fbf3eb7e 106}
107
27e05d7b 108=head2 run_cmd
109
110Call out to the C<git> binary and return a string consisting of the output.
111
112=cut
113
1ef8dc7d 114sub run_cmd {
115 my ($self, @args) = @_;
116
117 print STDERR 'RUNNING: ', $self->git, qq[ @args], $/;
118
119 open my $fh, '-|', $self->git, @args
120 or die "failed to run git command";
121 binmode $fh, ':encoding(UTF-8)';
122
123 my $output = do { local $/ = undef; <$fh> };
124 close $fh;
125
126 return $output;
127}
128
27e05d7b 129=head2 project_dir
130
131The directory under which the given project will reside i.e C<.git/..>
132
133=cut
134
1ef8dc7d 135sub project_dir {
136 my($self, $project) = @_;
137
138 my $dir = blessed($project) && $project->isa('Path::Class::Dir')
139 ? $project->stringify
27e05d7b 140 : $self->dir_from_project_name($project);
1ef8dc7d 141
27e05d7b 142 $dir .= '/.git'
143 if -f dir($dir)->file('.git/HEAD');
1ef8dc7d 144
145 return $dir;
146}
147
27e05d7b 148=head2 run_cmd_in
149
150Run a C<git> command in a given project and return the output as a string.
151
152=cut
153
1ef8dc7d 154sub run_cmd_in {
155 my ($self, $project, @args) = @_;
156
27e05d7b 157 return $self->run_cmd('--git-dir' => $self->project_dir($project), @args);
1ef8dc7d 158}
159
27e05d7b 160=head2 command
161
162Run a C<git> command for the project specified in the C<p> parameter and
163return the output as a list of strings corresponding to the lines of output.
164
165=cut
166
b3ad9e63 167sub command {
168 my($self, @args) = @_;
169
27e05d7b 170 my $output = $self->run_cmd('--git-dir' => $self->project_dir($self->project), @args);
b3ad9e63 171
172 return $output ? split(/\n/, $output) : ();
173}
174
27e05d7b 175=head2 project_info
176
177Returns a hash corresponding to a given project's properties. The keys will
178be:
179
180 name
181 description (empty if .git/description is empty/unnamed)
182 owner
183 last_change
184
185=cut
186
fbf3eb7e 187sub project_info {
1feb3d6b 188 my ($self, $project) = @_;
fbf3eb7e 189
1feb3d6b 190 return {
191 name => $project,
192 $self->get_project_properties(
27e05d7b 193 $self->dir_from_project_name($project),
194 ),
195 };
fbf3eb7e 196}
197
27e05d7b 198=head2 get_project_properties
199
200Called by C<project_info> to get a project's properties.
201
202=cut
203
fbf3eb7e 204sub get_project_properties {
1feb3d6b 205 my ($self, $dir) = @_;
206 my %props;
fbf3eb7e 207
1feb3d6b 208 eval {
209 $props{description} = $dir->file('description')->slurp;
210 chomp $props{description};
fbf3eb7e 211 };
212
1feb3d6b 213 if ($props{description} && $props{description} =~ /^Unnamed repository;/) {
214 delete $props{description};
215 }
fbf3eb7e 216
1feb3d6b 217 ($props{owner} = (getpwuid $dir->stat->uid)[6]) =~ s/,+$//;
fbf3eb7e 218
1feb3d6b 219 my $output = $self->run_cmd_in($dir, qw{
220 for-each-ref --format=%(committer)
221 --sort=-committerdate --count=1 refs/heads
222 });
fbf3eb7e 223
1feb3d6b 224 if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
225 my $dt = DateTime->from_epoch(epoch => $epoch);
226 $dt->set_time_zone($tz);
227 $props{last_change} = $dt;
228 }
fbf3eb7e 229
1feb3d6b 230 return %props;
fbf3eb7e 231}
232
27e05d7b 233=head2 list_projects
234
235For the C<repo_dir> specified in the config return an array of projects where
236each item will contain the contents of L</project_info>.
237
238=cut
239
fbf3eb7e 240sub list_projects {
27e05d7b 241 my ($self, $dir) = @_;
fbf3eb7e 242
27e05d7b 243 my $base = dir($dir || $self->repo_dir);
fbf3eb7e 244
1feb3d6b 245 my @ret;
246 my $dh = $base->open;
247 while (my $file = $dh->read) {
248 next if $file =~ /^.{1,2}$/;
249
250 my $obj = $base->subdir($file);
251 next unless -d $obj;
252 next unless $self->is_git_repo($obj);
253
254 # XXX Leaky abstraction alert!
255 my $is_bare = !-d $obj->subdir('.git');
d7c9a32f 256
1feb3d6b 257 my $name = (File::Spec->splitdir($obj))[-1];
258 push @ret, {
27e05d7b 259 name => ($name . ( $is_bare ? '' : '/.git' )),
1feb3d6b 260 $self->get_project_properties(
261 $is_bare ? $obj : $obj->subdir('.git')
262 ),
263 };
264 }
265
266 return [sort { $a->{name} cmp $b->{name} } @ret];
fbf3eb7e 267}
268
27e05d7b 269=head2 dir_from_project_name
270
271Get the corresponding directory of a given project.
272
273=cut
274
275sub dir_from_project_name {
1feb3d6b 276 my ($self, $project) = @_;
fbf3eb7e 277
1feb3d6b 278 return dir($self->repo_dir)->subdir($project);
fbf3eb7e 279}
280
27e05d7b 281=head2 head_hash
282
0ee97fec 283Find the hash of a given head (defaults to HEAD) of given (or current) project.
27e05d7b 284
285=cut
286
c8870bd3 287sub head_hash {
0ee97fec 288 my ($self, $head, $project) = @_;
fbf3eb7e 289
0ee97fec 290 my $output = $self->run_cmd_in($project || $self->project, qw/rev-parse --verify/, $head || 'HEAD' );
1feb3d6b 291 return unless defined $output;
fbf3eb7e 292
a7cc1ede 293 my($sha1) = $output =~ /^($SHA1RE)$/;
294 return $sha1;
fbf3eb7e 295}
296
27e05d7b 297=head2 list_tree
298
299For a given tree sha1 return an array describing the tree's contents. Where
300the keys for each item will be:
301
302 mode
303 type
304 object
305 file
306
307=cut
308
fbf3eb7e 309sub list_tree {
27e05d7b 310 my ($self, $rev, $project) = @_;
fbf3eb7e 311
27e05d7b 312 $project ||= $self->project;
c8870bd3 313 $rev ||= $self->head_hash($project);
fbf3eb7e 314
1feb3d6b 315 my $output = $self->run_cmd_in($project, qw/ls-tree -z/, $rev);
316 return unless defined $output;
fbf3eb7e 317
1feb3d6b 318 my @ret;
319 for my $line (split /\0/, $output) {
320 my ($mode, $type, $object, $file) = split /\s+/, $line, 4;
d7c9a32f 321
1feb3d6b 322 push @ret, {
b3fa97cd 323 mode => oct $mode,
0ee97fec 324 # XXX I wonder why directories always turn up as 040000 ...
b3fa97cd 325 modestr => $self->get_object_mode_string({mode=>oct $mode}),
326 type => $type,
327 object => $object,
328 file => $file,
27e05d7b 329 };
1feb3d6b 330 }
331
332 return @ret;
fbf3eb7e 333}
334
27e05d7b 335=head2 get_object_mode_string
336
337Provide a string equivalent of an octal mode e.g 0644 eq '-rw-r--r--'.
338
339=cut
340
fbf3eb7e 341sub get_object_mode_string {
1feb3d6b 342 my ($self, $object) = @_;
fbf3eb7e 343
1feb3d6b 344 return unless $object && $object->{mode};
345 return mode_to_string($object->{mode});
fbf3eb7e 346}
347
27e05d7b 348=head2 get_object_type
349
350=cut
351
fbf3eb7e 352sub get_object_type {
27e05d7b 353 my ($self, $object, $project) = @_;
1feb3d6b 354
27e05d7b 355 chomp(my $output = $self->run_cmd_in($project || $self->project, qw/cat-file -t/, $object));
1feb3d6b 356 return unless $output;
357
1feb3d6b 358 return $output;
359}
360
27e05d7b 361=head2 cat_file
362
363Return the contents of a given file.
364
365=cut
366
367sub cat_file {
368 my ($self, $object, $project) = @_;
369
370 my $type = $self->get_object_type($object);
371 die "object `$object' is not a file\n"
372 if (!defined $type || $type ne 'blob');
373
374 my $output = $self->run_cmd_in($project || $self->project, qw/cat-file -p/, $object);
375 return unless $output;
376
377 return $output;
378}
379
380=head2 hash_by_path
381
382For a given sha1 and path find the corresponding hash. Useful for find blobs.
383
384=cut
385
c8870bd3 386sub hash_by_path {
1feb3d6b 387 my($self, $base, $path, $type) = @_;
fbf3eb7e 388
1feb3d6b 389 $path =~ s{/+$}();
fbf3eb7e 390
c8870bd3 391 my($line) = $self->command('ls-tree', $base, '--', $path)
1feb3d6b 392 or return;
393
394 #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa panic.c'
b3ad9e63 395 $line =~ m/^([0-9]+) (.+) ($SHA1RE)\t/;
1feb3d6b 396 return defined $type && $type ne $2
397 ? ()
c8870bd3 398 : $3;
295c9703 399}
400
27e05d7b 401=head2 valid_rev
fbf3eb7e 402
27e05d7b 403Check whether a given rev is valid i.e looks like a sha1.
fbf3eb7e 404
27e05d7b 405=cut
fbf3eb7e 406
407sub valid_rev {
1feb3d6b 408 my ($self, $rev) = @_;
fbf3eb7e 409
1feb3d6b 410 return unless $rev;
b3ad9e63 411 return ($rev =~ /^($SHA1RE)$/);
fbf3eb7e 412}
413
9c0984d1 414=head2 raw_diff
27e05d7b 415
9c0984d1 416Provides the raw output of a diff.
27e05d7b 417
418=cut
419
ad8884fc 420# gitweb uses the following sort of command for diffing merges:
421# /home/dbrook/apps/bin/git --git-dir=/home/dbrook/dev/app/.git diff-tree -r -M --no-commit-id --patch-with-raw --full-index --cc 316cf158df3f6207afbae7270bcc5ba0 --
422# and for regular diffs
423# /home/dbrook/apps/bin/git --git-dir=/home/dbrook/dev/app/.git diff-tree -r -M --no-commit-id --patch-with-raw --full-index 2e3454ca0749641b42f063730b0090e1 316cf158df3f6207afbae7270bcc5ba0 --
424
9c0984d1 425sub raw_diff {
6cf4366a 426 my ($self, @args) = @_;
fbf3eb7e 427
ad8884fc 428 return $self->command(
429 qw(diff-tree -r -M --no-commit-id --full-index),
430 @args
431 );
9c0984d1 432}
fbf3eb7e 433
ad8884fc 434=pod
9c0984d1 435diff --git a/TODO b/TODO
436index 6a05e77..2071fd0 100644
437--- a/TODO
438+++ b/TODO
439@@ -2,4 +2,3 @@
440 * An action to find what branches have been merged, either as a list or through a search mechanism.
441 * An action to find which branches a given commit is on.
442 * Fix any not text/html bits e.g the patch action.
443-* Simplify the creation of links.
444diff --git a/lib/Gitalist/Controller/Root.pm b/lib/Gitalist/Controller/Root.pm
445index 706d024..7fac165 100644
446--- a/lib/Gitalist/Controller/Root.pm
447+++ b/lib/Gitalist/Controller/Root.pm
448@@ -157,23 +157,6 @@ sub shortlog : Local {
449 );
450 }
451
452-=head2 tree
453-
454-The tree of a given commit.
455=cut
456
457=head2 diff
458
459Returns a list of diff chunks corresponding to the files contained in the diff
460and some associated metadata.
461
462=cut
463
ad8884fc 464# XXX Ideally this would return a wee object instead of ad hoc structures.
9c0984d1 465sub diff {
ad8884fc 466 my($self, %args) = @_;
467
468 # So either a parent is specifed, or we use the commit's parent if there's
469 # only one, otherwise it was a merge commit.
470 my $parent = $args{parent}
471 ? $args{parent}
472 : @{$args{commit}->parents} <= 1
473 ? $args{commit}->parent_sha1
474 : '-c';
475 my @etc = (
476 ( $args{file} ? ('--', $args{file}) : () ),
477 );
478
479 my @out = $self->raw_diff(
480 ( $args{patch} ? '--patch-with-raw' : () ),
481 $parent, $args{commit}->sha1, @etc
482 );
9c0984d1 483
ad8884fc 484 # XXX Yes, there is much wrongness having parse_diff_tree be destructive.
485 my @difftree = $self->parse_diff_tree(\@out);
486
487 return \@difftree
488 unless $args{patch};
489
490 # The blank line between the tree and the patch.
491 shift @out;
492
493 # XXX And no I'm not happy about having diff return tree + patch.
494 return \@difftree, [$self->parse_diff(@out)];
6cf4366a 495}
496
497sub parse_diff {
498 my($self, @diff) = @_;
9c0984d1 499
500 my @ret;
9dc3b9a5 501 for (@diff) {
9c0984d1 502 # This regex is a little pathological.
9dc3b9a5 503 if(m{^diff --git (a/(.*?)) (b/\2)}) {
9c0984d1 504 push @ret, {
9dc3b9a5 505 head => $_,
9c0984d1 506 a => $1,
507 b => $3,
508 file => $2,
509 diff => '',
510 };
511 next;
512 }
513
9dc3b9a5 514 if(/^index (\w+)\.\.(\w+) (\d+)$/) {
9c0984d1 515 @{$ret[-1]}{qw(index src dst mode)} = ($_, $1, $2, $3);
516 next
517 }
518
9c0984d1 519 # XXX Somewhat hacky. Ahem.
9dc3b9a5 520 $ret[-1]{diff} .= "$_\n";
9c0984d1 521 }
522
523 return @ret;
fbf3eb7e 524}
525
ad8884fc 526# $ git diff-tree -r --no-commit-id -M b222ff0a7260cc1777c7e455dfcaf22551a512fc 7e54e579e196c6c545fee1030175f65a111039d4
527# :100644 100644 6a85d6c6315b55a99071974eb6ce643aeb2799d6 44c03ed6c328fa6de4b1d9b3f19a3de96b250370 M templates/blob.tt2
528
529=head2 parse_diff_tree
530
531Given a L<Git::PurePerl> commit object return a list of hashes corresponding
532to the C<diff-tree> output.
533
534=cut
535
536sub parse_diff_tree {
537 my($self, $diff) = @_;
538
539 my @keys = qw(modesrc modedst sha1src sha1dst status src dst);
540 my @ret;
b4b4d0fd 541 while(@$diff and $diff->[0] =~ /^:\d+/) {
542 my $line = shift @$diff;
ad8884fc 543 # see. man git-diff-tree for more info
544 # mode src, mode dst, sha1 src, sha1 dst, status, src[, dst]
b4b4d0fd 545 my @vals = $line =~ /^:(\d+) (\d+) ($SHA1RE) ($SHA1RE) ([ACDMRTUX]\d*)\t([^\t]+)(?:\t([^\n]+))?$/;
ad8884fc 546 my %line = zip @keys, @vals;
547 # Some convenience keys
548 $line{file} = $line{src};
549 $line{sha1} = $line{sha1dst};
b4b4d0fd 550 $line{is_new} = $line{sha1src} =~ /^0+$/
551 if $line{sha1src};
552 @line{qw/status sim/} = $line{status} =~ /(R)(\d+)/
553 if $line{status} =~ /^R/;
ad8884fc 554 push @ret, \%line;
555 }
556
557 return @ret;
558}
559
27e05d7b 560=head2 parse_rev_list
561
562Given the output of the C<rev-list> command return a list of hashes.
563
564=cut
565
47495599 566sub parse_rev_list {
567 my ($self, $output) = @_;
568 my @ret;
569
570 my @revs = split /\0/, $output;
1feb3d6b 571
47495599 572 for my $rev (split /\0/, $output) {
573 for my $line (split /\n/, $rev, 6) {
574 chomp $line;
575 next unless $line;
576
577 if ($self->valid_rev($line)) {
578 push @ret, $self->get_object($line);
579 }
580 }
1feb3d6b 581 }
47495599 582
583 return @ret;
fbf3eb7e 584}
585
27e05d7b 586=head2 list_revs
587
588Calls the C<rev-list> command (a low-level from of C<log>) and returns an
589array of hashes.
590
591=cut
592
fbf3eb7e 593sub list_revs {
27e05d7b 594 my ($self, %args) = @_;
fbf3eb7e 595
0ee97fec 596 $args{sha1} ||= $self->head_hash($args{project});
fbf3eb7e 597
27e05d7b 598 my $output = $self->run_cmd_in($args{project} || $self->project, 'rev-list',
1feb3d6b 599 '--header',
600 (defined $args{ count } ? "--max-count=$args{count}" : ()),
27e05d7b 601 (defined $args{ skip } ? "--skip=$args{skip}" : ()),
0ee97fec 602 $args{sha1},
1feb3d6b 603 '--',
27e05d7b 604 ($args{file} ? $args{file} : ()),
605 );
1feb3d6b 606 return unless $output;
fbf3eb7e 607
1feb3d6b 608 my @revs = $self->parse_rev_list($output);
fbf3eb7e 609
790ce598 610 return @revs;
fbf3eb7e 611}
612
27e05d7b 613=head2 rev_info
614
615Get a single piece of revision information for a given sha1.
616
617=cut
618
fbf3eb7e 619sub rev_info {
27e05d7b 620 my($self, $rev, $project) = @_;
fbf3eb7e 621
1feb3d6b 622 return unless $self->valid_rev($rev);
c5065c66 623
27e05d7b 624 return $self->list_revs(
625 rev => $rev, count => 1,
626 ( $project ? (project => $project) : () )
627 );
1feb3d6b 628}
629
27e05d7b 630=head2 reflog
631
632Calls the C<reflog> command and returns a list of hashes.
633
634=cut
635
1feb3d6b 636sub reflog {
637 my ($self, @logargs) = @_;
638
639 my @entries
640 = $self->run_cmd_in($self->project, qw(log -g), @logargs)
641 =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg;
642
ad8884fc 643=pod
1feb3d6b 644 commit 02526fc15beddf2c64798a947fecdd8d11bf993d
645 Reflog: HEAD@{14} (The Git Server <git@git.dev.venda.com>)
646 Reflog message: push
1ef8dc7d 647 Author: Foo Barsby <fbarsby@example.com>
1feb3d6b 648 Date: Thu Sep 17 12:26:05 2009 +0100
649
1ef8dc7d 650 Merge branch 'abc123'
1feb3d6b 651=cut
652
653 return map {
654
655 # XXX Stuff like this makes me want to switch to Git::PurePerl
656 my($sha1, $type, $author, $date)
657 = m{
b3ad9e63 658 ^ commit \s+ ($SHA1RE)$
1feb3d6b 659 .*?
660 Reflog[ ]message: \s+ (.+?)$ \s+
661 Author: \s+ ([^<]+) <.*?$ \s+
662 Date: \s+ (.+?)$
27e05d7b 663 }xms;
1feb3d6b 664
665 pos($_) = index($_, $date) + length $date;
666
667 # Yeah, I just did that.
668
669 my($msg) = /\G\s+(\S.*)/sg;
670
671 {
672 hash => $sha1,
673 type => $type,
674 author => $author,
675
676 # XXX Add DateTime goodness.
677 date => $date,
678 message => $msg,
679 };
1ef8dc7d 680 } @entries;
c5065c66 681}
682
790ce598 683=head2 heads
27e05d7b 684
685Returns an array of hashes representing the heads (aka branches) for the
686given, or current, project.
687
688=cut
689
790ce598 690sub heads {
1feb3d6b 691 my ($self, $project) = @_;
fbf3eb7e 692
790ce598 693 my @output = $self->command(qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
fbf3eb7e 694
1feb3d6b 695 my @ret;
790ce598 696 for my $line (@output) {
1feb3d6b 697 my ($rev, $head, $commiter) = split /\0/, $line, 3;
698 $head =~ s!^refs/heads/!!;
fbf3eb7e 699
790ce598 700 push @ret, { sha1 => $rev, name => $head };
fbf3eb7e 701
1feb3d6b 702 #FIXME: That isn't the time I'm looking for..
2247133f 703 if (my ($epoch, $tz) = $line =~ /\s(\d+)\s+([+-]\d+)$/) {
1feb3d6b 704 my $dt = DateTime->from_epoch(epoch => $epoch);
705 $dt->set_time_zone($tz);
706 $ret[-1]->{last_change} = $dt;
fbf3eb7e 707 }
1feb3d6b 708 }
fbf3eb7e 709
790ce598 710 return @ret;
fbf3eb7e 711}
712
1ef8dc7d 713=head2 refs_for
714
27e05d7b 715For a given sha1 check which branches currently point at it.
1ef8dc7d 716
717=cut
718
719sub refs_for {
720 my($self, $sha1) = @_;
721
722 my $refs = $self->references->{$sha1};
723
724 return $refs ? @$refs : ();
725}
726
27e05d7b 727=head2 references
1ef8dc7d 728
729A wrapper for C<git show-ref --dereference>. Based on gitweb's
730C<git_get_references>.
731
732=cut
733
734sub references {
735 my($self) = @_;
736
737 return $self->{references}
738 if $self->{references};
739
740 # 5dc01c595e6c6ec9ccda4f6f69c131c0dd945f8c refs/tags/v2.6.11
741 # c39ae07f393806ccf406ef966e9a15afc43cc36a refs/tags/v2.6.11^{}
b3ad9e63 742 my @reflist = $self->command(qw(show-ref --dereference))
1ef8dc7d 743 or return;
744
745 my %refs;
b3ad9e63 746 for(@reflist) {
1ef8dc7d 747 push @{$refs{$1}}, $2
b3ad9e63 748 if m!^($SHA1RE)\srefs/(.*)$!;
1ef8dc7d 749 }
750
751 return $self->{references} = \%refs;
752}
753
fbf3eb7e 7541;
755
756__PACKAGE__->meta->make_immutable;