perl/Git.pm

   1 =head1 NAME
   2
   3 Git - Perl interface to the Git version control system
   4
   5 =cut
   6
   7
   8 package Git;
   9
  10 use strict;
  11
  12
  13 BEGIN {
  14
  15 our ($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
  27   git_cmd_try { Git::command_noisy('update-server-info') }
  28               '%s failed w/ code %d';
  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
  35   my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
  36   my $lastrev = <$fh>; chomp $lastrev;
  37   $repo->command_close_pipe($fh, $c);
  38
  39   my $lastrev = $repo->command_oneline('rev-list', '--all');
  40
  41 =cut
  42
  43
  44 require Exporter;
  45
  46 @ISA = qw(Exporter);
  47
  48 @EXPORT = qw(git_cmd_try);
  49
  50 # Methods which can be called as standalone functions as well:
  51 @EXPORT_OK = qw(command command_oneline command_noisy
  52                 command_output_pipe command_input_pipe command_close_pipe
  53                 version exec_path hash_object git_cmd_try);
  54
  55
  56 =head1 DESCRIPTION
  57
  58 This module provides Perl scripts easy way to interface the Git version control
  59 system. The modules have an easy and well-tested way to call arbitrary Git
  60 commands; in the future, the interface will also provide specialized methods
  61 for doing easily operations which are not totally trivial to do over
  62 the generic command interface.
  63
  64 While some commands can be executed outside of any context (e.g. 'version'
  65 or 'init-db'), most operations require a repository context, which in practice
  66 means getting an instance of the Git object using the repository() constructor.
  67 (In the future, we will also get a new_repository() constructor.) All commands
  68 called as methods of the object are then executed in the context of the
  69 repository.
  70
  71 TODO: In the future, we might also do
  72
  73         my $subdir = $repo->subdir('Documentation');
  74         # Gets called in the subdirectory context:
  75         $subdir->command('status');
  76
  77         my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
  78         $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
  79         my @refs = $remoterepo->refs();
  80
  81 So far, all functions just die if anything goes wrong. If you don't want that,
  82 make appropriate provisions to catch the possible deaths. Better error recovery
  83 mechanisms will be provided in the future.
  84
  85 Currently, the module merely wraps calls to external Git tools. In the future,
  86 it will provide a much faster way to interact with Git by linking directly
  87 to libgit. This should be completely opaque to the user, though (performance
  88 increate nonwithstanding).
  89
  90 =cut
  91
  92
  93 use Carp qw(carp croak); # but croak is bad - throw instead
  94 use Error qw(:try);
  95
  96 require XSLoader;
  97 XSLoader::load('Git', $VERSION);
  98
  99 }
 100
 101
 102 =head1 CONSTRUCTORS
 103
 104 =over 4
 105
 106 =item repository ( OPTIONS )
 107
 108 =item repository ( DIRECTORY )
 109
 110 =item repository ()
 111
 112 Construct a new repository object.
 113 C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
 114 Possible options are:
 115
 116 B<Repository> - Path to the Git repository.
 117
 118 B<WorkingCopy> - Path to the associated working copy; not strictly required
 119 as many commands will happily crunch on a bare repository.
 120
 121 B<Directory> - Path to the Git working directory in its usual setup. This
 122 is just for convenient setting of both C<Repository> and C<WorkingCopy>
 123 at once: If the directory as a C<.git> subdirectory, C<Repository> is pointed
 124 to the subdirectory and the directory is assumed to be the working copy.
 125 If the directory does not have the subdirectory, C<WorkingCopy> is left
 126 undefined and C<Repository> is pointed to the directory itself.
 127
 128 You should not use both C<Directory> and either of C<Repository> and
 129 C<WorkingCopy> - the results of that are undefined.
 130
 131 Alternatively, a directory path may be passed as a single scalar argument
 132 to the constructor; it is equivalent to setting only the C<Directory> option
 133 field.
 134
 135 Calling the constructor with no options whatsoever is equivalent to
 136 calling it with C<< Directory => '.' >>.
 137
 138 =cut
 139
 140 sub repository {
 141         my $class = shift;
 142         my @args = @_;
 143         my %opts = ();
 144         my $self;
 145
 146         if (defined $args[0]) {
 147                 if ($#args % 2 != 1) {
 148                         # Not a hash.
 149                         $#args == 0 or throw Error::Simple("bad usage");
 150                         %opts = ( Directory => $args[0] );
 151                 } else {
 152                         %opts = @args;
 153                 }
 154
 155                 if ($opts{Directory}) {
 156                         -d $opts{Directory} or throw Error::Simple("Directory not found: $!");
 157                         if (-d $opts{Directory}."/.git") {
 158                                 # TODO: Might make this more clever
 159                                 $opts{WorkingCopy} = $opts{Directory};
 160                                 $opts{Repository} = $opts{Directory}."/.git";
 161                         } else {
 162                                 $opts{Repository} = $opts{Directory};
 163                         }
 164                         delete $opts{Directory};
 165                 }
 166         }
 167
 168         $self = { opts => \%opts };
 169         bless $self, $class;
 170 }
 171
 172
 173 =back
 174
 175 =head1 METHODS
 176
 177 =over 4
 178
 179 =item command ( COMMAND [, ARGUMENTS... ] )
 180
 181 Execute the given Git C<COMMAND> (specify it without the 'git-'
 182 prefix), optionally with the specified extra C<ARGUMENTS>.
 183
 184 The method can be called without any instance or on a specified Git repository
 185 (in that case the command will be run in the repository context).
 186
 187 In scalar context, it returns all the command output in a single string
 188 (verbatim).
 189
 190 In array context, it returns an array containing lines printed to the
 191 command's stdout (without trailing newlines).
 192
 193 In both cases, the command's stdin and stderr are the same as the caller's.
 194
 195 =cut
 196
 197 sub command {
 198         my ($fh, $ctx) = command_output_pipe(@_);
 199
 200         if (not defined wantarray) {
 201                 # Nothing to pepper the possible exception with.
 202                 _cmd_close($fh, $ctx);
 203
 204         } elsif (not wantarray) {
 205                 local $/;
 206                 my $text = <$fh>;
 207                 try {
 208                         _cmd_close($fh, $ctx);
 209                 } catch Git::Error::Command with {
 210                         # Pepper with the output:
 211                         my $E = shift;
 212                         $E->{'-outputref'} = \$text;
 213                         throw $E;
 214                 };
 215                 return $text;
 216
 217         } else {
 218                 my @lines = <$fh>;
 219                 chomp @lines;
 220                 try {
 221                         _cmd_close($fh, $ctx);
 222                 } catch Git::Error::Command with {
 223                         my $E = shift;
 224                         $E->{'-outputref'} = \@lines;
 225                         throw $E;
 226                 };
 227                 return @lines;
 228         }
 229 }
 230
 231
 232 =item command_oneline ( COMMAND [, ARGUMENTS... ] )
 233
 234 Execute the given C<COMMAND> in the same way as command()
 235 does but always return a scalar string containing the first line
 236 of the command's standard output.
 237
 238 =cut
 239
 240 sub command_oneline {
 241         my ($fh, $ctx) = command_output_pipe(@_);
 242
 243         my $line = <$fh>;
 244         chomp $line;
 245         try {
 246                 _cmd_close($fh, $ctx);
 247         } catch Git::Error::Command with {
 248                 # Pepper with the output:
 249                 my $E = shift;
 250                 $E->{'-outputref'} = \$line;
 251                 throw $E;
 252         };
 253         return $line;
 254 }
 255
 256
 257 =item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
 258
 259 Execute the given C<COMMAND> in the same way as command()
 260 does but return a pipe filehandle from which the command output can be
 261 read.
 262
 263 The function can return C<($pipe, $ctx)> in array context.
 264 See C<command_close_pipe()> for details.
 265
 266 =cut
 267
 268 sub command_output_pipe {
 269         _command_common_pipe('-|', @_);
 270 }
 271
 272
 273 =item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
 274
 275 Execute the given C<COMMAND> in the same way as command_output_pipe()
 276 does but return an input pipe filehandle instead; the command output
 277 is not captured.
 278
 279 The function can return C<($pipe, $ctx)> in array context.
 280 See C<command_close_pipe()> for details.
 281
 282 =cut
 283
 284 sub command_input_pipe {
 285         _command_common_pipe('|-', @_);
 286 }
 287
 288
 289 =item command_close_pipe ( PIPE [, CTX ] )
 290
 291 Close the C<PIPE> as returned from C<command_*_pipe()>, checking
 292 whether the command finished successfuly. The optional C<CTX> argument
 293 is required if you want to see the command name in the error message,
 294 and it is the second value returned by C<command_*_pipe()> when
 295 called in array context. The call idiom is:
 296
 297         my ($fh, $ctx) = $r->command_output_pipe('status');
 298         while (<$fh>) { ... }
 299         $r->command_close_pipe($fh, $ctx);
 300
 301 Note that you should not rely on whatever actually is in C<CTX>;
 302 currently it is simply the command name but in future the context might
 303 have more complicated structure.
 304
 305 =cut
 306
 307 sub command_close_pipe {
 308         my ($self, $fh, $ctx) = _maybe_self(@_);
 309         $ctx ||= '<unknown>';
 310         _cmd_close($fh, $ctx);
 311 }
 312
 313
 314 =item command_noisy ( COMMAND [, ARGUMENTS... ] )
 315
 316 Execute the given C<COMMAND> in the same way as command() does but do not
 317 capture the command output - the standard output is not redirected and goes
 318 to the standard output of the caller application.
 319
 320 While the method is called command_noisy(), you might want to as well use
 321 it for the most silent Git commands which you know will never pollute your
 322 stdout but you want to avoid the overhead of the pipe setup when calling them.
 323
 324 The function returns only after the command has finished running.
 325
 326 =cut
 327
 328 sub command_noisy {
 329         my ($self, $cmd, @args) = _maybe_self(@_);
 330         _check_valid_cmd($cmd);
 331
 332         my $pid = fork;
 333         if (not defined $pid) {
 334                 throw Error::Simple("fork failed: $!");
 335         } elsif ($pid == 0) {
 336                 _cmd_exec($self, $cmd, @args);
 337         }
 338         if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
 339                 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
 340         }
 341 }
 342
 343
 344 =item version ()
 345
 346 Return the Git version in use.
 347
 348 Implementation of this function is very fast; no external command calls
 349 are involved.
 350
 351 =cut
 352
 353 # Implemented in Git.xs.
 354
 355
 356 =item exec_path ()
 357
 358 Return path to the git sub-command executables (the same as
 359 C<git --exec-path>). Useful mostly only internally.
 360
 361 Implementation of this function is very fast; no external command calls
 362 are involved.
 363
 364 =cut
 365
 366 # Implemented in Git.xs.
 367
 368
 369 =item hash_object ( FILENAME [, TYPE ] )
 370
 371 =item hash_object ( FILEHANDLE [, TYPE ] )
 372
 373 Compute the SHA1 object id of the given C<FILENAME> (or data waiting in
 374 C<FILEHANDLE>) considering it is of the C<TYPE> object type (C<blob>
 375 (default), C<commit>, C<tree>).
 376
 377 In case of C<FILEHANDLE> passed instead of file name, all the data
 378 available are read and hashed, and the filehandle is automatically
 379 closed. The file handle should be freshly opened - if you have already
 380 read anything from the file handle, the results are undefined (since
 381 this function works directly with the file descriptor and internal
 382 PerlIO buffering might have messed things up).
 383
 384 The method can be called without any instance or on a specified Git repository,
 385 it makes zero difference.
 386
 387 The function returns the SHA1 hash.
 388
 389 Implementation of this function is very fast; no external command calls
 390 are involved.
 391
 392 =cut
 393
 394 # Implemented in Git.xs.
 395
 396
 397
 398 =back
 399
 400 =head1 ERROR HANDLING
 401
 402 All functions are supposed to throw Perl exceptions in case of errors.
 403 See the L<Error> module on how to catch those. Most exceptions are mere
 404 L<Error::Simple> instances.
 405
 406 However, the C<command()>, C<command_oneline()> and C<command_noisy()>
 407 functions suite can throw C<Git::Error::Command> exceptions as well: those are
 408 thrown when the external command returns an error code and contain the error
 409 code as well as access to the captured command's output. The exception class
 410 provides the usual C<stringify> and C<value> (command's exit code) methods and
 411 in addition also a C<cmd_output> method that returns either an array or a
 412 string with the captured command output (depending on the original function
 413 call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
 414 returns the command and its arguments (but without proper quoting).
 415
 416 Note that the C<command_*_pipe()> functions cannot throw this exception since
 417 it has no idea whether the command failed or not. You will only find out
 418 at the time you C<close> the pipe; if you want to have that automated,
 419 use C<command_close_pipe()>, which can throw the exception.
 420
 421 =cut
 422
 423 {
 424         package Git::Error::Command;
 425
 426         @Git::Error::Command::ISA = qw(Error);
 427
 428         sub new {
 429                 my $self = shift;
 430                 my $cmdline = '' . shift;
 431                 my $value = 0 + shift;
 432                 my $outputref = shift;
 433                 my(@args) = ();
 434
 435                 local $Error::Depth = $Error::Depth + 1;
 436
 437                 push(@args, '-cmdline', $cmdline);
 438                 push(@args, '-value', $value);
 439                 push(@args, '-outputref', $outputref);
 440
 441                 $self->SUPER::new(-text => 'command returned error', @args);
 442         }
 443
 444         sub stringify {
 445                 my $self = shift;
 446                 my $text = $self->SUPER::stringify;
 447                 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
 448         }
 449
 450         sub cmdline {
 451                 my $self = shift;
 452                 $self->{'-cmdline'};
 453         }
 454
 455         sub cmd_output {
 456                 my $self = shift;
 457                 my $ref = $self->{'-outputref'};
 458                 defined $ref or undef;
 459                 if (ref $ref eq 'ARRAY') {
 460                         return @$ref;
 461                 } else { # SCALAR
 462                         return $$ref;
 463                 }
 464         }
 465 }
 466
 467 =over 4
 468
 469 =item git_cmd_try { CODE } ERRMSG
 470
 471 This magical statement will automatically catch any C<Git::Error::Command>
 472 exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
 473 on its lips; the message will have %s substituted for the command line
 474 and %d for the exit status. This statement is useful mostly for producing
 475 more user-friendly error messages.
 476
 477 In case of no exception caught the statement returns C<CODE>'s return value.
 478
 479 Note that this is the only auto-exported function.
 480
 481 =cut
 482
 483 sub git_cmd_try(&$) {
 484         my ($code, $errmsg) = @_;
 485         my @result;
 486         my $err;
 487         my $array = wantarray;
 488         try {
 489                 if ($array) {
 490                         @result = &$code;
 491                 } else {
 492                         $result[0] = &$code;
 493                 }
 494         } catch Git::Error::Command with {
 495                 my $E = shift;
 496                 $err = $errmsg;
 497                 $err =~ s/\%s/$E->cmdline()/ge;
 498                 $err =~ s/\%d/$E->value()/ge;
 499                 # We can't croak here since Error.pm would mangle
 500                 # that to Error::Simple.
 501         };
 502         $err and croak $err;
 503         return $array ? @result : $result[0];
 504 }
 505
 506
 507 =back
 508
 509 =head1 COPYRIGHT
 510
 511 Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
 512
 513 This module is free software; it may be used, copied, modified
 514 and distributed under the terms of the GNU General Public Licence,
 515 either version 2, or (at your option) any later version.
 516
 517 =cut
 518
 519
 520 # Take raw method argument list and return ($obj, @args) in case
 521 # the method was called upon an instance and (undef, @args) if
 522 # it was called directly.
 523 sub _maybe_self {
 524         # This breaks inheritance. Oh well.
 525         ref $_[0] eq 'Git' ? @_ : (undef, @_);
 526 }
 527
 528 # Check if the command id is something reasonable.
 529 sub _check_valid_cmd {
 530         my ($cmd) = @_;
 531         $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
 532 }
 533
 534 # Common backend for the pipe creators.
 535 sub _command_common_pipe {
 536         my $direction = shift;
 537         my ($self, $cmd, @args) = _maybe_self(@_);
 538         _check_valid_cmd($cmd);
 539
 540         my $pid = open(my $fh, $direction);
 541         if (not defined $pid) {
 542                 throw Error::Simple("open failed: $!");
 543         } elsif ($pid == 0) {
 544                 _cmd_exec($self, $cmd, @args);
 545         }
 546         return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
 547 }
 548
 549 # When already in the subprocess, set up the appropriate state
 550 # for the given repository and execute the git command.
 551 sub _cmd_exec {
 552         my ($self, @args) = @_;
 553         if ($self) {
 554                 $self->{opts}->{Repository} and $ENV{'GIT_DIR'} = $self->{opts}->{Repository};
 555                 $self->{opts}->{WorkingCopy} and chdir($self->{opts}->{WorkingCopy});
 556         }
 557         _execv_git_cmd(@args);
 558         die "exec failed: $!";
 559 }
 560
 561 # Execute the given Git command ($_[0]) with arguments ($_[1..])
 562 # by searching for it at proper places.
 563 # _execv_git_cmd(), implemented in Git.xs.
 564
 565 # Close pipe to a subprocess.
 566 sub _cmd_close {
 567         my ($fh, $ctx) = @_;
 568         if (not close $fh) {
 569                 if ($!) {
 570                         # It's just close, no point in fatalities
 571                         carp "error closing pipe: $!";
 572                 } elsif ($? >> 8) {
 573                         # The caller should pepper this.
 574                         throw Git::Error::Command($ctx, $? >> 8);
 575                 }
 576                 # else we might e.g. closed a live stream; the command
 577                 # dying of SIGPIPE would drive us here.
 578         }
 579 }
 580
 581
 582 # Trickery for .xs routines: In order to avoid having some horrid
 583 # C code trying to do stuff with undefs and hashes, we gate all
 584 # xs calls through the following and in case we are being ran upon
 585 # an instance call a C part of the gate which will set up the
 586 # environment properly.
 587 sub _call_gate {
 588         my $xsfunc = shift;
 589         my ($self, @args) = _maybe_self(@_);
 590
 591         if (defined $self) {
 592                 # XXX: We ignore the WorkingCopy! To properly support
 593                 # that will require heavy changes in libgit.
 594
 595                 # XXX: And we ignore everything else as well. libgit
 596                 # at least needs to be extended to let us specify
 597                 # the $GIT_DIR instead of looking it up in environment.
 598                 #xs_call_gate($self->{opts}->{Repository});
 599         }
 600
 601         # Having to call throw from the C code is a sure path to insanity.
 602         local $SIG{__DIE__} = sub { throw Error::Simple("@_"); };
 603         &$xsfunc(@args);
 604 }
 605
 606 sub AUTOLOAD {
 607         my $xsname;
 608         our $AUTOLOAD;
 609         ($xsname = $AUTOLOAD) =~ s/.*:://;
 610         throw Error::Simple("&Git::$xsname not defined") if $xsname =~ /^xs_/;
 611         $xsname = 'xs_'.$xsname;
 612         _call_gate(\&$xsname, @_);
 613 }
 614
 615 sub DESTROY { }
 616
 617
 618 1; # Famous last words