diff --git a/CHANGES b/CHANGES index 28ea605..318f779 100644 --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,17 @@ Revision history for Perl module Git::PurePerl: + - Add decoding support for the new gpgsig commit header (Kent Fredric) + - 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) diff --git a/lib/Git/PurePerl.pm b/lib/Git/PurePerl.pm index 6728282..03e8639 100644 --- a/lib/Git/PurePerl.pm +++ b/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' => ( diff --git a/lib/Git/PurePerl/NewObject.pm b/lib/Git/PurePerl/NewObject.pm index 9305e2e..fbd1397 100644 --- a/lib/Git/PurePerl/NewObject.pm +++ b/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 ); diff --git a/lib/Git/PurePerl/Object.pm b/lib/Git/PurePerl/Object.pm index 8f561e6..71762f5 100644 --- a/lib/Git/PurePerl/Object.pm +++ b/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 ); diff --git a/lib/Git/PurePerl/Object/Commit.pm b/lib/Git/PurePerl/Object/Commit.pm index 071d17e..0030034 100644 --- a/lib/Git/PurePerl/Object/Commit.pm +++ b/lib/Git/PurePerl/Object/Commit.pm @@ -18,12 +18,14 @@ has 'committer' => has 'committed_time' => ( is => 'rw', isa => 'DateTime', required => 0 ); has 'comment' => ( is => 'rw', isa => 'Str', required => 0 ); has 'encoding' => ( is => 'rw', isa => 'Str', required => 0 ); +has 'gpg_signature' => ( is => 'rw', isa => 'Str', required => 0 ); my %method_map = ( 'tree' => 'tree_sha1', 'parent' => '_push_parent_sha1', 'author' => 'authored_time', - 'committer' => 'committed_time' + 'committer' => 'committed_time', + 'gpgsig' => 'gpg_signature', ); sub BUILD { @@ -32,6 +34,26 @@ sub BUILD { my @lines = split "\n", $self->content; my %header; while ( my $line = shift @lines ) { + + # Apparent format is roughly: + # + # + # # repeated + # + # And a line not leading with ends the token. + # + # Though, at present, git itself has this special-cased for GPG Signatures. + # + # Its probably extendable to support any value of though. + if ( $line =~ /^gpgsig (.*$)/ ) { + my $sig = "$1"; + while ( $line = $lines[0] ) { + last unless $line =~ /^ (.*$)/; + $sig .= "$1\n"; + shift @lines; + } + push @{ $header{gpgsig} }, $sig; + } last unless $line; my ( $key, $value ) = split ' ', $line, 2; push @{$header{$key}}, $value; @@ -63,6 +85,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 +105,88 @@ sub _push_parent_sha1 { push(@{$self->parent_sha1s}, $sha1); } +=head2 parent_sha1 + +Returns the C 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 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; diff --git a/lib/Git/PurePerl/Util.pm b/lib/Git/PurePerl/Util.pm new file mode 100644 index 0000000..654f5fa --- /dev/null +++ b/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) +# 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; + diff --git a/t/00_setup.t b/t/00_setup.t index 19de5de..b462b03 100644 --- a/t/00_setup.t +++ b/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; diff --git a/t/08_has_ancestor.t b/t/08_has_ancestor.t new file mode 100644 index 0000000..5fe014b --- /dev/null +++ b/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) +# 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; + diff --git a/t/09_util.t b/t/09_util.t new file mode 100644 index 0000000..562453f --- /dev/null +++ b/t/09_util.t @@ -0,0 +1,68 @@ +#!perl +use strict; +use warnings; +use Test::More; +use Git::PurePerl; +use Path::Class; + +use Git::PurePerl::Util qw( find_git_dir current_git_dir ); + +foreach my $directory (qw(test-project test-project-packs test-project-packs2)) +{ + my $dir = dir($directory); + my $gd = find_git_dir( dir($directory) ); + + is( + $gd->absolute->stringify, + dir($directory)->subdir('.git')->absolute->stringify, + "Correctly resolves an .git from a repo( $directory )" + ); + +} + +foreach my $directory ( + qw( + test-util/deep + test-util/deep/.git + test-util/deep/stage1 + test-util/deep/stage1/stage2/ + ) + ) +{ + is( + find_git_dir( dir($directory) )->absolute->stringify, + dir('test-util/deep/.git')->absolute->stringify, + "finding .git dirs works at all tree levels ( $directory )" + ); +} + +foreach my $directory ( + qw( + test-util/bare + test-util/bare/info + test-util/bare/objects + test-util/bare/refs + test-util/bare/refs/heads + ) + ) +{ + is( + find_git_dir( dir($directory) )->absolute->stringify, + dir('test-util/bare')->absolute->stringify, + "finding bare dirs works at all tree levels ( $directory )" + ); +} + +use Cwd qw( getcwd ); + +my $old_dir = getcwd; + +chdir "test-util/deep/stage1"; + +is( + current_git_dir()->absolute->stringify, + dir('.')->parent->subdir('.git')->absolute->stringify, + "Can work with CWD" +); + +done_testing; diff --git a/t/simple.t b/t/simple.t index 2874dd0..2c0ce45 100644 --- a/t/simple.t +++ b/t/simple.t @@ -7,7 +7,7 @@ use Path::Class; my $checkout_directory = dir('t/checkout'); -foreach my $directory qw(test-project test-project-packs test-project-packs2) +foreach my $directory (qw(test-project test-project-packs test-project-packs2)) { my $git = Git::PurePerl->new( directory => $directory ); like( $git->master_sha1, qr/^[a-z0-9]{40}$/ ); diff --git a/test-util.tgz b/test-util.tgz new file mode 100644 index 0000000..2112ed2 Binary files /dev/null and b/test-util.tgz differ