lib/Gitalist/Git/Project.pm

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