my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
STDERR => 0 );
+ my $sha1 = $repo->hash_and_insert_object('file.txt');
+ my $tempfile = tempfile();
+ my $size = $repo->cat_blob($sha1, $tempfile);
+
=cut
# Methods which can be called as standalone functions as well:
@EXPORT_OK = qw(command command_oneline command_noisy
command_output_pipe command_input_pipe command_close_pipe
+ command_bidi_pipe command_close_bidi_pipe
version exec_path hash_object git_cmd_try);
the generic command interface.
While some commands can be executed outside of any context (e.g. 'version'
-or 'init-db'), most operations require a repository context, which in practice
+or 'init'), most operations require a repository context, which in practice
means getting an instance of the Git object using the repository() constructor.
(In the future, we will also get a new_repository() constructor.) All commands
called as methods of the object are then executed in the context of the
use Carp qw(carp croak); # but croak is bad - throw instead
use Error qw(:try);
use Cwd qw(abs_path);
-
-require XSLoader;
-XSLoader::load('Git', $VERSION);
+use IPC::Open2 qw(open2);
}
bless $self, $class;
}
-
=back
=head1 METHODS
} else {
my @lines = <$fh>;
- chomp @lines;
+ defined and chomp for @lines;
try {
_cmd_close($fh, $ctx);
} catch Git::Error::Command with {
=item command_close_pipe ( PIPE [, CTX ] )
Close the C<PIPE> as returned from C<command_*_pipe()>, checking
-whether the command finished successfuly. The optional C<CTX> argument
+whether the command finished successfully. The optional C<CTX> argument
is required if you want to see the command name in the error message,
and it is the second value returned by C<command_*_pipe()> when
called in array context. The call idiom is:
_cmd_close($fh, $ctx);
}
+=item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
+
+Execute the given C<COMMAND> in the same way as command_output_pipe()
+does but return both an input pipe filehandle and an output pipe filehandle.
+
+The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>.
+See C<command_close_bidi_pipe()> for details.
+
+=cut
+
+sub command_bidi_pipe {
+ my ($pid, $in, $out);
+ $pid = open2($in, $out, 'git', @_);
+ return ($pid, $in, $out, join(' ', @_));
+}
+
+=item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] )
+
+Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
+checking whether the command finished successfully. The optional C<CTX>
+argument is required if you want to see the command name in the error message,
+and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom
+is:
+
+ my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
+ print "000000000\n" $out;
+ while (<$in>) { ... }
+ $r->command_close_bidi_pipe($pid, $in, $out, $ctx);
+
+Note that you should not rely on whatever actually is in C<CTX>;
+currently it is simply the command name but in future the context might
+have more complicated structure.
+
+=cut
+
+sub command_close_bidi_pipe {
+ 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);
+ }
+}
+
=item command_noisy ( COMMAND [, ARGUMENTS... ] )
Return the Git version in use.
-Implementation of this function is very fast; no external command calls
-are involved.
-
=cut
-# Implemented in Git.xs.
+sub version {
+ my $verstr = command_oneline('--version');
+ $verstr =~ s/^git version //;
+ $verstr;
+}
=item exec_path ()
Return path to the Git sub-command executables (the same as
C<git --exec-path>). Useful mostly only internally.
-Implementation of this function is very fast; no external command calls
-are involved.
-
=cut
-# Implemented in Git.xs.
+sub exec_path { command_oneline('--exec-path') }
=item repo_path ()
sub wc_chdir {
my ($self, $subdir) = @_;
-
$self->wc_path()
or throw Error::Simple("bare repository");
}
-=item hash_object ( TYPE, FILENAME )
+=item config ( VARIABLE )
+
+Retrieve the configuration C<VARIABLE> in the same manner as C<config>
+does. In scalar context requires the variable to be set only one time
+(exception is thrown otherwise), in array context returns allows the
+variable to be set multiple times and returns all the values.
-=item hash_object ( TYPE, FILEHANDLE )
+This currently wraps command('config') so it is not so fast.
-Compute the SHA1 object id of the given C<FILENAME> (or data waiting in
-C<FILEHANDLE>) considering it is of the C<TYPE> object type (C<blob>,
-C<commit>, C<tree>).
+=cut
-In case of C<FILEHANDLE> passed instead of file name, all the data
-available are read and hashed, and the filehandle is automatically
-closed. The file handle should be freshly opened - if you have already
-read anything from the file handle, the results are undefined (since
-this function works directly with the file descriptor and internal
-PerlIO buffering might have messed things up).
+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;
+ }
+ };
+}
+
+
+=item config_bool ( VARIABLE )
+
+Retrieve the bool configuration C<VARIABLE>. The return value
+is usable as a boolean in perl (and C<undef> if it's not defined,
+of course).
+
+This currently wraps command('config') so it is not so fast.
+
+=cut
+
+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;
+ }
+ };
+}
+
+=item config_int ( VARIABLE )
+
+Retrieve the integer configuration C<VARIABLE>. The return value
+is simple decimal number. An optional value suffix of 'k', 'm',
+or 'g' in the config file will cause the value to be multiplied
+by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
+It would return C<undef> if configuration variable is not defined,
+
+This currently wraps command('config') so it is not so fast.
+
+=cut
+
+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;
+ }
+ };
+}
+
+=item get_colorbool ( NAME )
+
+Finds if color should be used for NAMEd operation from the configuration,
+and returns boolean (true for "use color", false for "do not use color").
+
+=cut
+
+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');
+}
+
+=item get_color ( SLOT, COLOR )
+
+Finds color for SLOT from the configuration, while defaulting to COLOR,
+and returns the ANSI color escape sequence:
+
+ print $repo->get_color("color.interactive.prompt", "underline blue white");
+ print "some text";
+ print $repo->get_color("", "normal");
+
+=cut
+
+sub get_color {
+ my ($self, $slot, $default) = @_;
+ my $color = $self->command_oneline('config', '--get-color', $slot, $default);
+ if (!defined $color) {
+ $color = "";
+ }
+ return $color;
+}
+
+=item ident ( TYPE | IDENTSTR )
+
+=item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
+
+This suite of functions retrieves and parses ident information, as stored
+in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
+C<TYPE> can be either I<author> or I<committer>; case is insignificant).
+
+The C<ident> method retrieves the ident information from C<git-var>
+and either returns it as a scalar string or as an array with the fields parsed.
+Alternatively, it can take a prepared ident string (e.g. from the commit
+object) and just parse it.
+
+C<ident_person> returns the person part of the ident - name and email;
+it can take the same arguments as C<ident> or the array returned by C<ident>.
+
+The synopsis is like:
+
+ my ($name, $email, $time_tz) = ident('author');
+ "$name <$email>" eq ident_person('author');
+ "$name <$email>" eq ident_person($name);
+ $time_tz =~ /^\d+ [+-]\d{4}$/;
+
+=cut
+
+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]>";
+}
+
+
+=item hash_object ( TYPE, FILENAME )
+
+Compute the SHA1 object id of the given C<FILENAME> considering it is
+of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
The method can be called without any instance or on a specified Git repository,
it makes zero difference.
The function returns the SHA1 hash.
-Implementation of this function is very fast; no external command calls
-are involved.
-
=cut
+# TODO: Support for passing FILEHANDLE instead of FILENAME
sub hash_object {
my ($self, $type, $file) = _maybe_self(@_);
+ command_oneline('hash-object', '-t', $type, $file);
+}
- # hash_object_* implemented in Git.xs.
- if (ref($file) eq 'GLOB') {
- my $hash = hash_object_pipe($type, fileno($file));
- close $file;
- return $hash;
- } else {
- hash_object_file($type, $file);
+=item hash_and_insert_object ( FILENAME )
+
+Compute the SHA1 object id of the given C<FILENAME> and add the object to the
+object database.
+
+The function returns the SHA1 hash.
+
+=cut
+
+# TODO: Support for passing FILEHANDLE instead of FILENAME
+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};
+}
+
+=item cat_blob ( SHA1, FILEHANDLE )
+
+Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
+returns the number of bytes printed.
+
+=cut
+
+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};
+}
=back
_check_valid_cmd($cmd);
my $fh;
- if ($^O eq '##INSERT_ACTIVESTATE_STRING_HERE##') {
+ if ($^O eq 'MSWin32') {
# ActiveState Perl
#defined $opts{STDERR} and
# warn 'ignoring STDERR option - running w/ ActiveState';
$direction eq '-|' or
die 'input pipe for ActiveState not implemented';
- tie ($fh, 'Git::activestate_pipe', $cmd, @args);
+ # the strange construction with *ACPIPE is just to
+ # explain the tie below that we want to bind to
+ # a handle class, not scalar. It is not known if
+ # it is something specific to ActiveState Perl or
+ # just a Perl quirk.
+ tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args);
+ $fh = *ACPIPE;
} else {
my $pid = open($fh, $direction);
$self->wc_subdir() and chdir($self->wc_subdir());
}
_execv_git_cmd(@args);
- die "exec failed: $!";
+ die qq[exec "@args" failed: $!];
}
# Execute the given Git command ($_[0]) with arguments ($_[1..])
# by searching for it at proper places.
-# _execv_git_cmd(), implemented in Git.xs.
+sub _execv_git_cmd { exec('git', @_); }
# Close pipe to a subprocess.
sub _cmd_close {
}
-# Trickery for .xs routines: In order to avoid having some horrid
-# C code trying to do stuff with undefs and hashes, we gate all
-# xs calls through the following and in case we are being ran upon
-# an instance call a C part of the gate which will set up the
-# environment properly.
-sub _call_gate {
- my $xsfunc = shift;
- my ($self, @args) = _maybe_self(@_);
-
- if (defined $self) {
- # XXX: We ignore the WorkingCopy! To properly support
- # that will require heavy changes in libgit.
-
- # XXX: And we ignore everything else as well. libgit
- # at least needs to be extended to let us specify
- # the $GIT_DIR instead of looking it up in environment.
- #xs_call_gate($self->{opts}->{Repository});
- }
-
- # Having to call throw from the C code is a sure path to insanity.
- local $SIG{__DIE__} = sub { throw Error::Simple("@_"); };
- &$xsfunc(@args);
-}
-
-sub AUTOLOAD {
- my $xsname;
- our $AUTOLOAD;
- ($xsname = $AUTOLOAD) =~ s/.*:://;
- throw Error::Simple("&Git::$xsname not defined") if $xsname =~ /^xs_/;
- $xsname = 'xs_'.$xsname;
- _call_gate(\&$xsname, @_);
+sub DESTROY {
+ my ($self) = @_;
+ $self->_close_hash_and_insert_object();
+ $self->_close_cat_blob();
}
-sub DESTROY { }
-
# Pipe implementation for ActiveState Perl.
# FIXME: This is probably horrible idea and the thing will explode
# at the moment you give it arguments that require some quoting,
# but I have no ActiveState clue... --pasky
- my $cmdline = join " ", @params;
- my @data = qx{$cmdline};
+ # Let's just hope ActiveState Perl does at least the quoting
+ # correctly.
+ my @data = qx{git @params};
bless { i => 0, data => \@data }, $class;
}
if ($self->{i} >= scalar @{$self->{data}}) {
return undef;
}
- return $self->{'data'}->[ $self->{i}++ ];
+ my $i = $self->{i};
+ if (wantarray) {
+ $self->{i} = $#{$self->{'data'}} + 1;
+ return splice(@{$self->{'data'}}, $i);
+ }
+ $self->{i} = $i + 1;
+ return $self->{'data'}->[ $i ];
}
sub CLOSE {