lib/Gitalist/Model/Git.pm

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