🌐 AI搜索 & 代理 主页
Google Git
Sign in
chromium / external / github.com / git / git / refs/tags/v1.6.6.3 / . / perl / Git.pm
blob: e8df55d2f290210ba4cf7ae8c91639f2a34c834e [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
10use strict;
11
12
13BEGIN {
14
15our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
16
17# Totally unstable API.
18$VERSION = '0.01';
19
20
21=head1 SYNOPSIS
22
23 use Git;
24
25 my $version = Git::command_oneline('version');
26
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]27 git_cmd_try { Git::command_noisy('update-server-info') }
28 '%s failed w/ code %d';
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]29
30 my $repo = Git->repository (Directory => '/srv/git/cogito.git');
31
32
33 my @revs = $repo->command('rev-list', '--since=last monday', '--all');
34
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]35 my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]36 my $lastrev = <$fh>; chomp $lastrev;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]37 $repo->command_close_pipe($fh, $c);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]38
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]39 my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
40 STDERR => 0 );
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]41
Adam Roben71825302008-05-23 14:19:40[diff] [blame]42 my $sha1 = $repo->hash_and_insert_object('file.txt');
43 my $tempfile = tempfile();
44 my $size = $repo->cat_blob($sha1, $tempfile);
45
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]46=cut
47
48
49require Exporter;
50
51@ISA = qw(Exporter);
52
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]53@EXPORT = qw(git_cmd_try);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]54
55# Methods which can be called as standalone functions as well:
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]56@EXPORT_OK = qw(command command_oneline command_noisy
57 command_output_pipe command_input_pipe command_close_pipe
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]58 command_bidi_pipe command_close_bidi_pipe
Markus Heidelberg89a56bf2009-04-05 02:15:16[diff] [blame]59 version exec_path html_path hash_object git_cmd_try
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]60 remote_refs
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]61 temp_acquire temp_release temp_reset temp_path);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]62
63
64=head1 DESCRIPTION
65
66This module provides Perl scripts easy way to interface the Git version control
67system. The modules have an easy and well-tested way to call arbitrary Git
68commands; in the future, the interface will also provide specialized methods
69for doing easily operations which are not totally trivial to do over
70the generic command interface.
71
72While some commands can be executed outside of any context (e.g. 'version'
Nicolas Pitre5c94f872007-01-12 21:01:46[diff] [blame]73or 'init'), most operations require a repository context, which in practice
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]74means getting an instance of the Git object using the repository() constructor.
75(In the future, we will also get a new_repository() constructor.) All commands
76called as methods of the object are then executed in the context of the
77repository.
78
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]79Part of the "repository state" is also information about path to the attached
80working copy (unless you work with a bare repository). You can also navigate
81inside of the working copy using the C<wc_chdir()> method. (Note that
82the repository object is self-contained and will not change working directory
83of your process.)
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]84
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]85TODO: In the future, we might also do
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]86
87 my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
88 $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
89 my @refs = $remoterepo->refs();
90
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]91Currently, the module merely wraps calls to external Git tools. In the future,
92it will provide a much faster way to interact with Git by linking directly
93to libgit. This should be completely opaque to the user, though (performance
Abhijit Menon-Sen9751a322008-08-05 02:06:16[diff] [blame]94increase notwithstanding).
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]95
96=cut
97
98
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]99use Carp qw(carp croak); # but croak is bad - throw instead
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]100use Error qw(:try);
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]101use Cwd qw(abs_path);
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]102use IPC::Open2 qw(open2);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]103use Fcntl qw(SEEK_SET SEEK_CUR);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]104}
105
106
107=head1 CONSTRUCTORS
108
109=over 4
110
111=item repository ( OPTIONS )
112
113=item repository ( DIRECTORY )
114
115=item repository ()
116
117Construct a new repository object.
118C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
119Possible options are:
120
121B<Repository> - Path to the Git repository.
122
123B<WorkingCopy> - Path to the associated working copy; not strictly required
124as many commands will happily crunch on a bare repository.
125
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]126B<WorkingSubdir> - Subdirectory in the working copy to work inside.
127Just left undefined if you do not want to limit the scope of operations.
128
129B<Directory> - Path to the Git working directory in its usual setup.
130The C<.git> directory is searched in the directory and all the parent
131directories; if found, C<WorkingCopy> is set to the directory containing
132it and C<Repository> to the C<.git> directory itself. If no C<.git>
133directory was found, the C<Directory> is assumed to be a bare repository,
134C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
135If the C<$GIT_DIR> environment variable is set, things behave as expected
136as well.
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]137
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]138You should not use both C<Directory> and either of C<Repository> and
139C<WorkingCopy> - the results of that are undefined.
140
141Alternatively, a directory path may be passed as a single scalar argument
142to the constructor; it is equivalent to setting only the C<Directory> option
143field.
144
145Calling the constructor with no options whatsoever is equivalent to
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]146calling it with C<< Directory => '.' >>. In general, if you are building
147a standard porcelain command, simply doing C<< Git->repository() >> should
148do the right thing and setup the object to reflect exactly where the user
149is right now.
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]150
151=cut
152
153sub repository {
154 my $class = shift;
155 my @args = @_;
156 my %opts = ();
157 my $self;
158
159 if (defined $args[0]) {
160 if ($#args % 2 != 1) {
161 # Not a hash.
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]162 $#args == 0 or throw Error::Simple("bad usage");
163 %opts = ( Directory => $args[0] );
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]164 } else {
165 %opts = @args;
166 }
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]167 }
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]168
Philippe Bruhat (BooK)11b8a412008-12-29 00:25:00[diff] [blame]169 if (not defined $opts{Repository} and not defined $opts{WorkingCopy}
170 and not defined $opts{Directory}) {
171 $opts{Directory} = '.';
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]172 }
173
Philippe Bruhat (BooK)11b8a412008-12-29 00:25:00[diff] [blame]174 if (defined $opts{Directory}) {
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]175 -d $opts{Directory} or throw Error::Simple("Directory not found: $!");
176
177 my $search = Git->repository(WorkingCopy => $opts{Directory});
178 my $dir;
179 try {
180 $dir = $search->command_oneline(['rev-parse', '--git-dir'],
181 STDERR => 0);
182 } catch Git::Error::Command with {
183 $dir = undef;
184 };
185
186 if ($dir) {
Petr Baudis71efe0c2006-06-25 01:54:28[diff] [blame]187 $dir =~ m#^/# or $dir = $opts{Directory} . '/' . $dir;
Frank Lichtenheldfe53bbc2009-05-07 13:41:28[diff] [blame]188 $opts{Repository} = abs_path($dir);
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]189
190 # If --git-dir went ok, this shouldn't die either.
191 my $prefix = $search->command_oneline('rev-parse', '--show-prefix');
192 $dir = abs_path($opts{Directory}) . '/';
193 if ($prefix) {
194 if (substr($dir, -length($prefix)) ne $prefix) {
195 throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix");
196 }
197 substr($dir, -length($prefix)) = '';
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]198 }
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]199 $opts{WorkingCopy} = $dir;
200 $opts{WorkingSubdir} = $prefix;
201
202 } else {
203 # A bare repository? Let's see...
204 $dir = $opts{Directory};
205
206 unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") {
207 # Mimick git-rev-parse --git-dir error message:
Richard Hartmannf66bc5f2008-12-21 23:17:32[diff] [blame]208 throw Error::Simple("fatal: Not a git repository: $dir");
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]209 }
210 my $search = Git->repository(Repository => $dir);
211 try {
212 $search->command('symbolic-ref', 'HEAD');
213 } catch Git::Error::Command with {
214 # Mimick git-rev-parse --git-dir error message:
Richard Hartmannf66bc5f2008-12-21 23:17:32[diff] [blame]215 throw Error::Simple("fatal: Not a git repository: $dir");
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]216 }
217
218 $opts{Repository} = abs_path($dir);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]219 }
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]220
221 delete $opts{Directory};
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]222 }
223
Junio C Hamano81a71732006-09-03 05:58:48[diff] [blame]224 $self = { opts => \%opts };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]225 bless $self, $class;
226}
227
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]228=back
229
230=head1 METHODS
231
232=over 4
233
234=item command ( COMMAND [, ARGUMENTS... ] )
235
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]236=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
237
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]238Execute the given Git C<COMMAND> (specify it without the 'git-'
239prefix), optionally with the specified extra C<ARGUMENTS>.
240
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]241The second more elaborate form can be used if you want to further adjust
242the command execution. Currently, only one option is supported:
243
244B<STDERR> - How to deal with the command's error output. By default (C<undef>)
245it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
246it to be thrown away. If you want to process it, you can get it in a filehandle
247you specify, but you must be extremely careful; if the error output is not
248very short and you want to read it in the same process as where you called
249C<command()>, you are set up for a nice deadlock!
250
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]251The method can be called without any instance or on a specified Git repository
252(in that case the command will be run in the repository context).
253
254In scalar context, it returns all the command output in a single string
255(verbatim).
256
257In array context, it returns an array containing lines printed to the
258command's stdout (without trailing newlines).
259
260In both cases, the command's stdin and stderr are the same as the caller's.
261
262=cut
263
264sub command {
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]265 my ($fh, $ctx) = command_output_pipe(@_);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]266
267 if (not defined wantarray) {
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]268 # Nothing to pepper the possible exception with.
269 _cmd_close($fh, $ctx);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]270
271 } elsif (not wantarray) {
272 local $/;
273 my $text = <$fh>;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]274 try {
275 _cmd_close($fh, $ctx);
276 } catch Git::Error::Command with {
277 # Pepper with the output:
278 my $E = shift;
279 $E->{'-outputref'} = \$text;
280 throw $E;
281 };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]282 return $text;
283
284 } else {
285 my @lines = <$fh>;
Alex Riesen67e4baf2007-01-22 14:58:03[diff] [blame]286 defined and chomp for @lines;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]287 try {
288 _cmd_close($fh, $ctx);
289 } catch Git::Error::Command with {
290 my $E = shift;
291 $E->{'-outputref'} = \@lines;
292 throw $E;
293 };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]294 return @lines;
295 }
296}
297
298
299=item command_oneline ( COMMAND [, ARGUMENTS... ] )
300
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]301=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
302
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]303Execute the given C<COMMAND> in the same way as command()
304does but always return a scalar string containing the first line
305of the command's standard output.
306
307=cut
308
309sub command_oneline {
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]310 my ($fh, $ctx) = command_output_pipe(@_);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]311
312 my $line = <$fh>;
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]313 defined $line and chomp $line;
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]314 try {
315 _cmd_close($fh, $ctx);
316 } catch Git::Error::Command with {
317 # Pepper with the output:
318 my $E = shift;
319 $E->{'-outputref'} = \$line;
320 throw $E;
321 };
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]322 return $line;
323}
324
325
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]326=item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]327
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]328=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
329
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]330Execute the given C<COMMAND> in the same way as command()
331does but return a pipe filehandle from which the command output can be
332read.
333
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]334The function can return C<($pipe, $ctx)> in array context.
335See C<command_close_pipe()> for details.
336
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]337=cut
338
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]339sub command_output_pipe {
340 _command_common_pipe('-|', @_);
341}
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]342
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]343
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]344=item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
345
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]346=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
347
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]348Execute the given C<COMMAND> in the same way as command_output_pipe()
349does but return an input pipe filehandle instead; the command output
350is not captured.
351
352The function can return C<($pipe, $ctx)> in array context.
353See C<command_close_pipe()> for details.
354
355=cut
356
357sub command_input_pipe {
358 _command_common_pipe('|-', @_);
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]359}
360
361
362=item command_close_pipe ( PIPE [, CTX ] )
363
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]364Close the C<PIPE> as returned from C<command_*_pipe()>, checking
Pavel Roskin3dff5372007-02-04 04:49:16[diff] [blame]365whether the command finished successfully. The optional C<CTX> argument
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]366is required if you want to see the command name in the error message,
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]367and it is the second value returned by C<command_*_pipe()> when
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]368called in array context. The call idiom is:
369
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]370 my ($fh, $ctx) = $r->command_output_pipe('status');
371 while (<$fh>) { ... }
372 $r->command_close_pipe($fh, $ctx);
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]373
374Note that you should not rely on whatever actually is in C<CTX>;
375currently it is simply the command name but in future the context might
376have more complicated structure.
377
378=cut
379
380sub command_close_pipe {
381 my ($self, $fh, $ctx) = _maybe_self(@_);
382 $ctx ||= '<unknown>';
383 _cmd_close($fh, $ctx);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]384}
385
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]386=item command_bidi_pipe ( COMMAND [, ARGUMENTS... ] )
387
388Execute the given C<COMMAND> in the same way as command_output_pipe()
389does but return both an input pipe filehandle and an output pipe filehandle.
390
391The function will return return C<($pid, $pipe_in, $pipe_out, $ctx)>.
392See C<command_close_bidi_pipe()> for details.
393
394=cut
395
396sub command_bidi_pipe {
397 my ($pid, $in, $out);
398 $pid = open2($in, $out, 'git', @_);
399 return ($pid, $in, $out, join(' ', @_));
400}
401
402=item command_close_bidi_pipe ( PID, PIPE_IN, PIPE_OUT [, CTX] )
403
404Close the C<PIPE_IN> and C<PIPE_OUT> as returned from C<command_bidi_pipe()>,
405checking whether the command finished successfully. The optional C<CTX>
406argument is required if you want to see the command name in the error message,
407and it is the fourth value returned by C<command_bidi_pipe()>. The call idiom
408is:
409
410 my ($pid, $in, $out, $ctx) = $r->command_bidi_pipe('cat-file --batch-check');
411 print "000000000\n" $out;
412 while (<$in>) { ... }
413 $r->command_close_bidi_pipe($pid, $in, $out, $ctx);
414
415Note that you should not rely on whatever actually is in C<CTX>;
416currently it is simply the command name but in future the context might
417have more complicated structure.
418
419=cut
420
421sub command_close_bidi_pipe {
Abhijit Menon-Sen108c2aa2008-08-04 11:38:27[diff] [blame]422 local $?;
Adam Robend1a29af2008-05-23 14:19:39[diff] [blame]423 my ($pid, $in, $out, $ctx) = @_;
424 foreach my $fh ($in, $out) {
425 unless (close $fh) {
426 if ($!) {
427 carp "error closing pipe: $!";
428 } elsif ($? >> 8) {
429 throw Git::Error::Command($ctx, $? >>8);
430 }
431 }
432 }
433
434 waitpid $pid, 0;
435
436 if ($? >> 8) {
437 throw Git::Error::Command($ctx, $? >>8);
438 }
439}
440
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]441
442=item command_noisy ( COMMAND [, ARGUMENTS... ] )
443
444Execute the given C<COMMAND> in the same way as command() does but do not
445capture the command output - the standard output is not redirected and goes
446to the standard output of the caller application.
447
448While the method is called command_noisy(), you might want to as well use
449it for the most silent Git commands which you know will never pollute your
450stdout but you want to avoid the overhead of the pipe setup when calling them.
451
452The function returns only after the command has finished running.
453
454=cut
455
456sub command_noisy {
457 my ($self, $cmd, @args) = _maybe_self(@_);
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]458 _check_valid_cmd($cmd);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]459
460 my $pid = fork;
461 if (not defined $pid) {
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]462 throw Error::Simple("fork failed: $!");
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]463 } elsif ($pid == 0) {
464 _cmd_exec($self, $cmd, @args);
465 }
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]466 if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
467 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]468 }
469}
470
471
Petr Baudis63df97a2006-06-24 02:34:36[diff] [blame]472=item version ()
473
474Return the Git version in use.
475
Petr Baudis63df97a2006-06-24 02:34:36[diff] [blame]476=cut
477
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]478sub version {
479 my $verstr = command_oneline('--version');
480 $verstr =~ s/^git version //;
481 $verstr;
482}
Petr Baudis63df97a2006-06-24 02:34:36[diff] [blame]483
484
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]485=item exec_path ()
486
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]487Return path to the Git sub-command executables (the same as
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]488C<git --exec-path>). Useful mostly only internally.
489
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]490=cut
491
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]492sub exec_path { command_oneline('--exec-path') }
Petr Baudiseca1f6f2006-06-24 02:34:31[diff] [blame]493
494
Markus Heidelberg89a56bf2009-04-05 02:15:16[diff] [blame]495=item html_path ()
496
497Return path to the Git html documentation (the same as
498C<git --html-path>). Useful mostly only internally.
499
500=cut
501
502sub html_path { command_oneline('--html-path') }
503
504
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]505=item repo_path ()
506
507Return path to the git repository. Must be called on a repository instance.
508
509=cut
510
511sub repo_path { $_[0]->{opts}->{Repository} }
512
513
514=item wc_path ()
515
516Return path to the working copy. Must be called on a repository instance.
517
518=cut
519
520sub wc_path { $_[0]->{opts}->{WorkingCopy} }
521
522
523=item wc_subdir ()
524
525Return path to the subdirectory inside of a working copy. Must be called
526on a repository instance.
527
528=cut
529
530sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
531
532
533=item wc_chdir ( SUBDIR )
534
535Change the working copy subdirectory to work within. The C<SUBDIR> is
536relative to the working copy root directory (not the current subdirectory).
537Must be called on a repository instance attached to a working copy
538and the directory must exist.
539
540=cut
541
542sub wc_chdir {
543 my ($self, $subdir) = @_;
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]544 $self->wc_path()
545 or throw Error::Simple("bare repository");
546
547 -d $self->wc_path().'/'.$subdir
548 or throw Error::Simple("subdir not found: $!");
549 # Of course we will not "hold" the subdirectory so anyone
550 # can delete it now and we will never know. But at least we tried.
551
552 $self->{opts}->{WorkingSubdir} = $subdir;
553}
554
555
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]556=item config ( VARIABLE )
557
Tom Princee0d10e12007-01-29 00:16:53[diff] [blame]558Retrieve the configuration C<VARIABLE> in the same manner as C<config>
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]559does. In scalar context requires the variable to be set only one time
560(exception is thrown otherwise), in array context returns allows the
561variable to be set multiple times and returns all the values.
562
Tom Princee0d10e12007-01-29 00:16:53[diff] [blame]563This currently wraps command('config') so it is not so fast.
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]564
565=cut
566
567sub config {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]568 my ($self, $var) = _maybe_self(@_);
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]569
570 try {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]571 my @cmd = ('config');
572 unshift @cmd, $self if $self;
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]573 if (wantarray) {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]574 return command(@cmd, '--get-all', $var);
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]575 } else {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]576 return command_oneline(@cmd, '--get', $var);
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]577 }
578 } catch Git::Error::Command with {
579 my $E = shift;
580 if ($E->value() == 1) {
581 # Key not found.
Lea Wiemann32d80502008-06-01 20:34:47[diff] [blame]582 return;
Petr Baudisdc2613d2006-07-03 20:47:55[diff] [blame]583 } else {
584 throw $E;
585 }
586 };
587}
588
589
Petr Baudis35c49ee2007-05-09 10:49:41[diff] [blame]590=item config_bool ( VARIABLE )
Theodore Ts'o7b9a13e2007-02-20 20:13:42[diff] [blame]591
Petr Baudis35c49ee2007-05-09 10:49:41[diff] [blame]592Retrieve the bool configuration C<VARIABLE>. The return value
593is usable as a boolean in perl (and C<undef> if it's not defined,
594of course).
Theodore Ts'o7b9a13e2007-02-20 20:13:42[diff] [blame]595
Theodore Ts'o7b9a13e2007-02-20 20:13:42[diff] [blame]596This currently wraps command('config') so it is not so fast.
597
598=cut
599
Petr Baudis35c49ee2007-05-09 10:49:41[diff] [blame]600sub config_bool {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]601 my ($self, $var) = _maybe_self(@_);
Theodore Ts'o7b9a13e2007-02-20 20:13:42[diff] [blame]602
603 try {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]604 my @cmd = ('config', '--bool', '--get', $var);
605 unshift @cmd, $self if $self;
606 my $val = command_oneline(@cmd);
Petr Baudis35c49ee2007-05-09 10:49:41[diff] [blame]607 return undef unless defined $val;
608 return $val eq 'true';
Theodore Ts'o7b9a13e2007-02-20 20:13:42[diff] [blame]609 } catch Git::Error::Command with {
610 my $E = shift;
611 if ($E->value() == 1) {
612 # Key not found.
613 return undef;
614 } else {
615 throw $E;
616 }
617 };
618}
619
Jakub Narebski346d2032007-11-23 18:04:52[diff] [blame]620=item config_int ( VARIABLE )
621
622Retrieve the integer configuration C<VARIABLE>. The return value
623is simple decimal number. An optional value suffix of 'k', 'm',
624or 'g' in the config file will cause the value to be multiplied
625by 1024, 1048576 (1024^2), or 1073741824 (1024^3) prior to output.
626It would return C<undef> if configuration variable is not defined,
627
Jakub Narebski346d2032007-11-23 18:04:52[diff] [blame]628This currently wraps command('config') so it is not so fast.
629
630=cut
631
632sub config_int {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]633 my ($self, $var) = _maybe_self(@_);
Jakub Narebski346d2032007-11-23 18:04:52[diff] [blame]634
635 try {
Frank Lichtenheldc2e357c2008-03-14 17:29:28[diff] [blame]636 my @cmd = ('config', '--int', '--get', $var);
637 unshift @cmd, $self if $self;
638 return command_oneline(@cmd);
Jakub Narebski346d2032007-11-23 18:04:52[diff] [blame]639 } catch Git::Error::Command with {
640 my $E = shift;
641 if ($E->value() == 1) {
642 # Key not found.
643 return undef;
644 } else {
645 throw $E;
646 }
647 };
648}
Theodore Ts'o7b9a13e2007-02-20 20:13:42[diff] [blame]649
Junio C Hamanob4c61ed2007-12-05 08:50:23[diff] [blame]650=item get_colorbool ( NAME )
651
652Finds if color should be used for NAMEd operation from the configuration,
653and returns boolean (true for "use color", false for "do not use color").
654
655=cut
656
657sub get_colorbool {
658 my ($self, $var) = @_;
659 my $stdout_to_tty = (-t STDOUT) ? "true" : "false";
660 my $use_color = $self->command_oneline('config', '--get-colorbool',
661 $var, $stdout_to_tty);
662 return ($use_color eq 'true');
663}
664
665=item get_color ( SLOT, COLOR )
666
667Finds color for SLOT from the configuration, while defaulting to COLOR,
668and returns the ANSI color escape sequence:
669
670 print $repo->get_color("color.interactive.prompt", "underline blue white");
671 print "some text";
672 print $repo->get_color("", "normal");
673
674=cut
675
676sub get_color {
677 my ($self, $slot, $default) = @_;
678 my $color = $self->command_oneline('config', '--get-color', $slot, $default);
679 if (!defined $color) {
680 $color = "";
681 }
682 return $color;
683}
684
Petr Baudis31a92f62008-07-08 17:48:04[diff] [blame]685=item remote_refs ( REPOSITORY [, GROUPS [, REFGLOBS ] ] )
686
687This function returns a hashref of refs stored in a given remote repository.
688The hash is in the format C<refname =\> hash>. For tags, the C<refname> entry
689contains the tag object while a C<refname^{}> entry gives the tagged objects.
690
691C<REPOSITORY> has the same meaning as the appropriate C<git-ls-remote>
692argument; either an URL or a remote name (if called on a repository instance).
693C<GROUPS> is an optional arrayref that can contain 'tags' to return all the
694tags and/or 'heads' to return all the heads. C<REFGLOB> is an optional array
695of strings containing a shell-like glob to further limit the refs returned in
696the hash; the meaning is again the same as the appropriate C<git-ls-remote>
697argument.
698
699This function may or may not be called on a repository instance. In the former
700case, remote names as defined in the repository are recognized as repository
701specifiers.
702
703=cut
704
705sub remote_refs {
706 my ($self, $repo, $groups, $refglobs) = _maybe_self(@_);
707 my @args;
708 if (ref $groups eq 'ARRAY') {
709 foreach (@$groups) {
710 if ($_ eq 'heads') {
711 push (@args, '--heads');
712 } elsif ($_ eq 'tags') {
713 push (@args, '--tags');
714 } else {
715 # Ignore unknown groups for future
716 # compatibility
717 }
718 }
719 }
720 push (@args, $repo);
721 if (ref $refglobs eq 'ARRAY') {
722 push (@args, @$refglobs);
723 }
724
725 my @self = $self ? ($self) : (); # Ultra trickery
726 my ($fh, $ctx) = Git::command_output_pipe(@self, 'ls-remote', @args);
727 my %refs;
728 while (<$fh>) {
729 chomp;
730 my ($hash, $ref) = split(/\t/, $_, 2);
731 $refs{$ref} = $hash;
732 }
733 Git::command_close_pipe(@self, $fh, $ctx);
734 return \%refs;
735}
736
737
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]738=item ident ( TYPE | IDENTSTR )
739
740=item ident_person ( TYPE | IDENTSTR | IDENTARRAY )
741
742This suite of functions retrieves and parses ident information, as stored
743in the commit and tag objects or produced by C<var GIT_type_IDENT> (thus
744C<TYPE> can be either I<author> or I<committer>; case is insignificant).
745
Todd Zullinger5354a562008-07-30 17:48:33[diff] [blame]746The C<ident> method retrieves the ident information from C<git var>
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]747and either returns it as a scalar string or as an array with the fields parsed.
748Alternatively, it can take a prepared ident string (e.g. from the commit
749object) and just parse it.
750
751C<ident_person> returns the person part of the ident - name and email;
752it can take the same arguments as C<ident> or the array returned by C<ident>.
753
754The synopsis is like:
755
756 my ($name, $email, $time_tz) = ident('author');
757 "$name <$email>" eq ident_person('author');
758 "$name <$email>" eq ident_person($name);
759 $time_tz =~ /^\d+ [+-]\d{4}$/;
760
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]761=cut
762
763sub ident {
Frank Lichtenheld44617922008-03-14 17:29:29[diff] [blame]764 my ($self, $type) = _maybe_self(@_);
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]765 my $identstr;
766 if (lc $type eq lc 'committer' or lc $type eq lc 'author') {
Frank Lichtenheld44617922008-03-14 17:29:29[diff] [blame]767 my @cmd = ('var', 'GIT_'.uc($type).'_IDENT');
768 unshift @cmd, $self if $self;
769 $identstr = command_oneline(@cmd);
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]770 } else {
771 $identstr = $type;
772 }
773 if (wantarray) {
774 return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/;
775 } else {
776 return $identstr;
777 }
778}
779
780sub ident_person {
Frank Lichtenheld44617922008-03-14 17:29:29[diff] [blame]781 my ($self, @ident) = _maybe_self(@_);
782 $#ident == 0 and @ident = $self ? $self->ident($ident[0]) : ident($ident[0]);
Petr Baudisc7a30e52006-07-03 20:48:01[diff] [blame]783 return "$ident[0] <$ident[1]>";
784}
785
786
Petr Baudis24c4b712006-06-25 01:54:26[diff] [blame]787=item hash_object ( TYPE, FILENAME )
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]788
Lea Wiemann58c8dd22008-06-01 20:26:25[diff] [blame]789Compute the SHA1 object id of the given C<FILENAME> considering it is
790of the C<TYPE> object type (C<blob>, C<commit>, C<tree>).
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]791
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]792The method can be called without any instance or on a specified Git repository,
793it makes zero difference.
794
795The function returns the SHA1 hash.
796
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]797=cut
798
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]799# TODO: Support for passing FILEHANDLE instead of FILENAME
Petr Baudise6634ac2006-07-01 23:38:56[diff] [blame]800sub hash_object {
801 my ($self, $type, $file) = _maybe_self(@_);
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]802 command_oneline('hash-object', '-t', $type, $file);
Petr Baudise6634ac2006-07-01 23:38:56[diff] [blame]803}
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]804
805
Adam Roben71825302008-05-23 14:19:40[diff] [blame]806=item hash_and_insert_object ( FILENAME )
807
808Compute the SHA1 object id of the given C<FILENAME> and add the object to the
809object database.
810
811The function returns the SHA1 hash.
812
813=cut
814
815# TODO: Support for passing FILEHANDLE instead of FILENAME
816sub hash_and_insert_object {
817 my ($self, $filename) = @_;
818
819 carp "Bad filename \"$filename\"" if $filename =~ /[\r\n]/;
820
821 $self->_open_hash_and_insert_object_if_needed();
822 my ($in, $out) = ($self->{hash_object_in}, $self->{hash_object_out});
823
824 unless (print $out $filename, "\n") {
825 $self->_close_hash_and_insert_object();
826 throw Error::Simple("out pipe went bad");
827 }
828
829 chomp(my $hash = <$in>);
830 unless (defined($hash)) {
831 $self->_close_hash_and_insert_object();
832 throw Error::Simple("in pipe went bad");
833 }
834
835 return $hash;
836}
837
838sub _open_hash_and_insert_object_if_needed {
839 my ($self) = @_;
840
841 return if defined($self->{hash_object_pid});
842
843 ($self->{hash_object_pid}, $self->{hash_object_in},
844 $self->{hash_object_out}, $self->{hash_object_ctx}) =
845 command_bidi_pipe(qw(hash-object -w --stdin-paths));
846}
847
848sub _close_hash_and_insert_object {
849 my ($self) = @_;
850
851 return unless defined($self->{hash_object_pid});
852
853 my @vars = map { 'hash_object_' . $_ } qw(pid in out ctx);
854
Abhijit Menon-Sen452d36b2008-08-04 05:02:47[diff] [blame]855 command_close_bidi_pipe(@$self{@vars});
856 delete @$self{@vars};
Adam Roben71825302008-05-23 14:19:40[diff] [blame]857}
858
859=item cat_blob ( SHA1, FILEHANDLE )
860
861Prints the contents of the blob identified by C<SHA1> to C<FILEHANDLE> and
862returns the number of bytes printed.
863
864=cut
865
866sub cat_blob {
867 my ($self, $sha1, $fh) = @_;
868
869 $self->_open_cat_blob_if_needed();
870 my ($in, $out) = ($self->{cat_blob_in}, $self->{cat_blob_out});
871
872 unless (print $out $sha1, "\n") {
873 $self->_close_cat_blob();
874 throw Error::Simple("out pipe went bad");
875 }
876
877 my $description = <$in>;
878 if ($description =~ / missing$/) {
879 carp "$sha1 doesn't exist in the repository";
Junio C Hamanod683a0e2008-05-28 06:33:22[diff] [blame]880 return -1;
Adam Roben71825302008-05-23 14:19:40[diff] [blame]881 }
882
883 if ($description !~ /^[0-9a-fA-F]{40} \S+ (\d+)$/) {
884 carp "Unexpected result returned from git cat-file";
Junio C Hamanod683a0e2008-05-28 06:33:22[diff] [blame]885 return -1;
Adam Roben71825302008-05-23 14:19:40[diff] [blame]886 }
887
888 my $size = $1;
889
890 my $blob;
891 my $bytesRead = 0;
892
893 while (1) {
894 my $bytesLeft = $size - $bytesRead;
895 last unless $bytesLeft;
896
897 my $bytesToRead = $bytesLeft < 1024 ? $bytesLeft : 1024;
898 my $read = read($in, $blob, $bytesToRead, $bytesRead);
899 unless (defined($read)) {
900 $self->_close_cat_blob();
901 throw Error::Simple("in pipe went bad");
902 }
903
904 $bytesRead += $read;
905 }
906
907 # Skip past the trailing newline.
908 my $newline;
909 my $read = read($in, $newline, 1);
910 unless (defined($read)) {
911 $self->_close_cat_blob();
912 throw Error::Simple("in pipe went bad");
913 }
914 unless ($read == 1 && $newline eq "\n") {
915 $self->_close_cat_blob();
916 throw Error::Simple("didn't find newline after blob");
917 }
918
919 unless (print $fh $blob) {
920 $self->_close_cat_blob();
921 throw Error::Simple("couldn't write to passed in filehandle");
922 }
923
924 return $size;
925}
926
927sub _open_cat_blob_if_needed {
928 my ($self) = @_;
929
930 return if defined($self->{cat_blob_pid});
931
932 ($self->{cat_blob_pid}, $self->{cat_blob_in},
933 $self->{cat_blob_out}, $self->{cat_blob_ctx}) =
934 command_bidi_pipe(qw(cat-file --batch));
935}
936
937sub _close_cat_blob {
938 my ($self) = @_;
939
940 return unless defined($self->{cat_blob_pid});
941
942 my @vars = map { 'cat_blob_' . $_ } qw(pid in out ctx);
943
Abhijit Menon-Sen452d36b2008-08-04 05:02:47[diff] [blame]944 command_close_bidi_pipe(@$self{@vars});
945 delete @$self{@vars};
Adam Roben71825302008-05-23 14:19:40[diff] [blame]946}
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]947
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]948
949{ # %TEMP_* Lexical Context
950
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]951my (%TEMP_FILEMAP, %TEMP_FILES);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]952
953=item temp_acquire ( NAME )
954
955Attempts to retreive the temporary file mapped to the string C<NAME>. If an
956associated temp file has not been created this session or was closed, it is
957created, cached, and set for autoflush and binmode.
958
959Internally locks the file mapped to C<NAME>. This lock must be released with
960C<temp_release()> when the temp file is no longer needed. Subsequent attempts
961to retrieve temporary files mapped to the same C<NAME> while still locked will
962cause an error. This locking mechanism provides a weak guarantee and is not
963threadsafe. It does provide some error checking to help prevent temp file refs
964writing over one another.
965
966In general, the L<File::Handle> returned should not be closed by consumers as
967it defeats the purpose of this caching mechanism. If you need to close the temp
968file handle, then you should use L<File::Temp> or another temp file faculty
969directly. If a handle is closed and then requested again, then a warning will
970issue.
971
972=cut
973
974sub temp_acquire {
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]975 my $temp_fd = _temp_cache(@_);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]976
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]977 $TEMP_FILES{$temp_fd}{locked} = 1;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]978 $temp_fd;
979}
980
981=item temp_release ( NAME )
982
983=item temp_release ( FILEHANDLE )
984
985Releases a lock acquired through C<temp_acquire()>. Can be called either with
986the C<NAME> mapping used when acquiring the temp file or with the C<FILEHANDLE>
987referencing a locked temp file.
988
989Warns if an attempt is made to release a file that is not locked.
990
991The temp file will be truncated before being released. This can help to reduce
992disk I/O where the system is smart enough to detect the truncation while data
993is in the output buffers. Beware that after the temp file is released and
994truncated, any operations on that file may fail miserably until it is
995re-acquired. All contents are lost between each release and acquire mapped to
996the same string.
997
998=cut
999
1000sub temp_release {
1001 my ($self, $temp_fd, $trunc) = _maybe_self(@_);
1002
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1003 if (exists $TEMP_FILEMAP{$temp_fd}) {
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1004 $temp_fd = $TEMP_FILES{$temp_fd};
1005 }
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1006 unless ($TEMP_FILES{$temp_fd}{locked}) {
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1007 carp "Attempt to release temp file '",
1008 $temp_fd, "' that has not been locked";
1009 }
1010 temp_reset($temp_fd) if $trunc and $temp_fd->opened;
1011
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1012 $TEMP_FILES{$temp_fd}{locked} = 0;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1013 undef;
1014}
1015
1016sub _temp_cache {
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1017 my ($self, $name) = _maybe_self(@_);
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1018
Marcus Griepc14c8ce2008-08-15 19:53:59[diff] [blame]1019 _verify_require();
1020
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1021 my $temp_fd = \$TEMP_FILEMAP{$name};
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1022 if (defined $$temp_fd and $$temp_fd->opened) {
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1023 if ($TEMP_FILES{$$temp_fd}{locked}) {
Jay Soffian8faea4f2009-01-13 22:41:35[diff] [blame]1024 throw Error::Simple("Temp file with moniker '" .
1025 $name . "' already in use");
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1026 }
1027 } else {
1028 if (defined $$temp_fd) {
1029 # then we're here because of a closed handle.
1030 carp "Temp file '", $name,
1031 "' was closed. Opening replacement.";
1032 }
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1033 my $fname;
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1034
1035 my $tmpdir;
1036 if (defined $self) {
1037 $tmpdir = $self->repo_path();
1038 }
1039
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1040 ($$temp_fd, $fname) = File::Temp->tempfile(
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1041 'Git_XXXXXX', UNLINK => 1, DIR => $tmpdir,
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1042 ) or throw Error::Simple("couldn't open new temp file");
Marten Svanfeldt (dev)bcdd1b42008-11-13 12:04:09[diff] [blame]1043
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1044 $$temp_fd->autoflush;
1045 binmode $$temp_fd;
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1046 $TEMP_FILES{$$temp_fd}{fname} = $fname;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1047 }
1048 $$temp_fd;
1049}
1050
Marcus Griepc14c8ce2008-08-15 19:53:59[diff] [blame]1051sub _verify_require {
1052 eval { require File::Temp; require File::Spec; };
1053 $@ and throw Error::Simple($@);
1054}
1055
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1056=item temp_reset ( FILEHANDLE )
1057
1058Truncates and resets the position of the C<FILEHANDLE>.
1059
1060=cut
1061
1062sub temp_reset {
1063 my ($self, $temp_fd) = _maybe_self(@_);
1064
1065 truncate $temp_fd, 0
1066 or throw Error::Simple("couldn't truncate file");
1067 sysseek($temp_fd, 0, SEEK_SET) and seek($temp_fd, 0, SEEK_SET)
1068 or throw Error::Simple("couldn't seek to beginning of file");
1069 sysseek($temp_fd, 0, SEEK_CUR) == 0 and tell($temp_fd) == 0
1070 or throw Error::Simple("expected file position to be reset");
1071}
1072
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1073=item temp_path ( NAME )
1074
1075=item temp_path ( FILEHANDLE )
1076
1077Returns the filename associated with the given tempfile.
1078
1079=cut
1080
1081sub temp_path {
1082 my ($self, $temp_fd) = _maybe_self(@_);
1083
1084 if (exists $TEMP_FILEMAP{$temp_fd}) {
1085 $temp_fd = $TEMP_FILEMAP{$temp_fd};
1086 }
1087 $TEMP_FILES{$temp_fd}{fname};
1088}
1089
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1090sub END {
Marcus Griep836ff952008-09-08 16:53:01[diff] [blame]1091 unlink values %TEMP_FILEMAP if %TEMP_FILEMAP;
Marcus Griepe41352b2008-08-12 16:00:18[diff] [blame]1092}
1093
1094} # %TEMP_* Lexical Context
1095
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1096=back
1097
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]1098=head1 ERROR HANDLING
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1099
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]1100All functions are supposed to throw Perl exceptions in case of errors.
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1101See the L<Error> module on how to catch those. Most exceptions are mere
1102L<Error::Simple> instances.
1103
1104However, the C<command()>, C<command_oneline()> and C<command_noisy()>
1105functions suite can throw C<Git::Error::Command> exceptions as well: those are
1106thrown when the external command returns an error code and contain the error
1107code as well as access to the captured command's output. The exception class
1108provides the usual C<stringify> and C<value> (command's exit code) methods and
1109in addition also a C<cmd_output> method that returns either an array or a
1110string with the captured command output (depending on the original function
1111call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
1112returns the command and its arguments (but without proper quoting).
1113
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1114Note that the C<command_*_pipe()> functions cannot throw this exception since
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1115it has no idea whether the command failed or not. You will only find out
1116at the time you C<close> the pipe; if you want to have that automated,
1117use C<command_close_pipe()>, which can throw the exception.
1118
1119=cut
1120
1121{
1122 package Git::Error::Command;
1123
1124 @Git::Error::Command::ISA = qw(Error);
1125
1126 sub new {
1127 my $self = shift;
1128 my $cmdline = '' . shift;
1129 my $value = 0 + shift;
1130 my $outputref = shift;
1131 my(@args) = ();
1132
1133 local $Error::Depth = $Error::Depth + 1;
1134
1135 push(@args, '-cmdline', $cmdline);
1136 push(@args, '-value', $value);
1137 push(@args, '-outputref', $outputref);
1138
1139 $self->SUPER::new(-text => 'command returned error', @args);
1140 }
1141
1142 sub stringify {
1143 my $self = shift;
1144 my $text = $self->SUPER::stringify;
1145 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
1146 }
1147
1148 sub cmdline {
1149 my $self = shift;
1150 $self->{'-cmdline'};
1151 }
1152
1153 sub cmd_output {
1154 my $self = shift;
1155 my $ref = $self->{'-outputref'};
1156 defined $ref or undef;
1157 if (ref $ref eq 'ARRAY') {
1158 return @$ref;
1159 } else { # SCALAR
1160 return $$ref;
1161 }
1162 }
1163}
1164
1165=over 4
1166
1167=item git_cmd_try { CODE } ERRMSG
1168
1169This magical statement will automatically catch any C<Git::Error::Command>
1170exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
1171on its lips; the message will have %s substituted for the command line
1172and %d for the exit status. This statement is useful mostly for producing
1173more user-friendly error messages.
1174
1175In case of no exception caught the statement returns C<CODE>'s return value.
1176
1177Note that this is the only auto-exported function.
1178
1179=cut
1180
1181sub git_cmd_try(&$) {
1182 my ($code, $errmsg) = @_;
1183 my @result;
1184 my $err;
1185 my $array = wantarray;
1186 try {
1187 if ($array) {
1188 @result = &$code;
1189 } else {
1190 $result[0] = &$code;
1191 }
1192 } catch Git::Error::Command with {
1193 my $E = shift;
1194 $err = $errmsg;
1195 $err =~ s/\%s/$E->cmdline()/ge;
1196 $err =~ s/\%d/$E->value()/ge;
1197 # We can't croak here since Error.pm would mangle
1198 # that to Error::Simple.
1199 };
1200 $err and croak $err;
1201 return $array ? @result : $result[0];
1202}
1203
1204
1205=back
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1206
1207=head1 COPYRIGHT
1208
1209Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
1210
1211This module is free software; it may be used, copied, modified
1212and distributed under the terms of the GNU General Public Licence,
1213either version 2, or (at your option) any later version.
1214
1215=cut
1216
1217
1218# Take raw method argument list and return ($obj, @args) in case
1219# the method was called upon an instance and (undef, @args) if
1220# it was called directly.
1221sub _maybe_self {
Christian Jaegerd8b24b92008-10-18 18:25:12[diff] [blame]1222 UNIVERSAL::isa($_[0], 'Git') ? @_ : (undef, @_);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1223}
1224
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1225# Check if the command id is something reasonable.
1226sub _check_valid_cmd {
1227 my ($cmd) = @_;
1228 $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
1229}
1230
1231# Common backend for the pipe creators.
1232sub _command_common_pipe {
1233 my $direction = shift;
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]1234 my ($self, @p) = _maybe_self(@_);
1235 my (%opts, $cmd, @args);
1236 if (ref $p[0]) {
1237 ($cmd, @args) = @{shift @p};
1238 %opts = ref $p[0] ? %{$p[0]} : @p;
1239 } else {
1240 ($cmd, @args) = @p;
1241 }
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1242 _check_valid_cmd($cmd);
1243
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1244 my $fh;
Alex Riesend3b17852007-01-22 16:14:56[diff] [blame]1245 if ($^O eq 'MSWin32') {
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1246 # ActiveState Perl
1247 #defined $opts{STDERR} and
1248 # warn 'ignoring STDERR option - running w/ ActiveState';
1249 $direction eq '-|' or
1250 die 'input pipe for ActiveState not implemented';
Alex Riesenbed118d2007-01-22 16:16:05[diff] [blame]1251 # the strange construction with *ACPIPE is just to
1252 # explain the tie below that we want to bind to
1253 # a handle class, not scalar. It is not known if
1254 # it is something specific to ActiveState Perl or
1255 # just a Perl quirk.
1256 tie (*ACPIPE, 'Git::activestate_pipe', $cmd, @args);
1257 $fh = *ACPIPE;
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1258
1259 } else {
1260 my $pid = open($fh, $direction);
1261 if (not defined $pid) {
1262 throw Error::Simple("open failed: $!");
1263 } elsif ($pid == 0) {
1264 if (defined $opts{STDERR}) {
1265 close STDERR;
1266 }
1267 if ($opts{STDERR}) {
1268 open (STDERR, '>&', $opts{STDERR})
1269 or die "dup failed: $!";
1270 }
1271 _cmd_exec($self, $cmd, @args);
Petr Baudisd43ba462006-06-24 02:34:49[diff] [blame]1272 }
Petr Baudisd79850e2006-06-24 02:34:47[diff] [blame]1273 }
1274 return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
1275}
1276
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1277# When already in the subprocess, set up the appropriate state
1278# for the given repository and execute the git command.
1279sub _cmd_exec {
1280 my ($self, @args) = @_;
1281 if ($self) {
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]1282 $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
Frank Lichtenheldda159c72009-05-07 13:41:27[diff] [blame]1283 $self->repo_path() and $self->wc_path()
1284 and $ENV{'GIT_WORK_TREE'} = $self->wc_path();
Petr Baudisd5c77212006-06-24 02:34:51[diff] [blame]1285 $self->wc_path() and chdir($self->wc_path());
1286 $self->wc_subdir() and chdir($self->wc_subdir());
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1287 }
Petr Baudis97b16c02006-06-24 02:34:42[diff] [blame]1288 _execv_git_cmd(@args);
Ask Bjørn Hansen6aaa65d2007-11-06 10:54:01[diff] [blame]1289 die qq[exec "@args" failed: $!];
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1290}
1291
Petr Baudis8062f812006-06-24 02:34:34[diff] [blame]1292# Execute the given Git command ($_[0]) with arguments ($_[1..])
1293# by searching for it at proper places.
Petr Baudis18b0fc12006-09-23 18:20:47[diff] [blame]1294sub _execv_git_cmd { exec('git', @_); }
Petr Baudis8062f812006-06-24 02:34:34[diff] [blame]1295
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1296# Close pipe to a subprocess.
1297sub _cmd_close {
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1298 my ($fh, $ctx) = @_;
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1299 if (not close $fh) {
1300 if ($!) {
1301 # It's just close, no point in fatalities
1302 carp "error closing pipe: $!";
1303 } elsif ($? >> 8) {
Petr Baudis8b9150e2006-06-24 02:34:44[diff] [blame]1304 # The caller should pepper this.
1305 throw Git::Error::Command($ctx, $? >> 8);
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1306 }
1307 # else we might e.g. closed a live stream; the command
1308 # dying of SIGPIPE would drive us here.
1309 }
1310}
1311
1312
Adam Roben71825302008-05-23 14:19:40[diff] [blame]1313sub DESTROY {
1314 my ($self) = @_;
1315 $self->_close_hash_and_insert_object();
1316 $self->_close_cat_blob();
1317}
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]1318
1319
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1320# Pipe implementation for ActiveState Perl.
1321
1322package Git::activestate_pipe;
1323use strict;
1324
1325sub TIEHANDLE {
1326 my ($class, @params) = @_;
1327 # FIXME: This is probably horrible idea and the thing will explode
1328 # at the moment you give it arguments that require some quoting,
1329 # but I have no ActiveState clue... --pasky
Alex Riesend3b17852007-01-22 16:14:56[diff] [blame]1330 # Let's just hope ActiveState Perl does at least the quoting
1331 # correctly.
1332 my @data = qx{git @params};
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1333 bless { i => 0, data => \@data }, $class;
1334}
1335
1336sub READLINE {
1337 my $self = shift;
1338 if ($self->{i} >= scalar @{$self->{data}}) {
1339 return undef;
1340 }
Alex Riesen2f5b3982007-08-22 16:13:07[diff] [blame]1341 my $i = $self->{i};
1342 if (wantarray) {
1343 $self->{i} = $#{$self->{'data'}} + 1;
1344 return splice(@{$self->{'data'}}, $i);
1345 }
1346 $self->{i} = $i + 1;
1347 return $self->{'data'}->[ $i ];
Petr Baudisa6065b52006-06-25 01:54:23[diff] [blame]1348}
1349
1350sub CLOSE {
1351 my $self = shift;
1352 delete $self->{data};
1353 delete $self->{i};
1354}
1355
1356sub EOF {
1357 my $self = shift;
1358 return ($self->{i} >= scalar @{$self->{data}});
1359}
1360
1361
Petr Baudisb1edc532006-06-24 02:34:29[diff] [blame]13621; # Famous last words