lib/Gitalist/Git/Project.pm

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