lib/Gitalist/Git/Project.pm

   1 use MooseX::Declare;
   2
   3 class Gitalist::Git::Project {
   4     # FIXME, use Types::Path::Class and coerce
   5     use MooseX::Types::Common::String qw/NonEmptySimpleStr/;
   6     use MooseX::Types::Moose qw/Str Maybe Bool HashRef/;
   7     use DateTime;
   8     use MooseX::Types::Path::Class qw/Dir/;
   9     use List::MoreUtils qw/any zip/;
  10     use Gitalist::Git::Util;
  11     use aliased 'Gitalist::Git::Object';
  12
  13     our $SHA1RE = qr/[0-9a-fA-F]{40}/;
  14
  15     has name => ( isa => NonEmptySimpleStr,
  16                   is => 'ro', required => 1 );
  17     has path => ( isa => Dir,
  18                   is => 'ro', required => 1);
  19
  20     has description => ( isa => Str,
  21                          is => 'ro',
  22                          lazy_build => 1,
  23                      );
  24     has owner => ( isa => NonEmptySimpleStr,
  25                    is => 'ro',
  26                    lazy_build => 1,
  27                );
  28     has last_change => ( isa => Maybe['DateTime'],
  29                          is => 'ro',
  30                          lazy_build => 1,
  31                      );
  32     has _util => ( isa => 'Gitalist::Git::Util',
  33                    is => 'ro',
  34                    lazy_build => 1,
  35                    handles => [ 'run_cmd', 'get_gpp_object' ],
  36                );
  37
  38     has project_dir => ( isa => Dir,
  39         is => 'ro',
  40         lazy => 1,
  41         default => sub {
  42             my $self = shift;
  43             $self->is_bare
  44                 ? $self->path
  45                 : $self->path->subdir('.git')
  46         },
  47     );
  48     has is_bare => (
  49         isa => Bool,
  50         is => 'ro',
  51         lazy => 1,
  52         default => sub {
  53             my $self = shift;
  54             -f $self->path->file('.git', 'HEAD')
  55                 ? 0
  56                 : -f $self->path->file('HEAD')
  57                     ? 1
  58                     : confess("Cannot find " . $self->path . "/.git/HEAD or "
  59                         . $self->path . "/HEAD");
  60         },
  61     );
  62
  63     method BUILD {
  64         $self->$_() for qw/_util last_change owner description/; # Ensure to build early.
  65     }
  66
  67     method _project_dir {
  68         -f $self->{path}->file('.git', 'HEAD')
  69             ? $self->{path}->subdir('.git')
  70             : $self->{path};
  71     }
  72
  73     method _build__util {
  74         Gitalist::Git::Util->new(
  75             project => $self,
  76         );
  77     }
  78
  79     method _build_description {
  80         my $description = "";
  81         eval {
  82             $description = $self->project_dir->file('description')->slurp;
  83             chomp $description;
  84         };
  85         return $description;
  86     }
  87
  88     method _build_owner {
  89         my ($gecos, $name) = (getpwuid $self->project_dir->stat->uid)[6,0];
  90         $gecos =~ s/,+$//;
  91         return length($gecos) ? $gecos : $name;
  92     }
  93
  94     method _build_last_change {
  95         my $last_change;
  96         my $output = $self->run_cmd(
  97             qw{ for-each-ref --format=%(committer)
  98                 --sort=-committerdate --count=1 refs/heads
  99           });
 100         if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
 101             my $dt = DateTime->from_epoch(epoch => $epoch);
 102             $dt->set_time_zone($tz);
 103             $last_change = $dt;
 104         }
 105         return $last_change;
 106     }
 107
 108     method heads {
 109         my $cmdout = $self->run_cmd(qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
 110         my @output = $cmdout ? split(/\n/, $cmdout) : ();
 111         my @ret;
 112         for my $line (@output) {
 113             my ($rev, $head, $commiter) = split /\0/, $line, 3;
 114             $head =~ s!^refs/heads/!!;
 115
 116             push @ret, { sha1 => $rev, name => $head };
 117
 118             #FIXME: That isn't the time I'm looking for..
 119             if (my ($epoch, $tz) = $line =~ /\s(\d+)\s+([+-]\d+)$/) {
 120                 my $dt = DateTime->from_epoch(epoch => $epoch);
 121                 $dt->set_time_zone($tz);
 122                 $ret[-1]->{last_change} = $dt;
 123             }
 124         }
 125
 126         return @ret;
 127     }
 128
 129     method references {
 130         return $self->{references}
 131                 if $self->{references};
 132
 133         # 5dc01c595e6c6ec9ccda4f6f69c131c0dd945f8c refs/tags/v2.6.11
 134         # c39ae07f393806ccf406ef966e9a15afc43cc36a refs/tags/v2.6.11^{}
 135         my $cmdout = $self->run_cmd(qw(show-ref --dereference))
 136                 or return;
 137         my @reflist = $cmdout ? split(/\n/, $cmdout) : ();
 138         my %refs;
 139         for(@reflist) {
 140                 push @{$refs{$1}}, $2
 141                         if m!^($SHA1RE)\srefs/(.*)$!;
 142         }
 143
 144         return $self->{references} = \%refs;
 145 }
 146
 147     method valid_rev (Str $rev) {
 148         return ($rev =~ /^($SHA1RE)$/);
 149     }
 150
 151
 152 =head2 head_hash
 153
 154 Find the hash of a given head (defaults to HEAD).
 155
 156 =cut
 157
 158     method head_hash (Str $head?) {
 159         my $output = $self->run_cmd(qw/rev-parse --verify/, $head || 'HEAD' );
 160         return unless defined $output;
 161
 162         my($sha1) = $output =~ /^($SHA1RE)$/;
 163         return $sha1;
 164     }
 165
 166 =head2 list_tree
 167
 168 Return an array of contents for a given tree.
 169 The tree is specified by sha1, and defaults to HEAD.
 170 The keys for each item will be:
 171
 172         mode
 173         type
 174         object
 175         file
 176
 177 =cut
 178
 179     method list_tree (Str $sha1?) {
 180         $sha1 ||= $self->head_hash;
 181
 182         my $output = $self->run_cmd(qw/ls-tree -z/, $sha1);
 183         return unless defined $output;
 184
 185         my @ret;
 186         for my $line (split /\0/, $output) {
 187             my ($mode, $type, $object, $file) = split /\s+/, $line, 4;
 188             push @ret, Object->new( mode => oct $mode,
 189                                     type => $type,
 190                                     sha1 => $object,
 191                                     file => $file,
 192                                     project => $self,
 193                                   );
 194         }
 195         return @ret;
 196     }
 197
 198     method get_object (NonEmptySimpleStr $sha1) {
 199         unless ( $self->valid_rev($sha1) ) {
 200             $sha1 = $self->head_hash($sha1);
 201         }
 202         return Object->new(
 203             project => $self,
 204             sha1 => $sha1,
 205         );
 206     }
 207
 208     # Should be in ::Object
 209     method get_object_mode_string (Gitalist::Git::Object $object) {
 210         return unless $object && $object->{mode};
 211         return $object->{modestr};
 212     }
 213
 214     method get_object_type ($object) {
 215         chomp(my $output = $self->run_cmd(qw/cat-file -t/, $object));
 216         return unless $output;
 217
 218         return $output;
 219     }
 220
 221     method cat_file ($object) {
 222         my $type = $self->get_object_type($object);
 223         die "object `$object' is not a file\n"
 224             if (!defined $type || $type ne 'blob');
 225
 226         my $output = $self->run_cmd(qw/cat-file -p/, $object);
 227         return unless $output;
 228
 229         return $output;
 230     }
 231
 232     method hash_by_path ($base, $path?, $type?) {
 233         $path ||= '';
 234         $path =~ s{/+$}();
 235
 236         my $output = $self->run_cmd('ls-tree', $base, '--', $path)
 237             or return;
 238         my($line) = $output ? split(/\n/, $output) : ();
 239
 240         #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa  panic.c'
 241         $line =~ m/^([0-9]+) (.+) ($SHA1RE)\t/;
 242         return defined $type && $type ne $2
 243             ? ()
 244                 : $3;
 245     }
 246
 247     method list_revs ( NonEmptySimpleStr :$sha1!,
 248                        Int :$count?,
 249                        Int :$skip?,
 250                        HashRef :$search?,
 251                        NonEmptySimpleStr :$file?
 252                    ) {
 253         $sha1 = $self->head_hash($sha1)
 254             if !$sha1 || $sha1 !~ $SHA1RE;
 255
 256         my @search_opts;
 257         if($search) {
 258             $search->{type} = 'grep'
 259                 if $search->{type} eq 'commit';
 260             @search_opts = (
 261                 # This seems a little fragile ...
 262                 qq[--$search->{type}=$search->{text}],
 263                 '--regexp-ignore-case',
 264                 $search->{regexp} ? '--extended-regexp' : '--fixed-strings'
 265             );
 266         }
 267
 268         my $output = $self->run_cmd(
 269             'rev-list',
 270             '--header',
 271             (defined $count ? "--max-count=$count" : ()),
 272             (defined $skip ? "--skip=$skip"       : ()),
 273             @search_opts,
 274             $sha1,
 275             '--',
 276             ($file ? $file : ()),
 277         );
 278         return unless $output;
 279
 280         my @revs = $self->parse_rev_list($output);
 281
 282         return @revs;
 283     }
 284
 285     method parse_rev_list ($output) {
 286         return
 287             map  $self->get_gpp_object($_),
 288                 grep $self->valid_rev($_),
 289                     map  split(/\n/, $_, 6), split /\0/, $output;
 290     }
 291
 292     # XXX Ideally this would return a wee object instead of ad hoc structures.
 293     method diff ( Gitalist::Git::Object :$commit,
 294                   Bool :$patch?,
 295                   Maybe[NonEmptySimpleStr] :$parent?,
 296                   NonEmptySimpleStr :$file? ) {
 297         # Use parent if specifed, else take the parent from the commit
 298         # if there is only one, otherwise it was a merge commit.
 299         $parent = $parent
 300             ? $parent
 301             : $commit->parents <= 1
 302             ? $commit->parent_sha1
 303             : '-c';
 304         my @etc = (
 305             ( $file  ? ('--', $file) : () ),
 306         );
 307
 308         my @out = $self->raw_diff(
 309             \(( $patch ? '--patch-with-raw' : () ),
 310             $parent, $commit->sha1, @etc )
 311         );
 312
 313         # XXX Yes, there is much wrongness having parse_diff_tree be destructive.
 314         my @difftree = $self->parse_diff_tree(\@out);
 315
 316         return \@difftree
 317             unless $patch;
 318
 319         # The blank line between the tree and the patch.
 320         shift @out;
 321
 322         # XXX And no I'm not happy about having diff return tree + patch.
 323         return \@difftree, [$self->parse_diff(@out)];
 324     }
 325
 326     method parse_diff (@diff) {
 327         my @ret;
 328         for (@diff) {
 329             # This regex is a little pathological.
 330             if(m{^diff --git (a/(.*?)) (b/\2)}) {
 331                 push @ret, {
 332                     head => $_,
 333                     a    => $1,
 334                     b    => $3,
 335                     file => $2,
 336                     diff => '',
 337                 };
 338                 next;
 339             }
 340
 341             if(/^index (\w+)\.\.(\w+) (\d+)$/) {
 342                 @{$ret[-1]}{qw(index src dst mode)} = ($_, $1, $2, $3);
 343                 next
 344             }
 345
 346             # XXX Somewhat hacky. Ahem.
 347             $ret[@ret ? -1 : 0]{diff} .= "$_\n";
 348         }
 349
 350         return @ret;
 351     }
 352
 353     # gitweb uses the following sort of command for diffing merges:
 354 # /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 --
 355 # and for regular diffs
 356 # /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 --
 357
 358     method raw_diff (@args) {
 359         my $cmdout = $self->run_cmd(
 360             qw(diff-tree -r -M --no-commit-id --full-index),
 361             @args
 362         );
 363         return $cmdout ? split(/\n/, $cmdout) : ();
 364     }
 365
 366     method parse_diff_tree ($diff) {
 367         my @keys = qw(modesrc modedst sha1src sha1dst status src dst);
 368         my @ret;
 369         while (@$diff and $diff->[0] =~ /^:\d+/) {
 370             my $line = shift @$diff;
 371             # see. man git-diff-tree for more info
 372             # mode src, mode dst, sha1 src, sha1 dst, status, src[, dst]
 373             my @vals = $line =~ /^:(\d+) (\d+) ($SHA1RE) ($SHA1RE) ([ACDMRTUX]\d*)\t([^\t]+)(?:\t([^\n]+))?$/;
 374             my %line = zip @keys, @vals;
 375             # Some convenience keys
 376             $line{file}   = $line{src};
 377             $line{sha1}   = $line{sha1dst};
 378             $line{is_new} = $line{sha1src} =~ /^0+$/
 379                 if $line{sha1src};
 380             @line{qw/status sim/} = $line{status} =~ /(R)(\d+)/
 381                 if $line{status} =~ /^R/;
 382             push @ret, \%line;
 383         }
 384
 385         return @ret;
 386     }
 387
 388     method reflog (@logargs) {
 389         my @entries
 390             =  $self->run_cmd(qw(log -g), @logargs)
 391                 =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg;
 392
 393 =pod
 394   commit 02526fc15beddf2c64798a947fecdd8d11bf993d
 395   Reflog: HEAD@{14} (The Git Server <git@git.dev.venda.com>)
 396   Reflog message: push
 397   Author: Foo Barsby <fbarsby@example.com>
 398   Date:   Thu Sep 17 12:26:05 2009 +0100
 399
 400       Merge branch 'abc123'
 401
 402 =cut
 403
 404         return map {
 405             # XXX Stuff like this makes me want to switch to Git::PurePerl
 406             my($sha1, $type, $author, $date)
 407                 = m{
 408                        ^ commit \s+ ($SHA1RE)$
 409                        .*?
 410                        Reflog[ ]message: \s+ (.+?)$ \s+
 411                      Author: \s+ ([^<]+) <.*?$ \s+
 412                    Date: \s+ (.+?)$
 413                }xms;
 414
 415             pos($_) = index($_, $date) + length $date;
 416
 417             # Yeah, I just did that.
 418             my($msg) = /\G\s+(\S.*)/sg;
 419             {
 420                 hash    => $sha1,
 421                 type    => $type,
 422                 author  => $author,
 423
 424                 # XXX Add DateTime goodness.
 425                 date    => $date,
 426                 message => $msg,
 427             }
 428             ;
 429         } @entries;
 430     }
 431
 432     # Compatibility
 433
 434 =head2 info
 435
 436 Returns a hash containing properties of this project. The keys will
 437 be:
 438
 439         name
 440         description (empty if .git/description is empty/unnamed)
 441         owner
 442         last_change
 443
 444 =cut
 445
 446     method info {
 447         return {
 448             name => $self->name,
 449             description => $self->description,
 450             owner => $self->owner,
 451             last_change => $self->last_change,
 452         };
 453     };
 454
 455 } # end class