├── .gitignore ├── CHANGES ├── MANIFEST ├── Makefile.PL ├── README ├── lib └── Git │ ├── PurePerl.pm │ └── PurePerl │ ├── Actor.pm │ ├── DirectoryEntry.pm │ ├── Loose.pm │ ├── NewDirectoryEntry.pm │ ├── NewObject.pm │ ├── NewObject │ ├── Blob.pm │ ├── Commit.pm │ ├── Tag.pm │ └── Tree.pm │ ├── Object.pm │ ├── Object │ ├── Blob.pm │ ├── Commit.pm │ ├── Tag.pm │ └── Tree.pm │ ├── Pack.pm │ ├── Pack │ ├── WithIndex.pm │ └── WithoutIndex.pm │ ├── PackIndex.pm │ ├── PackIndex │ ├── Version1.pm │ └── Version2.pm │ └── Protocol.pm ├── t ├── 00_setup.t ├── init.t ├── protocol.t ├── protocol_gpp.t └── simple.t ├── test-project-packs.tgz ├── test-project-packs2.tgz └── test-project.tgz /.gitignore: -------------------------------------------------------------------------------- 1 | t/checkout/ 2 | test-project-packs/ 3 | test-project-packs2/ 4 | test-project/ -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | Revision history for Perl module Git::PurePerl: 2 | 3 | 0.42 4 | - allow put_object to update other heads than just 'master' 5 | (thanks to martijn) 6 | 7 | 0.41 Tue Apr 21 20:41:07 BST 2009 8 | - allow subdirectories in .git/refs/*/ (thanks to martijn) 9 | - run protocol.t test with --base-path to not care about where 10 | on the filesystem the checkout is (thanks to martijn) 11 | - when parsing a commit, split up the author and committer 12 | fields into name, email and commit time. This adds two new 13 | DateTime fields, authored_time and committed_time to ::Commit 14 | and changes the type of the author and committer fields to 15 | Git::PurePerl::Actor, which is an object with name and 16 | email fields (thanks to martijn) 17 | - add the parent field to a new commit when available (thanks 18 | to martijn) 19 | - allow bare repositories with the gitdir parameter (thanks 20 | to martijn) 21 | - fill new commits with real author, authored_time, committer, 22 | committed_time and comment (thanks to martijn) 23 | 24 | 0.40 Fri Mar 13 15:29:02 GMT 2009 25 | - Skip protocol tests on Win32 (thanks to fayland) 26 | - Add description (thanks to fayland) 27 | 28 | 0.39 Fri Mar 13 10:14:57 GMT 2009 29 | - add a method to generate the sha1 of an object 30 | - add a raw method to objects 31 | - add new set of classes to add objects 32 | - add class to talk the git protocol 33 | - add a method to checkout the head 34 | - add a method to return the references 35 | - add a method to return the commit for a reference 36 | - fix bug where it would not find an object if there was a 37 | mixture of packs and loose objects 38 | - fix bug to do with empty files 39 | - split methods into those that returns sha1s and those that 40 | return objects 41 | - add class to index packs 42 | - make it work under Win32 (thanks to fayland) 43 | 44 | 0.38 Thu Dec 18 10:26:49 GMT 2008 45 | - add init() method to create a new repository 46 | - create Git::PurePerl::Loose to handle loose objects 47 | - make Git::PurePerl::Pack's all_sha1s return a stream 48 | 49 | 0.37 Fri Dec 12 16:18:02 GMT 2008 50 | - add minimal docs (thanks to tokuhirom) 51 | - speed everything up by making the classes immutable 52 | - lazily build packs 53 | - simplify the code by splitting pack index reading into 54 | Git::PurePerl::PackIndex::Version1 and 55 | Git::PurePerl::PackIndex::Version2 56 | - minor tidying of code 57 | 58 | 0.36 Wed Nov 26 21:49:33 GMT 2008 59 | - add a class to represent tags 60 | - complain if the directory does not have a .git directory 61 | - remove commented-out code 62 | - only open a pack file or index once 63 | - remove some unnecessary seeks 64 | 65 | 0.35 Tue Nov 25 17:37:56 GMT 2008 66 | - add Data::Stream::Bulk as a prerequisite 67 | - add all_sha1s method 68 | 69 | 0.34 Fri Nov 21 17:20:17 GMT 2008 70 | - speed up finding objects in pack files by using a 71 | binary search algorithm 72 | 73 | 0.33 Thu Nov 20 09:28:36 GMT 2008 74 | - add support for version 2 pack index files 75 | - add support for ref_delta objects in pack files 76 | - add support for ofs_delta objects in pack files 77 | - update with cleaner tars 78 | 79 | 0.32 Fri Nov 14 16:47:59 GMT 2008 80 | - initial release 81 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | CHANGES 2 | lib/Git/PurePerl.pm 3 | lib/Git/PurePerl/Actor.pm 4 | lib/Git/PurePerl/DirectoryEntry.pm 5 | lib/Git/PurePerl/Loose.pm 6 | lib/Git/PurePerl/NewDirectoryEntry.pm 7 | lib/Git/PurePerl/NewObject.pm 8 | lib/Git/PurePerl/NewObject/Blob.pm 9 | lib/Git/PurePerl/NewObject/Commit.pm 10 | lib/Git/PurePerl/NewObject/Tag.pm 11 | lib/Git/PurePerl/NewObject/Tree.pm 12 | lib/Git/PurePerl/Object.pm 13 | lib/Git/PurePerl/Object/Blob.pm 14 | lib/Git/PurePerl/Object/Commit.pm 15 | lib/Git/PurePerl/Object/Tag.pm 16 | lib/Git/PurePerl/Object/Tree.pm 17 | lib/Git/PurePerl/Pack.pm 18 | lib/Git/PurePerl/Pack/WithIndex.pm 19 | lib/Git/PurePerl/Pack/WithoutIndex.pm 20 | lib/Git/PurePerl/PackIndex.pm 21 | lib/Git/PurePerl/PackIndex/Version1.pm 22 | lib/Git/PurePerl/PackIndex/Version2.pm 23 | lib/Git/PurePerl/Protocol.pm 24 | Makefile.PL 25 | MANIFEST This list of files 26 | README 27 | t/00_setup.t 28 | t/init.t 29 | t/protocol_gpp.t 30 | t/simple.t 31 | test-project-packs.tgz 32 | test-project-packs2.tgz 33 | test-project.tgz 34 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use ExtUtils::MakeMaker; 5 | WriteMakefile( 6 | NAME => 'Git::PurePerl', 7 | VERSION_FROM => 'lib/Git/PurePerl.pm', 8 | AUTHOR => 'Leon Brocard ', 9 | ABSTRACT => 'A Pure Perl interface to Git repositories', 10 | LICENSE => 'perl', 11 | PREREQ_PM => { 12 | 'Archive::Extract' => '0', 13 | 'Compress::Raw::Zlib' => '0', 14 | 'Compress::Zlib' => '0', 15 | 'Data::Stream::Bulk' => '0', 16 | 'DateTime' => '0', 17 | 'Digest::SHA1' => '0', 18 | 'File::Find::Rule' => '0', 19 | 'IO::Digest', => '0', 20 | 'Moose' => '0', 21 | 'MooseX::StrictConstructor' => '0', 22 | 'MooseX::Types::Path::Class' => '0', 23 | } 24 | ); 25 | 26 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | NAME 2 | Git::PurePerl - A Pure Perl interface to Git repositories 3 | 4 | SYNOPSIS 5 | my $git = Git::PurePerl->new( 6 | directory => '/path/to/git/' 7 | ); 8 | $git->master->committer; 9 | $git->master->comment; 10 | $git->get_object($git->master->tree); 11 | 12 | DESCRIPTION 13 | This module is a Pure Perl interface to Git repositories. 14 | 15 | It was mostly based on Grit . 16 | 17 | METHODS 18 | master 19 | get_object 20 | get_object_packed 21 | get_object_loose 22 | create_object 23 | all_sha1s 24 | 25 | AUTHOR 26 | Leon Brocard 27 | 28 | COPYRIGHT 29 | Copyright (C) 2008, Leon Brocard. 30 | 31 | LICENSE 32 | This module is free software; you can redistribute it or modify it under 33 | the same terms as Perl itself. 34 | 35 | -------------------------------------------------------------------------------- /lib/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::DirectoryEntry; 14 | use Git::PurePerl::Loose; 15 | use Git::PurePerl::Object; 16 | use Git::PurePerl::NewDirectoryEntry; 17 | use Git::PurePerl::NewObject; 18 | use Git::PurePerl::NewObject::Blob; 19 | use Git::PurePerl::NewObject::Commit; 20 | use Git::PurePerl::NewObject::Tag; 21 | use Git::PurePerl::NewObject::Tree; 22 | use Git::PurePerl::Object::Tree; 23 | use Git::PurePerl::Object::Blob; 24 | use Git::PurePerl::Object::Commit; 25 | use Git::PurePerl::Object::Tag; 26 | use Git::PurePerl::Object::Tree; 27 | use Git::PurePerl::Pack; 28 | use Git::PurePerl::Pack::WithIndex; 29 | use Git::PurePerl::Pack::WithoutIndex; 30 | use Git::PurePerl::PackIndex; 31 | use Git::PurePerl::PackIndex::Version1; 32 | use Git::PurePerl::PackIndex::Version2; 33 | use Git::PurePerl::Protocol; 34 | use IO::Digest; 35 | use IO::Socket::INET; 36 | use Path::Class; 37 | our $VERSION = '0.41'; 38 | 39 | has 'directory' => ( 40 | is => 'ro', 41 | isa => 'Path::Class::Dir', 42 | required => 0, 43 | coerce => 1 44 | ); 45 | 46 | has 'gitdir' => ( 47 | is => 'ro', 48 | isa => 'Path::Class::Dir', 49 | required => 1, 50 | coerce => 1 51 | ); 52 | 53 | has 'loose' => ( 54 | is => 'rw', 55 | isa => 'Git::PurePerl::Loose', 56 | required => 0, 57 | lazy_build => 1, 58 | ); 59 | 60 | has 'packs' => ( 61 | is => 'rw', 62 | isa => 'ArrayRef[Git::PurePerl::Pack]', 63 | required => 0, 64 | auto_deref => 1, 65 | lazy_build => 1, 66 | ); 67 | 68 | has 'description' => ( 69 | is => 'rw', 70 | isa => 'Str', 71 | lazy => 1, 72 | default => sub { 73 | my $self = shift; 74 | file( $self->gitdir, 'description' )->slurp( chomp => 1 ); 75 | } 76 | ); 77 | 78 | __PACKAGE__->meta->make_immutable; 79 | 80 | sub BUILDARGS { 81 | my $class = shift; 82 | my $params = $class->SUPER::BUILDARGS(@_); 83 | 84 | $params->{'gitdir'} ||= dir( $params->{'directory'}, '.git' ); 85 | return $params; 86 | } 87 | 88 | sub BUILD { 89 | my $self = shift; 90 | 91 | unless ( -d $self->gitdir ) { 92 | confess $self->directory . ' is not a directory'; 93 | } 94 | unless ( not defined $self->directory or -d $self->directory ) { 95 | confess $self->directory . ' is not a directory'; 96 | } 97 | } 98 | 99 | sub _build_loose { 100 | my $self = shift; 101 | my $loose_dir = dir( $self->gitdir, 'objects' ); 102 | return Git::PurePerl::Loose->new( directory => $loose_dir ); 103 | } 104 | 105 | sub _build_packs { 106 | my $self = shift; 107 | my $pack_dir = dir( $self->gitdir, 'objects', 'pack' ); 108 | my @packs; 109 | foreach my $filename ( $pack_dir->children ) { 110 | next unless $filename =~ /\.pack$/; 111 | push @packs, 112 | Git::PurePerl::Pack::WithIndex->new( filename => $filename ); 113 | } 114 | return \@packs; 115 | } 116 | 117 | sub _ref_names_recursive { 118 | my ( $dir, $base, $names ) = @_; 119 | 120 | foreach my $file ( $dir->children ) { 121 | if ( -d $file ) { 122 | my $reldir = $file->relative($dir); 123 | my $subbase = $base . $reldir . "/"; 124 | _ref_names_dir( $file, $subbase, $names ); 125 | } else { 126 | push @$names, $base . $file->basename; 127 | } 128 | } 129 | } 130 | 131 | sub ref_names { 132 | my $self = shift; 133 | my @names; 134 | foreach my $type (qw(heads remotes tags)) { 135 | my $dir = dir( $self->gitdir, 'refs', $type ); 136 | next unless -d $dir; 137 | my $base = "refs/$type/"; 138 | _ref_names_recursive( $dir, $base, \@names ); 139 | } 140 | my $packed_refs = file( $self->gitdir, 'packed-refs' ); 141 | if ( -f $packed_refs ) { 142 | foreach my $line ( $packed_refs->slurp( chomp => 1 ) ) { 143 | next if $line =~ /^#/; 144 | my ( $sha1, my $name ) = split ' ', $line; 145 | push @names, $name; 146 | } 147 | } 148 | return @names; 149 | } 150 | 151 | sub refs_sha1 { 152 | my $self = shift; 153 | return map { $self->ref_sha1($_) } $self->ref_names; 154 | } 155 | 156 | sub refs { 157 | my $self = shift; 158 | return map { $self->ref($_) } $self->ref_names; 159 | } 160 | 161 | sub ref_sha1 { 162 | my ( $self, $wantref ) = @_; 163 | my @refs; 164 | my $dir = dir( $self->gitdir, 'refs' ); 165 | next unless -d $dir; 166 | foreach my $file ( File::Find::Rule->new->file->in($dir) ) { 167 | my $ref = 'refs/' . file($file)->relative($dir)->as_foreign('Unix'); 168 | if ( $ref eq $wantref ) { 169 | my $sha1 = file($file)->slurp 170 | || confess("Error reading $file: $!"); 171 | chomp $sha1; 172 | return $sha1; 173 | } 174 | } 175 | 176 | my $packed_refs = file( $self->gitdir, 'packed-refs' ); 177 | if ( -f $packed_refs ) { 178 | foreach my $line ( $packed_refs->slurp( chomp => 1 ) ) { 179 | next if $line =~ /^#/; 180 | my ( $sha1, my $name ) = split ' ', $line; 181 | if ( $name eq $wantref ) { 182 | return $sha1; 183 | } 184 | } 185 | } 186 | return undef; 187 | } 188 | 189 | sub ref { 190 | my ( $self, $wantref ) = @_; 191 | return $self->get_object( $self->ref_sha1($wantref) ); 192 | } 193 | 194 | sub master_sha1 { 195 | my $self = shift; 196 | return $self->ref_sha1('refs/heads/master'); 197 | } 198 | 199 | sub master { 200 | my $self = shift; 201 | return $self->ref('refs/heads/master'); 202 | } 203 | 204 | sub get_object { 205 | my ( $self, $sha1 ) = @_; 206 | return unless $sha1; 207 | return $self->get_object_packed($sha1) || $self->get_object_loose($sha1); 208 | } 209 | 210 | sub get_objects { 211 | my ( $self, @sha1s ) = @_; 212 | return map { $self->get_object($_) } @sha1s; 213 | } 214 | 215 | sub get_object_packed { 216 | my ( $self, $sha1 ) = @_; 217 | 218 | foreach my $pack ( $self->packs ) { 219 | my ( $kind, $size, $content ) = $pack->get_object($sha1); 220 | if ( defined($kind) && defined($size) && defined($content) ) { 221 | return $self->create_object( $sha1, $kind, $size, $content ); 222 | } 223 | } 224 | } 225 | 226 | sub get_object_loose { 227 | my ( $self, $sha1 ) = @_; 228 | 229 | my ( $kind, $size, $content ) = $self->loose->get_object($sha1); 230 | if ( defined($kind) && defined($size) && defined($content) ) { 231 | return $self->create_object( $sha1, $kind, $size, $content ); 232 | } 233 | } 234 | 235 | sub create_object { 236 | my ( $self, $sha1, $kind, $size, $content ) = @_; 237 | if ( $kind eq 'commit' ) { 238 | return Git::PurePerl::Object::Commit->new( 239 | sha1 => $sha1, 240 | kind => $kind, 241 | size => $size, 242 | content => $content, 243 | git => $self, 244 | ); 245 | } elsif ( $kind eq 'tree' ) { 246 | return Git::PurePerl::Object::Tree->new( 247 | sha1 => $sha1, 248 | kind => $kind, 249 | size => $size, 250 | content => $content, 251 | git => $self, 252 | ); 253 | } elsif ( $kind eq 'blob' ) { 254 | return Git::PurePerl::Object::Blob->new( 255 | sha1 => $sha1, 256 | kind => $kind, 257 | size => $size, 258 | content => $content, 259 | git => $self, 260 | ); 261 | } elsif ( $kind eq 'tag' ) { 262 | return Git::PurePerl::Object::Tag->new( 263 | sha1 => $sha1, 264 | kind => $kind, 265 | size => $size, 266 | content => $content, 267 | git => $self, 268 | ); 269 | } else { 270 | confess "unknown kind $kind: $content"; 271 | } 272 | } 273 | 274 | sub all_sha1s { 275 | my $self = shift; 276 | my $dir = dir( $self->gitdir, 'objects' ); 277 | 278 | my @streams; 279 | push @streams, $self->loose->all_sha1s; 280 | 281 | foreach my $pack ( $self->packs ) { 282 | push @streams, $pack->all_sha1s; 283 | } 284 | 285 | return Data::Stream::Bulk::Cat->new( streams => \@streams ); 286 | } 287 | 288 | sub all_objects { 289 | my $self = shift; 290 | my $stream = $self->all_sha1s; 291 | return Data::Stream::Bulk::Filter->new( 292 | filter => sub { return [ $self->get_objects(@$_) ] }, 293 | stream => $stream, 294 | ); 295 | } 296 | 297 | sub put_object { 298 | my ( $self, $object, $ref ) = @_; 299 | $self->loose->put_object($object); 300 | 301 | if ( $object->kind eq 'commit' ) { 302 | $ref = 'master' unless $ref; 303 | $self->update_ref( $ref, $object->sha1 ); 304 | } 305 | } 306 | 307 | sub update_ref { 308 | my ( $self, $refname, $sha1 ) = @_; 309 | my $ref = file( $self->gitdir, 'refs', 'heads', $refname ); 310 | $ref->parent->mkpath; 311 | my $ref_fh = $ref->openw; 312 | $ref_fh->print($sha1) || die "Error writing to $ref"; 313 | 314 | # FIXME is this always what we want? 315 | my $head = file( $self->gitdir, 'HEAD' ); 316 | my $head_fh = $head->openw; 317 | $head_fh->print("ref: refs/heads/$refname") 318 | || die "Error writing to $head"; 319 | } 320 | 321 | sub init { 322 | my ( $class, %arguments ) = @_; 323 | 324 | my $directory = $arguments{directory}; 325 | my $git_dir; 326 | 327 | unless ( defined $directory ) { 328 | $git_dir = $arguments{gitdir} 329 | || confess 330 | "init() needs either a 'directory' or a 'gitdir' argument"; 331 | } else { 332 | if ( not defined $arguments{gitdir} ) { 333 | $git_dir = $arguments{gitdir} = dir( $directory, '.git' ); 334 | } 335 | dir($directory)->mkpath; 336 | } 337 | 338 | dir($git_dir)->mkpath; 339 | dir( $git_dir, 'refs', 'tags' )->mkpath; 340 | dir( $git_dir, 'objects', 'info' )->mkpath; 341 | dir( $git_dir, 'objects', 'pack' )->mkpath; 342 | dir( $git_dir, 'branches' )->mkpath; 343 | dir( $git_dir, 'hooks' )->mkpath; 344 | 345 | my $bare = defined($directory) ? 'false' : 'true'; 346 | $class->_add_file( 347 | file( $git_dir, 'config' ), 348 | "[core]\n\trepositoryformatversion = 0\n\tfilemode = true\n\tbare = $bare\n\tlogallrefupdates = true\n" 349 | ); 350 | $class->_add_file( file( $git_dir, 'description' ), 351 | "Unnamed repository; edit this file to name it for gitweb.\n" ); 352 | $class->_add_file( 353 | file( $git_dir, 'hooks', 'applypatch-msg' ), 354 | "# add shell script and make executable to enable\n" 355 | ); 356 | $class->_add_file( file( $git_dir, 'hooks', 'post-commit' ), 357 | "# add shell script and make executable to enable\n" ); 358 | $class->_add_file( 359 | file( $git_dir, 'hooks', 'post-receive' ), 360 | "# add shell script and make executable to enable\n" 361 | ); 362 | $class->_add_file( file( $git_dir, 'hooks', 'post-update' ), 363 | "# add shell script and make executable to enable\n" ); 364 | $class->_add_file( 365 | file( $git_dir, 'hooks', 'pre-applypatch' ), 366 | "# add shell script and make executable to enable\n" 367 | ); 368 | $class->_add_file( file( $git_dir, 'hooks', 'pre-commit' ), 369 | "# add shell script and make executable to enable\n" ); 370 | $class->_add_file( file( $git_dir, 'hooks', 'pre-rebase' ), 371 | "# add shell script and make executable to enable\n" ); 372 | $class->_add_file( file( $git_dir, 'hooks', 'update' ), 373 | "# add shell script and make executable to enable\n" ); 374 | 375 | dir( $git_dir, 'info' )->mkpath; 376 | $class->_add_file( file( $git_dir, 'info', 'exclude' ), 377 | "# *.[oa]\n# *~\n" ); 378 | 379 | return $class->new(%arguments); 380 | } 381 | 382 | sub checkout { 383 | my ( $self, $directory, $tree ) = @_; 384 | $tree ||= $self->master->tree; 385 | confess("Missing tree") unless $tree; 386 | foreach my $directory_entry ( $tree->directory_entries ) { 387 | my $filename = file( $directory, $directory_entry->filename ); 388 | my $sha1 = $directory_entry->sha1; 389 | my $mode = $directory_entry->mode; 390 | my $object = $self->get_object($sha1); 391 | if ( $object->kind eq 'blob' ) { 392 | $self->_add_file( $filename, $object->content ); 393 | chmod( oct( '0' . $mode ), $filename ) 394 | || die "Error chmoding $filename to $mode: $!"; 395 | } elsif ( $object->kind eq 'tree' ) { 396 | dir($filename)->mkpath; 397 | $self->checkout( $filename, $object ); 398 | } else { 399 | die $object->kind; 400 | } 401 | } 402 | } 403 | 404 | sub clone { 405 | my ( $self, $hostname, $project ) = @_; 406 | my $protocol = Git::PurePerl::Protocol->new( 407 | hostname => $hostname, 408 | project => $project, 409 | ); 410 | 411 | my $sha1s = $protocol->connect; 412 | my $head = $sha1s->{HEAD}; 413 | my $data = $protocol->fetch_pack($head); 414 | 415 | my $filename 416 | = file( $self->gitdir, 'objects', 'pack', 'pack-' . $head . '.pack' ); 417 | $self->_add_file( $filename, $data ); 418 | 419 | my $pack 420 | = Git::PurePerl::Pack::WithoutIndex->new( filename => $filename ); 421 | $pack->create_index(); 422 | 423 | $self->update_ref( master => $head ); 424 | } 425 | 426 | sub _add_file { 427 | my ( $class, $filename, $contents ) = @_; 428 | my $fh = $filename->openw || confess "Error opening to $filename: $!"; 429 | $fh->print($contents) || confess "Error writing to $filename: $!"; 430 | $fh->close || confess "Error closing $filename: $!"; 431 | } 432 | 433 | 1; 434 | 435 | __END__ 436 | 437 | =head1 NAME 438 | 439 | Git::PurePerl - A Pure Perl interface to Git repositories 440 | 441 | =head1 SYNOPSIS 442 | 443 | my $git = Git::PurePerl->new( 444 | directory => '/path/to/git/' 445 | ); 446 | $git->master->committer; 447 | $git->master->comment; 448 | $git->get_object($git->master->tree); 449 | 450 | =head1 DESCRIPTION 451 | 452 | This module is a Pure Perl interface to Git repositories. 453 | 454 | It was mostly based on Grit L. 455 | 456 | =head1 METHODS 457 | 458 | =over 4 459 | 460 | =item master 461 | 462 | =item get_object 463 | 464 | =item get_object_packed 465 | 466 | =item get_object_loose 467 | 468 | =item create_object 469 | 470 | =item all_sha1s 471 | 472 | =back 473 | 474 | =head1 AUTHOR 475 | 476 | Leon Brocard 477 | 478 | =head1 COPYRIGHT 479 | 480 | Copyright (C) 2008, Leon Brocard. 481 | 482 | =head1 LICENSE 483 | 484 | This module is free software; you can redistribute it or 485 | modify it under the same terms as Perl itself. 486 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Actor.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Actor; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | 6 | has 'name' => ( is => 'ro', isa => 'Str', required => 1 ); 7 | has 'email' => ( is => 'ro', isa => 'Str', required => 1 ); 8 | 9 | __PACKAGE__->meta->make_immutable; 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/DirectoryEntry.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::DirectoryEntry; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | 6 | has 'mode' => ( is => 'ro', isa => 'Str', required => 1 ); 7 | has 'filename' => ( is => 'ro', isa => 'Str', required => 1 ); 8 | has 'sha1' => ( is => 'ro', isa => 'Str', required => 1 ); 9 | has 'git' => ( is => 'ro', isa => 'Git::PurePerl', required => 1 ); 10 | 11 | __PACKAGE__->meta->make_immutable; 12 | 13 | sub object { 14 | my $self = shift; 15 | return $self->git->get_object( $self->sha1 ); 16 | } 17 | 18 | 1; 19 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Loose.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Loose; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use MooseX::Types::Path::Class; 5 | use Compress::Zlib qw(compress uncompress); 6 | use Path::Class; 7 | 8 | has 'directory' => ( 9 | is => 'ro', 10 | isa => 'Path::Class::Dir', 11 | required => 1, 12 | coerce => 1 13 | ); 14 | 15 | __PACKAGE__->meta->make_immutable; 16 | 17 | sub get_object { 18 | my ( $self, $sha1 ) = @_; 19 | 20 | my $filename 21 | = file( $self->directory, substr( $sha1, 0, 2 ), substr( $sha1, 2 ) ); 22 | return unless -f $filename; 23 | 24 | my $compressed = $filename->slurp; 25 | my $data = uncompress($compressed); 26 | my ( $kind, $size, $content ) = $data =~ /^(\w+) (\d+)\0(.+)$/s; 27 | return ( $kind, $size, $content ); 28 | } 29 | 30 | sub put_object { 31 | my ( $self, $object ) = @_; 32 | 33 | my $filename = file( 34 | $self->directory, 35 | substr( $object->sha1, 0, 2 ), 36 | substr( $object->sha1, 2 ) 37 | ); 38 | $filename->parent->mkpath; 39 | my $compressed = compress( $object->raw ); 40 | my $fh = $filename->openw; 41 | $fh->print($compressed) || die "Error writing to $filename: $!"; 42 | } 43 | 44 | sub all_sha1s { 45 | my $self = shift; 46 | my $files = Data::Stream::Bulk::Path::Class->new( 47 | dir => $self->directory, 48 | only_files => 1, 49 | ); 50 | return Data::Stream::Bulk::Filter->new( 51 | filter => sub { 52 | [ map { m{([a-z0-9]{2})[/\\]([a-z0-9]{38})}; $1 . $2 } 53 | grep {m{[/\\][a-z0-9]{2}[/\\]}} @$_ 54 | ]; 55 | }, 56 | stream => $files, 57 | ); 58 | } 59 | 60 | 1; 61 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/NewDirectoryEntry.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::NewDirectoryEntry; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | 6 | has 'mode' => ( is => 'ro', isa => 'Str', required => 1 ); 7 | has 'filename' => ( is => 'ro', isa => 'Str', required => 1 ); 8 | has 'sha1' => ( is => 'ro', isa => 'Str', required => 1 ); 9 | 10 | __PACKAGE__->meta->make_immutable; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/NewObject.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::NewObject; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | 6 | enum 'ObjectKind' => qw(commit tree blob tag); 7 | 8 | has 'kind' => ( is => 'ro', isa => 'ObjectKind', required => 1 ); 9 | has 'size' => ( is => 'ro', isa => 'Int', required => 0, lazy_build => 1 ); 10 | has 'content' => ( is => 'rw', isa => 'Str', required => 0, lazy_build => 1 ); 11 | has 'sha1' => ( is => 'ro', isa => 'Str', required => 0, lazy_build => 1 ); 12 | 13 | __PACKAGE__->meta->make_immutable; 14 | 15 | sub _build_sha1 { 16 | my $self = shift; 17 | my $sha1 = Digest::SHA1->new; 18 | $sha1->add( $self->raw ); 19 | my $sha1_hex = $sha1->hexdigest; 20 | return $sha1_hex; 21 | } 22 | 23 | sub _build_size { 24 | my $self = shift; 25 | return length $self->content; 26 | } 27 | 28 | sub raw { 29 | my $self = shift; 30 | return $self->kind . ' ' . $self->size . "\0" . $self->content; 31 | } 32 | 33 | 1; 34 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/NewObject/Blob.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::NewObject::Blob; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | extends 'Git::PurePerl::NewObject'; 6 | 7 | has 'kind' => 8 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'blob' ); 9 | 10 | __PACKAGE__->meta->make_immutable; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/NewObject/Commit.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::NewObject::Commit; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | use DateTime; 6 | extends 'Git::PurePerl::NewObject'; 7 | 8 | has 'kind' => 9 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'commit' ); 10 | has 'tree' => ( is => 'rw', isa => 'Str', required => 1 ); 11 | has 'parent' => ( is => 'rw', isa => 'Str', required => 0 ); 12 | has 'author' => ( is => 'rw', isa => 'Git::PurePerl::Actor', required => 1 ); 13 | has 'authored_time' => ( is => 'rw', isa => 'DateTime', required => 1 ); 14 | has 'committer' => 15 | ( is => 'rw', isa => 'Git::PurePerl::Actor', required => 1 ); 16 | has 'committed_time' => ( is => 'rw', isa => 'DateTime', required => 1 ); 17 | has 'comment' => ( is => 'rw', isa => 'Str', required => 1 ); 18 | 19 | __PACKAGE__->meta->make_immutable; 20 | 21 | sub _build_content { 22 | my $self = shift; 23 | my $content; 24 | 25 | $content .= 'tree ' . $self->tree . "\n"; 26 | $content .= 'parent ' . $self->parent . "\n" if $self->parent; 27 | $content 28 | .= "author " 29 | . $self->author->name . ' <' 30 | . $self->author->email . "> " 31 | . $self->authored_time->epoch . " " 32 | . DateTime::TimeZone->offset_as_string( $self->authored_time->offset ) 33 | . "\n"; 34 | $content 35 | .= "committer " 36 | . $self->committer->name . ' <' 37 | . $self->author->email . "> " 38 | . $self->committed_time->epoch . " " 39 | . DateTime::TimeZone->offset_as_string( 40 | $self->committed_time->offset ) 41 | . "\n"; 42 | $content .= "\n"; 43 | my $comment = $self->comment; 44 | chomp $comment; 45 | $content .= "$comment\n"; 46 | 47 | $self->content($content); 48 | } 49 | 50 | 1; 51 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/NewObject/Tag.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::NewObject::Tag; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | extends 'Git::PurePerl::NewObject'; 6 | 7 | has 'kind' => 8 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'tag' ); 9 | has 'object' => ( is => 'rw', isa => 'Str', required => 1 ); 10 | has 'tag' => ( is => 'rw', isa => 'Str', required => 1 ); 11 | has 'tagger' => ( is => 'rw', isa => 'Str', required => 1 ); 12 | has 'comment' => ( is => 'rw', isa => 'Str', required => 1 ); 13 | 14 | __PACKAGE__->meta->make_immutable; 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/NewObject/Tree.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::NewObject::Tree; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | extends 'Git::PurePerl::NewObject'; 6 | 7 | has 'kind' => 8 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'tree' ); 9 | has 'directory_entries' => ( 10 | is => 'rw', 11 | isa => 'ArrayRef[Git::PurePerl::NewDirectoryEntry]', 12 | required => 1, 13 | auto_deref => 1, 14 | ); 15 | 16 | __PACKAGE__->meta->make_immutable; 17 | 18 | sub _build_content { 19 | my $self = shift; 20 | my $content; 21 | foreach my $de ( $self->directory_entries ) { 22 | $content 23 | .= $de->mode . ' ' 24 | . $de->filename . "\0" 25 | . pack( 'H*', $de->sha1 ); 26 | } 27 | $self->content($content); 28 | } 29 | 30 | 1; 31 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Object.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Object; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | 6 | enum 'ObjectKind' => qw(commit tree blob tag); 7 | 8 | has 'kind' => ( is => 'ro', isa => 'ObjectKind', required => 1 ); 9 | has 'size' => ( is => 'ro', isa => 'Int', required => 1 ); 10 | has 'content' => ( is => 'rw', isa => 'Str', required => 1 ); 11 | has 'sha1' => ( is => 'ro', isa => 'Str', required => 1 ); 12 | has 'git' => ( is => 'ro', isa => 'Git::PurePerl', required => 1 ); 13 | 14 | __PACKAGE__->meta->make_immutable; 15 | 16 | 1; 17 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Object/Blob.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Object::Blob; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | extends 'Git::PurePerl::Object'; 6 | 7 | has 'kind' => 8 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'blob' ); 9 | 10 | __PACKAGE__->meta->make_immutable; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Object/Commit.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Object::Commit; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | extends 'Git::PurePerl::Object'; 6 | 7 | has 'kind' => 8 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'commit' ); 9 | has 'tree_sha1' => ( is => 'rw', isa => 'Str', required => 0 ); 10 | has 'parent_sha1' => ( is => 'rw', isa => 'Str', required => 0 ); 11 | has 'author' => ( is => 'rw', isa => 'Git::PurePerl::Actor', required => 0 ); 12 | has 'authored_time' => ( is => 'rw', isa => 'DateTime', required => 0 ); 13 | has 'committer' => 14 | ( is => 'rw', isa => 'Git::PurePerl::Actor', required => 0 ); 15 | has 'committed_time' => ( is => 'rw', isa => 'DateTime', required => 0 ); 16 | has 'comment' => ( is => 'rw', isa => 'Str', required => 0 ); 17 | 18 | __PACKAGE__->meta->make_immutable; 19 | 20 | my %method_map = ( 21 | 'tree' => 'tree_sha1', 22 | 'parent' => 'parent_sha1', 23 | 'author' => 'authored_time', 24 | 'committer' => 'committed_time' 25 | ); 26 | 27 | sub BUILD { 28 | my $self = shift; 29 | return unless $self->content; 30 | my @lines = split "\n", $self->content; 31 | while ( my $line = shift @lines ) { 32 | last unless $line; 33 | my ( $key, $value ) = split ' ', $line, 2; 34 | if ( $key eq 'committer' or $key eq 'author' ) { 35 | my @data = split ' ', $value; 36 | my ( $email, $epoch, $tz ) = splice( @data, -3 ); 37 | $email = substr( $email, 1, -1 ); 38 | my $name = join ' ', @data; 39 | my $actor 40 | = Git::PurePerl::Actor->new( name => $name, email => $email ); 41 | $self->$key($actor); 42 | $key = $method_map{$key}; 43 | my $dt 44 | = DateTime->from_epoch( epoch => $epoch, time_zone => $tz ); 45 | $self->$key($dt); 46 | } else { 47 | $key = $method_map{$key} || $key; 48 | $self->$key($value); 49 | } 50 | } 51 | $self->comment( join "\n", @lines ); 52 | } 53 | 54 | sub tree { 55 | my $self = shift; 56 | return $self->git->get_object( $self->tree_sha1 ); 57 | } 58 | 59 | sub parent { 60 | my $self = shift; 61 | return $self->git->get_object( $self->parent_sha1 ); 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Object/Tag.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Object::Tag; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | extends 'Git::PurePerl::Object'; 6 | 7 | has 'kind' => 8 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'tag' ); 9 | has 'object' => ( is => 'rw', isa => 'Str', required => 0 ); 10 | has 'tag' => ( is => 'rw', isa => 'Str', required => 0 ); 11 | has 'tagger' => ( is => 'rw', isa => 'Str', required => 0 ); 12 | has 'comment' => ( is => 'rw', isa => 'Str', required => 0 ); 13 | 14 | __PACKAGE__->meta->make_immutable; 15 | 16 | sub BUILD { 17 | my $self = shift; 18 | my @lines = split "\n", $self->content; 19 | while ( my $line = shift @lines ) { 20 | last unless $line; 21 | my ( $key, $value ) = split ' ', $line, 2; 22 | next if $key eq 'type'; 23 | $self->$key($value); 24 | } 25 | $self->comment( join "\n", @lines ); 26 | } 27 | 28 | 1; 29 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Object/Tree.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Object::Tree; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | extends 'Git::PurePerl::Object'; 6 | 7 | has 'kind' => 8 | ( is => 'ro', isa => 'ObjectKind', required => 1, default => 'tree' ); 9 | has 'directory_entries' => ( 10 | is => 'rw', 11 | isa => 'ArrayRef[Git::PurePerl::DirectoryEntry]', 12 | required => 0, 13 | auto_deref => 1, 14 | ); 15 | 16 | __PACKAGE__->meta->make_immutable; 17 | 18 | sub BUILD { 19 | my $self = shift; 20 | my $content = $self->content; 21 | return unless $content; 22 | my @directory_entries; 23 | while ($content) { 24 | my $space_index = index( $content, ' ' ); 25 | my $mode = substr( $content, 0, $space_index ); 26 | $content = substr( $content, $space_index + 1 ); 27 | my $null_index = index( $content, "\0" ); 28 | my $filename = substr( $content, 0, $null_index ); 29 | $content = substr( $content, $null_index + 1 ); 30 | my $sha1 = unpack( 'H*', substr( $content, 0, 20 ) ); 31 | $content = substr( $content, 20 ); 32 | push @directory_entries, 33 | Git::PurePerl::DirectoryEntry->new( 34 | mode => $mode, 35 | filename => $filename, 36 | sha1 => $sha1, 37 | git => $self->git, 38 | ); 39 | } 40 | $self->directory_entries( \@directory_entries ); 41 | } 42 | 43 | 1; 44 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Pack.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Pack; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use MooseX::Types::Path::Class; 5 | use Compress::Raw::Zlib; 6 | use IO::File; 7 | 8 | has 'filename' => 9 | ( is => 'ro', isa => 'Path::Class::File', required => 1, coerce => 1 ); 10 | has 'fh' => ( is => 'rw', isa => 'IO::File', required => 0 ); 11 | 12 | __PACKAGE__->meta->make_immutable; 13 | 14 | my @TYPES = ( 'none', 'commit', 'tree', 'blob', 'tag', '', 'ofs_delta', 15 | 'ref_delta' ); 16 | my $OBJ_NONE = 0; 17 | my $OBJ_COMMIT = 1; 18 | my $OBJ_TREE = 2; 19 | my $OBJ_BLOB = 3; 20 | my $OBJ_TAG = 4; 21 | my $OBJ_OFS_DELTA = 6; 22 | my $OBJ_REF_DELTA = 7; 23 | 24 | my $SHA1Size = 20; 25 | 26 | sub BUILD { 27 | my $self = shift; 28 | my $fh = IO::File->new( $self->filename ) || confess($!); 29 | $self->fh($fh); 30 | } 31 | 32 | sub all_sha1s { 33 | my ( $self, $want_sha1 ) = @_; 34 | return Data::Stream::Bulk::Array->new( 35 | array => [ $self->index->all_sha1s ] ); 36 | } 37 | 38 | sub unpack_object { 39 | my ( $self, $offset ) = @_; 40 | my $obj_offset = $offset; 41 | my $fh = $self->fh; 42 | 43 | $fh->seek( $offset, 0 ) || die "Error seeking in pack: $!"; 44 | $fh->read( my $c, 1 ) || die "Error reading from pack: $!"; 45 | $c = unpack( 'C', $c ) || die $!; 46 | 47 | my $size = ( $c & 0xf ); 48 | my $type_number = ( $c >> 4 ) & 7; 49 | my $type = $TYPES[$type_number] || confess "invalid type $type_number"; 50 | 51 | my $shift = 4; 52 | $offset++; 53 | 54 | while ( ( $c & 0x80 ) != 0 ) { 55 | $fh->read( $c, 1 ) || die $!; 56 | $c = unpack( 'C', $c ) || die $!; 57 | $size |= ( ( $c & 0x7f ) << $shift ); 58 | $shift += 7; 59 | $offset += 1; 60 | } 61 | 62 | if ( $type eq 'ofs_delta' || $type eq 'ref_delta' ) { 63 | ( $type, $size, my $content ) 64 | = $self->unpack_deltified( $type, $offset, $obj_offset, $size ); 65 | return ( $type, $size, $content ); 66 | 67 | } elsif ( $type eq 'commit' 68 | || $type eq 'tree' 69 | || $type eq 'blob' 70 | || $type eq 'tag' ) 71 | { 72 | my $content = $self->read_compressed( $offset, $size ); 73 | return ( $type, $size, $content ); 74 | } else { 75 | confess "invalid type $type"; 76 | } 77 | } 78 | 79 | sub read_compressed { 80 | my ( $self, $offset, $size ) = @_; 81 | my $fh = $self->fh; 82 | 83 | $fh->seek( $offset, 0 ) || die $!; 84 | my ( $deflate, $status ) = Compress::Raw::Zlib::Inflate->new( 85 | -AppendOutput => 1, 86 | -ConsumeInput => 0 87 | ); 88 | 89 | my $out = ""; 90 | while ( length($out) < $size ) { 91 | $fh->read( my $block, 4096 ) || die $!; 92 | my $status = $deflate->inflate( $block, $out ); 93 | } 94 | confess "$out is not $size" unless length($out) == $size; 95 | 96 | $fh->seek( $offset + $deflate->total_in, 0 ) || die $!; 97 | return $out; 98 | } 99 | 100 | sub unpack_deltified { 101 | my ( $self, $type, $offset, $obj_offset, $size ) = @_; 102 | my $fh = $self->fh; 103 | 104 | my $base; 105 | 106 | $fh->seek( $offset, 0 ) || die $!; 107 | $fh->read( my $data, $SHA1Size ) || die $!; 108 | my $sha1 = unpack( 'H*', $data ); 109 | 110 | if ( $type eq 'ofs_delta' ) { 111 | my $i = 0; 112 | my $c = unpack( 'C', substr( $data, $i, 1 ) ); 113 | my $base_offset = $c & 0x7f; 114 | 115 | while ( ( $c & 0x80 ) != 0 ) { 116 | $c = unpack( 'C', substr( $data, ++$i, 1 ) ); 117 | $base_offset++; 118 | $base_offset <<= 7; 119 | $base_offset |= $c & 0x7f; 120 | } 121 | $base_offset = $obj_offset - $base_offset; 122 | $offset += $i + 1; 123 | 124 | ( $type, undef, $base ) = $self->unpack_object($base_offset); 125 | } else { 126 | ( $type, undef, $base ) = $self->get_object($sha1); 127 | $offset += $SHA1Size; 128 | 129 | } 130 | 131 | my $delta = $self->read_compressed( $offset, $size ); 132 | my $new = $self->patch_delta( $base, $delta ); 133 | 134 | return ( $type, length($new), $new ); 135 | } 136 | 137 | sub patch_delta { 138 | my ( $self, $base, $delta ) = @_; 139 | 140 | my ( $src_size, $pos ) = $self->patch_delta_header_size( $delta, 0 ); 141 | if ( $src_size != length($base) ) { 142 | confess "invalid delta data"; 143 | } 144 | 145 | ( my $dest_size, $pos ) = $self->patch_delta_header_size( $delta, $pos ); 146 | my $dest = ""; 147 | 148 | while ( $pos < length($delta) ) { 149 | my $c = substr( $delta, $pos, 1 ); 150 | $c = unpack( 'C', $c ); 151 | $pos++; 152 | if ( ( $c & 0x80 ) != 0 ) { 153 | 154 | my $cp_off = 0; 155 | my $cp_size = 0; 156 | $cp_off = unpack( 'C', substr( $delta, $pos++, 1 ) ) 157 | if ( $c & 0x01 ) != 0; 158 | $cp_off |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 8 159 | if ( $c & 0x02 ) != 0; 160 | $cp_off |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 16 161 | if ( $c & 0x04 ) != 0; 162 | $cp_off |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 24 163 | if ( $c & 0x08 ) != 0; 164 | $cp_size = unpack( 'C', substr( $delta, $pos++, 1 ) ) 165 | if ( $c & 0x10 ) != 0; 166 | $cp_size |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 8 167 | if ( $c & 0x20 ) != 0; 168 | $cp_size |= unpack( 'C', substr( $delta, $pos++, 1 ) ) << 16 169 | if ( $c & 0x40 ) != 0; 170 | $cp_size = 0x10000 if $cp_size == 0; 171 | 172 | $dest .= substr( $base, $cp_off, $cp_size ); 173 | } elsif ( $c != 0 ) { 174 | $dest .= substr( $delta, $pos, $c ); 175 | $pos += $c; 176 | } else { 177 | confess 'invalid delta data'; 178 | } 179 | } 180 | 181 | if ( length($dest) != $dest_size ) { 182 | confess 'invalid delta data'; 183 | } 184 | return $dest; 185 | } 186 | 187 | sub patch_delta_header_size { 188 | my ( $self, $delta, $pos ) = @_; 189 | 190 | my $size = 0; 191 | my $shift = 0; 192 | while (1) { 193 | 194 | my $c = substr( $delta, $pos, 1 ); 195 | unless ( defined $c ) { 196 | confess 'invalid delta header'; 197 | } 198 | $c = unpack( 'C', $c ); 199 | 200 | $pos++; 201 | $size |= ( $c & 0x7f ) << $shift; 202 | $shift += 7; 203 | last if ( $c & 0x80 ) == 0; 204 | } 205 | return ( $size, $pos ); 206 | } 207 | 208 | 209 | 210 | 1; 211 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Pack/WithIndex.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Pack::WithIndex; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | extends 'Git::PurePerl::Pack'; 5 | 6 | has 'index_filename' => 7 | ( is => 'rw', isa => 'Path::Class::File', required => 0, coerce => 1 ); 8 | has 'index' => 9 | ( is => 'rw', isa => 'Git::PurePerl::PackIndex', required => 0 ); 10 | 11 | __PACKAGE__->meta->make_immutable; 12 | 13 | sub BUILD { 14 | my $self = shift; 15 | my $index_filename = $self->filename; 16 | $index_filename =~ s/\.pack/.idx/; 17 | $self->index_filename($index_filename); 18 | 19 | my $index_fh = IO::File->new($index_filename) || confess($!); 20 | $index_fh->read( my $signature, 4 ); 21 | $index_fh->read( my $version, 4 ); 22 | $version = unpack( 'N', $version ); 23 | $index_fh->close; 24 | 25 | if ( $signature eq "\377tOc" ) { 26 | if ( $version == 2 ) { 27 | $self->index( 28 | Git::PurePerl::PackIndex::Version2->new( 29 | filename => $index_filename 30 | ) 31 | ); 32 | } else { 33 | confess("Unknown version"); 34 | } 35 | } else { 36 | $self->index( 37 | Git::PurePerl::PackIndex::Version1->new( 38 | filename => $index_filename 39 | ) 40 | ); 41 | } 42 | } 43 | 44 | sub get_object { 45 | my ( $self, $want_sha1 ) = @_; 46 | my $offset = $self->index->get_object_offset($want_sha1); 47 | return unless $offset; 48 | return $self->unpack_object($offset); 49 | } 50 | 51 | 1; 52 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Pack/WithoutIndex.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Pack::WithoutIndex; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | extends 'Git::PurePerl::Pack'; 5 | 6 | has 'offsets' => ( is => 'rw', isa => 'HashRef', required => 0 ); 7 | 8 | __PACKAGE__->meta->make_immutable; 9 | 10 | my @TYPES = ( 'none', 'commit', 'tree', 'blob', 'tag', '', 'ofs_delta', 11 | 'ref_delta' ); 12 | 13 | sub create_index { 14 | my ($self) = @_; 15 | my $index_filename = $self->filename; 16 | $index_filename =~ s/\.pack/.idx/; 17 | my $index_fh = IO::File->new("> $index_filename") || die $!; 18 | 19 | my $iod = IO::Digest->new( $index_fh, 'SHA1' ); 20 | 21 | my $offsets = $self->create_index_offsets; 22 | my @fan_out_table; 23 | foreach my $sha1 ( sort keys %$offsets ) { 24 | my $offset = $offsets->{$sha1}; 25 | my $slot = unpack( 'C', pack( 'H*', $sha1 ) ); 26 | $fan_out_table[$slot]++; 27 | } 28 | foreach my $i ( 0 .. 255 ) { 29 | $index_fh->print( pack( 'N', $fan_out_table[$i] || 0 ) ) || die $!; 30 | $fan_out_table[ $i + 1 ] += $fan_out_table[$i] || 0; 31 | } 32 | foreach my $sha1 ( sort keys %$offsets ) { 33 | my $offset = $offsets->{$sha1}; 34 | $index_fh->print( pack( 'N', $offset ) ) || die $!; 35 | $index_fh->print( pack( 'H*', $sha1 ) ) || die $!; 36 | } 37 | 38 | # read the pack checksum from the end of the pack file 39 | my $size = -s $self->filename; 40 | my $fh = $self->fh; 41 | $fh->seek( $size - 20, 0 ) || die $!; 42 | my $read = $fh->read( my $pack_sha1, 20 ) || die $!; 43 | 44 | $index_fh->print($pack_sha1) || die $!; 45 | $index_fh->print( $iod->digest ) || die $!; 46 | 47 | $index_fh->close() || die $!; 48 | } 49 | 50 | sub create_index_offsets { 51 | my ($self) = @_; 52 | my $fh = $self->fh; 53 | 54 | $fh->read( my $signature, 4 ); 55 | $fh->read( my $version, 4 ); 56 | $version = unpack( 'N', $version ); 57 | $fh->read( my $objects, 4 ); 58 | $objects = unpack( 'N', $objects ); 59 | 60 | my %offsets; 61 | $self->offsets( \%offsets ); 62 | 63 | foreach my $i ( 1 .. $objects ) { 64 | my $offset = $fh->tell || die "Error telling filehandle: $!"; 65 | my $obj_offset = $offset; 66 | $fh->read( my $c, 1 ) || die "Error reading from pack: $!"; 67 | $c = unpack( 'C', $c ) || die $!; 68 | $offset++; 69 | 70 | my $size = ( $c & 0xf ); 71 | my $type_number = ( $c >> 4 ) & 7; 72 | my $type = $TYPES[$type_number] 73 | || confess 74 | "invalid type $type_number at offset $offset, size $size"; 75 | 76 | my $shift = 4; 77 | 78 | while ( ( $c & 0x80 ) != 0 ) { 79 | $fh->read( $c, 1 ) || die $!; 80 | $c = unpack( 'C', $c ) || die $!; 81 | $offset++; 82 | $size |= ( ( $c & 0x7f ) << $shift ); 83 | $shift += 7; 84 | } 85 | 86 | my $content; 87 | 88 | if ( $type eq 'ofs_delta' || $type eq 'ref_delta' ) { 89 | ( $type, $size, $content ) 90 | = $self->unpack_deltified( $type, $offset, $obj_offset, $size, 91 | \%offsets ); 92 | } elsif ( $type eq 'commit' 93 | || $type eq 'tree' 94 | || $type eq 'blob' 95 | || $type eq 'tag' ) 96 | { 97 | $content = $self->read_compressed( $offset, $size ); 98 | } else { 99 | confess "invalid type $type"; 100 | } 101 | 102 | my $raw = $type . ' ' . $size . "\0" . $content; 103 | my $sha1 = Digest::SHA1->new; 104 | $sha1->add($raw); 105 | my $sha1_hex = $sha1->hexdigest; 106 | $offsets{$sha1_hex} = $obj_offset; 107 | } 108 | 109 | return \%offsets; 110 | } 111 | 112 | sub get_object { 113 | my ( $self, $want_sha1 ) = @_; 114 | my $offset = $self->offsets->{$want_sha1}; 115 | return unless $offset; 116 | return $self->unpack_object($offset); 117 | } 118 | 119 | 1; 120 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/PackIndex.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::PackIndex; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use IO::File; 5 | 6 | has 'filename' => 7 | ( is => 'ro', isa => 'Path::Class::File', required => 1, coerce => 1 ); 8 | 9 | has 'fh' => ( is => 'rw', isa => 'IO::File', required => 0 ); 10 | 11 | has 'offsets' => 12 | ( is => 'rw', isa => 'ArrayRef[Int]', required => 0, auto_deref => 1, ); 13 | has 'size' => ( is => 'rw', isa => 'Int', required => 0 ); 14 | 15 | __PACKAGE__->meta->make_immutable; 16 | 17 | my $FanOutCount = 256; 18 | my $SHA1Size = 20; 19 | my $IdxOffsetSize = 4; 20 | my $OffsetSize = 4; 21 | my $CrcSize = 4; 22 | my $OffsetStart = $FanOutCount * $IdxOffsetSize; 23 | my $SHA1Start = $OffsetStart + $OffsetSize; 24 | my $EntrySize = $OffsetSize + $SHA1Size; 25 | my $EntrySizeV2 = $SHA1Size + $CrcSize + $OffsetSize; 26 | 27 | sub BUILD { 28 | my $self = shift; 29 | my $filename = $self->filename; 30 | 31 | my $fh = IO::File->new($filename) || confess($!); 32 | $self->fh($fh); 33 | 34 | my @offsets = (0); 35 | $fh->seek( $self->global_offset, 0 ); 36 | foreach my $i ( 0 .. $FanOutCount - 1 ) { 37 | $fh->read( my $data, $IdxOffsetSize ); 38 | my $offset = unpack( 'N', $data ); 39 | confess("pack has discontinuous index") if $offset < $offsets[-1]; 40 | push @offsets, $offset; 41 | } 42 | $self->offsets( \@offsets ); 43 | $self->size( $offsets[-1] ); 44 | } 45 | 46 | 1; 47 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/PackIndex/Version1.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::PackIndex::Version1; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | 5 | extends 'Git::PurePerl::PackIndex'; 6 | __PACKAGE__->meta->make_immutable; 7 | 8 | my $FanOutCount = 256; 9 | my $SHA1Size = 20; 10 | my $IdxOffsetSize = 4; 11 | my $OffsetSize = 4; 12 | my $CrcSize = 4; 13 | my $OffsetStart = $FanOutCount * $IdxOffsetSize; 14 | my $SHA1Start = $OffsetStart + $OffsetSize; 15 | my $EntrySize = $OffsetSize + $SHA1Size; 16 | my $EntrySizeV2 = $SHA1Size + $CrcSize + $OffsetSize; 17 | 18 | sub global_offset { 19 | return 0; 20 | } 21 | 22 | sub all_sha1s { 23 | my ( $self, $want_sha1 ) = @_; 24 | my $fh = $self->fh; 25 | my @sha1s; 26 | 27 | my $pos = $OffsetStart; 28 | $fh->seek( $pos, 0 ) || die $!; 29 | foreach my $i ( 1 .. $self->size ) { 30 | $fh->read( my $data, $OffsetSize ) || die $!; 31 | my $offset = unpack( 'N', $data ); 32 | $fh->read( $data, $SHA1Size ) || die $!; 33 | my $sha1 = unpack( 'H*', $data ); 34 | push @sha1s, $sha1; 35 | $pos += $EntrySize; 36 | } 37 | return @sha1s; 38 | } 39 | 40 | sub get_object_offset { 41 | my ( $self, $want_sha1 ) = @_; 42 | my @offsets = $self->offsets; 43 | my $fh = $self->fh; 44 | 45 | my $slot = unpack( 'C', pack( 'H*', $want_sha1 ) ); 46 | return unless defined $slot; 47 | 48 | my ( $first, $last ) = @offsets[ $slot, $slot + 1 ]; 49 | 50 | while ( $first < $last ) { 51 | my $mid = int( ( $first + $last ) / 2 ); 52 | $fh->seek( $SHA1Start + $mid * $EntrySize, 0 ) || die $!; 53 | $fh->read( my $data, $SHA1Size ) || die $!; 54 | my $midsha1 = unpack( 'H*', $data ); 55 | if ( $midsha1 lt $want_sha1 ) { 56 | $first = $mid + 1; 57 | } elsif ( $midsha1 gt $want_sha1 ) { 58 | $last = $mid; 59 | } else { 60 | my $pos = $OffsetStart + $mid * $EntrySize; 61 | $fh->seek( $pos, 0 ) || die $!; 62 | $fh->read( my $data, $OffsetSize ) || die $!; 63 | my $offset = unpack( 'N', $data ); 64 | return $offset; 65 | } 66 | } 67 | 68 | return; 69 | } 70 | 71 | 1; 72 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/PackIndex/Version2.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::PackIndex::Version2; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | 5 | extends 'Git::PurePerl::PackIndex'; 6 | __PACKAGE__->meta->make_immutable; 7 | 8 | my $FanOutCount = 256; 9 | my $SHA1Size = 20; 10 | my $IdxOffsetSize = 4; 11 | my $OffsetSize = 4; 12 | my $CrcSize = 4; 13 | my $OffsetStart = $FanOutCount * $IdxOffsetSize; 14 | my $SHA1Start = $OffsetStart + $OffsetSize; 15 | my $EntrySize = $OffsetSize + $SHA1Size; 16 | my $EntrySizeV2 = $SHA1Size + $CrcSize + $OffsetSize; 17 | 18 | sub global_offset { 19 | return 8; 20 | } 21 | 22 | sub all_sha1s { 23 | my ( $self, $want_sha1 ) = @_; 24 | my $fh = $self->fh; 25 | my @sha1s; 26 | my @data; 27 | 28 | my $pos = $OffsetStart; 29 | $fh->seek( $pos + $self->global_offset, 0 ) || die $!; 30 | foreach my $i ( 0 .. $self->size - 1 ) { 31 | $fh->read( my $sha1, $SHA1Size ) || die $!; 32 | $data[$i] = [ unpack( 'H*', $sha1 ), 0, 0 ]; 33 | $pos += $SHA1Size; 34 | } 35 | $fh->seek( $pos + $self->global_offset, 0 ) || die $!; 36 | foreach my $i ( 0 .. $self->size - 1 ) { 37 | $fh->read( my $crc, $CrcSize ) || die $!; 38 | $data[$i]->[1] = unpack( 'H*', $crc ); 39 | $pos += $CrcSize; 40 | } 41 | $fh->seek( $pos + $self->global_offset, 0 ) || die $!; 42 | foreach my $i ( 0 .. $self->size - 1 ) { 43 | $fh->read( my $offset, $OffsetSize ) || die $!; 44 | $data[$i]->[2] = unpack( 'N', $offset ); 45 | $pos += $OffsetSize; 46 | } 47 | foreach my $data (@data) { 48 | my ( $sha1, $crc, $offset ) = @$data; 49 | push @sha1s, $sha1; 50 | } 51 | 52 | return @sha1s; 53 | } 54 | 55 | sub get_object_offset { 56 | my ( $self, $want_sha1 ) = @_; 57 | my @offsets = $self->offsets; 58 | my $fh = $self->fh; 59 | 60 | my $slot = unpack( 'C', pack( 'H*', $want_sha1 ) ); 61 | return unless defined $slot; 62 | 63 | my ( $first, $last ) = @offsets[ $slot, $slot + 1 ]; 64 | 65 | while ( $first < $last ) { 66 | my $mid = int( ( $first + $last ) / 2 ); 67 | 68 | $fh->seek( $self->global_offset + $OffsetStart + ( $mid * $SHA1Size ), 69 | 0 ) 70 | || die $!; 71 | $fh->read( my $data, $SHA1Size ) || die $!; 72 | my $midsha1 = unpack( 'H*', $data ); 73 | if ( $midsha1 lt $want_sha1 ) { 74 | $first = $mid + 1; 75 | } elsif ( $midsha1 gt $want_sha1 ) { 76 | $last = $mid; 77 | } else { 78 | my $pos 79 | = $self->global_offset 80 | + $OffsetStart 81 | + ( $self->size * ( $SHA1Size + $CrcSize ) ) 82 | + ( $mid * $OffsetSize ); 83 | $fh->seek( $pos, 0 ) || die $!; 84 | $fh->read( my $data, $OffsetSize ) || die $!; 85 | my $offset = unpack( 'N', $data ); 86 | return $offset; 87 | } 88 | } 89 | return; 90 | } 91 | 92 | 1; 93 | -------------------------------------------------------------------------------- /lib/Git/PurePerl/Protocol.pm: -------------------------------------------------------------------------------- 1 | package Git::PurePerl::Protocol; 2 | use Moose; 3 | use MooseX::StrictConstructor; 4 | use Moose::Util::TypeConstraints; 5 | 6 | has 'hostname' => ( is => 'ro', isa => 'Str', required => 1 ); 7 | has 'port' => ( is => 'ro', isa => 'Int', required => 0, default => 9418 ); 8 | has 'project' => ( is => 'ro', isa => 'Str', required => 1 ); 9 | has 'socket' => ( is => 'rw', isa => 'IO::Socket', required => 0 ); 10 | 11 | sub connect { 12 | my $self = shift; 13 | 14 | my $socket = IO::Socket::INET->new( 15 | PeerAddr => $self->hostname, 16 | PeerPort => $self->port, 17 | Proto => 'tcp' 18 | ) || die $!; 19 | $socket->autoflush(1) || die $!; 20 | $self->socket($socket); 21 | 22 | $self->send_line( "git-upload-pack " 23 | . $self->project 24 | . "\0host=" 25 | . $self->hostname 26 | . "\0" ); 27 | 28 | my %sha1s; 29 | while ( my $line = $self->read_line() ) { 30 | 31 | # warn "S $line"; 32 | my ( $sha1, $name ) = $line =~ /^([a-z0-9]+) ([^\0\n]+)/; 33 | 34 | #use YAML; warn Dump $line; 35 | $sha1s{$name} = $sha1; 36 | } 37 | return \%sha1s; 38 | } 39 | 40 | sub fetch_pack { 41 | my ( $self, $sha1 ) = @_; 42 | $self->send_line("want $sha1 side-band-64k\n"); 43 | 44 | #send_line( 45 | # "want 0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391 multi_ack side-band-64k ofs-delta\n" 46 | #); 47 | $self->send_line(''); 48 | $self->send_line('done'); 49 | 50 | my $pack; 51 | 52 | while ( my $line = $self->read_line() ) { 53 | if ( $line =~ s/^\x02// ) { 54 | print $line; 55 | } elsif ( $line =~ /^NAK\n/ ) { 56 | } elsif ( $line =~ s/^\x01// ) { 57 | $pack .= $line; 58 | } else { 59 | die "Unknown line: $line"; 60 | } 61 | 62 | #say "s $line"; 63 | } 64 | return $pack; 65 | } 66 | 67 | sub send_line { 68 | my ( $self, $line ) = @_; 69 | my $length = length($line); 70 | if ( $length == 0 ) { 71 | } else { 72 | $length += 4; 73 | } 74 | 75 | #warn "length $length"; 76 | my $prefix = sprintf( "%04X", $length ); 77 | my $text = $prefix . $line; 78 | 79 | # warn "$text"; 80 | $self->socket->print($text) || die $!; 81 | } 82 | 83 | sub read_line { 84 | my $self = shift; 85 | my $socket = $self->socket; 86 | 87 | my $ret = $socket->read( my $prefix, 4 ); 88 | if ( not defined $ret ) { 89 | die "error: $!"; 90 | } elsif ( $ret == 0 ) { 91 | die "EOF"; 92 | } 93 | 94 | return if $prefix eq '0000'; 95 | 96 | # warn "read prefix [$prefix]"; 97 | 98 | my $len = 0; 99 | foreach my $n ( 0 .. 3 ) { 100 | my $c = substr( $prefix, $n, 1 ); 101 | $len <<= 4; 102 | 103 | if ( $c ge '0' && $c le '9' ) { 104 | $len += ord($c) - ord('0'); 105 | } elsif ( $c ge 'a' && $c le 'f' ) { 106 | $len += ord($c) - ord('a') + 10; 107 | } elsif ( $c ge 'A' && $c le 'F' ) { 108 | $len += ord($c) - ord('A') + 10; 109 | } 110 | } 111 | 112 | #say "len $len"; 113 | $socket->read( my $data, $len - 4 ) || die $!; 114 | return $data; 115 | } 116 | 117 | 1; 118 | -------------------------------------------------------------------------------- /t/00_setup.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More tests => 1; 5 | use Archive::Extract; 6 | 7 | foreach my $name qw(test-project test-project-packs test-project-packs2) { 8 | next if -d $name; 9 | my $ae = Archive::Extract->new( archive => "$name.tgz" ); 10 | $ae->extract; 11 | } 12 | ok(1, 'extracted'); 13 | 14 | =for shell 15 | 16 | # How to create test-project and test-project-packs: 17 | 18 | mkdir test-project 19 | cd test-project 20 | git init 21 | git config user.name "Your Name Comes Here" 22 | git config user.email you@yourdomain.example.com 23 | echo 'hello world' > file.txt 24 | git add . 25 | git commit -a -m "initial commit" 26 | echo 'hello world!' >file.txt 27 | git commit -a -m "add emphasis" 28 | echo "hello world, again" >>file.txt 29 | git commit -a -m "add again" 30 | cd .. 31 | tar fvzc test-project.tgz test-project 32 | 33 | cd test-project 34 | git gc 35 | cd .. 36 | mv test-project test-project-packs 37 | tar fvzc test-project-packs.tgz test-project-packs 38 | rm -rf test-project-packs 39 | 40 | # and likewise but on a recent git for test-project-packs2 41 | tar fvzc test-project-packs2.tgz test-project-packs2 42 | 43 | =cut 44 | -------------------------------------------------------------------------------- /t/init.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More tests => 97; 5 | use Git::PurePerl; 6 | use Path::Class; 7 | 8 | for my $directory (qw(test-init test-init-bare.git)) { 9 | 10 | dir($directory)->rmtree; 11 | 12 | my $git; 13 | if ( $directory eq 'test-init-bare.git' ) { 14 | $git = Git::PurePerl->init( gitdir => $directory ); 15 | } else { 16 | $git = Git::PurePerl->init( directory => $directory ); 17 | } 18 | 19 | isa_ok( $git, 'Git::PurePerl', 'can init' ); 20 | 21 | is( $git->description, 22 | 'Unnamed repository; edit this file to name it for gitweb.' ); 23 | 24 | is( $git->all_sha1s->all, 0, 'does not contain any sha1s' ); 25 | is( $git->all_objects->all, 0, 'does not contain any objects' ); 26 | 27 | my $hello = Git::PurePerl::NewObject::Blob->new( content => 'hello' ); 28 | $git->put_object($hello); 29 | is( $hello->sha1, 'b6fc4c620b67d95f953a5c1c1230aaab5db5a1b0' ); 30 | is( $git->get_object('b6fc4c620b67d95f953a5c1c1230aaab5db5a1b0')->content, 31 | 'hello' ); 32 | 33 | my $there = Git::PurePerl::NewObject::Blob->new( content => 'there' ); 34 | $git->put_object($there); 35 | is( $there->sha1, 'c78ee1a5bdf46d22da300b68d50bc45c587c3293' ); 36 | is( $git->get_object('c78ee1a5bdf46d22da300b68d50bc45c587c3293')->content, 37 | 'there' ); 38 | 39 | my $hello_de = Git::PurePerl::NewDirectoryEntry->new( 40 | mode => '100644', 41 | filename => 'hello.txt', 42 | sha1 => $hello->sha1, 43 | ); 44 | my $there_de = Git::PurePerl::NewDirectoryEntry->new( 45 | mode => '100644', 46 | filename => 'there.txt', 47 | sha1 => $there->sha1, 48 | ); 49 | my $tree = Git::PurePerl::NewObject::Tree->new( 50 | directory_entries => [ $hello_de, $there_de ] ); 51 | is( $tree->sha1, '6d991aebc86bd09e86d74bb84bb9ebfb97e18026' ); 52 | $git->put_object($tree); 53 | my $tree2 = $git->get_object('6d991aebc86bd09e86d74bb84bb9ebfb97e18026'); 54 | is( $tree2->kind, 'tree' ); 55 | is( $tree2->size, 74 ); 56 | my @directory_entries = $tree2->directory_entries; 57 | is( @directory_entries, 2 ); 58 | my $directory_entry = $directory_entries[0]; 59 | is( $directory_entry->mode, '100644' ); 60 | is( $directory_entry->filename, 'hello.txt' ); 61 | is( $directory_entry->sha1, 'b6fc4c620b67d95f953a5c1c1230aaab5db5a1b0' ); 62 | my $directory_entry2 = $directory_entries[1]; 63 | is( $directory_entry2->mode, '100644' ); 64 | is( $directory_entry2->filename, 'there.txt' ); 65 | is( $directory_entry2->sha1, 'c78ee1a5bdf46d22da300b68d50bc45c587c3293' ); 66 | 67 | my $actor = Git::PurePerl::Actor->new( 68 | name => 'Your Name Comes Here', 69 | email => 'you@yourdomain.example.com' 70 | ); 71 | my $commit = Git::PurePerl::NewObject::Commit->new( 72 | tree => $tree->sha1, 73 | author => $actor, 74 | authored_time => DateTime->from_epoch( epoch => 1240341681 ), 75 | committer => $actor, 76 | committed_time => DateTime->from_epoch( epoch => 1240341682 ), 77 | comment => 'Fix', 78 | ); 79 | is( $commit->sha1, '860caea5ba298bb4f1df9a80fad84951fcc7db72' ); 80 | $git->put_object($commit); 81 | 82 | my $commit2 83 | = $git->get_object('860caea5ba298bb4f1df9a80fad84951fcc7db72'); 84 | is( $commit2->tree_sha1, $tree->sha1 ); 85 | isa_ok( $commit2->author, 'Git::PurePerl::Actor' ); 86 | is( $commit2->author->name, 'Your Name Comes Here' ); 87 | is( $commit2->author->email, 'you@yourdomain.example.com' ); 88 | isa_ok( $commit2->committer, 'Git::PurePerl::Actor' ); 89 | is( $commit2->committer->name, 'Your Name Comes Here' ); 90 | is( $commit2->committer->email, 'you@yourdomain.example.com' ); 91 | is( $commit2->authored_time->epoch, 1240341681 ); 92 | is( $commit2->committed_time->epoch, 1240341682 ); 93 | is( $commit2->comment, 'Fix' ); 94 | 95 | if ( $directory eq 'test-init-bare.git' ) { 96 | $git = Git::PurePerl->new( gitdir => $directory ); 97 | } else { 98 | $git = Git::PurePerl->new( directory => $directory ); 99 | } 100 | isa_ok( $git, 'Git::PurePerl', 'can get object' ); 101 | 102 | is( $git->all_sha1s->all, 4, 'contains four sha1s' ); 103 | is( $git->all_objects->all, 4, 'contains four objects' ); 104 | 105 | my $checkout_directory = dir('t/checkout'); 106 | $checkout_directory->rmtree; 107 | $checkout_directory->mkpath; 108 | unless ( $directory eq 'test-init-bare.git' ) { 109 | $git->checkout($checkout_directory); 110 | is_deeply( 111 | [ sort $checkout_directory->as_foreign('Unix')->children ], 112 | [ 't/checkout/hello.txt', 't/checkout/there.txt' ], 113 | 'checkout has two files' 114 | ); 115 | is( file('t/checkout/hello.txt')->slurp, 116 | 'hello', 'hello.txt has latest content' ); 117 | is( file('t/checkout/there.txt')->slurp, 118 | 'there', 'there.txt has latest content' ); 119 | } 120 | 121 | is_deeply( [ $git->ref_names ], ['refs/heads/master'], 122 | 'have ref master' ); 123 | 124 | isa_ok( 125 | $git->ref('refs/heads/master'), 126 | 'Git::PurePerl::Object::Commit', 127 | 'have master commit' 128 | ); 129 | is( $git->ref('refs/heads/master')->sha1, 130 | $commit->sha1, 'master points to our commit' ); 131 | 132 | my $here = Git::PurePerl::NewObject::Blob->new( content => 'here' ); 133 | $git->put_object($here); 134 | 135 | my $here_de = Git::PurePerl::NewDirectoryEntry->new( 136 | mode => '100644', 137 | filename => 'there.txt', 138 | sha1 => $here->sha1, 139 | ); 140 | $tree = Git::PurePerl::NewObject::Tree->new( 141 | directory_entries => [ $hello_de, $here_de ] ); 142 | $git->put_object($tree); 143 | my $newcommit = Git::PurePerl::NewObject::Commit->new( 144 | tree => $tree->sha1, 145 | parent => $commit->sha1, 146 | author => $actor, 147 | authored_time => DateTime->from_epoch( epoch => 1240341683 ), 148 | committer => $actor, 149 | committed_time => DateTime->from_epoch( epoch => 1240341684 ), 150 | comment => 'Fix again', 151 | ); 152 | $git->put_object($newcommit); 153 | 154 | my $newcommit2 = $git->get_object( $newcommit->sha1 ); 155 | isa_ok( $newcommit2->author, 'Git::PurePerl::Actor' ); 156 | is( $newcommit2->author->name, 'Your Name Comes Here' ); 157 | is( $newcommit2->author->email, 'you@yourdomain.example.com' ); 158 | isa_ok( $newcommit2->committer, 'Git::PurePerl::Actor' ); 159 | is( $newcommit2->committer->name, 'Your Name Comes Here' ); 160 | is( $newcommit2->committer->email, 'you@yourdomain.example.com' ); 161 | is( $newcommit2->authored_time->epoch, 1240341683 ); 162 | is( $newcommit2->committed_time->epoch, 1240341684 ); 163 | is( $newcommit2->comment, 'Fix again' ); 164 | 165 | is( $git->ref('refs/heads/master')->sha1, 166 | $newcommit->sha1, 'master updated' ); 167 | 168 | is( $git->all_sha1s->all, 7, 'contains seven sha1s' ); 169 | is( $git->all_objects->all, 7, 'contains seven objects' ); 170 | } 171 | -------------------------------------------------------------------------------- /t/protocol.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | BEGIN { 7 | if ( $^O eq 'MSWin32' ) { 8 | plan skip_all => 'Windows does NOT have git-daemon yet'; 9 | } 10 | plan tests => 14; 11 | } 12 | use Git::PurePerl; 13 | use IO::File; 14 | use Path::Class; 15 | 16 | # git daemon --verbose --reuseaddr --export-all --base-path=/home/acme/git/git-pureperl 17 | 18 | my $directory = 'test-protocol'; 19 | dir($directory)->rmtree; 20 | 21 | my $git = Git::PurePerl->init( directory => $directory ); 22 | isa_ok( $git, 'Git::PurePerl', 'can init' ); 23 | 24 | $git->clone( 'localhost', '/test-project' ); 25 | 26 | is( $git->all_sha1s->all, 9 ); 27 | is( $git->all_objects->all, 9 ); 28 | 29 | $git->update_master('0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391'); 30 | 31 | like( $git->master_sha1, qr/^[a-z0-9]{40}$/ ); 32 | my $commit = $git->master; 33 | 34 | is( $commit->kind, 'commit' ); 35 | is( $commit->size, 256 ); 36 | like( $commit->sha1, qr/^[a-z0-9]{40}$/ ); 37 | is( $commit->tree_sha1, '37b4fcd62571f07408e830f455268891f95cecf5' ); 38 | like( $commit->parent_sha1, qr/^[a-z0-9]{40}$/ ); 39 | is( $commit->author->name, 'Your Name Comes Here' ); 40 | is( $commit->author->email, 'you@yourdomain.example.com' ); 41 | is( $commit->committer->name, 'Your Name Comes Here' ); 42 | is( $commit->committer->email, 'you@yourdomain.example.com' ); 43 | is( $commit->comment, 'add again' ); 44 | -------------------------------------------------------------------------------- /t/protocol_gpp.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Git::PurePerl; 5 | use IO::File; 6 | use Path::Class; 7 | use Test::More tests => 3; 8 | 9 | my $directory = 'test-protocol'; 10 | dir($directory)->rmtree; 11 | 12 | my $git = Git::PurePerl->init( directory => $directory ); 13 | isa_ok( $git, 'Git::PurePerl', 'can init' ); 14 | 15 | $git->clone( 'github.com', '/acme/git-pureperl.git' ); 16 | 17 | ok( $git->all_sha1s->all >= 604 ); 18 | ok( $git->all_objects->all >= 604 ); 19 | -------------------------------------------------------------------------------- /t/simple.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More tests => 198; 5 | use Git::PurePerl; 6 | use Path::Class; 7 | 8 | my $checkout_directory = dir('t/checkout'); 9 | 10 | foreach my $directory qw(test-project test-project-packs test-project-packs2) 11 | { 12 | my $git = Git::PurePerl->new( directory => $directory ); 13 | like( $git->master_sha1, qr/^[a-z0-9]{40}$/ ); 14 | my $commit = $git->master; 15 | 16 | is( $commit->kind, 'commit' ); 17 | is( $commit->size, 256 ); 18 | like( $commit->sha1, qr/^[a-z0-9]{40}$/ ); 19 | is( $commit->tree_sha1, '37b4fcd62571f07408e830f455268891f95cecf5' ); 20 | like( $commit->parent_sha1, qr/^[a-z0-9]{40}$/ ); 21 | isa_ok( $commit->author, 'Git::PurePerl::Actor' ); 22 | isa_ok( $commit->committer, 'Git::PurePerl::Actor' ); 23 | is( $commit->author->name, 'Your Name Comes Here' ); 24 | is( $commit->committer->name, 'Your Name Comes Here' ); 25 | isa_ok( $commit->authored_time, 'DateTime' ); 26 | is( $commit->authored_time->month, 11 ); 27 | is( $commit->comment, 'add again' ); 28 | 29 | my $tree = $commit->tree; 30 | is( $tree->kind, 'tree' ); 31 | is( $tree->size, 36 ); 32 | my @directory_entries = $tree->directory_entries; 33 | is( @directory_entries, 1 ); 34 | my $directory_entry = $directory_entries[0]; 35 | is( $directory_entry->mode, '100644' ); 36 | is( $directory_entry->filename, 'file.txt' ); 37 | is( $directory_entry->sha1, '513feba2e53ebbd2532419ded848ba19de88ba00' ); 38 | 39 | my $blob = $directory_entry->object; 40 | is( $blob->kind, 'blob' ); 41 | is( $blob->size, 32 ); 42 | is( $blob->content, 'hello world! 43 | hello world, again 44 | ' 45 | ); 46 | 47 | $commit = $commit->parent; 48 | is( $commit->kind, 'commit' ); 49 | is( $commit->size, 259 ); 50 | like( $commit->sha1, qr/^[a-z0-9]{40}$/ ); 51 | is( $commit->tree_sha1, 'd0492b368b66bdabf2ac1fd8c92b39d3db916e59' ); 52 | like( $commit->parent_sha1, qr/^[a-z0-9]{40}$/ ); 53 | is( $commit->author->email, 'you@yourdomain.example.com' ); 54 | is( $commit->committer->email, 'you@yourdomain.example.com' ); 55 | is( $commit->comment, 'add emphasis' ); 56 | 57 | $tree = $commit->tree; 58 | is( $tree->kind, 'tree' ); 59 | is( $tree->size, 36 ); 60 | @directory_entries = $tree->directory_entries; 61 | is( @directory_entries, 1 ); 62 | $directory_entry = $directory_entries[0]; 63 | is( $directory_entry->mode, '100644' ); 64 | is( $directory_entry->filename, 'file.txt' ); 65 | is( $directory_entry->sha1, 'a0423896973644771497bdc03eb99d5281615b51' ); 66 | 67 | $blob = $directory_entry->object; 68 | is( $blob->kind, 'blob' ); 69 | is( $blob->size, 13 ); 70 | is( $blob->content, 'hello world! 71 | ' 72 | ); 73 | 74 | $commit = $commit->parent; 75 | is( $commit->kind, 'commit' ); 76 | is( $commit->size, 213 ); 77 | like( $commit->sha1, qr/^[a-z0-9]{40}$/ ); 78 | is( $commit->tree_sha1, '92b8b694ffb1675e5975148e1121810081dbdffe' ); 79 | is( $commit->parent_sha1, undef ); 80 | is( $commit->parent, undef ); 81 | is( $commit->author->name, 'Your Name Comes Here' ); 82 | is( $commit->committer->name, 'Your Name Comes Here' ); 83 | is( $commit->comment, 'initial commit' ); 84 | 85 | $tree = $commit->tree; 86 | is( $tree->kind, 'tree' ); 87 | is( $tree->size, 36 ); 88 | @directory_entries = $tree->directory_entries; 89 | is( @directory_entries, 1 ); 90 | $directory_entry = $directory_entries[0]; 91 | is( $directory_entry->mode, '100644' ); 92 | is( $directory_entry->filename, 'file.txt' ); 93 | is( $directory_entry->sha1, '3b18e512dba79e4c8300dd08aeb37f8e728b8dad' ); 94 | 95 | $blob = $directory_entry->object; 96 | is( $blob->kind, 'blob' ); 97 | is( $blob->size, 12 ); 98 | is( $blob->content, 'hello world 99 | ' 100 | ); 101 | 102 | is( $git->all_sha1s->all, 9 ); 103 | is( $git->all_objects->all, 9 ); 104 | 105 | $checkout_directory->rmtree; 106 | $checkout_directory->mkpath; 107 | $git->checkout($checkout_directory); 108 | is_deeply( [ $checkout_directory->as_foreign('Unix')->children ], 109 | ['t/checkout/file.txt'], 'checkout has one file' ); 110 | is( file('t/checkout/file.txt')->slurp, 'hello world! 111 | hello world, again 112 | ', 'checkout has latest content' 113 | ); 114 | 115 | is_deeply( [ $git->ref_names ], ['refs/heads/master'], 'have ref names' ); 116 | isa_ok( ( $git->refs )[0], 'Git::PurePerl::Object::Commit', 'have refs' ); 117 | ok( $git->refs_sha1, 'have refs_sha1' ); 118 | ok( $git->ref_sha1('refs/heads/master'), 'have ref_sha1 for master' ); 119 | isa_ok( 120 | $git->ref('refs/heads/master'), 121 | 'Git::PurePerl::Object::Commit', 122 | 'have ref master' 123 | ); 124 | } 125 | -------------------------------------------------------------------------------- /test-project-packs.tgz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/acme/git-pureperl/4642624c353903a4508b5c79e142c01597da9a82/test-project-packs.tgz -------------------------------------------------------------------------------- /test-project-packs2.tgz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/acme/git-pureperl/4642624c353903a4508b5c79e142c01597da9a82/test-project-packs2.tgz -------------------------------------------------------------------------------- /test-project.tgz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/acme/git-pureperl/4642624c353903a4508b5c79e142c01597da9a82/test-project.tgz --------------------------------------------------------------------------------