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