🌐 AI搜索 & 代理 主页
Google Git
Sign in
chromium / external / github.com / git / git / refs/tags/v2.20.2 / . / perl / Git.pm
blob: d856930b2e5f31bb7b1e7aef46e8e056068bb431 [file] [log] [blame]
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1=head1 NAME
2
3Git - Perl interface to the Git version control system
4
5=cut
6
7
8package Git;
9
Ævar Arnfjörð Bjarmasond48b2842010-09-24 20:00:52[diff] [blame]10use 5.008;
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]11use strict;
Ævar Arnfjörð Bjarmasonf0e19cb2018-02-25 19:46:27[diff] [blame]12use warnings;
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]13
Ævar Arnfjörð Bjarmason29118b32018-03-03 15:38:09[diff] [blame]14use File::Temp ();
15use File::Spec ();
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]16
17BEGIN {
18
19our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
20
21# Totally unstable API.
22$VERSION = '0.01';
23
24
25=head1 SYNOPSIS
26
27 use Git;
28
29 my $version = Git::command_oneline('version');
30
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]31 git_cmd_try { Git::command_noisy('update-server-info') }
32 '%s failed w/ code %d';
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]33
34 my $repo = Git->repository (Directory => '/srv/git/cogito.git');
35
36
37 my @revs = $repo->command('rev-list', '--since=last monday', '--all');
38
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]39 my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]40 my $lastrev = <$fh>; chomp $lastrev;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]41 $repo->command_close_pipe($fh, $c);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]42
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]43 my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
44 STDERR => 0 );
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]45
Adam Roben71825302008-05-23 14:19:40[diff] [blame]46 my $sha1 = $repo->hash_and_insert_object('file.txt');
47 my $tempfile = tempfile();
48 my $size = $repo->cat_blob($sha1, $tempfile);
49
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]50=cut
51
52
53require Exporter;
54
55@ISA = qw(Exporter);
56
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]57@EXPORT = qw(git_cmd_try);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]58
59# Methods which can be called as standalone functions as well:
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]60@EXPORT_OK = qw(command command_oneline command_noisy
61 command_output_pipe command_input_pipe command_close_pipe
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]62 command_bidi_pipe command_close_bidi_pipe
Markus Heidelberg89a56bf2009-04-05 02:15:16[diff] [blame]63 version exec_path html_path hash_object git_cmd_try
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]64 remote_refs prompt
Eric Wongb26098f2016-10-14 00:27:53[diff] [blame]65 get_tz_offset get_record
Michal Nazarewicz52dce6d2013-02-12 14:02:32[diff] [blame]66 credential credential_read credential_write
Phillip Wood1d542a52017-06-30 09:49:09[diff] [blame]67 temp_acquire temp_is_locked temp_release temp_reset temp_path
68 unquote_path);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]69
70
71=head1 DESCRIPTION
72
73This module provides Perl scripts easy way to interface the Git version control
74system. The modules have an easy and well-tested way to call arbitrary Git
75commands; in the future, the interface will also provide specialized methods
76for doing easily operations which are not totally trivial to do over
77the generic command interface.
78
79While some commands can be executed outside of any context (e.g. 'version'
Nicolas Pitre5c94f872007-01-12 21:01:46[diff] [blame]80or 'init'), most operations require a repository context, which in practice
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]81means getting an instance of the Git object using the repository() constructor.
82(In the future, we will also get a new_repository() constructor.) All commands
83called as methods of the object are then executed in the context of the
84repository.
85
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]86Part of the "repository state" is also information about path to the attached
87working copy (unless you work with a bare repository). You can also navigate
88inside of the working copy using the C<wc_chdir()> method. (Note that
89the repository object is self-contained and will not change working directory
90of your process.)
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]91
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]92TODO: In the future, we might also do
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]93
94 my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
95 $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
96 my @refs = $remoterepo->refs();
97
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]98Currently, the module merely wraps calls to external Git tools. In the future,
99it will provide a much faster way to interact with Git by linking directly
100to libgit. This should be completely opaque to the user, though (performance
Abhijit Menon-Sen9751a322008-08-05 02:06:16[diff] [blame]101increase notwithstanding).
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]102
103=cut
104
105
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]106use Carp qw(carp croak); # but croak is bad - throw instead
Ævar Arnfjörð Bjarmason28654672018-03-03 15:38:13[diff] [blame]107use Git::LoadCPAN::Error qw(:try);
Masatake Osanai48d9e6a2011-02-14 22:13:04[diff] [blame]108use Cwd qw(abs_path cwd);
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]109use IPC::Open2 qw(open2);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]110use Fcntl qw(SEEK_SET SEEK_CUR);
Ben Walton75f7b5d2013-02-09 21:46:57[diff] [blame]111use Time::Local qw(timegm);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]112}
113
114
115=head1 CONSTRUCTORS
116
117=over 4
118
119=item repository ( OPTIONS )
120
121=item repository ( DIRECTORY )
122
123=item repository ()
124
125Construct a new repository object.
126C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
127Possible options are:
128
129B<Repository> - Path to the Git repository.
130
131B<WorkingCopy> - Path to the associated working copy; not strictly required
132as many commands will happily crunch on a bare repository.
133
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]134B<WorkingSubdir> - Subdirectory in the working copy to work inside.
135Just left undefined if you do not want to limit the scope of operations.
136
137B<Directory> - Path to the Git working directory in its usual setup.
138The C<.git> directory is searched in the directory and all the parent
139directories; if found, C<WorkingCopy> is set to the directory containing
140it and C<Repository> to the C<.git> directory itself. If no C<.git>
141directory was found, the C<Directory> is assumed to be a bare repository,
142C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
143If the C<$GIT_DIR> environment variable is set, things behave as expected
144as well.
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]145
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]146You should not use both C<Directory> and either of C<Repository> and
147C<WorkingCopy> - the results of that are undefined.
148
149Alternatively, a directory path may be passed as a single scalar argument
150to the constructor; it is equivalent to setting only the C<Directory> option
151field.
152
153Calling the constructor with no options whatsoever is equivalent to
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]154calling it with C<< Directory => '.' >>. In general, if you are building
155a standard porcelain command, simply doing C<< Git->repository() >> should
156do the right thing and setup the object to reflect exactly where the user
157is right now.
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]158
159=cut
160
161sub repository {
162 my $class = shift;
163 my @args = @_;
164 my %opts = ();
165 my $self;
166
167 if (defined $args[0]) {
168 if ($#args % 2 != 1) {
169 # Not a hash.
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]170 $#args == 0 or throw Error::Simple("bad usage");
171 %opts = ( Directory => $args[0] );
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]172 } else {
173 %opts = @args;
174 }
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]175 }
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]176
Philippe Bruhat (BooK)11b8a412008-12-29 00:25:00[diff] [blame]177 if (not defined $opts{Repository} and not defined $opts{WorkingCopy}
178 and not defined $opts{Directory}) {
179 $opts{Directory} = '.';
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]180 }
181
Philippe Bruhat (BooK)11b8a412008-12-29 00:25:00[diff] [blame]182 if (defined $opts{Directory}) {
Philippe Bruhat (BooK)64abcc42010-06-17 23:47:31[diff] [blame]183 -d $opts{Directory} or throw Error::Simple("Directory not found: $opts{Directory} $!");
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]184
185 my $search = Git->repository(WorkingCopy => $opts{Directory});
186 my $dir;
187 try {
188 $dir = $search->command_oneline(['rev-parse', '--git-dir'],
189 STDERR => 0);
190 } catch Git::Error::Command with {
191 $dir = undef;
192 };
193
194 if ($dir) {
Johannes Schindelin888ab712016-01-26 14:34:35[diff] [blame]195 File::Spec->file_name_is_absolute($dir) or $dir = $opts{Directory} . '/' . $dir;
Frank Lichtenheldfe53bbc2009-05-07 13:41:28[diff] [blame]196 $opts{Repository} = abs_path($dir);
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]197
198 # If --git-dir went ok, this shouldn't die either.
199 my $prefix = $search->command_oneline('rev-parse', '--show-prefix');
200 $dir = abs_path($opts{Directory}) . '/';
201 if ($prefix) {
202 if (substr($dir, -length($prefix)) ne $prefix) {
203 throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix");
204 }
205 substr($dir, -length($prefix)) = '';
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]206 }
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]207 $opts{WorkingCopy} = $dir;
208 $opts{WorkingSubdir} = $prefix;
209
210 } else {
211 # A bare repository? Let's see...
212 $dir = $opts{Directory};
213
214 unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") {
Junio C Hamano9517e6b2010-02-04 05:23:18[diff] [blame]215 # Mimic git-rev-parse --git-dir error message:
Richard Hartmannf66bc5f2008-12-21 23:17:32[diff] [blame]216 throw Error::Simple("fatal: Not a git repository: $dir");
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]217 }
218 my $search = Git->repository(Repository => $dir);
219 try {
220 $search->command('symbolic-ref', 'HEAD');
221 } catch Git::Error::Command with {
Junio C Hamano9517e6b2010-02-04 05:23:18[diff] [blame]222 # Mimic git-rev-parse --git-dir error message:
Richard Hartmannf66bc5f2008-12-21 23:17:32[diff] [blame]223 throw Error::Simple("fatal: Not a git repository: $dir");
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]224 }
225
226 $opts{Repository} = abs_path($dir);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]227 }
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]228
229 delete $opts{Directory};
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]230 }
231
Junio C Hamano81a71732006-09-03 05:58:48[diff] [blame]232 $self = { opts => \%opts };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]233 bless $self, $class;
234}
235
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]236=back
237
238=head1 METHODS
239
240=over 4
241
242=item command ( COMMAND [, ARGUMENTS... ] )
243
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]244=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
245
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]246Execute the given Git C<COMMAND> (specify it without the 'git-'
247prefix), optionally with the specified extra C<ARGUMENTS>.
248
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]249The second more elaborate form can be used if you want to further adjust
250the command execution. Currently, only one option is supported:
251
252B<STDERR> - How to deal with the command's error output. By default (C<undef>)
253it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
254it to be thrown away. If you want to process it, you can get it in a filehandle
255you specify, but you must be extremely careful; if the error output is not
256very short and you want to read it in the same process as where you called
257C<command()>, you are set up for a nice deadlock!
258
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]259The method can be called without any instance or on a specified Git repository
260(in that case the command will be run in the repository context).
261
262In scalar context, it returns all the command output in a single string
263(verbatim).
264
265In array context, it returns an array containing lines printed to the
266command's stdout (without trailing newlines).
267
268In both cases, the command's stdin and stderr are the same as the caller's.
269
270=cut
271
272sub command {
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]273 my ($fh, $ctx) = command_output_pipe(@_);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]274
275 if (not defined wantarray) {
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]276 # Nothing to pepper the possible exception with.
Michal Nazarewicz1323dba2013-02-12 14:02:30[diff] [blame]277 _cmd_close($ctx, $fh);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]278
279 } elsif (not wantarray) {
280 local $/;
281 my $text = <$fh>;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]282 try {
Michal Nazarewicz1323dba2013-02-12 14:02:30[diff] [blame]283 _cmd_close($ctx, $fh);
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]284 } catch Git::Error::Command with {
285 # Pepper with the output:
286 my $E = shift;
287 $E->{'-outputref'} = \$text;
288 throw $E;
289 };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]290 return $text;
291
292 } else {
293 my @lines = <$fh>;
Alex Riesen67e4baf2007-01-22 14:58:03[diff] [blame]294 defined and chomp for @lines;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]295 try {
Michal Nazarewicz1323dba2013-02-12 14:02:30[diff] [blame]296 _cmd_close($ctx, $fh);
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]297 } catch Git::Error::Command with {
298 my $E = shift;
299 $E->{'-outputref'} = \@lines;
300 throw $E;
301 };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]302 return @lines;
303 }
304}
305
306
307=item command_oneline ( COMMAND [, ARGUMENTS... ] )
308
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]309=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
310
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]311Execute the given C<COMMAND> in the same way as command()
312does but always return a scalar string containing the first line
313of the command's standard output.
314
315=cut
316
317sub command_oneline {
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]318 my ($fh, $ctx) = command_output_pipe(@_);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]319
320 my $line = <$fh>;
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]321 defined $line and chomp $line;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]322 try {
Michal Nazarewicz1323dba2013-02-12 14:02:30[diff] [blame]323 _cmd_close($ctx, $fh);
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]324 } catch Git::Error::Command with {
325 # Pepper with the output:
326 my $E = shift;
327 $E->{'-outputref'} = \$line;
328 throw $E;
329 };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]330 return $line;
331}
332
333
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]334=item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]335
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]336=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
337
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]338Execute the given C<COMMAND> in the same way as command()
339does but return a pipe filehandle from which the command output can be
340read.
341
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]342The function can return C<($pipe, $ctx)> in array context.
343See C<command_close_pipe()> for details.
344
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]345=cut
346
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]347sub command_output_pipe {
348 _command_common_pipe('-|', @_);
349}
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]350
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]351
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]352=item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
353
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]354=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
355
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]356Execute the given C<COMMAND> in the same way as command_output_pipe()
357does but return an input pipe filehandle instead; the command output
358is not captured.
359
360The function can return C<($pipe, $ctx)> in array context.
361See C<command_close_pipe()> for details.
362
363=cut
364
365sub command_input_pipe {
366 _command_common_pipe('|-', @_);
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]367}
368
369
370=item command_close_pipe ( PIPE [, CTX ] )
371
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]372Close the C<PIPE> as returned from C<command_*_pipe()>, checking
Pavel Roskin3dff5372007-02-04 04:49:16[diff] [blame]373whether the command finished successfully. The optional C<CTX> argument
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]374is required if you want to see the command name in the error message,
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]375and it is the second value returned by C<command_*_pipe()> when
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]376called in array context. The call idiom is:
377
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]378 my ($fh, $ctx) = $r->command_output_pipe('status');
379 while (<$fh>) { ... }
380 $r->command_close_pipe($fh, $ctx);
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]381
382Note that you should not rely on whatever actually is in C<CTX>;
383currently it is simply the command name but in future the context might
384have more complicated structure.
385
386=cut
387
388sub command_close_pipe {
389 my ($self, $fh, $ctx) = _maybe_self(@_);
390 $ctx ||= '<unknown>';
Michal Nazarewicz1323dba2013-02-12 14:02:30[diff] [blame]391 _cmd_close($ctx, $fh);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]392}
393
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]394=item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
395
396Execute the given C<COMMAND> in the same way as command_output_pipe()
397does but return both an input pipe filehandle and an output pipe filehandle.
398
Li Peng832c0e52016-05-06 12:36:46[diff] [blame]399The function will return C<($pid, $pipe_in, $pipe_out, $ctx)>.
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]400See C<command_close_bidi_pipe()> for details.
401
402=cut
403
404sub command_bidi_pipe {
405 my ($pid, $in, $out);
Masatake Osanai48d9e6a2011-02-14 22:13:04[diff] [blame]406 my ($self) = _maybe_self(@_);
407 local %ENV = %ENV;
408 my $cwd_save = undef;
409 if ($self) {
410 shift;
411 $cwd_save = cwd();
412 _setup_git_cmd_env($self);
413 }
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]414 $pid = open2($in, $out, 'git', @_);
Masatake Osanai48d9e6a2011-02-14 22:13:04[diff] [blame]415 chdir($cwd_save) if $cwd_save;
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]416 return ($pid, $in, $out, join(' ', @_));
417}
418
419=item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] )
420
421Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
422checking whether the command finished successfully. The optional C<CTX>
423argument is required if you want to see the command name in the error message,
424and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom
425is:
426
427 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
Michal Nazarewicz8a2cc512013-02-07 14:01:18[diff] [blame]428 print $out "000000000\n";
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]429 while (<$in>) { ... }
430 $r->command_close_bidi_pipe($pid, $in, $out, $ctx);
431
432Note that you should not rely on whatever actually is in C<CTX>;
433currently it is simply the command name but in future the context might
434have more complicated structure.
435
Michal Nazarewiczf4c00352013-02-12 14:02:31[diff] [blame]436C<PIPE_IN> and C<PIPE_OUT> may be C<undef> if they have been closed prior to
437calling this function. This may be useful in a query-response type of
438commands where caller first writes a query and later reads response, eg:
439
440 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
441 print $out "000000000\n";
442 close $out;
443 while (<$in>) { ... }
444 $r->command_close_bidi_pipe($pid, $in, undef, $ctx);
445
446This idiom may prevent potential dead locks caused by data sent to the output
447pipe not being flushed and thus not reaching the executed command.
448
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]449=cut
450
451sub command_close_bidi_pipe {
Abhijit Menon-Sen108c2aa2008-08-04 11:38:27[diff] [blame]452 local $?;
Michal Nazarewicz1bc760a2013-02-07 14:01:17[diff] [blame]453 my ($self, $pid, $in, $out, $ctx) = _maybe_self(@_);
Michal Nazarewiczf4c00352013-02-12 14:02:31[diff] [blame]454 _cmd_close($ctx, (grep { defined } ($in, $out)));
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]455 waitpid $pid, 0;
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]456 if ($? >> 8) {
457 throw Git::Error::Command($ctx, $? >>8);
458 }
459}
460
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]461
462=item command_noisy ( COMMAND [, ARGUMENTS... ] )
463
464Execute the given C<COMMAND> in the same way as command() does but do not
465capture the command output - the standard output is not redirected and goes
466to the standard output of the caller application.
467
468While the method is called command_noisy(), you might want to as well use
469it for the most silent Git commands which you know will never pollute your
470stdout but you want to avoid the overhead of the pipe setup when calling them.
471
472The function returns only after the command has finished running.
473
474=cut
475
476sub command_noisy {
477 my ($self, $cmd, @args) = _maybe_self(@_);
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]478 _check_valid_cmd($cmd);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]479
480 my $pid = fork;
481 if (not defined $pid) {
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]482 throw Error::Simple("fork failed: $!");
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]483 } elsif ($pid == 0) {
484 _cmd_exec($self, $cmd, @args);
485 }
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]486 if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
487 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]488 }
489}
490
491
Petr Baudis63df97a2006-06-24 02:34:36[diff] [blame]492=item version ()
493
494Return the Git version in use.
495
Petr Baudis63df97a2006-06-24 02:34:36[diff] [blame]496=cut
497
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]498sub version {
499 my $verstr = command_oneline('--version');
500 $verstr =~ s/^git version //;
501 $verstr;
502}
Petr Baudis63df97a2006-06-24 02:34:36[diff] [blame]503
504
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]505=item exec_path ()
506
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]507Return path to the Git sub-command executables (the same as
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]508C<git --exec-path>). Useful mostly only internally.
509
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]510=cut
511
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]512sub exec_path { command_oneline('--exec-path') }
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]513
514
Markus Heidelberg89a56bf2009-04-05 02:15:16[diff] [blame]515=item html_path ()
516
517Return path to the Git html documentation (the same as
518C<git --html-path>). Useful mostly only internally.
519
520=cut
521
522sub html_path { command_oneline('--html-path') }
523
Ben Walton68868ff2013-02-09 21:46:56[diff] [blame]524
525=item get_tz_offset ( TIME )
526
527Return the time zone offset from GMT in the form +/-HHMM where HH is
528the number of hours from GMT and MM is the number of minutes. This is
529the equivalent of what strftime("%z", ...) would provide on a GNU
530platform.
531
532If TIME is not supplied, the current local time is used.
533
534=cut
535
536sub get_tz_offset {
Junio C Hamanof81935c2017-08-07 22:15:57[diff] [blame]537 # some systems don't handle or mishandle %z, so be creative.
Ben Walton68868ff2013-02-09 21:46:56[diff] [blame]538 my $t = shift || time;
Bernhard M. Wiedemanna40e06e2018-02-23 17:20:45[diff] [blame]539 my @t = localtime($t);
540 $t[5] += 1900;
541 my $gm = timegm(@t);
Ben Walton75f7b5d2013-02-09 21:46:57[diff] [blame]542 my $sign = qw( + + - )[ $gm <=> $t ];
Ben Walton68868ff2013-02-09 21:46:56[diff] [blame]543 return sprintf("%s%02d%02d", $sign, (gmtime(abs($t - $gm)))[2,1]);
544}
545
Eric Wongb26098f2016-10-14 00:27:53[diff] [blame]546=item get_record ( FILEHANDLE, INPUT_RECORD_SEPARATOR )
547
548Read one record from FILEHANDLE delimited by INPUT_RECORD_SEPARATOR,
549removing any trailing INPUT_RECORD_SEPARATOR.
550
551=cut
552
553sub get_record {
554 my ($fh, $rs) = @_;
555 local $/ = $rs;
556 my $rec = <$fh>;
Ævar Arnfjörð Bjarmason51db2712018-04-06 13:15:14[diff] [blame]557 chomp $rec if defined $rec;
Eric Wongb26098f2016-10-14 00:27:53[diff] [blame]558 $rec;
559}
Ben Walton68868ff2013-02-09 21:46:56[diff] [blame]560
Sven Strickrothe9263e42012-12-18 00:28:48[diff] [blame]561=item prompt ( PROMPT , ISPASSWORD )
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]562
563Query user C<PROMPT> and return answer from user.
564
Sven Strickroth8f3cab22012-12-18 00:28:47[diff] [blame]565Honours GIT_ASKPASS and SSH_ASKPASS environment variables for querying
566the user. If no *_ASKPASS variable is set or an error occoured,
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]567the terminal is tried as a fallback.
Sven Strickrothe9263e42012-12-18 00:28:48[diff] [blame]568If C<ISPASSWORD> is set and true, the terminal disables echo.
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]569
570=cut
571
572sub prompt {
Sven Strickrothe9263e42012-12-18 00:28:48[diff] [blame]573 my ($prompt, $isPassword) = @_;
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]574 my $ret;
575 if (exists $ENV{'GIT_ASKPASS'}) {
576 $ret = _prompt($ENV{'GIT_ASKPASS'}, $prompt);
577 }
Sven Strickroth8f3cab22012-12-18 00:28:47[diff] [blame]578 if (!defined $ret && exists $ENV{'SSH_ASKPASS'}) {
579 $ret = _prompt($ENV{'SSH_ASKPASS'}, $prompt);
580 }
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]581 if (!defined $ret) {
582 print STDERR $prompt;
583 STDERR->flush;
Sven Strickrothe9263e42012-12-18 00:28:48[diff] [blame]584 if (defined $isPassword && $isPassword) {
585 require Term::ReadKey;
586 Term::ReadKey::ReadMode('noecho');
587 $ret = '';
588 while (defined(my $key = Term::ReadKey::ReadKey(0))) {
589 last if $key =~ /[\012\015]/; # \n\r
590 $ret .= $key;
591 }
592 Term::ReadKey::ReadMode('restore');
593 print STDERR "\n";
594 STDERR->flush;
595 } else {
596 chomp($ret = <STDIN>);
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]597 }
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]598 }
599 return $ret;
600}
601
602sub _prompt {
603 my ($askpass, $prompt) = @_;
604 return unless length $askpass;
Sven Strickrothe9263e42012-12-18 00:28:48[diff] [blame]605 $prompt =~ s/\n/ /g;
Sven Strickroth38ecf3a2012-12-18 00:28:45[diff] [blame]606 my $ret;
607 open my $fh, "-|", $askpass, $prompt or return;
608 $ret = <$fh>;
609 $ret =~ s/[\015\012]//g; # strip \r\n, chomp does not work on all systems (i.e. windows) as expected
610 close ($fh);
611 return $ret;
612}
Markus Heidelberg89a56bf2009-04-05 02:15:16[diff] [blame]613
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]614=item repo_path ()
615
616Return path to the git repository. Must be called on a repository instance.
617
618=cut
619
620sub repo_path { $_[0]->{opts}->{Repository} }
621
622
623=item wc_path ()
624
625Return path to the working copy. Must be called on a repository instance.
626
627=cut
628
629sub wc_path { $_[0]->{opts}->{WorkingCopy} }
630
631
632=item wc_subdir ()
633
634Return path to the subdirectory inside of a working copy. Must be called
635on a repository instance.
636
637=cut
638
639sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
640
641
642=item wc_chdir ( SUBDIR )
643
644Change the working copy subdirectory to work within. The C<SUBDIR> is
645relative to the working copy root directory (not the current subdirectory).
646Must be called on a repository instance attached to a working copy
647and the directory must exist.
648
649=cut
650
651sub wc_chdir {
652 my ($self, $subdir) = @_;
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]653 $self->wc_path()
654 or throw Error::Simple("bare repository");
655
656 -d $self->wc_path().'/'.$subdir
Philippe Bruhat (BooK)64abcc42010-06-17 23:47:31[diff] [blame]657 or throw Error::Simple("subdir not found: $subdir $!");
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]658 # Of course we will not "hold" the subdirectory so anyone
659 # can delete it now and we will never know. But at least we tried.
660
661 $self->{opts}->{WorkingSubdir} = $subdir;
662}
663
664
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]665=item config ( VARIABLE )
666
Tom Princee0d10e12007-01-29 00:16:53[diff] [blame]667Retrieve the configuration C<VARIABLE> in the same manner as C<config>
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]668does. In scalar context requires the variable to be set only one time
669(exception is thrown otherwise), in array context returns allows the
670variable to be set multiple times and returns all the values.
671
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]672=cut
673
674sub config {
Junio C Hamano6942a3d2011-10-18 09:47:01[diff] [blame]675 return _config_common({}, @_);
676}
677
678
679=item config_bool ( VARIABLE )
680
681Retrieve the bool configuration C<VARIABLE>. The return value
682is usable as a boolean in perl (and C<undef> if it's not defined,
683of course).
684
685=cut
686
687sub config_bool {
688 my $val = scalar _config_common({'kind' => '--bool'}, @_);
689
690 # Do not rewrite this as return (defined $val && $val eq 'true')
691 # as some callers do care what kind of falsehood they receive.
692 if (!defined $val) {
693 return undef;
694 } else {
695 return $val eq 'true';
696 }
697}
698
699
700=item config_path ( VARIABLE )
701
702Retrieve the path configuration C<VARIABLE>. The return value
703is an expanded path or C<undef> if it's not defined.
704
705=cut
706
707sub config_path {
708 return _config_common({'kind' => '--path'}, @_);
709}
710
711
712=item config_int ( VARIABLE )
713
714Retrieve the integer configuration C<VARIABLE>. The return value
715is simple decimal number. An optional value suffix of 'k', 'm',
716or 'g' in the config file will cause the value to be multiplied
717by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
Alexander Kuleshovef2956a2015-02-18 17:32:20[diff] [blame]718It would return C<undef> if configuration variable is not defined.
Junio C Hamano6942a3d2011-10-18 09:47:01[diff] [blame]719
720=cut
721
722sub config_int {
723 return scalar _config_common({'kind' => '--int'}, @_);
724}
725
726# Common subroutine to implement bulk of what the config* family of methods
Alexander Kuleshovef2956a2015-02-18 17:32:20[diff] [blame]727# do. This currently wraps command('config') so it is not so fast.
Junio C Hamano6942a3d2011-10-18 09:47:01[diff] [blame]728sub _config_common {
729 my ($opts) = shift @_;
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]730 my ($self, $var) = _maybe_self(@_);
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]731
732 try {
Junio C Hamano6942a3d2011-10-18 09:47:01[diff] [blame]733 my @cmd = ('config', $opts->{'kind'} ? $opts->{'kind'} : ());
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]734 unshift @cmd, $self if $self;
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]735 if (wantarray) {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]736 return command(@cmd, '--get-all', $var);
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]737 } else {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]738 return command_oneline(@cmd, '--get', $var);
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]739 }
740 } catch Git::Error::Command with {
741 my $E = shift;
742 if ($E->value() == 1) {
743 # Key not found.
Lea Wiemann32d80502008-06-01 20:34:47[diff] [blame]744 return;
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]745 } else {
746 throw $E;
747 }
748 };
749}
750
Junio C Hamanob4c61ed2007-12-05 08:50:23[diff] [blame]751=item get_colorbool ( NAME )
752
753Finds if color should be used for NAMEd operation from the configuration,
754and returns boolean (true for "use color", false for "do not use color").
755
756=cut
757
758sub get_colorbool {
759 my ($self, $var) = @_;
760 my $stdout_to_tty = (-t STDOUT) ? "true" : "false";
761 my $use_color = $self->command_oneline('config', '--get-colorbool',
762 $var, $stdout_to_tty);
763 return ($use_color eq 'true');
764}
765
766=item get_color ( SLOT, COLOR )
767
768Finds color for SLOT from the configuration, while defaulting to COLOR,
769and returns the ANSI color escape sequence:
770
771 print $repo->get_color("color.interactive.prompt", "underline blue white");
772 print "some text";
773 print $repo->get_color("", "normal");
774
775=cut
776
777sub get_color {
778 my ($self, $slot, $default) = @_;
779 my $color = $self->command_oneline('config', '--get-color', $slot, $default);
780 if (!defined $color) {
781 $color = "";
782 }
783 return $color;
784}
785
Petr Baudis31a92f62008-07-08 17:48:04[diff] [blame]786=item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
787
788This function returns a hashref of refs stored in a given remote repository.
789The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
790contains the tag object while a C<refname^{}> entry gives the tagged objects.
791
792C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
Jim Meyeringa7793a72012-03-28 08:41:54[diff] [blame]793argument; either a URL or a remote name (if called on a repository instance).
Petr Baudis31a92f62008-07-08 17:48:04[diff] [blame]794C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
795tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
796of strings containing a shell-like glob to further limit the refs returned in
797the hash; the meaning is again the same as the appropriate C<git-ls-remote>
798argument.
799
800This function may or may not be called on a repository instance. In the former
801case, remote names as defined in the repository are recognized as repository
802specifiers.
803
804=cut
805
806sub remote_refs {
807 my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);
808 my @args;
809 if (ref $groups eq 'ARRAY') {
810 foreach (@$groups) {
811 if ($_ eq 'heads') {
812 push (@args, '--heads');
813 } elsif ($_ eq 'tags') {
814 push (@args, '--tags');
815 } else {
816 # Ignore unknown groups for future
817 # compatibility
818 }
819 }
820 }
821 push (@args, $repo);
822 if (ref $refglobs eq 'ARRAY') {
823 push (@args, @$refglobs);
824 }
825
826 my @self = $self ? ($self) : (); # Ultra trickery
827 my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);
828 my %refs;
829 while (<$fh>) {
830 chomp;
831 my ($hash, $ref) = split(/\t/, $_, 2);
832 $refs{$ref} = $hash;
833 }
834 Git::command_close_pipe(@self, $fh, $ctx);
835 return \%refs;
836}
837
838
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]839=item ident ( TYPE | IDENTSTR )
840
841=item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
842
843This suite of functions retrieves and parses ident information, as stored
844in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
845C<TYPE> can be either I<author> or I<committer>; case is insignificant).
846
Todd Zullinger5354a562008-07-30 17:48:33[diff] [blame]847The C<ident> method retrieves the ident information from C<git var>
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]848and either returns it as a scalar string or as an array with the fields parsed.
849Alternatively, it can take a prepared ident string (e.g. from the commit
850object) and just parse it.
851
852C<ident_person> returns the person part of the ident - name and email;
853it can take the same arguments as C<ident> or the array returned by C<ident>.
854
855The synopsis is like:
856
857 my ($name, $email, $time_tz) = ident('author');
858 "$name <$email>" eq ident_person('author');
859 "$name <$email>" eq ident_person($name);
860 $time_tz =~ /^\d+ [+-]\d{4}$/;
861
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]862=cut
863
864sub ident {
Frank Lichtenheld44617922008-03-14 17:29:29[diff] [blame]865 my ($self, $type) = _maybe_self(@_);
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]866 my $identstr;
867 if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
Frank Lichtenheld44617922008-03-14 17:29:29[diff] [blame]868 my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
869 unshift @cmd, $self if $self;
870 $identstr = command_oneline(@cmd);
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]871 } else {
872 $identstr = $type;
873 }
874 if (wantarray) {
875 return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
876 } else {
877 return $identstr;
878 }
879}
880
881sub ident_person {
Frank Lichtenheld44617922008-03-14 17:29:29[diff] [blame]882 my ($self, @ident) = _maybe_self(@_);
883 $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]884 return "$ident[0] <$ident[1]>";
885}
886
Petr Baudis24c4b712006-06-25 01:54:26[diff] [blame]887=item hash_object ( TYPE, FILENAME )
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]888
Lea Wiemann58c8dd22008-06-01 20:26:25[diff] [blame]889Compute the SHA1 object id of the given C<FILENAME> considering it is
890of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]891
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]892The method can be called without any instance or on a specified Git repository,
893it makes zero difference.
894
895The function returns the SHA1 hash.
896
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]897=cut
898
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]899# TODO: Support for passing FILEHANDLE instead of FILENAME
Petr Baudise6634ac2006-07-01 23:38:56[diff] [blame]900sub hash_object {
901 my ($self, $type, $file) = _maybe_self(@_);
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]902 command_oneline('hash-object', '-t', $type, $file);
Petr Baudise6634ac2006-07-01 23:38:56[diff] [blame]903}
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]904
905
Adam Roben71825302008-05-23 14:19:40[diff] [blame]906=item hash_and_insert_object ( FILENAME )
907
908Compute the SHA1 object id of the given C<FILENAME> and add the object to the
909object database.
910
911The function returns the SHA1 hash.
912
913=cut
914
915# TODO: Support for passing FILEHANDLE instead of FILENAME
916sub hash_and_insert_object {
917 my ($self, $filename) = @_;
918
919 carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/;
920
921 $self->_open_hash_and_insert_object_if_needed();
922 my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out});
923
924 unless (print $out $filename, "\n") {
925 $self->_close_hash_and_insert_object();
926 throw Error::Simple("out pipe went bad");
927 }
928
929 chomp(my $hash = <$in>);
930 unless (defined($hash)) {
931 $self->_close_hash_and_insert_object();
932 throw Error::Simple("in pipe went bad");
933 }
934
935 return $hash;
936}
937
938sub _open_hash_and_insert_object_if_needed {
939 my ($self) = @_;
940
941 return if defined($self->{hash_object_pid});
942
943 ($self->{hash_object_pid}, $self->{hash_object_in},
944 $self->{hash_object_out}, $self->{hash_object_ctx}) =
Masatake Osanai48d9e6a2011-02-14 22:13:04[diff] [blame]945 $self->command_bidi_pipe(qw(hash-object -w --stdin-paths --no-filters));
Adam Roben71825302008-05-23 14:19:40[diff] [blame]946}
947
948sub _close_hash_and_insert_object {
949 my ($self) = @_;
950
951 return unless defined($self->{hash_object_pid});
952
953 my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);
954
Abhijit Menon-Sen452d36b2008-08-04 05:02:47[diff] [blame]955 command_close_bidi_pipe(@$self{@vars});
956 delete @$self{@vars};
Adam Roben71825302008-05-23 14:19:40[diff] [blame]957}
958
959=item cat_blob ( SHA1, FILEHANDLE )
960
961Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
962returns the number of bytes printed.
963
964=cut
965
966sub cat_blob {
967 my ($self, $sha1, $fh) = @_;
968
969 $self->_open_cat_blob_if_needed();
970 my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out});
971
972 unless (print $out $sha1, "\n") {
973 $self->_close_cat_blob();
974 throw Error::Simple("out pipe went bad");
975 }
976
977 my $description = <$in>;
978 if ($description =~ / missing$/) {
979 carp "$sha1 doesn't exist in the repository";
Junio C Hamanod683a0e2008-05-28 06:33:22[diff] [blame]980 return -1;
Adam Roben71825302008-05-23 14:19:40[diff] [blame]981 }
982
983 if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) {
984 carp "Unexpected result returned from git cat-file";
Junio C Hamanod683a0e2008-05-28 06:33:22[diff] [blame]985 return -1;
Adam Roben71825302008-05-23 14:19:40[diff] [blame]986 }
987
988 my $size = $1;
989
990 my $blob;
Joshua Clayton712c6ad2013-02-22 21:01:18[diff] [blame]991 my $bytesLeft = $size;
Adam Roben71825302008-05-23 14:19:40[diff] [blame]992
993 while (1) {
Adam Roben71825302008-05-23 14:19:40[diff] [blame]994 last unless $bytesLeft;
995
996 my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024;
Joshua Clayton712c6ad2013-02-22 21:01:18[diff] [blame]997 my $read = read($in, $blob, $bytesToRead);
Adam Roben71825302008-05-23 14:19:40[diff] [blame]998 unless (defined($read)) {
999 $self->_close_cat_blob();
1000 throw Error::Simple("in pipe went bad");
1001 }
Joshua Clayton712c6ad2013-02-22 21:01:18[diff] [blame]1002 unless (print $fh $blob) {
1003 $self->_close_cat_blob();
1004 throw Error::Simple("couldn't write to passed in filehandle");
1005 }
1006 $bytesLeft -= $read;
Adam Roben71825302008-05-23 14:19:40[diff] [blame]1007 }
1008
1009 # Skip past the trailing newline.
1010 my $newline;
1011 my $read = read($in, $newline, 1);
1012 unless (defined($read)) {
1013 $self->_close_cat_blob();
1014 throw Error::Simple("in pipe went bad");
1015 }
1016 unless ($read == 1 && $newline eq "\n") {
1017 $self->_close_cat_blob();
1018 throw Error::Simple("didn't find newline after blob");
1019 }
1020
Adam Roben71825302008-05-23 14:19:40[diff] [blame]1021 return $size;
1022}
1023
1024sub _open_cat_blob_if_needed {
1025 my ($self) = @_;
1026
1027 return if defined($self->{cat_blob_pid});
1028
1029 ($self->{cat_blob_pid}, $self->{cat_blob_in},
1030 $self->{cat_blob_out}, $self->{cat_blob_ctx}) =
Masatake Osanai48d9e6a2011-02-14 22:13:04[diff] [blame]1031 $self->command_bidi_pipe(qw(cat-file --batch));
Adam Roben71825302008-05-23 14:19:40[diff] [blame]1032}
1033
1034sub _close_cat_blob {
1035 my ($self) = @_;
1036
1037 return unless defined($self->{cat_blob_pid});
1038
1039 my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);
1040
Abhijit Menon-Sen452d36b2008-08-04 05:02:47[diff] [blame]1041 command_close_bidi_pipe(@$self{@vars});
1042 delete @$self{@vars};
Adam Roben71825302008-05-23 14:19:40[diff] [blame]1043}
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1044
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1045
Michal Nazarewicz52dce6d2013-02-12 14:02:32[diff] [blame]1046=item credential_read( FILEHANDLE )
1047
1048Reads credential key-value pairs from C<FILEHANDLE>. Reading stops at EOF or
1049when an empty line is encountered. Each line must be of the form C<key=value>
1050with a non-empty key. Function returns hash with all read values. Any white
1051space (other than new-line character) is preserved.
1052
1053=cut
1054
1055sub credential_read {
1056 my ($self, $reader) = _maybe_self(@_);
1057 my %credential;
1058 while (<$reader>) {
1059 chomp;
1060 if ($_ eq '') {
1061 last;
1062 } elsif (!/^([^=]+)=(.*)$/) {
1063 throw Error::Simple("unable to parse git credential data:\n$_");
1064 }
1065 $credential{$1} = $2;
1066 }
1067 return %credential;
1068}
1069
1070=item credential_write( FILEHANDLE, CREDENTIAL_HASHREF )
1071
1072Writes credential key-value pairs from hash referenced by
1073C<CREDENTIAL_HASHREF> to C<FILEHANDLE>. Keys and values cannot contain
1074new-lines or NUL bytes characters, and key cannot contain equal signs nor be
1075empty (if they do Error::Simple is thrown). Any white space is preserved. If
1076value for a key is C<undef>, it will be skipped.
1077
1078If C<'url'> key exists it will be written first. (All the other key-value
1079pairs are written in sorted order but you should not depend on that). Once
1080all lines are written, an empty line is printed.
1081
1082=cut
1083
1084sub credential_write {
1085 my ($self, $writer, $credential) = _maybe_self(@_);
1086 my ($key, $value);
1087
1088 # Check if $credential is valid prior to writing anything
1089 while (($key, $value) = each %$credential) {
1090 if (!defined $key || !length $key) {
1091 throw Error::Simple("credential key empty or undefined");
1092 } elsif ($key =~ /[=\n\0]/) {
1093 throw Error::Simple("credential key contains invalid characters: $key");
1094 } elsif (defined $value && $value =~ /[\n\0]/) {
1095 throw Error::Simple("credential value for key=$key contains invalid characters: $value");
1096 }
1097 }
1098
1099 for $key (sort {
1100 # url overwrites other fields, so it must come first
1101 return -1 if $a eq 'url';
1102 return 1 if $b eq 'url';
1103 return $a cmp $b;
1104 } keys %$credential) {
1105 if (defined $credential->{$key}) {
1106 print $writer $key, '=', $credential->{$key}, "\n";
1107 }
1108 }
1109 print $writer "\n";
1110}
1111
1112sub _credential_run {
1113 my ($self, $credential, $op) = _maybe_self(@_);
1114 my ($pid, $reader, $writer, $ctx) = command_bidi_pipe('credential', $op);
1115
1116 credential_write $writer, $credential;
1117 close $writer;
1118
1119 if ($op eq "fill") {
1120 %$credential = credential_read $reader;
1121 }
1122 if (<$reader>) {
1123 throw Error::Simple("unexpected output from git credential $op response:\n$_\n");
1124 }
1125
1126 command_close_bidi_pipe($pid, $reader, undef, $ctx);
1127}
1128
1129=item credential( CREDENTIAL_HASHREF [, OPERATION ] )
1130
1131=item credential( CREDENTIAL_HASHREF, CODE )
1132
1133Executes C<git credential> for a given set of credentials and specified
1134operation. In both forms C<CREDENTIAL_HASHREF> needs to be a reference to
1135a hash which stores credentials. Under certain conditions the hash can
1136change.
1137
1138In the first form, C<OPERATION> can be C<'fill'>, C<'approve'> or C<'reject'>,
1139and function will execute corresponding C<git credential> sub-command. If
1140it's omitted C<'fill'> is assumed. In case of C<'fill'> the values stored in
1141C<CREDENTIAL_HASHREF> will be changed to the ones returned by the C<git
1142credential fill> command. The usual usage would look something like:
1143
1144 my %cred = (
1145 'protocol' => 'https',
1146 'host' => 'example.com',
1147 'username' => 'bob'
1148 );
1149 Git::credential \%cred;
1150 if (try_to_authenticate($cred{'username'}, $cred{'password'})) {
1151 Git::credential \%cred, 'approve';
1152 ... do more stuff ...
1153 } else {
1154 Git::credential \%cred, 'reject';
1155 }
1156
1157In the second form, C<CODE> needs to be a reference to a subroutine. The
1158function will execute C<git credential fill> to fill the provided credential
1159hash, then call C<CODE> with C<CREDENTIAL_HASHREF> as the sole argument. If
1160C<CODE>'s return value is defined, the function will execute C<git credential
1161approve> (if return value yields true) or C<git credential reject> (if return
1162value is false). If the return value is undef, nothing at all is executed;
1163this is useful, for example, if the credential could neither be verified nor
1164rejected due to an unrelated network error. The return value is the same as
1165what C<CODE> returns. With this form, the usage might look as follows:
1166
1167 if (Git::credential {
1168 'protocol' => 'https',
1169 'host' => 'example.com',
1170 'username' => 'bob'
1171 }, sub {
1172 my $cred = shift;
1173 return !!try_to_authenticate($cred->{'username'},
1174 $cred->{'password'});
1175 }) {
1176 ... do more stuff ...
1177 }
1178
1179=cut
1180
1181sub credential {
1182 my ($self, $credential, $op_or_code) = (_maybe_self(@_), 'fill');
1183
1184 if ('CODE' eq ref $op_or_code) {
1185 _credential_run $credential, 'fill';
1186 my $ret = $op_or_code->($credential);
1187 if (defined $ret) {
1188 _credential_run $credential, $ret ? 'approve' : 'reject';
1189 }
1190 return $ret;
1191 } else {
1192 _credential_run $credential, $op_or_code;
1193 }
1194}
1195
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1196{ # %TEMP_* Lexical Context
1197
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1198my (%TEMP_FILEMAP, %TEMP_FILES);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1199
1200=item temp_acquire ( NAME )
1201
Stefano Lattarini41ccfdd2013-04-11 22:36:10[diff] [blame]1202Attempts to retrieve the temporary file mapped to the string C<NAME>. If an
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1203associated temp file has not been created this session or was closed, it is
1204created, cached, and set for autoflush and binmode.
1205
1206Internally locks the file mapped to C<NAME>. This lock must be released with
1207C<temp_release()> when the temp file is no longer needed. Subsequent attempts
1208to retrieve temporary files mapped to the same C<NAME> while still locked will
1209cause an error. This locking mechanism provides a weak guarantee and is not
1210threadsafe. It does provide some error checking to help prevent temp file refs
1211writing over one another.
1212
1213In general, the L<File::Handle> returned should not be closed by consumers as
1214it defeats the purpose of this caching mechanism. If you need to close the temp
1215file handle, then you should use L<File::Temp> or another temp file faculty
1216directly. If a handle is closed and then requested again, then a warning will
1217issue.
1218
1219=cut
1220
1221sub temp_acquire {
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1222 my $temp_fd = _temp_cache(@_);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1223
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1224 $TEMP_FILES{$temp_fd}{locked} = 1;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1225 $temp_fd;
1226}
1227
Kyle J. McKay4e63dcc2013-07-07 04:20:48[diff] [blame]1228=item temp_is_locked ( NAME )
1229
1230Returns true if the internal lock created by a previous C<temp_acquire()>
1231call with C<NAME> is still in effect.
1232
1233When temp_acquire is called on a C<NAME>, it internally locks the temporary
1234file mapped to C<NAME>. That lock will not be released until C<temp_release()>
1235is called with either the original C<NAME> or the L<File::Handle> that was
1236returned from the original call to temp_acquire.
1237
1238Subsequent attempts to call C<temp_acquire()> with the same C<NAME> will fail
1239unless there has been an intervening C<temp_release()> call for that C<NAME>
1240(or its corresponding L<File::Handle> that was returned by the original
1241C<temp_acquire()> call).
1242
1243If true is returned by C<temp_is_locked()> for a C<NAME>, an attempt to
1244C<temp_acquire()> the same C<NAME> will cause an error unless
1245C<temp_release> is first called on that C<NAME> (or its corresponding
1246L<File::Handle> that was returned by the original C<temp_acquire()> call).
1247
1248=cut
1249
1250sub temp_is_locked {
1251 my ($self, $name) = _maybe_self(@_);
1252 my $temp_fd = \$TEMP_FILEMAP{$name};
1253
1254 defined $$temp_fd && $$temp_fd->opened && $TEMP_FILES{$$temp_fd}{locked};
1255}
1256
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1257=item temp_release ( NAME )
1258
1259=item temp_release ( FILEHANDLE )
1260
1261Releases a lock acquired through C<temp_acquire()>. Can be called either with
1262the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE>
1263referencing a locked temp file.
1264
1265Warns if an attempt is made to release a file that is not locked.
1266
1267The temp file will be truncated before being released. This can help to reduce
1268disk I/O where the system is smart enough to detect the truncation while data
1269is in the output buffers. Beware that after the temp file is released and
1270truncated, any operations on that file may fail miserably until it is
1271re-acquired. All contents are lost between each release and acquire mapped to
1272the same string.
1273
1274=cut
1275
1276sub temp_release {
1277 my ($self, $temp_fd, $trunc) = _maybe_self(@_);
1278
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1279 if (exists $TEMP_FILEMAP{$temp_fd}) {
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1280 $temp_fd = $TEMP_FILES{$temp_fd};
1281 }
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1282 unless ($TEMP_FILES{$temp_fd}{locked}) {
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1283 carp "Attempt to release temp file '",
1284 $temp_fd, "' that has not been locked";
1285 }
1286 temp_reset($temp_fd) if $trunc and $temp_fd->opened;
1287
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1288 $TEMP_FILES{$temp_fd}{locked} = 0;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1289 undef;
1290}
1291
1292sub _temp_cache {
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1293 my ($self, $name) = _maybe_self(@_);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1294
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1295 my $temp_fd = \$TEMP_FILEMAP{$name};
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1296 if (defined $$temp_fd and $$temp_fd->opened) {
Kyle J. McKay9c081072013-07-19 00:16:16[diff] [blame]1297 if ($TEMP_FILES{$$temp_fd}{locked}) {
Jay Soffian8faea4f2009-01-13 22:41:35[diff] [blame]1298 throw Error::Simple("Temp file with moniker '" .
1299 $name . "' already in use");
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1300 }
1301 } else {
1302 if (defined $$temp_fd) {
1303 # then we're here because of a closed handle.
1304 carp "Temp file '", $name,
1305 "' was closed. Opening replacement.";
1306 }
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1307 my $fname;
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1308
1309 my $tmpdir;
1310 if (defined $self) {
1311 $tmpdir = $self->repo_path();
1312 }
1313
Eric Wong822aaf02014-10-29 19:31:55[diff] [blame]1314 my $n = $name;
1315 $n =~ s/\W/_/g; # no strange chars
1316
H. Merijn Brandeafc2dd2013-04-29 08:09:57[diff] [blame]1317 ($$temp_fd, $fname) = File::Temp::tempfile(
Eric Wong822aaf02014-10-29 19:31:55[diff] [blame]1318 "Git_${n}_XXXXXX", UNLINK => 1, DIR => $tmpdir,
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1319 ) or throw Error::Simple("couldn't open new temp file");
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1320
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1321 $$temp_fd->autoflush;
1322 binmode $$temp_fd;
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1323 $TEMP_FILES{$$temp_fd}{fname} = $fname;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1324 }
1325 $$temp_fd;
1326}
1327
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1328=item temp_reset ( FILEHANDLE )
1329
1330Truncates and resets the position of the C<FILEHANDLE>.
1331
1332=cut
1333
1334sub temp_reset {
1335 my ($self, $temp_fd) = _maybe_self(@_);
1336
1337 truncate $temp_fd, 0
1338 or throw Error::Simple("couldn't truncate file");
1339 sysseek($temp_fd, 0, SEEK_SET) and seek($temp_fd, 0, SEEK_SET)
1340 or throw Error::Simple("couldn't seek to beginning of file");
1341 sysseek($temp_fd, 0, SEEK_CUR) == 0 and tell($temp_fd) == 0
1342 or throw Error::Simple("expected file position to be reset");
1343}
1344
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1345=item temp_path ( NAME )
1346
1347=item temp_path ( FILEHANDLE )
1348
1349Returns the filename associated with the given tempfile.
1350
1351=cut
1352
1353sub temp_path {
1354 my ($self, $temp_fd) = _maybe_self(@_);
1355
1356 if (exists $TEMP_FILEMAP{$temp_fd}) {
1357 $temp_fd = $TEMP_FILEMAP{$temp_fd};
1358 }
1359 $TEMP_FILES{$temp_fd}{fname};
1360}
1361
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1362sub END {
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1363 unlink values %TEMP_FILEMAP if %TEMP_FILEMAP;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1364}
1365
1366} # %TEMP_* Lexical Context
1367
Vasco Almeida2db87102016-12-14 12:54:24[diff] [blame]1368=item prefix_lines ( PREFIX, STRING [, STRING... ])
1369
1370Prefixes lines in C<STRING> with C<PREFIX>.
1371
1372=cut
1373
1374sub prefix_lines {
1375 my $prefix = shift;
1376 my $string = join("\n", @_);
1377 $string =~ s/^/$prefix/mg;
1378 return $string;
1379}
1380
Phillip Wood1d542a52017-06-30 09:49:09[diff] [blame]1381=item unquote_path ( PATH )
1382
1383Unquote a quoted path containing c-escapes as returned by ls-files etc.
1384when not using -z or when parsing the output of diff -u.
1385
1386=cut
1387
1388{
1389 my %cquote_map = (
Phillip Wood4cebfac2017-06-30 09:49:10[diff] [blame]1390 "a" => chr(7),
Phillip Wood1d542a52017-06-30 09:49:09[diff] [blame]1391 "b" => chr(8),
1392 "t" => chr(9),
1393 "n" => chr(10),
1394 "v" => chr(11),
1395 "f" => chr(12),
1396 "r" => chr(13),
1397 "\\" => "\\",
1398 "\042" => "\042",
1399 );
1400
1401 sub unquote_path {
1402 local ($_) = @_;
1403 my ($retval, $remainder);
1404 if (!/^\042(.*)\042$/) {
1405 return $_;
1406 }
1407 ($_, $retval) = ($1, "");
1408 while (/^([^\\]*)\\(.*)$/) {
1409 $remainder = $2;
1410 $retval .= $1;
1411 for ($remainder) {
1412 if (/^([0-3][0-7][0-7])(.*)$/) {
1413 $retval .= chr(oct($1));
1414 $_ = $2;
1415 last;
1416 }
Phillip Wood4cebfac2017-06-30 09:49:10[diff] [blame]1417 if (/^([\\\042abtnvfr])(.*)$/) {
Phillip Wood1d542a52017-06-30 09:49:09[diff] [blame]1418 $retval .= $cquote_map{$1};
1419 $_ = $2;
1420 last;
1421 }
Phillip Woodd5f28b72017-06-30 09:49:11[diff] [blame]1422 # This is malformed
1423 throw Error::Simple("invalid quoted path $_[0]");
Phillip Wood1d542a52017-06-30 09:49:09[diff] [blame]1424 }
1425 $_ = $remainder;
1426 }
1427 $retval .= $_;
1428 return $retval;
1429 }
1430}
1431
Vasco Almeida2db87102016-12-14 12:54:24[diff] [blame]1432=item get_comment_line_char ( )
1433
1434Gets the core.commentchar configuration value.
1435The value falls-back to '#' if core.commentchar is set to 'auto'.
1436
1437=cut
1438
1439sub get_comment_line_char {
1440 my $comment_line_char = config("core.commentchar") || '#';
1441 $comment_line_char = '#' if ($comment_line_char eq 'auto');
1442 $comment_line_char = '#' if (length($comment_line_char) != 1);
1443 return $comment_line_char;
1444}
1445
1446=item comment_lines ( STRING [, STRING... ])
1447
1448Comments lines following core.commentchar configuration.
1449
1450=cut
1451
1452sub comment_lines {
1453 my $comment_line_char = get_comment_line_char;
1454 return prefix_lines("$comment_line_char ", @_);
1455}
1456
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1457=back
1458
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]1459=head1 ERROR HANDLING
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1460
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]1461All functions are supposed to throw Perl exceptions in case of errors.
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1462See the L<Error> module on how to catch those. Most exceptions are mere
1463L<Error::Simple> instances.
1464
1465However, the C<command()>, C<command_oneline()> and C<command_noisy()>
1466functions suite can throw C<Git::Error::Command> exceptions as well: those are
1467thrown when the external command returns an error code and contain the error
1468code as well as access to the captured command's output. The exception class
1469provides the usual C<stringify> and C<value> (command's exit code) methods and
1470in addition also a C<cmd_output> method that returns either an array or a
1471string with the captured command output (depending on the original function
1472call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
1473returns the command and its arguments (but without proper quoting).
1474
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1475Note that the C<command_*_pipe()> functions cannot throw this exception since
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1476it has no idea whether the command failed or not. You will only find out
1477at the time you C<close> the pipe; if you want to have that automated,
1478use C<command_close_pipe()>, which can throw the exception.
1479
1480=cut
1481
1482{
1483 package Git::Error::Command;
1484
1485 @Git::Error::Command::ISA = qw(Error);
1486
1487 sub new {
1488 my $self = shift;
1489 my $cmdline = '' . shift;
1490 my $value = 0 + shift;
1491 my $outputref = shift;
1492 my(@args) = ();
1493
1494 local $Error::Depth = $Error::Depth + 1;
1495
1496 push(@args, '-cmdline', $cmdline);
1497 push(@args, '-value', $value);
1498 push(@args, '-outputref', $outputref);
1499
1500 $self->SUPER::new(-text => 'command returned error', @args);
1501 }
1502
1503 sub stringify {
1504 my $self = shift;
1505 my $text = $self->SUPER::stringify;
1506 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
1507 }
1508
1509 sub cmdline {
1510 my $self = shift;
1511 $self->{'-cmdline'};
1512 }
1513
1514 sub cmd_output {
1515 my $self = shift;
1516 my $ref = $self->{'-outputref'};
1517 defined $ref or undef;
1518 if (ref $ref eq 'ARRAY') {
1519 return @$ref;
1520 } else { # SCALAR
1521 return $$ref;
1522 }
1523 }
1524}
1525
1526=over 4
1527
1528=item git_cmd_try { CODE } ERRMSG
1529
1530This magical statement will automatically catch any C<Git::Error::Command>
1531exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
1532on its lips; the message will have %s substituted for the command line
1533and %d for the exit status. This statement is useful mostly for producing
1534more user-friendly error messages.
1535
1536In case of no exception caught the statement returns C<CODE>'s return value.
1537
1538Note that this is the only auto-exported function.
1539
1540=cut
1541
1542sub git_cmd_try(&$) {
1543 my ($code, $errmsg) = @_;
1544 my @result;
1545 my $err;
1546 my $array = wantarray;
1547 try {
1548 if ($array) {
1549 @result = &$code;
1550 } else {
1551 $result[0] = &$code;
1552 }
1553 } catch Git::Error::Command with {
1554 my $E = shift;
1555 $err = $errmsg;
1556 $err =~ s/\%s/$E->cmdline()/ge;
1557 $err =~ s/\%d/$E->value()/ge;
1558 # We can't croak here since Error.pm would mangle
1559 # that to Error::Simple.
1560 };
1561 $err and croak $err;
1562 return $array ? @result : $result[0];
1563}
1564
1565
1566=back
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1567
1568=head1 COPYRIGHT
1569
1570Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
1571
1572This module is free software; it may be used, copied, modified
1573and distributed under the terms of the GNU General Public Licence,
1574either version 2, or (at your option) any later version.
1575
1576=cut
1577
1578
1579# Take raw method argument list and return ($obj, @args) in case
1580# the method was called upon an instance and (undef, @args) if
1581# it was called directly.
1582sub _maybe_self {
Christian Jaegerd8b24b92008-10-18 18:25:12[diff] [blame]1583 UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1584}
1585
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1586# Check if the command id is something reasonable.
1587sub _check_valid_cmd {
1588 my ($cmd) = @_;
1589 $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
1590}
1591
1592# Common backend for the pipe creators.
1593sub _command_common_pipe {
1594 my $direction = shift;
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]1595 my ($self, @p) = _maybe_self(@_);
1596 my (%opts, $cmd, @args);
1597 if (ref $p[0]) {
1598 ($cmd, @args) = @{shift @p};
1599 %opts = ref $p[0] ? %{$p[0]} : @p;
1600 } else {
1601 ($cmd, @args) = @p;
1602 }
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1603 _check_valid_cmd($cmd);
1604
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1605 my $fh;
Alex Riesend3b17852007-01-22 16:14:56[diff] [blame]1606 if ($^O eq 'MSWin32') {
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1607 # ActiveState Perl
1608 #defined $opts{STDERR} and
1609 # warn 'ignoring STDERR option - running w/ ActiveState';
1610 $direction eq '-|' or
1611 die 'input pipe for ActiveState not implemented';
Alex Riesenbed118d2007-01-22 16:16:05[diff] [blame]1612 # the strange construction with *ACPIPE is just to
1613 # explain the tie below that we want to bind to
1614 # a handle class, not scalar. It is not known if
1615 # it is something specific to ActiveState Perl or
1616 # just a Perl quirk.
1617 tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args);
1618 $fh = *ACPIPE;
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1619
1620 } else {
1621 my $pid = open($fh, $direction);
1622 if (not defined $pid) {
1623 throw Error::Simple("open failed: $!");
1624 } elsif ($pid == 0) {
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1625 if ($opts{STDERR}) {
1626 open (STDERR, '>&', $opts{STDERR})
1627 or die "dup failed: $!";
Thomas Rastbd4ca092013-04-04 20:41:41[diff] [blame]1628 } elsif (defined $opts{STDERR}) {
1629 open (STDERR, '>', '/dev/null')
1630 or die "opening /dev/null failed: $!";
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1631 }
1632 _cmd_exec($self, $cmd, @args);
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]1633 }
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1634 }
1635 return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
1636}
1637
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1638# When already in the subprocess, set up the appropriate state
1639# for the given repository and execute the git command.
1640sub _cmd_exec {
1641 my ($self, @args) = @_;
Masatake Osanai48d9e6a2011-02-14 22:13:04[diff] [blame]1642 _setup_git_cmd_env($self);
1643 _execv_git_cmd(@args);
1644 die qq[exec "@args" failed: $!];
1645}
1646
1647# set up the appropriate state for git command
1648sub _setup_git_cmd_env {
1649 my $self = shift;
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1650 if ($self) {
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]1651 $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
Frank Lichtenheldda159c72009-05-07 13:41:27[diff] [blame]1652 $self->repo_path() and $self->wc_path()
1653 and $ENV{'GIT_WORK_TREE'} = $self->wc_path();
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]1654 $self->wc_path() and chdir($self->wc_path());
1655 $self->wc_subdir() and chdir($self->wc_subdir());
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1656 }
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1657}
1658
Petr Baudis8062f812006-06-24 02:34:34[diff] [blame]1659# Execute the given Git command ($_[0]) with arguments ($_[1..])
1660# by searching for it at proper places.
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]1661sub _execv_git_cmd { exec('git', @_); }
Petr Baudis8062f812006-06-24 02:34:34[diff] [blame]1662
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1663# Close pipe to a subprocess.
1664sub _cmd_close {
Michal Nazarewicz1323dba2013-02-12 14:02:30[diff] [blame]1665 my $ctx = shift @_;
1666 foreach my $fh (@_) {
1667 if (close $fh) {
1668 # nop
1669 } elsif ($!) {
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1670 # It's just close, no point in fatalities
1671 carp "error closing pipe: $!";
1672 } elsif ($? >> 8) {
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1673 # The caller should pepper this.
1674 throw Git::Error::Command($ctx, $? >> 8);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1675 }
1676 # else we might e.g. closed a live stream; the command
1677 # dying of SIGPIPE would drive us here.
1678 }
1679}
1680
1681
Adam Roben71825302008-05-23 14:19:40[diff] [blame]1682sub DESTROY {
1683 my ($self) = @_;
1684 $self->_close_hash_and_insert_object();
1685 $self->_close_cat_blob();
1686}
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1687
1688
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1689# Pipe implementation for ActiveState Perl.
1690
1691package Git::activestate_pipe;
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1692
1693sub TIEHANDLE {
1694 my ($class, @params) = @_;
1695 # FIXME: This is probably horrible idea and the thing will explode
1696 # at the moment you give it arguments that require some quoting,
1697 # but I have no ActiveState clue... --pasky
Alex Riesend3b17852007-01-22 16:14:56[diff] [blame]1698 # Let's just hope ActiveState Perl does at least the quoting
1699 # correctly.
1700 my @data = qx{git @params};
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1701 bless { i => 0, data => \@data }, $class;
1702}
1703
1704sub READLINE {
1705 my $self = shift;
1706 if ($self->{i} >= scalar @{$self->{data}}) {
1707 return undef;
1708 }
Alex Riesen2f5b3982007-08-22 16:13:07[diff] [blame]1709 my $i = $self->{i};
1710 if (wantarray) {
1711 $self->{i} = $#{$self->{'data'}} + 1;
1712 return splice(@{$self->{'data'}}, $i);
1713 }
1714 $self->{i} = $i + 1;
1715 return $self->{'data'}->[ $i ];
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1716}
1717
1718sub CLOSE {
1719 my $self = shift;
1720 delete $self->{data};
1721 delete $self->{i};
1722}
1723
1724sub EOF {
1725 my $self = shift;
1726 return ($self->{i} >= scalar @{$self->{data}});
1727}
1728
1729
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]17301; # Famous last words