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 # abstraction fail - but currently needed for unit tests to work
  18 use Gitalist;
  19
  20 {
  21         my $git;
  22         sub git {
  23                 return $git
  24                         if $git;
  25
  26                 if (my $config_git = Gitalist->config->{git}) {
  27                         $git = $config_git if -x $config_git;
  28                 }
  29                 else {
  30                         require File::Which;
  31                         $git = File::Which::which('git');
  32                 }
  33
  34                 if (!$git) {
  35                         die <<EOR
  36 Could not find a git executable.
  37 Please specify the which git executable to use in gitweb.yml
  38 EOR
  39                 }
  40
  41                 return $git;
  42         }
  43 }
  44
  45 sub is_git_repo {
  46     my ($self, $dir) = @_;
  47
  48     return -f $dir->file('HEAD') || -f $dir->file('.git/HEAD');
  49 }
  50
  51 sub project_info {
  52     my ($self, $project) = @_;
  53
  54     return {
  55         name => $project,
  56         $self->get_project_properties(
  57                 $self->git_dir_from_project_name($project),
  58         ),
  59     };
  60 }
  61
  62 sub get_project_properties {
  63     my ($self, $dir) = @_;
  64     my %props;
  65
  66     eval {
  67         $props{description} = $dir->file('description')->slurp;
  68         chomp $props{description};
  69     };
  70
  71     if ($props{description} && $props{description} =~ /^Unnamed repository;/) {
  72         delete $props{description};
  73     }
  74
  75     $props{owner} = (getpwuid $dir->stat->uid)[6];
  76
  77     my $output = $self->run_cmd_in($dir, qw{
  78             for-each-ref --format=%(committer)
  79             --sort=-committerdate --count=1 refs/heads
  80     });
  81
  82     if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
  83         my $dt = DateTime->from_epoch(epoch => $epoch);
  84         $dt->set_time_zone($tz);
  85         $props{last_change} = $dt;
  86     }
  87
  88     return %props;
  89 }
  90
  91 sub list_projects {
  92     my ($self) = @_;
  93
  94     my $base = dir(Gitalist->config->{repo_dir});
  95
  96     my @ret;
  97     my $dh = $base->open;
  98     while (my $file = $dh->read) {
  99         next if $file =~ /^.{1,2}$/;
 100
 101         my $obj = $base->subdir($file);
 102         next unless -d $obj;
 103         next unless $self->is_git_repo($obj);
 104                 # XXX Leaky abstraction alert!
 105                 my $is_bare = !-d $obj->subdir('.git');
 106
 107                 my $name = (File::Spec->splitdir($obj))[-1];
 108         push @ret, {
 109             name => ($name . ( $is_bare ? '.git' : '/.git' )),
 110             $self->get_project_properties(
 111                                 $is_bare ? $obj : $obj->subdir('.git')
 112                         ),
 113         };
 114     }
 115
 116     return [sort { $a->{name} cmp $b->{name} } @ret];
 117 }
 118
 119 sub run_cmd {
 120     my ($self, @args) = @_;
 121
 122     open my $fh, '-|', __PACKAGE__->git, @args
 123         or die "failed to run git command";
 124     binmode $fh, ':encoding(UTF-8)';
 125
 126     my $output = do { local $/ = undef; <$fh> };
 127     close $fh;
 128
 129     return $output;
 130 }
 131
 132 sub run_cmd_in {
 133     my ($self, $project, @args) = @_;
 134
 135     my $path;
 136     if (blessed($project) && $project->isa('Path::Class::Dir')) {
 137         $path = $project->stringify;
 138     }
 139     else {
 140         $path = $self->git_dir_from_project_name($project);
 141     }
 142     return $self->run_cmd('--git-dir' => $path, @args);
 143 }
 144
 145 sub git_dir_from_project_name {
 146     my ($self, $project) = @_;
 147
 148     return dir(Gitalist->config->{repo_dir})->subdir($project);
 149 }
 150
 151 sub get_head_hash {
 152     my ($self, $project) = @_;
 153
 154     my $output = $self->run_cmd_in($project, qw/rev-parse --verify HEAD/ );
 155     return unless defined $output;
 156
 157     my ($head) = $output =~ /^([0-9a-fA-F]{40})$/;
 158     return $head;
 159 }
 160
 161 sub list_tree {
 162     my ($self, $project, $rev) = @_;
 163
 164     $rev ||= $self->get_head_hash($project);
 165
 166     my $output = $self->run_cmd_in($project, qw/ls-tree -z/, $rev);
 167     return unless defined $output;
 168
 169     my @ret;
 170     for my $line (split /\0/, $output) {
 171         my ($mode, $type, $object, $file) = split /\s+/, $line, 4;
 172
 173         push @ret, {
 174             mode   => oct $mode,
 175             type   => $type,
 176             object => $object,
 177             file   => $file,
 178         };
 179     }
 180
 181     return @ret;
 182 }
 183
 184 sub get_object_mode_string {
 185     my ($self, $object) = @_;
 186
 187     return unless $object && $object->{mode};
 188     return mode_to_string($object->{mode});
 189 }
 190
 191 sub get_object_type {
 192     my ($self, $project, $object) = @_;
 193
 194     my $output = $self->run_cmd_in($project, qw/cat-file -t/, $object);
 195     return unless $output;
 196
 197     chomp $output;
 198     return $output;
 199 }
 200
 201 sub cat_file {
 202     my ($self, $project, $object) = @_;
 203
 204     my $type = $self->get_object_type($project, $object);
 205     die "object `$object' is not a file\n"
 206         if (!defined $type || $type ne 'blob');
 207
 208     my $output = $self->run_cmd_in($project, qw/cat-file -p/, $object);
 209     return unless $output;
 210
 211     return $output;
 212 }
 213
 214 sub valid_rev {
 215     my ($self, $rev) = @_;
 216
 217     return unless $rev;
 218     return ($rev =~ /^([0-9a-fA-F]{40})$/);
 219 }
 220
 221 sub diff {
 222     my ($self, $project, @revs) = @_;
 223
 224     croak("Gitalist::Model::Git::diff needs a project and either one or two revisions")
 225         if scalar @revs < 1
 226         || scalar @revs > 2
 227         || any { !$self->valid_rev($_) } @revs;
 228
 229     my $output = $self->run_cmd_in($project, 'diff', @revs);
 230     return unless $output;
 231
 232     return $output;
 233 }
 234
 235 {
 236     my $formatter = DateTime::Format::Mail->new;
 237
 238     sub parse_rev_list {
 239         my ($self, $output) = @_;
 240         my @ret;
 241
 242         my @revs = split /\0/, $output;
 243
 244         for my $rev (split /\0/, $output) {
 245             for my $line (split /\n/, $rev, 6) {
 246                 chomp $line;
 247                 next unless $line;
 248
 249                 if ($self->valid_rev($line)) {
 250                     push @ret, {rev => $line};
 251                     next;
 252                 }
 253
 254                 if (my ($key, $value) = $line =~ /^(tree|parent)\s+(.*)$/) {
 255                     $ret[-1]->{$key} = $value;
 256                     next;
 257                 }
 258
 259                 if (my ($key, $value, $epoch, $tz) = $line =~ /^(author|committer)\s+(.*)\s+(\d+)\s+([+-]\d+)$/) {
 260                     $ret[-1]->{$key} = $value;
 261                     eval {
 262                         $ret[-1]->{ $key . "_datetime" } = DateTime->from_epoch(epoch => $epoch);
 263                         $ret[-1]->{ $key . "_datetime" }->set_time_zone($tz);
 264                         $ret[-1]->{ $key . "_datetime" }->set_formatter($formatter);
 265                     };
 266
 267                     if ($@) {
 268                         $ret[-1]->{ $key . "_datetime" } = "$epoch $tz";
 269                     }
 270
 271                     if (my ($name, $email) = $value =~ /^([^<]+)\s+<([^>]+)>$/) {
 272                         $ret[-1]->{ $key . "_name"  } = $name;
 273                         $ret[-1]->{ $key . "_email" } = $email;
 274                     }
 275                 }
 276
 277                 $line =~ s/^\n?\s{4}//;
 278                 $ret[-1]->{longmessage} = $line;
 279                 $ret[-1]->{message} = (split /\n/, $line, 2)[0];
 280             }
 281         }
 282
 283         return @ret;
 284     }
 285 }
 286
 287 sub list_revs {
 288     my ($self, $project, %args) = @_;
 289
 290     $args{rev} ||= $self->get_head_hash($project);
 291
 292     my $output = $self->run_cmd_in($project, 'rev-list',
 293             '--header',
 294             (defined $args{ count } ? "--max-count=$args{count}" : ()),
 295             (defined $args{ skip  } ? "--skip=$args{skip}"     : ()),
 296             $args{rev},
 297             '--',
 298             ($args{file} || ()),
 299     );
 300     return unless $output;
 301
 302     my @revs = $self->parse_rev_list($output);
 303
 304     return \@revs;
 305 }
 306
 307 sub rev_info {
 308     my ($self, $project, $rev) = @_;
 309
 310     return unless $self->valid_rev($rev);
 311
 312     return $self->list_revs($project, rev => $rev, count => 1);
 313 }
 314
 315 sub get_heads {
 316     my ($self, $project) = @_;
 317
 318     my $output = $self->run_cmd_in($project, qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
 319     return unless $output;
 320
 321     my @ret;
 322     for my $line (split /\n/, $output) {
 323         my ($rev, $head, $commiter) = split /\0/, $line, 3;
 324         $head =~ s!^refs/heads/!!;
 325
 326         push @ret, { rev => $rev, name => $head };
 327
 328         #FIXME: That isn't the time I'm looking for..
 329         if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
 330             my $dt = DateTime->from_epoch(epoch => $epoch);
 331             $dt->set_time_zone($tz);
 332             $ret[-1]->{last_change} = $dt;
 333         }
 334     }
 335
 336     return \@ret;
 337 }
 338
 339 sub archive {
 340     my ($self, $project, $rev) = @_;
 341
 342     #FIXME: huge memory consuption
 343     #TODO: compression
 344     return $self->run_cmd_in($project, qw/archive --format=tar/, "--prefix=${project}/", $rev);
 345 }
 346
 347 1;
 348
 349 __PACKAGE__->meta->make_immutable;