X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FGitalist%2FModel%2FGit.pm;h=1d9328f2200fe7d1f5bf156e795a10fe6e9f5fbf;hb=30e4d46d3ec8b7a731e84e3fe7ef375d33d78e61;hp=a4afd8ef4d484961320409a42f00391c0067b5db;hpb=c5065c66384f6e83e1be34af16aae03995064884;p=catagits%2FGitalist.git diff --git a/lib/Gitalist/Model/Git.pm b/lib/Gitalist/Model/Git.pm index a4afd8e..1d9328f 100644 --- a/lib/Gitalist/Model/Git.pm +++ b/lib/Gitalist/Model/Git.pm @@ -3,403 +3,762 @@ package Gitalist::Model::Git; use Moose; use namespace::autoclean; -BEGIN { extends 'Catalyst::Model' } +extends 'Catalyst::Model'; +with 'Catalyst::Component::InstancePerContext'; use DateTime; use Path::Class; +use File::Which; use Carp qw/croak/; use File::Find::Rule; use DateTime::Format::Mail; use File::Stat::ModeString; -use List::MoreUtils qw/any/; +use List::MoreUtils qw/any zip/; use Scalar::Util qw/blessed/; +use MooseX::Types::Common::String qw/NonEmptySimpleStr/; # FIXME, use Types::Path::Class and coerce -{ - my $git; - sub git { - return $git - if $git; - - if (my $config_git = Gitalist->config->{git}) { - $git = $config_git if -x $config_git; - } - else { - require File::Which; - $git = File::Which::which('git'); - } - - if (!$git) { - die < ( isa => NonEmptySimpleStr, is => 'ro', lazy_build => 1 ); # Fixme - path::class +has git => ( isa => NonEmptySimpleStr, is => 'ro', lazy_build => 1 ); +# These are dynamic and can be different from one request to the next. +has project => ( isa => NonEmptySimpleStr, is => 'rw'); +has gpp => ( isa => 'Git::PurePerl', is => 'rw', lazy_build => 1 ); + +sub build_per_context_instance { + my ( $self, $c ) = @_; + + # If we don't have a project param it probably means we're at / + return $self + unless $c->req->param('p'); + + $self->project( $c->req->param('p') ); + + (my $pd = $self->project_dir( $self->project )) =~ s{/\.git$}(); + $self->gpp( Git::PurePerl->new(directory => $pd) ); + + return $self; +} + +=head2 BUILD + +=cut + +sub BUILD { + my ($self) = @_; + $self->git; # Cause lazy value build. + $self->repo_dir; +} + +sub _build_git { + my $git = File::Which::which('git'); + + if (!$git) { + die <config->{repo_dir}; } +=head2 get_object + +A wrapper for the equivalent L method. + +=cut + +sub get_object { + my($self, $sha1) = @_; + + # We either want an object or undef, *not* an empty list. + return $self->gpp->get_object($sha1) || undef; +} + +=head2 is_git_repo + +Determine whether a given directory (as a L object) is a +C repo. + +=cut + sub is_git_repo { - my ($self, $dir) = @_; + my ($self, $dir) = @_; - return -f $dir->file('HEAD') || -f $dir->file('.git/HEAD'); + return -f $dir->file('HEAD') || -f $dir->file('.git/HEAD'); } -sub project_info { - my ($self, $project) = @_; +=head2 run_cmd - return { - name => $project, - $self->get_project_properties( - $self->git_dir_from_project_name($project), - ), - }; +Call out to the C binary and return a string consisting of the output. + +=cut + +sub run_cmd { + my ($self, @args) = @_; + + print STDERR 'RUNNING: ', $self->git, qq[ @args], $/; + + open my $fh, '-|', $self->git, @args + or die "failed to run git command"; + binmode $fh, ':encoding(UTF-8)'; + + my $output = do { local $/ = undef; <$fh> }; + close $fh; + + return $output; } -sub get_project_properties { - my ($self, $dir) = @_; - my %props; +=head2 project_dir - eval { - $props{description} = $dir->file('description')->slurp; - chomp $props{description}; - }; +The directory under which the given project will reside i.e C<.git/..> - if ($props{description} && $props{description} =~ /^Unnamed repository;/) { - delete $props{description}; - } +=cut - $props{owner} = (getpwuid $dir->stat->uid)[6]; +sub project_dir { + my($self, $project) = @_; - my $output = $self->run_cmd_in($dir, qw{ - for-each-ref --format=%(committer) - --sort=-committerdate --count=1 refs/heads - }); + my $dir = blessed($project) && $project->isa('Path::Class::Dir') + ? $project->stringify + : $self->dir_from_project_name($project); - if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) { - my $dt = DateTime->from_epoch(epoch => $epoch); - $dt->set_time_zone($tz); - $props{last_change} = $dt; - } + $dir .= '/.git' + if -f dir($dir)->file('.git/HEAD'); - return %props; + return $dir; } -sub list_projects { - my ($self) = @_; +=head2 run_cmd_in - my $base = dir(Gitalist->config->{repo_dir}); - - my @ret; - my $dh = $base->open; - while (my $file = $dh->read) { - next if $file =~ /^.{1,2}$/; - - my $obj = $base->subdir($file); - next unless -d $obj; - next unless $self->is_git_repo($obj); - # XXX Leaky abstraction alert! - my $is_bare = !-d $obj->subdir('.git'); - - my $name = (File::Spec->splitdir($obj))[-1]; - push @ret, { - name => ($name . ( $is_bare ? '.git' : '/.git' )), - $self->get_project_properties( - $is_bare ? $obj : $obj->subdir('.git') - ), - }; - } +Run a C command in a given project and return the output as a string. + +=cut - return [sort { $a->{name} cmp $b->{name} } @ret]; +sub run_cmd_in { + my ($self, $project, @args) = @_; + + return $self->run_cmd('--git-dir' => $self->project_dir($project), @args); } -sub run_cmd { - my ($self, @args) = @_; +=head2 command - open my $fh, '-|', __PACKAGE__->git, @args - or die "failed to run git command"; - binmode $fh, ':encoding(UTF-8)'; +Run a C command for the project specified in the C

parameter and +return the output as a list of strings corresponding to the lines of output. - print STDERR "RAN - git @_[1..$#_]\n"; +=cut + +sub command { + my($self, @args) = @_; - my $output = do { local $/ = undef; <$fh> }; - close $fh; + my $output = $self->run_cmd('--git-dir' => $self->project_dir($self->project), @args); - return $output; + return $output ? split(/\n/, $output) : (); } -sub run_cmd_in { - my ($self, $project, @args) = @_; +=head2 project_info - my $path; - if (blessed($project) && $project->isa('Path::Class::Dir')) { - $path = $project->stringify; - } - else { - $path = $self->git_dir_from_project_name($project); - } - return $self->run_cmd('--git-dir' => $path, @args); +Returns a hash corresponding to a given project's properties. The keys will +be: + + name + description (empty if .git/description is empty/unnamed) + owner + last_change + +=cut + +sub project_info { + my ($self, $project) = @_; + + return { + name => $project, + $self->get_project_properties( + $self->dir_from_project_name($project), + ), + }; } -sub git_dir_from_project_name { - my ($self, $project) = @_; +=head2 get_project_properties + +Called by C to get a project's properties. + +=cut + +sub get_project_properties { + my ($self, $dir) = @_; + my %props; - return dir(Gitalist->config->{repo_dir})->subdir($project); + eval { + $props{description} = $dir->file('description')->slurp; + chomp $props{description}; + }; + + if ($props{description} && $props{description} =~ /^Unnamed repository;/) { + delete $props{description}; + } + + ($props{owner} = (getpwuid $dir->stat->uid)[6]) =~ s/,+$//; + + my $output = $self->run_cmd_in($dir, qw{ + for-each-ref --format=%(committer) + --sort=-committerdate --count=1 refs/heads + }); + + if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) { + my $dt = DateTime->from_epoch(epoch => $epoch); + $dt->set_time_zone($tz); + $props{last_change} = $dt; + } + + return %props; } -sub get_head_hash { - my ($self, $project) = @_; +=head2 list_projects + +For the C specified in the config return an array of projects where +each item will contain the contents of L. + +=cut + +sub list_projects { + my ($self, $dir) = @_; + + my $base = dir($dir || $self->repo_dir); - my $output = $self->run_cmd_in($project, qw/rev-parse --verify HEAD/ ); - return unless defined $output; + my @ret; + my $dh = $base->open; + while (my $file = $dh->read) { + next if $file =~ /^.{1,2}$/; - my ($head) = $output =~ /^([0-9a-fA-F]{40})$/; - return $head; + my $obj = $base->subdir($file); + next unless -d $obj; + next unless $self->is_git_repo($obj); + + # XXX Leaky abstraction alert! + my $is_bare = !-d $obj->subdir('.git'); + + my $name = (File::Spec->splitdir($obj))[-1]; + push @ret, { + name => ($name . ( $is_bare ? '' : '/.git' )), + $self->get_project_properties( + $is_bare ? $obj : $obj->subdir('.git') + ), + }; + } + + return [sort { $a->{name} cmp $b->{name} } @ret]; } -sub list_tree { - my ($self, $project, $rev) = @_; +=head2 dir_from_project_name - $rev ||= $self->get_head_hash($project); +Get the corresponding directory of a given project. - my $output = $self->run_cmd_in($project, qw/ls-tree -z/, $rev); - return unless defined $output; +=cut - my @ret; - for my $line (split /\0/, $output) { - my ($mode, $type, $object, $file) = split /\s+/, $line, 4; +sub dir_from_project_name { + my ($self, $project) = @_; - push @ret, { - mode => oct $mode, - type => $type, - object => $object, - file => $file, - }; - } + return dir($self->repo_dir)->subdir($project); +} - return @ret; +=head2 head_hash + +Find the hash of a given head (defaults to HEAD) of given (or current) project. + +=cut + +sub head_hash { + my ($self, $head) = @_; + + my($output) = $self->command(qw/rev-parse --verify/, $head || 'HEAD' ); + return unless $output; + + my($sha1) = $output =~ /^($SHA1RE)$/; + return $sha1; +} + +=head2 list_tree + +For a given tree sha1 return an array describing the tree's contents. Where +the keys for each item will be: + + mode + type + object + file + +=cut + +sub list_tree { + my ($self, $sha1) = @_; + + $sha1 = $self->head_hash($sha1) + if !$sha1 or $sha1 !~ $SHA1RE; + + my($output) = $self->command(qw/ls-tree -z/, $sha1); + return + unless $output; + + my @ret; + for my $line (split /\0/, $output) { + my ($mode, $type, $object, $file) = split /\s+/, $line, 4; + + push @ret, { + mode => oct $mode, + # XXX I wonder why directories always turn up as 040000 ... + modestr => $self->get_object_mode_string({mode=>oct $mode}), + type => $type, + object => $object, + file => $file, + }; + } + + return @ret; } +=head2 get_object_mode_string + +Provide a string equivalent of an octal mode e.g 0644 eq '-rw-r--r--'. + +=cut + sub get_object_mode_string { - my ($self, $object) = @_; + my ($self, $object) = @_; - return unless $object && $object->{mode}; - return mode_to_string($object->{mode}); + return unless $object && $object->{mode}; + return mode_to_string($object->{mode}); } +=head2 get_object_type + +=cut + sub get_object_type { - my ($self, $project, $object) = @_; + my ($self, $object) = @_; - my $output = $self->run_cmd_in($project, qw/cat-file -t/, $object); - return unless $output; + my($output) = $self->command(qw/cat-file -t/, $object) + or return; - chomp $output; - return $output; + return $output; } -sub get_hash_by_path { - my($self, $project, $base, $path, $type) = @_; +=head2 cat_file + +Return the contents of a given file. - $path =~ s{/+$}(); +=cut + +sub cat_file { + my ($self, $object) = @_; - my $line = $self->run_cmd_in($project, 'ls-tree', $base, '--', $path) + my $type = $self->get_object_type($object); + die "object `$object' is not a file\n" + if (!defined $type || $type ne 'blob'); + + my($output) = $self->command(qw/cat-file -p/, $object) or return; - #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa panic.c' - $line =~ m/^([0-9]+) (.+) ([0-9a-fA-F]{40})\t/; - return defined $type && $type ne $2 - ? () - : return $3; + return $output; } -sub cat_file { - my ($self, $project, $object) = @_; +=head2 hash_by_path + +For a given sha1 and path find the corresponding hash. Useful for find blobs. + +=cut + +sub hash_by_path { + my($self, $base, $path, $type) = @_; - my $type = $self->get_object_type($project, $object); - die "object `$object' is not a file\n" - if (!defined $type || $type ne 'blob'); + $path =~ s{/+$}(); - my $output = $self->run_cmd_in($project, qw/cat-file -p/, $object); - return unless $output; + my($line) = $self->command('ls-tree', $base, '--', $path) + or return; - return $output; + #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa panic.c' + $line =~ m/^([0-9]+) (.+) ($SHA1RE)\t/; + return defined $type && $type ne $2 + ? () + : $3; } +=head2 valid_rev + +Check whether a given rev is valid i.e looks like a sha1. + +=cut + sub valid_rev { - my ($self, $rev) = @_; + my ($self, $rev) = @_; - return unless $rev; - return ($rev =~ /^([0-9a-fA-F]{40})$/); + return unless $rev; + return ($rev =~ /^($SHA1RE)$/); } -sub diff { - my ($self, $project, @revs) = @_; +=head2 raw_diff - croak("Gitalist::Model::Git::diff needs a project and either one or two revisions") - if scalar @revs < 1 - || scalar @revs > 2 - || any { !$self->valid_rev($_) } @revs; +Provides the raw output of a diff. - my $output = $self->run_cmd_in($project, 'diff', @revs); - return unless $output; +=cut + +# gitweb uses the following sort of command for diffing merges: +# /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 -- +# and for regular diffs +# /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 -- + +sub raw_diff { + my ($self, @args) = @_; - return $output; + return $self->command( + qw(diff-tree -r -M --no-commit-id --full-index), + @args + ); } -{ - my $formatter = DateTime::Format::Mail->new; +=pod +diff --git a/TODO b/TODO +index 6a05e77..2071fd0 100644 +--- a/TODO ++++ b/TODO +@@ -2,4 +2,3 @@ + * An action to find what branches have been merged, either as a list or through a search mechanism. + * An action to find which branches a given commit is on. + * Fix any not text/html bits e.g the patch action. +-* Simplify the creation of links. +diff --git a/lib/Gitalist/Controller/Root.pm b/lib/Gitalist/Controller/Root.pm +index 706d024..7fac165 100644 +--- a/lib/Gitalist/Controller/Root.pm ++++ b/lib/Gitalist/Controller/Root.pm +@@ -157,23 +157,6 @@ sub shortlog : Local { + ); + } + +-=head2 tree +- +-The tree of a given commit. +=cut - sub parse_rev_list { - my ($self, $output) = @_; - my @ret; +=head2 diff - my @revs = split /\0/, $output; +Returns a list of diff chunks corresponding to the files contained in the diff +and some associated metadata. - for my $rev (split /\0/, $output) { - for my $line (split /\n/, $rev, 6) { - chomp $line; - next unless $line; +=cut - if ($self->valid_rev($line)) { - push @ret, {rev => $line}; - next; - } +# XXX Ideally this would return a wee object instead of ad hoc structures. +sub diff { + my($self, %args) = @_; + + # So either a parent is specifed, or we use the commit's parent if there's + # only one, otherwise it was a merge commit. + my $parent = $args{parent} + ? $args{parent} + : @{$args{commit}->parents} <= 1 + ? $args{commit}->parent_sha1 + : '-c'; + my @etc = ( + ( $args{file} ? ('--', $args{file}) : () ), + ); + + my @out = $self->raw_diff( + ( $args{patch} ? '--patch-with-raw' : () ), + $parent, $args{commit}->sha1, @etc + ); + + # XXX Yes, there is much wrongness having parse_diff_tree be destructive. + my @difftree = $self->parse_diff_tree(\@out); + + return \@difftree + unless $args{patch}; + + # The blank line between the tree and the patch. + shift @out; + + # XXX And no I'm not happy about having diff return tree + patch. + return \@difftree, [$self->parse_diff(@out)]; +} - if (my ($key, $value) = $line =~ /^(tree|parent)\s+(.*)$/) { - $ret[-1]->{$key} = $value; - next; - } +sub parse_diff { + my($self, @diff) = @_; + + my @ret; + for (@diff) { + # This regex is a little pathological. + if(m{^diff --git (a/(.*?)) (b/\2)}) { + push @ret, { + head => $_, + a => $1, + b => $3, + file => $2, + diff => '', + }; + next; + } + + if(/^index (\w+)\.\.(\w+) (\d+)$/) { + @{$ret[-1]}{qw(index src dst mode)} = ($_, $1, $2, $3); + next + } + + # XXX Somewhat hacky. Ahem. + $ret[@ret ? -1 : 0]{diff} .= "$_\n"; + } - if (my ($key, $value, $epoch, $tz) = $line =~ /^(author|committer)\s+(.*)\s+(\d+)\s+([+-]\d+)$/) { - $ret[-1]->{$key} = $value; - eval { - $ret[-1]->{ $key . "_datetime" } = DateTime->from_epoch(epoch => $epoch); - $ret[-1]->{ $key . "_datetime" }->set_time_zone($tz); - $ret[-1]->{ $key . "_datetime" }->set_formatter($formatter); - }; + return @ret; +} - if ($@) { - $ret[-1]->{ $key . "_datetime" } = "$epoch $tz"; - } +# $ git diff-tree -r --no-commit-id -M b222ff0a7260cc1777c7e455dfcaf22551a512fc 7e54e579e196c6c545fee1030175f65a111039d4 +# :100644 100644 6a85d6c6315b55a99071974eb6ce643aeb2799d6 44c03ed6c328fa6de4b1d9b3f19a3de96b250370 M templates/blob.tt2 - if (my ($name, $email) = $value =~ /^([^<]+)\s+<([^>]+)>$/) { - $ret[-1]->{ $key . "_name" } = $name; - $ret[-1]->{ $key . "_email" } = $email; - } - } +=head2 parse_diff_tree - $line =~ s/^\n?\s{4}//; - $ret[-1]->{longmessage} = $line; - $ret[-1]->{message} = (split /\n/, $line, 2)[0]; - } - } +Given a L commit object return a list of hashes corresponding +to the C output. - return @ret; - } +=cut + +sub parse_diff_tree { + my($self, $diff) = @_; + + my @keys = qw(modesrc modedst sha1src sha1dst status src dst); + my @ret; + while(@$diff and $diff->[0] =~ /^:\d+/) { + my $line = shift @$diff; + # see. man git-diff-tree for more info + # mode src, mode dst, sha1 src, sha1 dst, status, src[, dst] + my @vals = $line =~ /^:(\d+) (\d+) ($SHA1RE) ($SHA1RE) ([ACDMRTUX]\d*)\t([^\t]+)(?:\t([^\n]+))?$/; + my %line = zip @keys, @vals; + # Some convenience keys + $line{file} = $line{src}; + $line{sha1} = $line{sha1dst}; + $line{is_new} = $line{sha1src} =~ /^0+$/ + if $line{sha1src}; + @line{qw/status sim/} = $line{status} =~ /(R)(\d+)/ + if $line{status} =~ /^R/; + push @ret, \%line; + } + + return @ret; } -sub list_revs { - my ($self, $project, %args) = @_; +=head2 parse_rev_list - $args{rev} ||= $self->get_head_hash($project); +Given the output of the C command return a list of hashes. - my $output = $self->run_cmd_in($project, 'rev-list', - '--header', - (defined $args{ count } ? "--max-count=$args{count}" : ()), - (defined $args{ skip } ? "--skip=$args{skip}" : ()), - $args{rev}, - '--', - ($args{file} || ()), - ); - return unless $output; +=cut + +sub parse_rev_list { + my ($self, $output) = @_; - my @revs = $self->parse_rev_list($output); + return + map $self->get_object($_), + grep $self->valid_rev($_), + map split(/\n/, $_, 6), split /\0/, $output; +} + +=head2 list_revs + +Calls the C command (a low-level from of C) and returns an +array of hashes. - return \@revs; +=cut + +sub list_revs { + my ($self, %args) = @_; + + $args{sha1} = $self->head_hash($args{sha1}) + if !$args{sha1} || $args{sha1} !~ $SHA1RE; + + my @search_opts; + if($args{search}) { + my $sargs = $args{search}; + $sargs->{type} = 'grep' + if $sargs->{type} eq 'commit'; + @search_opts = ( + # This seems a little fragile ... + qq[--$sargs->{type}=$sargs->{text}], + '--regexp-ignore-case', + $sargs->{regexp} ? '--extended-regexp' : '--fixed-strings' + ); + } + + $DB::single=1; + my $output = $self->run_cmd_in($args{project} || $self->project, 'rev-list', + '--header', + (defined $args{ count } ? "--max-count=$args{count}" : ()), + (defined $args{ skip } ? "--skip=$args{skip}" : ()), + @search_opts, + $args{sha1}, + '--', + ($args{file} ? $args{file} : ()), + ); + return unless $output; + + my @revs = $self->parse_rev_list($output); + + return @revs; } +=head2 rev_info + +Get a single piece of revision information for a given sha1. + +=cut + sub rev_info { - my ($self, $project, $rev) = @_; + my($self, $rev, $project) = @_; - return unless $self->valid_rev($rev); + return unless $self->valid_rev($rev); - return $self->list_revs($project, rev => $rev, count => 1); + return $self->list_revs( + rev => $rev, count => 1, + ( $project ? (project => $project) : () ) + ); } -sub reflog { - my ($self, $project, @logargs) = @_; +=head2 reflog - my @entries - = $self->run_cmd_in($project, qw(log -g), @logargs) - =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg; +Calls the C command and returns a list of hashes. -=begin +=cut + +sub reflog { + my ($self, @logargs) = @_; + my @entries + = $self->run_cmd_in($self->project, qw(log -g), @logargs) + =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg; + +=pod commit 02526fc15beddf2c64798a947fecdd8d11bf993d Reflog: HEAD@{14} (The Git Server ) Reflog message: push - Author: Iain Loasby + Author: Foo Barsby Date: Thu Sep 17 12:26:05 2009 +0100 - Merge branch 'rt125181 + Merge branch 'abc123' =cut - return map { - # XXX Stuff like this makes me want to switch to Git::PurePerl - my($sha1, $type, $author, $date) - = m{ - ^ commit \s+ ([0-9a-f]+)$ + + return map { + + # XXX Stuff like this makes me want to switch to Git::PurePerl + my($sha1, $type, $author, $date) + = m{ + ^ commit \s+ ($SHA1RE)$ .*? Reflog[ ]message: \s+ (.+?)$ \s+ Author: \s+ ([^<]+) <.*?$ \s+ Date: \s+ (.+?)$ }xms; - pos($_) = index($_, $date) + length $date; - # Yeah, I just did that. + pos($_) = index($_, $date) + length $date; - my($msg) = /\G\s+(\S.*)/sg; + # Yeah, I just did that. - { - hash => $sha1, - type => $type, - author => $author, - # XXX Add DateTime goodness. - date => $date, - message => $msg, - }; - } @entries; + my($msg) = /\G\s+(\S.*)/sg; + + { + hash => $sha1, + type => $type, + author => $author, + + # XXX Add DateTime goodness. + date => $date, + message => $msg, + }; + } @entries; } -sub get_heads { - my ($self, $project) = @_; +=head2 heads + +Returns an array of hashes representing the heads (aka branches) for the +given, or current, project. + +=cut + +sub heads { + my ($self, $project) = @_; - my $output = $self->run_cmd_in($project, qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads'); - return unless $output; + my @output = $self->command(qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads'); - my @ret; - for my $line (split /\n/, $output) { - my ($rev, $head, $commiter) = split /\0/, $line, 3; - $head =~ s!^refs/heads/!!; + my @ret; + for my $line (@output) { + my ($rev, $head, $commiter) = split /\0/, $line, 3; + $head =~ s!^refs/heads/!!; - push @ret, { rev => $rev, name => $head }; + push @ret, { sha1 => $rev, name => $head }; - #FIXME: That isn't the time I'm looking for.. - if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) { - my $dt = DateTime->from_epoch(epoch => $epoch); - $dt->set_time_zone($tz); - $ret[-1]->{last_change} = $dt; - } + #FIXME: That isn't the time I'm looking for.. + if (my ($epoch, $tz) = $line =~ /\s(\d+)\s+([+-]\d+)$/) { + my $dt = DateTime->from_epoch(epoch => $epoch); + $dt->set_time_zone($tz); + $ret[-1]->{last_change} = $dt; } + } + + return @ret; +} + +=head2 refs_for + +For a given sha1 check which branches currently point at it. - return \@ret; +=cut + +sub refs_for { + my($self, $sha1) = @_; + + my $refs = $self->references->{$sha1}; + + return $refs ? @$refs : (); } -sub archive { - my ($self, $project, $rev) = @_; +=head2 references + +A wrapper for C. Based on gitweb's +C. + +=cut + +sub references { + my($self) = @_; + + return $self->{references} + if $self->{references}; + + # 5dc01c595e6c6ec9ccda4f6f69c131c0dd945f8c refs/tags/v2.6.11 + # c39ae07f393806ccf406ef966e9a15afc43cc36a refs/tags/v2.6.11^{} + my @reflist = $self->command(qw(show-ref --dereference)) + or return; + + my %refs; + for(@reflist) { + push @{$refs{$1}}, $2 + if m!^($SHA1RE)\srefs/(.*)$!; + } - #FIXME: huge memory consuption - #TODO: compression - return $self->run_cmd_in($project, qw/archive --format=tar/, "--prefix=${project}/", $rev); + return $self->{references} = \%refs; } 1;