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 (Str $sha1) {
 199         return Object->new(
 200             project => $self,
 201             sha1 => $sha1,
 202         );
 203     }
 204
 205     # Should be in ::Object
 206     method get_object_mode_string (Gitalist::Git::Object $object) {
 207         return unless $object && $object->{mode};
 208         return $object->{modestr};
 209     }
 210
 211     method get_object_type ($object) {
 212         chomp(my $output = $self->run_cmd(qw/cat-file -t/, $object));
 213         return unless $output;
 214
 215         return $output;
 216     }
 217
 218     method cat_file ($object) {
 219         my $type = $self->get_object_type($object);
 220         die "object `$object' is not a file\n"
 221             if (!defined $type || $type ne 'blob');
 222
 223         my $output = $self->run_cmd(qw/cat-file -p/, $object);
 224         return unless $output;
 225
 226         return $output;
 227     }
 228
 229     method hash_by_path ($base, $path?, $type?) {
 230         $path ||= '';
 231         $path =~ s{/+$}();
 232
 233         my $output = $self->run_cmd('ls-tree', $base, '--', $path)
 234             or return;
 235         my($line) = $output ? split(/\n/, $output) : ();
 236
 237         #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa  panic.c'
 238         $line =~ m/^([0-9]+) (.+) ($SHA1RE)\t/;
 239         return defined $type && $type ne $2
 240             ? ()
 241                 : $3;
 242     }
 243
 244     method list_revs ( NonEmptySimpleStr :$sha1!,
 245                        Int :$count?,
 246                        Int :$skip?,
 247                        HashRef :$search?,
 248                        NonEmptySimpleStr :$file?
 249                    ) {
 250         $sha1 = $self->head_hash($sha1)
 251             if !$sha1 || $sha1 !~ $SHA1RE;
 252
 253         my @search_opts;
 254         if($search) {
 255             $search->{type} = 'grep'
 256                 if $search->{type} eq 'commit';
 257             @search_opts = (
 258                 # This seems a little fragile ...
 259                 qq[--$search->{type}=$search->{text}],
 260                 '--regexp-ignore-case',
 261                 $search->{regexp} ? '--extended-regexp' : '--fixed-strings'
 262             );
 263         }
 264
 265         my $output = $self->run_cmd(
 266             'rev-list',
 267             '--header',
 268             (defined $count ? "--max-count=$count" : ()),
 269             (defined $skip ? "--skip=$skip"       : ()),
 270             @search_opts,
 271             $sha1,
 272             '--',
 273             ($file ? $file : ()),
 274         );
 275         return unless $output;
 276
 277         my @revs = $self->parse_rev_list($output);
 278
 279         return @revs;
 280     }
 281
 282     method parse_rev_list ($output) {
 283         return
 284             map  $self->get_gpp_object($_),
 285                 grep $self->valid_rev($_),
 286                     map  split(/\n/, $_, 6), split /\0/, $output;
 287     }
 288
 289     # XXX Ideally this would return a wee object instead of ad hoc structures.
 290     method diff ( Gitalist::Git::Object :$commit,
 291                   Bool :$patch?,
 292                   NonEmptySimpleStr :$parent?,
 293                   NonEmptySimpleStr :$file? ) {
 294         # Use parent if specifed, else take the parent from the commit
 295         # if there is only one, otherwise it was a merge commit.
 296         $parent = $parent
 297             ? $parent
 298             : $commit->parents <= 1
 299             ? $commit->parent_sha1
 300             : '-c';
 301         my @etc = (
 302             ( $file  ? ('--', $file) : () ),
 303         );
 304
 305         my @out = $self->raw_diff(
 306             ( $patch ? '--patch-with-raw' : () ),
 307             $parent, $commit->sha1, @etc
 308         );
 309
 310         # XXX Yes, there is much wrongness having parse_diff_tree be destructive.
 311         my @difftree = $self->parse_diff_tree(\@out);
 312
 313         return \@difftree
 314             unless $patch;
 315
 316         # The blank line between the tree and the patch.
 317         shift @out;
 318
 319         # XXX And no I'm not happy about having diff return tree + patch.
 320         return \@difftree, [$self->parse_diff(@out)];
 321     }
 322
 323     method parse_diff (@diff) {
 324         my @ret;
 325         for (@diff) {
 326             # This regex is a little pathological.
 327             if(m{^diff --git (a/(.*?)) (b/\2)}) {
 328                 push @ret, {
 329                     head => $_,
 330                     a    => $1,
 331                     b    => $3,
 332                     file => $2,
 333                     diff => '',
 334                 };
 335                 next;
 336             }
 337
 338             if(/^index (\w+)\.\.(\w+) (\d+)$/) {
 339                 @{$ret[-1]}{qw(index src dst mode)} = ($_, $1, $2, $3);
 340                 next
 341             }
 342
 343             # XXX Somewhat hacky. Ahem.
 344             $ret[@ret ? -1 : 0]{diff} .= "$_\n";
 345         }
 346
 347         return @ret;
 348     }
 349
 350     # gitweb uses the following sort of command for diffing merges:
 351 # /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 --
 352 # and for regular diffs
 353 # /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 --
 354
 355     method raw_diff (@args) {
 356         my $cmdout = $self->run_cmd(
 357             qw(diff-tree -r -M --no-commit-id --full-index),
 358             @args
 359         );
 360         return $cmdout ? split(/\n/, $cmdout) : ();
 361     }
 362
 363     method parse_diff_tree ($diff) {
 364         my @keys = qw(modesrc modedst sha1src sha1dst status src dst);
 365         my @ret;
 366         while (@$diff and $diff->[0] =~ /^:\d+/) {
 367             my $line = shift @$diff;
 368             # see. man git-diff-tree for more info
 369             # mode src, mode dst, sha1 src, sha1 dst, status, src[, dst]
 370             my @vals = $line =~ /^:(\d+) (\d+) ($SHA1RE) ($SHA1RE) ([ACDMRTUX]\d*)\t([^\t]+)(?:\t([^\n]+))?$/;
 371             my %line = zip @keys, @vals;
 372             # Some convenience keys
 373             $line{file}   = $line{src};
 374             $line{sha1}   = $line{sha1dst};
 375             $line{is_new} = $line{sha1src} =~ /^0+$/
 376                 if $line{sha1src};
 377             @line{qw/status sim/} = $line{status} =~ /(R)(\d+)/
 378                 if $line{status} =~ /^R/;
 379             push @ret, \%line;
 380         }
 381
 382         return @ret;
 383     }
 384
 385     # Compatibility
 386
 387 =head2 info
 388
 389 Returns a hash containing properties of this project. The keys will
 390 be:
 391
 392         name
 393         description (empty if .git/description is empty/unnamed)
 394         owner
 395         last_change
 396
 397 =cut
 398
 399     method info {
 400         return {
 401             name => $self->name,
 402             description => $self->description,
 403             owner => $self->owner,
 404             last_change => $self->last_change,
 405         };
 406     };
 407
 408 } # end class