Has ancestor improvement for Object::Commit

CHANGES

@@ -1,5 +1,16 @@
 Revision history for Perl module Git::PurePerl:
 
+     - Add basic documentation for Object::Commit (Kent Fredric)
+     - Add has_ancestor_sha1 method to Object::Commit (Kent Fredric)
+     - Add Git::PurePerl::Util with handy current_git_dir() util (Kent Fredric)
+
+0.50 Sat Jan 25 14:58:16 CET 2014
+     - Now with the changes from 0.49 in CHANGES. That's it.
+
+0.49 Sat Jan 25 14:55:42 CET 2014
+     - qw() in list context is an error now (gregor herrmann)
+     - Fixed RT#90667 (Zoffix Znet)
+
 0.48 Thu Jul 14 22:53:55 BST 2011
      - Translation from Digest::SHA1 to Digest::SHA (Jonas Genannt)
      - A git object can also be of zero size. (Christian Walde)

lib/Git/PurePerl.pm

@@ -37,7 +37,7 @@ use IO::Socket::INET;
 use Path::Class;
 use namespace::autoclean;
 
-our $VERSION = '0.48';
+our $VERSION = '0.50';
 $VERSION = eval $VERSION;
 
 has 'directory' => (

lib/Git/PurePerl/NewObject.pm

@@ -4,7 +4,7 @@ use MooseX::StrictConstructor;
 use Moose::Util::TypeConstraints;
 use namespace::autoclean;
 
-enum 'ObjectKind' => qw(commit tree blob tag);
+enum 'ObjectKind' => [qw(commit tree blob tag)];
 
 has 'kind' => ( is => 'ro', isa => 'ObjectKind', required => 1 );
 has 'size' => ( is => 'ro', isa => 'Int', required => 0, lazy_build => 1 );

lib/Git/PurePerl/Object.pm

@@ -4,7 +4,7 @@ use MooseX::StrictConstructor;
 use Moose::Util::TypeConstraints;
 use namespace::autoclean;
 
-enum 'ObjectKind' => qw(commit tree blob tag);
+enum 'ObjectKind' => [qw(commit tree blob tag)];
 
 has 'kind'    => ( is => 'ro', isa => 'ObjectKind',    required => 1 );
 has 'size'    => ( is => 'ro', isa => 'Int',           required => 1 );

lib/Git/PurePerl/Object/Commit.pm

@@ -63,6 +63,13 @@ sub BUILD {
     $self->comment( decode($encoding, join "\n", @lines) );
 }
 
+=head1 METHODS
+
+=head2 tree
+
+Returns the L<< C<::Tree>|Git::PurePerl::Object::Tree >> associated with this commit.
+
+=cut
 
 sub tree {
     my $self = shift;
@@ -76,20 +83,88 @@ sub _push_parent_sha1 {
     push(@{$self->parent_sha1s}, $sha1);
 }
 
+=head2 parent_sha1
+
+Returns the C<sha1> for the first parent of this this commit.
+
+=cut
+
 sub parent_sha1 {
     return shift->parent_sha1s->[0];
 }
-
+
+=head2 parent
+
+Returns the L<< C<::Commit>|Git::PurePerl::Object::Commit >> for this commits first parent.
+
+=cut
+
 sub parent {
     my $self = shift;
     return $self->git->get_object( $self->parent_sha1 );
 }
 
+=head2 parents
+
+Returns L<< C<::Commit>s|Git::PurePerl::Object::Commit >> for all this commits parents.
+
+=cut
+
 sub parents {
     my $self = shift;
 
     return map { $self->git->get_object( $_ ) } @{$self->parent_sha1s};
 }
 
+=head2 has_ancestor_sha1
+
+Traverses up the parentage of the object graph to find out if the given C<sha1> appears as an ancestor.
+
+  if ( $commit_object->has_ancestor_sha1( 'deadbeef' x  5 ) ) {
+    ...
+  }
+
+=cut
+
+sub has_ancestor_sha1 {
+    my ( $self, $sha1 ) = @_;
+
+    # This may seem redundant, but its not entirely.
+    # However, its a penalty paid for the branch shortening optimization.
+    #
+    # x^, y^ , z^ , y[ y^ , y... ] , z[ z^ , z... ]
+    #
+    # Will still be faster than
+    #
+    # x^, y[ y^ , y... ] , z[ z^ , z... ]
+    #
+    # In the event y is very long.
+
+    return 1 if $self->sha1 eq $sha1;
+
+    # This is a slight optimization of sorts,
+    # as it means
+    #   x->{ y->{ y' } , z->{ z' } }
+    # has a check order of:
+    #   x^, y^ , z^ , y[ y^ , ... ], z[ z^, ... ]
+    # instead of
+    #   x^, y[ y^, y... ], z[ z^, z... ]
+    # Which will probably make things a bit faster if y is incredibly large
+    # and you just want to check if a given commit x has a direct ancestor i.
+
+    for my $parent ( @{ $self->parent_sha1s } ) {
+        return 1 if $parent eq $sha1;
+    }
+
+    # Depth First.
+    # TODO perhaps make it breadth first? could be very useful on very long repos
+    # where the given ancestor might not be in the "first-parent" ancestry line.
+    # But if somebody wants this feature, they'll have to provide the benchmarks, the code, or both.
+
+    for my $parent ( $self->parents ) {
+        return 1 if $parent->has_ancestor_sha1( $sha1, );
+    }
+    return;
+}
 __PACKAGE__->meta->make_immutable;
 

lib/Git/PurePerl/Util.pm

@@ -0,0 +1,97 @@
+use strict;
+use warnings;
+
+package Git::PurePerl::Util;
+
+# FILENAME: Util.pm
+# CREATED: 29/05/12 21:46:21 by Kent Fredric (kentnl) <[email protected]>
+# ABSTRACT: Helper tools for Git::PurePerl
+
+use Sub::Exporter -setup => {
+    exports => [qw( current_git_dir find_git_dir is_git_dir )],
+    groups  => { default => [qw( current_git_dir )], },
+};
+use Path::Class qw( dir );
+
+=head1 SYNOPSIS
+
+	use Git::PurePerl::Util;
+	use Git::PurePerl;
+
+	my $repo = Git::PurePerl->new(
+		gitdir => current_git_dir(),
+	);
+
+=cut
+
+=head1 FUNCTIONS
+
+=head2 is_git_dir
+
+Determines if the given C<$dir> has the basic requirements of a Git repository dir.
+
+( ie: either a checkouts C<.git> folder, or a bare repository )
+
+	if ( is_git_dir( $dir ) ) {
+		...
+	}
+
+=cut
+
+sub is_git_dir {
+    my ($dir) = @_;
+    return if not -e $dir->subdir('objects');
+    return if not -e $dir->subdir('refs');
+    return if not -e $dir->file('HEAD');
+    return 1;
+}
+
+=head2 find_git_dir
+
+	my $dir = find_git_dir( $subdir );
+
+Finds the closest C<.git> or bare tree that is either at C<$subdir> or somewhere above C<$subdir>
+
+If C<$subdir> is inside a 'bare' repo, returns the path to that repo.
+
+If C<$subdir> is inside a checkout, returns the path to the checkouts C<.git> dir.
+
+If C<$subdir> is not inside a git repo, returns a false value.
+
+=cut
+
+sub find_git_dir {
+    my $start = shift;
+
+    return $start if is_git_dir($start);
+
+    my $repodir = $start->subdir('.git');
+
+    return $repodir if -e $repodir and is_git_dir($repodir);
+
+    return find_git_dir( $start->parent )
+      if $start->parent->absolute ne $start->absolute;
+
+    return undef;
+}
+
+=head2 current_git_dir
+
+Finds the closest C<.git> or bare tree by walking up parents.
+
+	my $git_dir = current_git_dir();
+
+If C<$CWD> is inside a bare repo somewhere, it will return the path to the bare repo root directory.
+
+If C<$CWD> is inside a git checkout, it will return the path to the C<.git> folder of that checkout.
+
+If C<$CWD> is not inside any recognisable git repo, will return a false value.
+
+=cut
+
+sub current_git_dir {
+    return find_git_dir( dir('.') );
+}
+
+1;
+

t/00_setup.t

@@ -4,7 +4,7 @@ use warnings;
 use Test::More;
 use Archive::Extract;
 
-foreach my $name qw(test-project test-project-packs test-project-packs2 test-encoding) {
+foreach my $name (qw(test-project test-project-packs test-project-packs2 test-encoding test-util)) {
     next if -d $name;
     my $ae = Archive::Extract->new( archive => "$name.tgz" );
     $ae->extract;

t/08_has_ancestor.t

@@ -0,0 +1,79 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+# FILENAME: 08_has_ancestor.t
+# CREATED: 31/05/12 07:48:42 by Kent Fredric (kentnl) <[email protected]>
+# ABSTRACT: Tests for has_ancestor
+use strict;
+use warnings;
+use Test::More;
+use Git::PurePerl;
+use Path::Class;
+
+sub shatrim {
+    return substr( shift, 0, 8 );
+}
+
+sub repo_ancestor_check {
+    my ( $repo, $commit, @ancestors ) = @_;
+    my $git = Git::PurePerl->new( directory => $repo );
+    my $commit_obj = $git->get_object($commit);
+    for my $ancestor (@ancestors) {
+        my ( $tcommit, $tancestor ) = map { shatrim($_) } $commit, $ancestor;
+        ok(
+            $commit_obj->has_ancestor_sha1($ancestor),
+            "$repo @ $tcommit has ancestor $tancestor"
+        );
+    }
+}
+
+sub repo_ancestor_not_check {
+    my ( $repo, $commit, @ancestors ) = @_;
+    my $git = Git::PurePerl->new( directory => $repo );
+    my $commit_obj = $git->get_object($commit);
+    for my $ancestor (@ancestors) {
+        my ( $tcommit, $tancestor ) = map { shatrim($_) } $commit, $ancestor;
+        ok(
+            !$commit_obj->has_ancestor_sha1($ancestor),
+            "$repo @ $tcommit has no ancestor $tancestor"
+        );
+    }
+}
+
+repo_ancestor_check(
+    'test-project' => '0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391' => qw(
+      a47f812b901251922153bac347a348604a24e372
+      d24a32a404ce934cd4f39fd632fc1d43c413f652
+      )
+);
+
+repo_ancestor_check(
+    'test-project' => 'a47f812b901251922153bac347a348604a24e372' => qw(
+      d24a32a404ce934cd4f39fd632fc1d43c413f652
+      )
+);
+
+repo_ancestor_not_check(
+    'test-project' => '0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391' => qw(
+      deadbeefdeadbeefdeadbeefdeadbeefdeadbeef
+      )
+);
+
+repo_ancestor_not_check(
+    'test-project' => 'a47f812b901251922153bac347a348604a24e372' => qw(
+      0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391
+      deadbeefdeadbeefdeadbeefdeadbeefdeadbeef
+      )
+);
+repo_ancestor_not_check(
+    'test-project' => 'd24a32a404ce934cd4f39fd632fc1d43c413f652' => qw(
+      0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391
+      deadbeefdeadbeefdeadbeefdeadbeefdeadbeef
+      a47f812b901251922153bac347a348604a24e372
+      )
+);
+
+done_testing;
+