local-lib5/lib/perl5/Git/PurePerl.pm

   1 package Git::PurePerl;
   2 use Moose;
   3 use MooseX::StrictConstructor;
   4 use MooseX::Types::Path::Class;
   5 use Compress::Zlib qw(uncompress);
   6 use Data::Stream::Bulk;
   7 use Data::Stream::Bulk::Array;
   8 use Data::Stream::Bulk::Path::Class;
   9 use DateTime;
  10 use Digest::SHA1;
  11 use File::Find::Rule;
  12 use Git::PurePerl::Actor;
  13 use Git::PurePerl::Config;
  14 use Git::PurePerl::DirectoryEntry;
  15 use Git::PurePerl::Loose;
  16 use Git::PurePerl::Object;
  17 use Git::PurePerl::NewDirectoryEntry;
  18 use Git::PurePerl::NewObject;
  19 use Git::PurePerl::NewObject::Blob;
  20 use Git::PurePerl::NewObject::Commit;
  21 use Git::PurePerl::NewObject::Tag;
  22 use Git::PurePerl::NewObject::Tree;
  23 use Git::PurePerl::Object::Tree;
  24 use Git::PurePerl::Object::Blob;
  25 use Git::PurePerl::Object::Commit;
  26 use Git::PurePerl::Object::Tag;
  27 use Git::PurePerl::Object::Tree;
  28 use Git::PurePerl::Pack;
  29 use Git::PurePerl::Pack::WithIndex;
  30 use Git::PurePerl::Pack::WithoutIndex;
  31 use Git::PurePerl::PackIndex;
  32 use Git::PurePerl::PackIndex::Version1;
  33 use Git::PurePerl::PackIndex::Version2;
  34 use Git::PurePerl::Protocol;
  35 use IO::Digest;
  36 use IO::Socket::INET;
  37 use Path::Class;
  38 use namespace::autoclean;
  39
  40 our $VERSION = '0.46';
  41 $VERSION = eval $VERSION;
  42
  43 has 'directory' => (
  44     is       => 'ro',
  45     isa      => 'Path::Class::Dir',
  46     required => 0,
  47     coerce   => 1
  48 );
  49
  50 has 'gitdir' => (
  51     is       => 'ro',
  52     isa      => 'Path::Class::Dir',
  53     required => 1,
  54     coerce   => 1
  55 );
  56
  57 has 'loose' => (
  58     is         => 'rw',
  59     isa        => 'Git::PurePerl::Loose',
  60     required   => 0,
  61     lazy_build => 1,
  62 );
  63
  64 has 'packs' => (
  65     is         => 'rw',
  66     isa        => 'ArrayRef[Git::PurePerl::Pack]',
  67     required   => 0,
  68     auto_deref => 1,
  69     lazy_build => 1,
  70 );
  71
  72 has 'description' => (
  73     is      => 'rw',
  74     isa     => 'Str',
  75     lazy    => 1,
  76     default => sub {
  77         my $self = shift;
  78         file( $self->gitdir, 'description' )->slurp( chomp => 1 );
  79     }
  80 );
  81
  82 has 'config' => (
  83     is      => 'ro',
  84     isa     => 'Git::PurePerl::Config',
  85     lazy    => 1,
  86     default => sub {
  87         my $self = shift;
  88         Git::PurePerl::Config->new(git => $self);
  89     }
  90 );
  91
  92 __PACKAGE__->meta->make_immutable;
  93
  94 sub BUILDARGS {
  95     my $class  = shift;
  96     my $params = $class->SUPER::BUILDARGS(@_);
  97
  98     $params->{'gitdir'} ||= dir( $params->{'directory'}, '.git' );
  99     return $params;
 100 }
 101
 102 sub BUILD {
 103     my $self = shift;
 104
 105     unless ( -d $self->gitdir ) {
 106         confess $self->gitdir . ' is not a directory';
 107     }
 108     unless ( not defined $self->directory or -d $self->directory ) {
 109         confess $self->directory . ' is not a directory';
 110     }
 111 }
 112
 113 sub _build_loose {
 114     my $self = shift;
 115     my $loose_dir = dir( $self->gitdir, 'objects' );
 116     return Git::PurePerl::Loose->new( directory => $loose_dir );
 117 }
 118
 119 sub _build_packs {
 120     my $self = shift;
 121     my $pack_dir = dir( $self->gitdir, 'objects', 'pack' );
 122     my @packs;
 123     foreach my $filename ( $pack_dir->children ) {
 124         next unless $filename =~ /\.pack$/;
 125         push @packs,
 126             Git::PurePerl::Pack::WithIndex->new( filename => $filename );
 127     }
 128     return \@packs;
 129 }
 130
 131 sub _ref_names_recursive {
 132     my ( $dir, $base, $names ) = @_;
 133
 134     foreach my $file ( $dir->children ) {
 135         if ( -d $file ) {
 136             my $reldir  = $file->relative($dir);
 137             my $subbase = $base . $reldir . "/";
 138             _ref_names_recursive( $file, $subbase, $names );
 139         } else {
 140             push @$names, $base . $file->basename;
 141         }
 142     }
 143 }
 144
 145 sub ref_names {
 146     my $self = shift;
 147     my @names;
 148     foreach my $type (qw(heads remotes tags)) {
 149         my $dir = dir( $self->gitdir, 'refs', $type );
 150         next unless -d $dir;
 151         my $base = "refs/$type/";
 152         _ref_names_recursive( $dir, $base, \@names );
 153     }
 154     my $packed_refs = file( $self->gitdir, 'packed-refs' );
 155     if ( -f $packed_refs ) {
 156         foreach my $line ( $packed_refs->slurp( chomp => 1 ) ) {
 157             next if $line =~ /^#/;
 158             my ( $sha1, my $name ) = split ' ', $line;
 159             push @names, $name;
 160         }
 161     }
 162     return @names;
 163 }
 164
 165 sub refs_sha1 {
 166     my $self = shift;
 167     return map { $self->ref_sha1($_) } $self->ref_names;
 168 }
 169
 170 sub refs {
 171     my $self = shift;
 172     return map { $self->ref($_) } $self->ref_names;
 173 }
 174
 175 sub ref_sha1 {
 176     my ( $self, $wantref ) = @_;
 177     my @refs;
 178     my $dir = dir( $self->gitdir, 'refs' );
 179     return unless -d $dir;
 180
 181     if ($wantref eq "HEAD") {
 182         my $file = file($self->gitdir, 'HEAD');
 183         my $sha1 = file($file)->slurp
 184             || confess("Error reading $file: $!");
 185         chomp $sha1;
 186         return $self->ref_sha1($1) if $sha1 =~ /^ref: (.*)/;
 187         return $sha1;
 188     }
 189
 190     foreach my $file ( File::Find::Rule->new->file->in($dir) ) {
 191         my $ref = 'refs/' . file($file)->relative($dir)->as_foreign('Unix');
 192         if ( $ref eq $wantref ) {
 193             my $sha1 = file($file)->slurp
 194                 || confess("Error reading $file: $!");
 195             chomp $sha1;
 196             return $self->ref_sha1($1) if $sha1 =~ /^ref: (.*)/;
 197             return $sha1;
 198         }
 199     }
 200
 201     my $packed_refs = file( $self->gitdir, 'packed-refs' );
 202     if ( -f $packed_refs ) {
 203         foreach my $line ( $packed_refs->slurp( chomp => 1 ) ) {
 204             next if $line =~ /^#/;
 205             my ( $sha1, my $name ) = split ' ', $line;
 206             if ( $name eq $wantref ) {
 207                 return $self->ref_sha1($1) if $sha1 =~ /^ref: (.*)/;
 208                 return $sha1;
 209             }
 210         }
 211     }
 212     return undef;
 213 }
 214
 215 sub ref {
 216     my ( $self, $wantref ) = @_;
 217     return $self->get_object( $self->ref_sha1($wantref) );
 218 }
 219
 220 sub master_sha1 {
 221     my $self = shift;
 222     return $self->ref_sha1('refs/heads/master');
 223 }
 224
 225 sub master {
 226     my $self = shift;
 227     return $self->ref('refs/heads/master');
 228 }
 229
 230 sub head_sha1 {
 231     my $self = shift;
 232     return $self->ref_sha1('HEAD');
 233 }
 234
 235 sub head {
 236     my $self = shift;
 237     return $self->ref('HEAD');
 238 }
 239
 240 sub get_object {
 241     my ( $self, $sha1 ) = @_;
 242     return unless $sha1;
 243     return $self->get_object_packed($sha1) || $self->get_object_loose($sha1);
 244 }
 245
 246 sub get_objects {
 247     my ( $self, @sha1s ) = @_;
 248     return map { $self->get_object($_) } @sha1s;
 249 }
 250
 251 sub get_object_packed {
 252     my ( $self, $sha1 ) = @_;
 253
 254     foreach my $pack ( $self->packs ) {
 255         my ( $kind, $size, $content ) = $pack->get_object($sha1);
 256         if ( defined($kind) && defined($size) && defined($content) ) {
 257             return $self->create_object( $sha1, $kind, $size, $content );
 258         }
 259     }
 260 }
 261
 262 sub get_object_loose {
 263     my ( $self, $sha1 ) = @_;
 264
 265     my ( $kind, $size, $content ) = $self->loose->get_object($sha1);
 266     if ( defined($kind) && defined($size) && defined($content) ) {
 267         return $self->create_object( $sha1, $kind, $size, $content );
 268     }
 269 }
 270
 271 sub create_object {
 272     my ( $self, $sha1, $kind, $size, $content ) = @_;
 273     if ( $kind eq 'commit' ) {
 274         return Git::PurePerl::Object::Commit->new(
 275             sha1    => $sha1,
 276             kind    => $kind,
 277             size    => $size,
 278             content => $content,
 279             git     => $self,
 280         );
 281     } elsif ( $kind eq 'tree' ) {
 282         return Git::PurePerl::Object::Tree->new(
 283             sha1    => $sha1,
 284             kind    => $kind,
 285             size    => $size,
 286             content => $content,
 287             git     => $self,
 288         );
 289     } elsif ( $kind eq 'blob' ) {
 290         return Git::PurePerl::Object::Blob->new(
 291             sha1    => $sha1,
 292             kind    => $kind,
 293             size    => $size,
 294             content => $content,
 295             git     => $self,
 296         );
 297     } elsif ( $kind eq 'tag' ) {
 298         return Git::PurePerl::Object::Tag->new(
 299             sha1    => $sha1,
 300             kind    => $kind,
 301             size    => $size,
 302             content => $content,
 303             git     => $self,
 304         );
 305     } else {
 306         confess "unknown kind $kind: $content";
 307     }
 308 }
 309
 310 sub all_sha1s {
 311     my $self = shift;
 312     my $dir = dir( $self->gitdir, 'objects' );
 313
 314     my @streams;
 315     push @streams, $self->loose->all_sha1s;
 316
 317     foreach my $pack ( $self->packs ) {
 318         push @streams, $pack->all_sha1s;
 319     }
 320
 321     return Data::Stream::Bulk::Cat->new( streams => \@streams );
 322 }
 323
 324 sub all_objects {
 325     my $self   = shift;
 326     my $stream = $self->all_sha1s;
 327     return Data::Stream::Bulk::Filter->new(
 328         filter => sub { return [ $self->get_objects(@$_) ] },
 329         stream => $stream,
 330     );
 331 }
 332
 333 sub put_object {
 334     my ( $self, $object, $ref ) = @_;
 335     $self->loose->put_object($object);
 336
 337     if ( $object->kind eq 'commit' ) {
 338         $ref = 'master' unless $ref;
 339         $self->update_ref( $ref, $object->sha1 );
 340     }
 341 }
 342
 343 sub update_ref {
 344     my ( $self, $refname, $sha1 ) = @_;
 345     my $ref = file( $self->gitdir, 'refs', 'heads', $refname );
 346     $ref->parent->mkpath;
 347     my $ref_fh = $ref->openw;
 348     $ref_fh->print($sha1) || die "Error writing to $ref";
 349
 350     # FIXME is this always what we want?
 351     my $head = file( $self->gitdir, 'HEAD' );
 352     my $head_fh = $head->openw;
 353     $head_fh->print("ref: refs/heads/$refname")
 354         || die "Error writing to $head";
 355 }
 356
 357 sub init {
 358     my ( $class, %arguments ) = @_;
 359
 360     my $directory = $arguments{directory};
 361     my $git_dir;
 362
 363     unless ( defined $directory ) {
 364         $git_dir = $arguments{gitdir}
 365             || confess
 366             "init() needs either a 'directory' or a 'gitdir' argument";
 367     } else {
 368         if ( not defined $arguments{gitdir} ) {
 369             $git_dir = $arguments{gitdir} = dir( $directory, '.git' );
 370         }
 371         dir($directory)->mkpath;
 372     }
 373
 374     dir($git_dir)->mkpath;
 375     dir( $git_dir, 'refs',    'tags' )->mkpath;
 376     dir( $git_dir, 'objects', 'info' )->mkpath;
 377     dir( $git_dir, 'objects', 'pack' )->mkpath;
 378     dir( $git_dir, 'branches' )->mkpath;
 379     dir( $git_dir, 'hooks' )->mkpath;
 380
 381     my $bare = defined($directory) ? 'false' : 'true';
 382     $class->_add_file(
 383         file( $git_dir, 'config' ),
 384         "[core]\n\trepositoryformatversion = 0\n\tfilemode = true\n\tbare = $bare\n\tlogallrefupdates = true\n"
 385     );
 386     $class->_add_file( file( $git_dir, 'description' ),
 387         "Unnamed repository; edit this file to name it for gitweb.\n" );
 388     $class->_add_file(
 389         file( $git_dir, 'hooks', 'applypatch-msg' ),
 390         "# add shell script and make executable to enable\n"
 391     );
 392     $class->_add_file( file( $git_dir, 'hooks', 'post-commit' ),
 393         "# add shell script and make executable to enable\n" );
 394     $class->_add_file(
 395         file( $git_dir, 'hooks', 'post-receive' ),
 396         "# add shell script and make executable to enable\n"
 397     );
 398     $class->_add_file( file( $git_dir, 'hooks', 'post-update' ),
 399         "# add shell script and make executable to enable\n" );
 400     $class->_add_file(
 401         file( $git_dir, 'hooks', 'pre-applypatch' ),
 402         "# add shell script and make executable to enable\n"
 403     );
 404     $class->_add_file( file( $git_dir, 'hooks', 'pre-commit' ),
 405         "# add shell script and make executable to enable\n" );
 406     $class->_add_file( file( $git_dir, 'hooks', 'pre-rebase' ),
 407         "# add shell script and make executable to enable\n" );
 408     $class->_add_file( file( $git_dir, 'hooks', 'update' ),
 409         "# add shell script and make executable to enable\n" );
 410
 411     dir( $git_dir, 'info' )->mkpath;
 412     $class->_add_file( file( $git_dir, 'info', 'exclude' ),
 413         "# *.[oa]\n# *~\n" );
 414
 415     return $class->new(%arguments);
 416 }
 417
 418 sub checkout {
 419     my ( $self, $directory, $tree ) = @_;
 420     $directory ||= $self->directory;
 421     $tree ||= $self->master->tree;
 422     confess("Missing tree") unless $tree;
 423     foreach my $directory_entry ( $tree->directory_entries ) {
 424         my $filename = file( $directory, $directory_entry->filename );
 425         my $sha1     = $directory_entry->sha1;
 426         my $mode     = $directory_entry->mode;
 427         my $object   = $self->get_object($sha1);
 428         if ( $object->kind eq 'blob' ) {
 429             $self->_add_file( $filename, $object->content );
 430             chmod( oct( '0' . $mode ), $filename )
 431                 || die "Error chmoding $filename to $mode: $!";
 432         } elsif ( $object->kind eq 'tree' ) {
 433             dir($filename)->mkpath;
 434             $self->checkout( $filename, $object );
 435         } else {
 436             die $object->kind;
 437         }
 438     }
 439 }
 440
 441 sub clone {
 442     my ( $self, $hostname, $project ) = @_;
 443     my $protocol = Git::PurePerl::Protocol->new(
 444         hostname => $hostname,
 445         project  => $project,
 446     );
 447
 448     my $sha1s = $protocol->connect;
 449     my $head  = $sha1s->{HEAD};
 450     my $data  = $protocol->fetch_pack($head);
 451
 452     my $filename
 453         = file( $self->gitdir, 'objects', 'pack', 'pack-' . $head . '.pack' );
 454     $self->_add_file( $filename, $data );
 455
 456     my $pack
 457         = Git::PurePerl::Pack::WithoutIndex->new( filename => $filename );
 458     $pack->create_index();
 459
 460     $self->update_ref( master => $head );
 461 }
 462
 463 sub _add_file {
 464     my ( $class, $filename, $contents ) = @_;
 465     my $fh = $filename->openw || confess "Error opening to $filename: $!";
 466     binmode($fh); #important for Win32
 467     $fh->print($contents) || confess "Error writing to $filename: $!";
 468     $fh->close || confess "Error closing $filename: $!";
 469 }
 470
 471 1;
 472
 473 __END__
 474
 475 =head1 NAME
 476
 477 Git::PurePerl - A Pure Perl interface to Git repositories
 478
 479 =head1 SYNOPSIS
 480
 481     my $git = Git::PurePerl->new(
 482         directory => '/path/to/git/'
 483     );
 484     $git->master->committer;
 485     $git->master->comment;
 486     $git->get_object($git->master->tree);
 487
 488 =head1 DESCRIPTION
 489
 490 This module is a Pure Perl interface to Git repositories.
 491
 492 It was mostly based on Grit L<http://grit.rubyforge.org/>.
 493
 494 =head1 METHODS
 495
 496 =over 4
 497
 498 =item master
 499
 500 =item get_object
 501
 502 =item get_object_packed
 503
 504 =item get_object_loose
 505
 506 =item create_object
 507
 508 =item all_sha1s
 509
 510 =back
 511
 512 =head1 MAINTAINANCE
 513
 514 This module is maintained in git at L<http://github.com/bobtfish/git-pureperl/>.
 515
 516 Patches are welcome, please come speak to one of the L<Gitalist> team
 517 on C<< #gitalist >>.
 518
 519 =head1 AUTHOR
 520
 521 Leon Brocard <acme@astray.com>
 522
 523 =head1 CONTRIBUTORS
 524
 525 =over 4
 526
 527 =item Chris Reinhardt
 528
 529 =item Tomas (t0m) Doran
 530
 531 =item Dan (broquaint) Brook
 532
 533 =item Alex Vandiver
 534
 535 =item Dagfinn Ilmari MannsE<aring>ker
 536
 537 =back
 538
 539 =head1 COPYRIGHT
 540
 541 Copyright (C) 2008, Leon Brocard and the above mentioned contributors.
 542
 543 =head1 LICENSE
 544
 545 This module is free software; you can redistribute it or
 546 modify it under the same terms as Perl itself.
 547
 548 =cut
 549