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