lib/Gitalist/Git/Project.pm

   1 use MooseX::Declare;
   2
   3 =head1 NAME
   4
   5 Gitalist::Git::Project - Model of a git repository
   6
   7 =head1 SYNOPSIS
   8
   9     my $gitrepo = dir('/repo/base/Gitalist');
  10     my $project = Gitalist::Git::Project->new($gitrepo);
  11      $project->name;        # 'Gitalist'
  12      $project->path;        # '/repo/base/Gitalist/.git'
  13      $project->description; # 'Unnamed repository.'
  14
  15 =head1 DESCRIPTION
  16
  17 This class models a git repository, referred to in Gitalist
  18 as a "Project".
  19
  20 =cut
  21
  22 class Gitalist::Git::Project with Gitalist::Git::HasUtils {
  23     # FIXME, use Types::Path::Class and coerce
  24     use MooseX::Types::Common::String qw/NonEmptySimpleStr/;
  25     use MooseX::Types::Path::Class qw/Dir/;
  26     use MooseX::Types::Moose qw/Str Maybe Bool HashRef ArrayRef/;
  27     use List::MoreUtils qw/any zip/;
  28     use DateTime;
  29     use Gitalist::Git::Object::Commit;
  30     use aliased 'Gitalist::Git::Object';
  31
  32     our $SHA1RE = qr/[0-9a-fA-F]{40}/;
  33
  34     around BUILDARGS (ClassName $class: Dir $dir) {
  35         # Allows us to be called as Project->new($dir)
  36         # Last path component becomes $self->name
  37         # Full path to git objects becomes $self->path
  38         my $name = $dir->dir_list(-1);
  39         $dir = $dir->subdir('.git') if (-f $dir->file('.git', 'HEAD'));
  40         confess("Can't find a git repository at " . $dir)
  41             unless ( -f $dir->file('HEAD') );
  42         return $class->$orig(name => $name,
  43                              path => $dir);
  44     }
  45
  46 =head1 ATTRIBUTES
  47
  48 =head2 name
  49
  50 The name of the Project.  By default, this is derived from the path to the git repository.
  51
  52 =cut
  53     has name => ( isa => NonEmptySimpleStr,
  54                   is => 'ro', required => 1 );
  55
  56 =head2 path
  57
  58 L<Path::Class:Dir> for the location of the git repository.
  59
  60 =cut
  61     has path => ( isa => Dir,
  62                   is => 'ro', required => 1);
  63
  64 =head2 description
  65
  66 String containing .git/description
  67
  68 =cut
  69     has description => ( isa => Str,
  70                          is => 'ro',
  71                          lazy_build => 1,
  72                      );
  73
  74 =head2 owner
  75
  76 Owner of the files on disk.
  77
  78 =cut
  79     has owner => ( isa => NonEmptySimpleStr,
  80                    is => 'ro',
  81                    lazy_build => 1,
  82                );
  83
  84 =head2 last_change
  85
  86 L<DateTime> for the time of the last update.
  87 undef if the repository has never been used.
  88
  89 =cut
  90     has last_change => ( isa => Maybe['DateTime'],
  91                          is => 'ro',
  92                          lazy_build => 1,
  93                      );
  94
  95 =head2 is_bare
  96
  97 Bool indicating whether this Project is bare.
  98
  99 =cut
 100     has is_bare => ( isa => Bool,
 101                      is => 'ro',
 102                      lazy => 1,
 103                      default => sub {
 104                          -d $_[0]->path->parent->subdir->($_[0]->name)
 105                              ? 1 : 0
 106                          },
 107                      );
 108
 109 =head2 heads
 110
 111 ArrayRef of hashes containing the name and sha1 of all heads.
 112
 113 =cut
 114     has heads => ( isa => ArrayRef[HashRef],
 115                    is => 'ro',
 116                    lazy_build => 1);
 117
 118 =head2 references
 119
 120 Hashref of ArrayRefs for each reference.
 121
 122 =cut
 123     has references => ( isa => HashRef[ArrayRef[Str]],
 124                         is => 'ro',
 125                         lazy_build => 1 );
 126
 127     method BUILD {
 128         $self->$_() for qw/last_change owner description/; # Ensure to build early.
 129     }
 130
 131 =head1 METHODS
 132
 133 =head2 head_hash ($head?)
 134
 135 Return the sha1 for HEAD, or any specified head.
 136
 137 =cut
 138     method head_hash (Str $head?) {
 139         my $output = $self->run_cmd(qw/rev-parse --verify/, $head || 'HEAD' );
 140         confess("No such head: " . $head) unless defined $output;
 141
 142         my($sha1) = $output =~ /^($SHA1RE)$/;
 143         return $sha1;
 144     }
 145
 146 =head2 list_tree ($sha1?)
 147
 148 Return an array of contents for a given tree.
 149 The tree is specified by sha1, and defaults to HEAD.
 150 Each item is a L<Gitalist::Git::Object>.
 151
 152 =cut
 153     method list_tree (Str $sha1?) {
 154         $sha1 ||= $self->head_hash;
 155         my $object = $self->get_object($sha1);
 156         return @{$object->tree};
 157     }
 158
 159 =head2 get_object ($sha1)
 160
 161 Return a L<Gitalist::Git::Object> for the given sha1.
 162
 163 =cut
 164     method get_object (NonEmptySimpleStr $sha1) {
 165         unless ( $self->_is_valid_rev($sha1) ) {
 166             $sha1 = $self->head_hash($sha1);
 167         }
 168         my $type = $self->run_cmd('cat-file', '-t', $sha1);
 169         chomp($type);
 170         my $class = 'Gitalist::Git::Object';
 171         if ($type eq 'commit') {
 172             $class .= '::' . ucfirst($type);
 173         };
 174         return $class->new(
 175             project => $self,
 176             sha1 => $sha1,
 177         );
 178     }
 179
 180 =head2 hash_by_path($sha1, $path, $type?)
 181
 182 Returns the sha1 for a given path, optionally limited by type.
 183
 184 =cut
 185     method hash_by_path ($base, $path = '', $type?) {
 186         $path =~ s{/+$}();
 187         # FIXME should this really just take the first result?
 188         my @paths = $self->run_cmd('ls-tree', $base, '--', $path)
 189             or return;
 190         my $line = $paths[0];
 191
 192         #'100644 blob 0fa3f3a66fb6a137f6ec2c19351ed4d807070ffa  panic.c'
 193         $line =~ m/^([0-9]+) (.+) ($SHA1RE)\t/;
 194         return defined $type && $type ne $2
 195             ? ()
 196                 : $3;
 197     }
 198
 199 =head2 list_revs($sha1, $count?, $skip?, \%search?, $file?)
 200
 201 Returns a list of revs for the given head ($sha1).
 202
 203 =cut
 204     method list_revs ( NonEmptySimpleStr :$sha1!,
 205                        Int :$count?,
 206                        Int :$skip?,
 207                        HashRef :$search?,
 208                        NonEmptySimpleStr :$file? ) {
 209         $sha1 = $self->head_hash($sha1)
 210             if !$sha1 || $sha1 !~ $SHA1RE;
 211
 212         my @search_opts;
 213         if ($search) {
 214             $search->{type} = 'grep'
 215                 if $search->{type} eq 'commit';
 216             @search_opts = (
 217                 # This seems a little fragile ...
 218                 qq[--$search->{type}=$search->{text}],
 219                 '--regexp-ignore-case',
 220                 $search->{regexp} ? '--extended-regexp' : '--fixed-strings'
 221             );
 222         }
 223
 224         my $output = $self->run_cmd(
 225             'rev-list',
 226             '--header',
 227             (defined $count ? "--max-count=$count" : ()),
 228             (defined $skip ? "--skip=$skip"       : ()),
 229             @search_opts,
 230             $sha1,
 231             '--',
 232             ($file ? $file : ()),
 233         );
 234         return unless $output;
 235
 236         my @revs = $self->_parse_rev_list($output);
 237
 238         return @revs;
 239     }
 240
 241 =head2 diff($commit, $patch?, $parent?, $file?)
 242
 243 Generate a diff from a given L<Gitalist::Git::Object>.
 244
 245 =cut
 246
 247     method diff ( Gitalist::Git::Object :$commit!,
 248                   Bool :$patch?,
 249                   Maybe[NonEmptySimpleStr] :$parent?,
 250                   NonEmptySimpleStr :$file?
 251               ) {
 252               return $commit->diff( patch => $patch,
 253                                     parent => $parent,
 254                                     file => $file);
 255     }
 256
 257 =head2 reflog(@lorgargs)
 258
 259 Return a list of hashes representing each reflog entry.
 260
 261 FIXME Should this return objects?
 262
 263 =cut
 264     method reflog (@logargs) {
 265         my @entries
 266             =  $self->run_cmd(qw(log -g), @logargs)
 267                 =~ /(^commit.+?(?:(?=^commit)|(?=\z)))/msg;
 268
 269         #  commit 02526fc15beddf2c64798a947fecdd8d11bf993d
 270         #  Reflog: HEAD@{14} (The Git Server <git@git.dev.venda.com>)
 271         #  Reflog message: push
 272         #  Author: Foo Barsby <fbarsby@example.com>
 273         #  Date:   Thu Sep 17 12:26:05 2009 +0100
 274         #
 275         #      Merge branch 'abc123'
 276
 277         return map {
 278             # XXX Stuff like this makes me want to switch to Git::PurePerl
 279             my($sha1, $type, $author, $date)
 280                 = m{
 281                        ^ commit \s+ ($SHA1RE)$
 282                        .*?
 283                        Reflog[ ]message: \s+ (.+?)$ \s+
 284                      Author: \s+ ([^<]+) <.*?$ \s+
 285                    Date: \s+ (.+?)$
 286                }xms;
 287
 288             pos($_) = index($_, $date) + length $date;
 289
 290             # Yeah, I just did that.
 291             my($msg) = /\G\s+(\S.*)/sg;
 292             {
 293                 hash    => $sha1,
 294                 type    => $type,
 295                 author  => $author,
 296
 297                 # XXX Add DateTime goodness.
 298                 date    => $date,
 299                 message => $msg,
 300             }
 301             ;
 302         } @entries;
 303     }
 304
 305     ## BUILDERS
 306     method _build__util {
 307         Gitalist::Git::Util->new(
 308             project => $self,
 309         );
 310     }
 311
 312     method _build_description {
 313         my $description = "";
 314         eval {
 315             $description = $self->path->file('description')->slurp;
 316             chomp $description;
 317         };
 318         return $description;
 319     }
 320
 321     method _build_owner {
 322         my ($gecos, $name) = (getpwuid $self->path->stat->uid)[6,0];
 323         $gecos =~ s/,+$//;
 324         return length($gecos) ? $gecos : $name;
 325     }
 326
 327     method _build_last_change {
 328         my $last_change;
 329         my $output = $self->run_cmd(
 330             qw{ for-each-ref --format=%(committer)
 331                 --sort=-committerdate --count=1 refs/heads
 332           });
 333         if (my ($epoch, $tz) = $output =~ /\s(\d+)\s+([+-]\d+)$/) {
 334             my $dt = DateTime->from_epoch(epoch => $epoch);
 335             $dt->set_time_zone($tz);
 336             $last_change = $dt;
 337         }
 338         return $last_change;
 339     }
 340
 341     method _build_heads {
 342         my @revlines = $self->run_cmd_list(qw/for-each-ref --sort=-committerdate /, '--format=%(objectname)%00%(refname)%00%(committer)', 'refs/heads');
 343         my @ret;
 344         for my $line (@revlines) {
 345             my ($rev, $head, $commiter) = split /\0/, $line, 3;
 346             $head =~ s!^refs/heads/!!;
 347
 348             push @ret, { sha1 => $rev, name => $head };
 349
 350             #FIXME: That isn't the time I'm looking for..
 351             if (my ($epoch, $tz) = $line =~ /\s(\d+)\s+([+-]\d+)$/) {
 352                 my $dt = DateTime->from_epoch(epoch => $epoch);
 353                 $dt->set_time_zone($tz);
 354                 $ret[-1]->{last_change} = $dt;
 355             }
 356         }
 357
 358         return \@ret;
 359     }
 360
 361     method _build_references {
 362         # 5dc01c595e6c6ec9ccda4f6f69c131c0dd945f8c refs/tags/v2.6.11
 363         # c39ae07f393806ccf406ef966e9a15afc43cc36a refs/tags/v2.6.11^{}
 364         my @reflist = $self->run_cmd_list(qw(show-ref --dereference))
 365             or return;
 366         my %refs;
 367         for (@reflist) {
 368             push @{$refs{$1}}, $2
 369                 if m!^($SHA1RE)\srefs/(.*)$!;
 370         }
 371
 372         return \%refs;
 373     }
 374
 375     ## Private methods
 376     method _is_valid_rev (Str $rev) {
 377         return ($rev =~ /^($SHA1RE)$/);
 378     }
 379
 380     method _parse_rev_list ($output) {
 381         return
 382             map  $self->get_gpp_object($_),
 383                 grep $self->_is_valid_rev($_),
 384                     map  split(/\n/, $_, 6), split /\0/, $output;
 385     }
 386
 387 =head1 SEE ALSO
 388
 389 L<Gitalist::Git::Util> L<Gitalist::Git::Object>
 390
 391 =head1 AUTHORS AND COPYRIGHT
 392
 393   Catalyst application:
 394     (C) 2009 Venda Ltd and Dan Brook <dbrook@venda.com>
 395
 396   Original gitweb.cgi from which this was derived:
 397     (C) 2005-2006, Kay Sievers <kay.sievers@vrfy.org>
 398     (C) 2005, Christian Gierke
 399
 400 =head1 LICENSE
 401
 402 FIXME - Is this going to be GPLv2 as per gitweb? If so this is broken..
 403
 404 This library is free software. You can redistribute it and/or modify
 405 it under the same terms as Perl itself.
 406
 407 =cut
 408
 409 } # end class