package Git;

use strict;

BEGIN {

our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);

$VERSION = '0.01';

require Exporter;

@ISA = qw(Exporter);

@EXPORT = qw(git_cmd_try);

@EXPORT_OK = qw(command command_oneline command_noisy

temp_acquire temp_release temp_reset temp_path);

use Carp qw(carp croak); # but croak is bad - throw instead

use Error qw(:try);

use Cwd qw(abs_path);

use IPC::Open2 qw(open2);

use Fcntl qw(SEEK_SET SEEK_CUR);

}

sub repository {

my $class = shift;

my @args = @_;

my %opts = ();

my $self;

if (defined $args[0]) {

if ($#args % 2 != 1) {

# Not a hash.

$#args == 0 or throw Error::Simple("bad usage");

%opts = ( Directory => $args[0] );

} else {

%opts = @args;

}

}

if (not defined $opts{Repository} and not defined $opts{WorkingCopy}

and not defined $opts{Directory}) {

$opts{Directory} = '.';

}

if (defined $opts{Directory}) {

-d $opts{Directory} or throw Error::Simple("Directory not found: $!");

my $search = Git->repository(WorkingCopy => $opts{Directory});

my $dir;

try {

$dir = $search->command_oneline(['rev-parse', '--git-dir'],

STDERR => 0);

} catch Git::Error::Command with {

$dir = undef;

};

if ($dir) {

$dir =~ m#^/# or $dir = $opts{Directory} . '/' . $dir;

$opts{Repository} = $dir;

# If --git-dir went ok, this shouldn't die either.

my $prefix = $search->command_oneline('rev-parse', '--show-prefix');

$dir = abs_path($opts{Directory}) . '/';

if ($prefix) {

if (substr($dir, -length($prefix)) ne $prefix) {

throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix");

}

substr($dir, -length($prefix)) = '';

}

$opts{WorkingCopy} = $dir;

$opts{WorkingSubdir} = $prefix;

} else {

# A bare repository? Let's see...

$dir = $opts{Directory};

unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") {

# Mimick git-rev-parse --git-dir error message:

throw Error::Simple("fatal: Not a git repository: $dir");

}

my $search = Git->repository(Repository => $dir);

try {

$search->command('symbolic-ref', 'HEAD');

} catch Git::Error::Command with {

# Mimick git-rev-parse --git-dir error message:

throw Error::Simple("fatal: Not a git repository: $dir");

}

$opts{Repository} = abs_path($dir);

}

delete $opts{Directory};

}

$self = { opts => \%opts };

bless $self, $class;

}

sub command {

my ($fh, $ctx) = command_output_pipe(@_);

if (not defined wantarray) {

# Nothing to pepper the possible exception with.

_cmd_close($fh, $ctx);

} elsif (not wantarray) {

local $/;

my $text = <$fh>;

try {

_cmd_close($fh, $ctx);

} catch Git::Error::Command with {

# Pepper with the output:

my $E = shift;

$E->{'-outputref'} = \$text;

throw $E;

};

return $text;

} else {

my @lines = <$fh>;

defined and chomp for @lines;

try {

_cmd_close($fh, $ctx);

} catch Git::Error::Command with {

my $E = shift;

$E->{'-outputref'} = \@lines;

throw $E;

};

return @lines;

}

}

sub command_oneline {

my ($fh, $ctx) = command_output_pipe(@_);

my $line = <$fh>;

defined $line and chomp $line;

try {

_cmd_close($fh, $ctx);

} catch Git::Error::Command with {

# Pepper with the output:

my $E = shift;

$E->{'-outputref'} = \$line;

throw $E;

};

return $line;

}

sub command_output_pipe {

_command_common_pipe('-|', @_);

}

sub command_input_pipe {

_command_common_pipe('|-', @_);

}

sub command_close_pipe {

my ($self, $fh, $ctx) = _maybe_self(@_);

$ctx ||= '<unknown>';

_cmd_close($fh, $ctx);

}

sub command_bidi_pipe {

my ($pid, $in, $out);

$pid = open2($in, $out, 'git', @_);

return ($pid, $in, $out, join(' ', @_));

}

sub command_close_bidi_pipe {

local $?;

my ($pid, $in, $out, $ctx) = @_;

foreach my $fh ($in, $out) {

unless (close $fh) {

if ($!) {

carp "error closing pipe: $!";

} elsif ($? >> 8) {

throw Git::Error::Command($ctx, $? >>8);

}

}

}

waitpid $pid, 0;

if ($? >> 8) {

throw Git::Error::Command($ctx, $? >>8);

}

}

sub command_noisy {

my ($self, $cmd, @args) = _maybe_self(@_);

_check_valid_cmd($cmd);

my $pid = fork;

if (not defined $pid) {

throw Error::Simple("fork failed: $!");

} elsif ($pid == 0) {

_cmd_exec($self, $cmd, @args);

}

if (waitpid($pid, 0) > 0 and $?>>8 != 0) {

throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);

}

}

sub version {

my $verstr = command_oneline('--version');

$verstr =~ s/^git version //;

$verstr;

}

sub exec_path { command_oneline('--exec-path') }

sub html_path { command_oneline('--html-path') }

sub repo_path { $_[0]->{opts}->{Repository} }

sub wc_path { $_[0]->{opts}->{WorkingCopy} }

sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }

sub wc_chdir {

my ($self, $subdir) = @_;

$self->wc_path()

or throw Error::Simple("bare repository");

-d $self->wc_path().'/'.$subdir

or throw Error::Simple("subdir not found: $!");

# Of course we will not "hold" the subdirectory so anyone

# can delete it now and we will never know. But at least we tried.

$self->{opts}->{WorkingSubdir} = $subdir;

}

sub config {

my ($self, $var) = _maybe_self(@_);

try {

my @cmd = ('config');

unshift @cmd, $self if $self;

if (wantarray) {

return command(@cmd, '--get-all', $var);

} else {

return command_oneline(@cmd, '--get', $var);

}

} catch Git::Error::Command with {

my $E = shift;

if ($E->value() == 1) {

# Key not found.

return;

} else {

throw $E;

}

};

}

sub config_bool {

my ($self, $var) = _maybe_self(@_);

try {

my @cmd = ('config', '--bool', '--get', $var);

unshift @cmd, $self if $self;

my $val = command_oneline(@cmd);

return undef unless defined $val;

return $val eq 'true';

} catch Git::Error::Command with {

my $E = shift;

if ($E->value() == 1) {

# Key not found.

return undef;

} else {

throw $E;

}

};

}

sub config_int {

my ($self, $var) = _maybe_self(@_);

try {

my @cmd = ('config', '--int', '--get', $var);

unshift @cmd, $self if $self;

return command_oneline(@cmd);

} catch Git::Error::Command with {

my $E = shift;

if ($E->value() == 1) {

# Key not found.

return undef;

} else {

throw $E;

}

};

}

sub get_colorbool {

my ($self, $var) = @_;

my $stdout_to_tty = (-t STDOUT) ? "true" : "false";

my $use_color = $self->command_oneline('config', '--get-colorbool',

$var, $stdout_to_tty);

return ($use_color eq 'true');

}

sub get_color {

my ($self, $slot, $default) = @_;

my $color = $self->command_oneline('config', '--get-color', $slot, $default);

if (!defined $color) {

$color = "";

}

return $color;

}

sub remote_refs {

my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);

my @args;

if (ref $groups eq 'ARRAY') {

foreach (@$groups) {

if ($_ eq 'heads') {

push (@args, '--heads');

} elsif ($_ eq 'tags') {

push (@args, '--tags');

} else {

# Ignore unknown groups for future

# compatibility

}

}

}

push (@args, $repo);

if (ref $refglobs eq 'ARRAY') {

push (@args, @$refglobs);

}

my @self = $self ? ($self) : (); # Ultra trickery

my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);

my %refs;

while (<$fh>) {

chomp;

my ($hash, $ref) = split(/\t/, $_, 2);

$refs{$ref} = $hash;

}

Git::command_close_pipe(@self, $fh, $ctx);

return \%refs;

}

sub ident {

my ($self, $type) = _maybe_self(@_);

my $identstr;

if (lc $type eq lc 'committer' or lc $type eq lc 'author') {

my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');

unshift @cmd, $self if $self;

$identstr = command_oneline(@cmd);

} else {

$identstr = $type;

}

if (wantarray) {

return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;

} else {

return $identstr;

}

}

sub ident_person {

my ($self, @ident) = _maybe_self(@_);

$#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);

return "$ident[0] <$ident[1]>";

}

sub hash_object {

my ($self, $type, $file) = _maybe_self(@_);

command_oneline('hash-object', '-t', $type, $file);

}

sub hash_and_insert_object {

my ($self, $filename) = @_;

carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/;

$self->_open_hash_and_insert_object_if_needed();

my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out});

unless (print $out $filename, "\n") {

$self->_close_hash_and_insert_object();

throw Error::Simple("out pipe went bad");

}

chomp(my $hash = <$in>);

unless (defined($hash)) {

$self->_close_hash_and_insert_object();

throw Error::Simple("in pipe went bad");

}

return $hash;

}

sub _open_hash_and_insert_object_if_needed {

my ($self) = @_;

return if defined($self->{hash_object_pid});

($self->{hash_object_pid}, $self->{hash_object_in},

$self->{hash_object_out}, $self->{hash_object_ctx}) =

command_bidi_pipe(qw(hash-object -w --stdin-paths));

}

sub _close_hash_and_insert_object {

my ($self) = @_;

return unless defined($self->{hash_object_pid});

my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);

command_close_bidi_pipe(@$self{@vars});

delete @$self{@vars};

}

sub cat_blob {

my ($self, $sha1, $fh) = @_;

$self->_open_cat_blob_if_needed();

my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out});

unless (print $out $sha1, "\n") {

$self->_close_cat_blob();

throw Error::Simple("out pipe went bad");

}

my $description = <$in>;

if ($description =~ / missing$/) {

carp "$sha1 doesn't exist in the repository";

return -1;

}

if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) {

carp "Unexpected result returned from git cat-file";

return -1;

}

my $size = $1;

my $blob;

my $bytesRead = 0;

while (1) {

my $bytesLeft = $size - $bytesRead;

last unless $bytesLeft;

my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024;

my $read = read($in, $blob, $bytesToRead, $bytesRead);

unless (defined($read)) {

$self->_close_cat_blob();

throw Error::Simple("in pipe went bad");

}

$bytesRead += $read;

}

# Skip past the trailing newline.

my $newline;

my $read = read($in, $newline, 1);

unless (defined($read)) {

$self->_close_cat_blob();

throw Error::Simple("in pipe went bad");

}

unless ($read == 1 && $newline eq "\n") {

$self->_close_cat_blob();

throw Error::Simple("didn't find newline after blob");

}

unless (print $fh $blob) {

$self->_close_cat_blob();

throw Error::Simple("couldn't write to passed in filehandle");

}

return $size;

}

sub _open_cat_blob_if_needed {

my ($self) = @_;

return if defined($self->{cat_blob_pid});

($self->{cat_blob_pid}, $self->{cat_blob_in},

$self->{cat_blob_out}, $self->{cat_blob_ctx}) =

command_bidi_pipe(qw(cat-file --batch));

}

sub _close_cat_blob {

my ($self) = @_;

return unless defined($self->{cat_blob_pid});

my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);

command_close_bidi_pipe(@$self{@vars});

delete @$self{@vars};

}

{ # %TEMP_* Lexical Context

my (%TEMP_FILEMAP, %TEMP_FILES);

sub temp_acquire {

my $temp_fd = _temp_cache(@_);

$TEMP_FILES{$temp_fd}{locked} = 1;

$temp_fd;

}

sub temp_release {