package Git::PurePerl; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Path::Class; use Compress::Zlib qw(uncompress); use Git::PurePerl::DirectoryEntry; use Git::PurePerl::Object; use Git::PurePerl::Object::Blob; use Git::PurePerl::Object::Commit; use Git::PurePerl::Object::Tree; use Git::PurePerl::Pack; use Path::Class; our $VERSION = '0.34'; has 'directory' => ( is => 'ro', isa => 'Path::Class::Dir', required => 1, coerce => 1 ); has 'packs' => ( is => 'rw', isa => 'ArrayRef[Git::PurePerl::Pack]', required => 0, auto_deref => 1, ); sub BUILD { my $self = shift; my $pack_dir = dir( $self->directory, '.git', 'objects', 'pack' ); my @packs; foreach my $filename ( $pack_dir->children ) { next unless $filename =~ /\.pack$/; push @packs, Git::PurePerl::Pack->new( filename => $filename ); } $self->packs( \@packs ); } sub master { my $self = shift; my $master = file( $self->directory, '.git', 'refs', 'heads', 'master' ); my $sha1; if ( -f $master ) { $sha1 = $master->slurp || confess('Missing refs/heads/master'); chomp $sha1; } else { my $packed_refs = file( $self->directory, '.git', 'packed-refs' ); my $content = $packed_refs->slurp || confess('Missing refs/heads/master'); foreach my $line ( split "\n", $content ) { next if $line =~ /^#/; ( $sha1, my $name ) = split ' ', $line; last if $name eq 'refs/heads/master'; } } return $self->get_object($sha1); } sub get_object { my ( $self, $sha1 ) = @_; return $self->get_object_packed($sha1) || $self->get_object_loose($sha1); } sub get_object_packed { my ( $self, $sha1 ) = @_; foreach my $pack ( $self->packs ) { my ( $kind, $size, $content ) = $pack->get_object($sha1); if ( $kind && $size && $content ) { return $self->create_object( $sha1, $kind, $size, $content ); } } } sub get_object_loose { my ( $self, $sha1 ) = @_; my $filename = file( $self->directory, '.git', 'objects', substr( $sha1, 0, 2 ), substr( $sha1, 2 ) ); my $compressed = $filename->slurp; my $data = uncompress($compressed); my ( $kind, $size, $content ) = $data =~ /^(\w+) (\d+)\0(.+)$/s; return $self->create_object( $sha1, $kind, $size, $content ); } sub create_object { my ( $self, $sha1, $kind, $size, $content ) = @_; if ( $kind eq 'commit' ) { return Git::PurePerl::Object::Commit->new( sha1 => $sha1, kind => $kind, size => $size, content => $content, ); } elsif ( $kind eq 'tree' ) { return Git::PurePerl::Object::Tree->new( sha1 => $sha1, kind => $kind, size => $size, content => $content, ); } elsif ( $kind eq 'blob' ) { return Git::PurePerl::Object::Blob->new( sha1 => $sha1, kind => $kind, size => $size, content => $content, ); } else { confess "unknown kind $kind"; } } 1; __END__ =head1 NAME Git::PurePerl - A Pure Perl interface to Git repositories =head1 SYNOPSIS =head1 DESCRIPTION This module is a Pure Perl interface to Git repositories. It was mostly based on Grit L. =head1 AUTHOR Leon Brocard =head1 COPYRIGHT Copyright (C) 2008, Leon Brocard. =head1 LICENSE This module is free software; you can redistribute it or modify it under the same terms as Perl itself.