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