Add a has_ancestor_sha1 method on Object::Commit.

This will hopefully make finding common parents of 2 given
refs/tags/branches easier as well as finding if one is the parent of the
other, which will be very very useful if anyone ever plans on adding a
rebase function to Git::PurePerl

Add tests for has_ancestor

Author: kentfredric

CHANGES

@@ -1,5 +1,6 @@
 Revision history for Perl module Git::PurePerl:
 
+     - 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

lib/Git/PurePerl/Object/Commit.pm

@@ -91,5 +91,55 @@ sub parents {
     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;
 

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;
+