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