Use $GITPERLLIB instead of $RUNNING_GIT_TESTS and centralize @INC munging
[git/git.git] / perl / Git.pm
CommitLineData
b1edc53d
PB
1=head1 NAME
2
3Git - Perl interface to the Git version control system
4
5=cut
6
7
8package Git;
9
10use strict;
11
12
13BEGIN {
14
15our ($VERSION, @ISA, @EXPORT, @EXPORT_OK);
16
17# Totally unstable API.
18$VERSION = '0.01';
19
20
21=head1 SYNOPSIS
22
23 use Git;
24
25 my $version = Git::command_oneline('version');
26
8b9150e3
PB
27 git_cmd_try { Git::command_noisy('update-server-info') }
28 '%s failed w/ code %d';
b1edc53d
PB
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
d79850e1 35 my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
b1edc53d 36 my $lastrev = <$fh>; chomp $lastrev;
8b9150e3 37 $repo->command_close_pipe($fh, $c);
b1edc53d 38
d43ba468
PB
39 my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
40 STDERR => 0 );
b1edc53d
PB
41
42=cut
43
44
45require Exporter;
46
47@ISA = qw(Exporter);
48
8b9150e3 49@EXPORT = qw(git_cmd_try);
b1edc53d
PB
50
51# Methods which can be called as standalone functions as well:
d79850e1
PB
52@EXPORT_OK = qw(command command_oneline command_noisy
53 command_output_pipe command_input_pipe command_close_pipe
8b9150e3 54 version exec_path hash_object git_cmd_try);
b1edc53d
PB
55
56
57=head1 DESCRIPTION
58
59This module provides Perl scripts easy way to interface the Git version control
60system. The modules have an easy and well-tested way to call arbitrary Git
61commands; in the future, the interface will also provide specialized methods
62for doing easily operations which are not totally trivial to do over
63the generic command interface.
64
65While some commands can be executed outside of any context (e.g. 'version'
66or 'init-db'), most operations require a repository context, which in practice
67means getting an instance of the Git object using the repository() constructor.
68(In the future, we will also get a new_repository() constructor.) All commands
69called as methods of the object are then executed in the context of the
70repository.
71
d5c7721d
PB
72Part of the "repository state" is also information about path to the attached
73working copy (unless you work with a bare repository). You can also navigate
74inside of the working copy using the C<wc_chdir()> method. (Note that
75the repository object is self-contained and will not change working directory
76of your process.)
b1edc53d 77
d5c7721d 78TODO: In the future, we might also do
b1edc53d
PB
79
80 my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master');
81 $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/');
82 my @refs = $remoterepo->refs();
83
b1edc53d
PB
84Currently, the module merely wraps calls to external Git tools. In the future,
85it will provide a much faster way to interact with Git by linking directly
86to libgit. This should be completely opaque to the user, though (performance
87increate nonwithstanding).
88
89=cut
90
91
8b9150e3 92use Carp qw(carp croak); # but croak is bad - throw instead
97b16c06 93use Error qw(:try);
d5c7721d 94use Cwd qw(abs_path);
b1edc53d
PB
95
96require XSLoader;
97XSLoader::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
112Construct a new repository object.
113C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
114Possible options are:
115
116B<Repository> - Path to the Git repository.
117
118B<WorkingCopy> - Path to the associated working copy; not strictly required
119as many commands will happily crunch on a bare repository.
120
d5c7721d
PB
121B<WorkingSubdir> - Subdirectory in the working copy to work inside.
122Just left undefined if you do not want to limit the scope of operations.
123
124B<Directory> - Path to the Git working directory in its usual setup.
125The C<.git> directory is searched in the directory and all the parent
126directories; if found, C<WorkingCopy> is set to the directory containing
127it and C<Repository> to the C<.git> directory itself. If no C<.git>
128directory was found, the C<Directory> is assumed to be a bare repository,
129C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
130If the C<$GIT_DIR> environment variable is set, things behave as expected
131as well.
b1edc53d 132
b1edc53d
PB
133You should not use both C<Directory> and either of C<Repository> and
134C<WorkingCopy> - the results of that are undefined.
135
136Alternatively, a directory path may be passed as a single scalar argument
137to the constructor; it is equivalent to setting only the C<Directory> option
138field.
139
140Calling the constructor with no options whatsoever is equivalent to
d5c7721d
PB
141calling it with C<< Directory => '.' >>. In general, if you are building
142a standard porcelain command, simply doing C<< Git->repository() >> should
143do the right thing and setup the object to reflect exactly where the user
144is right now.
b1edc53d
PB
145
146=cut
147
148sub repository {
149 my $class = shift;
150 my @args = @_;
151 my %opts = ();
152 my $self;
153
154 if (defined $args[0]) {
155 if ($#args % 2 != 1) {
156 # Not a hash.
97b16c06
PB
157 $#args == 0 or throw Error::Simple("bad usage");
158 %opts = ( Directory => $args[0] );
b1edc53d
PB
159 } else {
160 %opts = @args;
161 }
d5c7721d
PB
162 }
163
164 if (not defined $opts{Repository} and not defined $opts{WorkingCopy}) {
165 $opts{Directory} ||= '.';
166 }
167
168 if ($opts{Directory}) {
169 -d $opts{Directory} or throw Error::Simple("Directory not found: $!");
170
171 my $search = Git->repository(WorkingCopy => $opts{Directory});
172 my $dir;
173 try {
174 $dir = $search->command_oneline(['rev-parse', '--git-dir'],
175 STDERR => 0);
176 } catch Git::Error::Command with {
177 $dir = undef;
178 };
b1edc53d 179
d5c7721d 180 if ($dir) {
71efe0ca
PB
181 $dir =~ m#^/# or $dir = $opts{Directory} . '/' . $dir;
182 $opts{Repository} = $dir;
d5c7721d
PB
183
184 # If --git-dir went ok, this shouldn't die either.
185 my $prefix = $search->command_oneline('rev-parse', '--show-prefix');
186 $dir = abs_path($opts{Directory}) . '/';
187 if ($prefix) {
188 if (substr($dir, -length($prefix)) ne $prefix) {
189 throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix");
190 }
191 substr($dir, -length($prefix)) = '';
b1edc53d 192 }
d5c7721d
PB
193 $opts{WorkingCopy} = $dir;
194 $opts{WorkingSubdir} = $prefix;
195
196 } else {
197 # A bare repository? Let's see...
198 $dir = $opts{Directory};
199
200 unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") {
201 # Mimick git-rev-parse --git-dir error message:
202 throw Error::Simple('fatal: Not a git repository');
203 }
204 my $search = Git->repository(Repository => $dir);
205 try {
206 $search->command('symbolic-ref', 'HEAD');
207 } catch Git::Error::Command with {
208 # Mimick git-rev-parse --git-dir error message:
209 throw Error::Simple('fatal: Not a git repository');
210 }
211
212 $opts{Repository} = abs_path($dir);
b1edc53d 213 }
d5c7721d
PB
214
215 delete $opts{Directory};
b1edc53d
PB
216 }
217
218 $self = { opts => \%opts };
219 bless $self, $class;
220}
221
222
223=back
224
225=head1 METHODS
226
227=over 4
228
229=item command ( COMMAND [, ARGUMENTS... ] )
230
d43ba468
PB
231=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
232
b1edc53d
PB
233Execute the given Git C<COMMAND> (specify it without the 'git-'
234prefix), optionally with the specified extra C<ARGUMENTS>.
235
d43ba468
PB
236The second more elaborate form can be used if you want to further adjust
237the command execution. Currently, only one option is supported:
238
239B<STDERR> - How to deal with the command's error output. By default (C<undef>)
240it is delivered to the caller's C<STDERR>. A false value (0 or '') will cause
241it to be thrown away. If you want to process it, you can get it in a filehandle
242you specify, but you must be extremely careful; if the error output is not
243very short and you want to read it in the same process as where you called
244C<command()>, you are set up for a nice deadlock!
245
b1edc53d
PB
246The method can be called without any instance or on a specified Git repository
247(in that case the command will be run in the repository context).
248
249In scalar context, it returns all the command output in a single string
250(verbatim).
251
252In array context, it returns an array containing lines printed to the
253command's stdout (without trailing newlines).
254
255In both cases, the command's stdin and stderr are the same as the caller's.
256
257=cut
258
259sub command {
d79850e1 260 my ($fh, $ctx) = command_output_pipe(@_);
b1edc53d
PB
261
262 if (not defined wantarray) {
8b9150e3
PB
263 # Nothing to pepper the possible exception with.
264 _cmd_close($fh, $ctx);
b1edc53d
PB
265
266 } elsif (not wantarray) {
267 local $/;
268 my $text = <$fh>;
8b9150e3
PB
269 try {
270 _cmd_close($fh, $ctx);
271 } catch Git::Error::Command with {
272 # Pepper with the output:
273 my $E = shift;
274 $E->{'-outputref'} = \$text;
275 throw $E;
276 };
b1edc53d
PB
277 return $text;
278
279 } else {
280 my @lines = <$fh>;
b1edc53d 281 chomp @lines;
8b9150e3
PB
282 try {
283 _cmd_close($fh, $ctx);
284 } catch Git::Error::Command with {
285 my $E = shift;
286 $E->{'-outputref'} = \@lines;
287 throw $E;
288 };
b1edc53d
PB
289 return @lines;
290 }
291}
292
293
294=item command_oneline ( COMMAND [, ARGUMENTS... ] )
295
d43ba468
PB
296=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
297
b1edc53d
PB
298Execute the given C<COMMAND> in the same way as command()
299does but always return a scalar string containing the first line
300of the command's standard output.
301
302=cut
303
304sub command_oneline {
d79850e1 305 my ($fh, $ctx) = command_output_pipe(@_);
b1edc53d
PB
306
307 my $line = <$fh>;
d5c7721d 308 defined $line and chomp $line;
8b9150e3
PB
309 try {
310 _cmd_close($fh, $ctx);
311 } catch Git::Error::Command with {
312 # Pepper with the output:
313 my $E = shift;
314 $E->{'-outputref'} = \$line;
315 throw $E;
316 };
b1edc53d
PB
317 return $line;
318}
319
320
d79850e1 321=item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
b1edc53d 322
d43ba468
PB
323=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
324
b1edc53d
PB
325Execute the given C<COMMAND> in the same way as command()
326does but return a pipe filehandle from which the command output can be
327read.
328
d79850e1
PB
329The function can return C<($pipe, $ctx)> in array context.
330See C<command_close_pipe()> for details.
331
b1edc53d
PB
332=cut
333
d79850e1
PB
334sub command_output_pipe {
335 _command_common_pipe('-|', @_);
336}
b1edc53d 337
b1edc53d 338
d79850e1
PB
339=item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
340
d43ba468
PB
341=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
342
d79850e1
PB
343Execute the given C<COMMAND> in the same way as command_output_pipe()
344does but return an input pipe filehandle instead; the command output
345is not captured.
346
347The function can return C<($pipe, $ctx)> in array context.
348See C<command_close_pipe()> for details.
349
350=cut
351
352sub command_input_pipe {
353 _command_common_pipe('|-', @_);
8b9150e3
PB
354}
355
356
357=item command_close_pipe ( PIPE [, CTX ] )
358
d79850e1 359Close the C<PIPE> as returned from C<command_*_pipe()>, checking
8b9150e3
PB
360whether the command finished successfuly. The optional C<CTX> argument
361is required if you want to see the command name in the error message,
d79850e1 362and it is the second value returned by C<command_*_pipe()> when
8b9150e3
PB
363called in array context. The call idiom is:
364
d79850e1
PB
365 my ($fh, $ctx) = $r->command_output_pipe('status');
366 while (<$fh>) { ... }
367 $r->command_close_pipe($fh, $ctx);
8b9150e3
PB
368
369Note that you should not rely on whatever actually is in C<CTX>;
370currently it is simply the command name but in future the context might
371have more complicated structure.
372
373=cut
374
375sub command_close_pipe {
376 my ($self, $fh, $ctx) = _maybe_self(@_);
377 $ctx ||= '<unknown>';
378 _cmd_close($fh, $ctx);
b1edc53d
PB
379}
380
381
382=item command_noisy ( COMMAND [, ARGUMENTS... ] )
383
384Execute the given C<COMMAND> in the same way as command() does but do not
385capture the command output - the standard output is not redirected and goes
386to the standard output of the caller application.
387
388While the method is called command_noisy(), you might want to as well use
389it for the most silent Git commands which you know will never pollute your
390stdout but you want to avoid the overhead of the pipe setup when calling them.
391
392The function returns only after the command has finished running.
393
394=cut
395
396sub command_noisy {
397 my ($self, $cmd, @args) = _maybe_self(@_);
d79850e1 398 _check_valid_cmd($cmd);
b1edc53d
PB
399
400 my $pid = fork;
401 if (not defined $pid) {
97b16c06 402 throw Error::Simple("fork failed: $!");
b1edc53d
PB
403 } elsif ($pid == 0) {
404 _cmd_exec($self, $cmd, @args);
405 }
8b9150e3
PB
406 if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
407 throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
b1edc53d
PB
408 }
409}
410
411
63df97ae
PB
412=item version ()
413
414Return the Git version in use.
415
416Implementation of this function is very fast; no external command calls
417are involved.
418
419=cut
420
421# Implemented in Git.xs.
422
423
eca1f6fd
PB
424=item exec_path ()
425
d5c7721d 426Return path to the Git sub-command executables (the same as
eca1f6fd
PB
427C<git --exec-path>). Useful mostly only internally.
428
429Implementation of this function is very fast; no external command calls
430are involved.
431
432=cut
433
434# Implemented in Git.xs.
435
436
d5c7721d
PB
437=item repo_path ()
438
439Return path to the git repository. Must be called on a repository instance.
440
441=cut
442
443sub repo_path { $_[0]->{opts}->{Repository} }
444
445
446=item wc_path ()
447
448Return path to the working copy. Must be called on a repository instance.
449
450=cut
451
452sub wc_path { $_[0]->{opts}->{WorkingCopy} }
453
454
455=item wc_subdir ()
456
457Return path to the subdirectory inside of a working copy. Must be called
458on a repository instance.
459
460=cut
461
462sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' }
463
464
465=item wc_chdir ( SUBDIR )
466
467Change the working copy subdirectory to work within. The C<SUBDIR> is
468relative to the working copy root directory (not the current subdirectory).
469Must be called on a repository instance attached to a working copy
470and the directory must exist.
471
472=cut
473
474sub wc_chdir {
475 my ($self, $subdir) = @_;
476
477 $self->wc_path()
478 or throw Error::Simple("bare repository");
479
480 -d $self->wc_path().'/'.$subdir
481 or throw Error::Simple("subdir not found: $!");
482 # Of course we will not "hold" the subdirectory so anyone
483 # can delete it now and we will never know. But at least we tried.
484
485 $self->{opts}->{WorkingSubdir} = $subdir;
486}
487
488
24c4b714 489=item hash_object ( TYPE, FILENAME )
b1edc53d 490
24c4b714 491=item hash_object ( TYPE, FILEHANDLE )
b1edc53d
PB
492
493Compute the SHA1 object id of the given C<FILENAME> (or data waiting in
24c4b714
PB
494C<FILEHANDLE>) considering it is of the C<TYPE> object type (C<blob>,
495C<commit>, C<tree>).
b1edc53d
PB
496
497In case of C<FILEHANDLE> passed instead of file name, all the data
498available are read and hashed, and the filehandle is automatically
499closed. The file handle should be freshly opened - if you have already
500read anything from the file handle, the results are undefined (since
501this function works directly with the file descriptor and internal
502PerlIO buffering might have messed things up).
503
504The method can be called without any instance or on a specified Git repository,
505it makes zero difference.
506
507The function returns the SHA1 hash.
508
509Implementation of this function is very fast; no external command calls
510are involved.
511
512=cut
513
e6634ac9
PB
514sub hash_object {
515 my ($self, $type, $file) = _maybe_self(@_);
516
517 # hash_object_* implemented in Git.xs.
518
519 if (ref($file) eq 'GLOB') {
520 my $hash = hash_object_pipe($type, fileno($file));
521 close $file;
522 return $hash;
523 } else {
524 hash_object_file($type, $file);
525 }
526}
b1edc53d
PB
527
528
8b9150e3 529
b1edc53d
PB
530=back
531
97b16c06 532=head1 ERROR HANDLING
b1edc53d 533
97b16c06 534All functions are supposed to throw Perl exceptions in case of errors.
8b9150e3
PB
535See the L<Error> module on how to catch those. Most exceptions are mere
536L<Error::Simple> instances.
537
538However, the C<command()>, C<command_oneline()> and C<command_noisy()>
539functions suite can throw C<Git::Error::Command> exceptions as well: those are
540thrown when the external command returns an error code and contain the error
541code as well as access to the captured command's output. The exception class
542provides the usual C<stringify> and C<value> (command's exit code) methods and
543in addition also a C<cmd_output> method that returns either an array or a
544string with the captured command output (depending on the original function
545call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
546returns the command and its arguments (but without proper quoting).
547
d79850e1 548Note that the C<command_*_pipe()> functions cannot throw this exception since
8b9150e3
PB
549it has no idea whether the command failed or not. You will only find out
550at the time you C<close> the pipe; if you want to have that automated,
551use C<command_close_pipe()>, which can throw the exception.
552
553=cut
554
555{
556 package Git::Error::Command;
557
558 @Git::Error::Command::ISA = qw(Error);
559
560 sub new {
561 my $self = shift;
562 my $cmdline = '' . shift;
563 my $value = 0 + shift;
564 my $outputref = shift;
565 my(@args) = ();
566
567 local $Error::Depth = $Error::Depth + 1;
568
569 push(@args, '-cmdline', $cmdline);
570 push(@args, '-value', $value);
571 push(@args, '-outputref', $outputref);
572
573 $self->SUPER::new(-text => 'command returned error', @args);
574 }
575
576 sub stringify {
577 my $self = shift;
578 my $text = $self->SUPER::stringify;
579 $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n";
580 }
581
582 sub cmdline {
583 my $self = shift;
584 $self->{'-cmdline'};
585 }
586
587 sub cmd_output {
588 my $self = shift;
589 my $ref = $self->{'-outputref'};
590 defined $ref or undef;
591 if (ref $ref eq 'ARRAY') {
592 return @$ref;
593 } else { # SCALAR
594 return $$ref;
595 }
596 }
597}
598
599=over 4
600
601=item git_cmd_try { CODE } ERRMSG
602
603This magical statement will automatically catch any C<Git::Error::Command>
604exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
605on its lips; the message will have %s substituted for the command line
606and %d for the exit status. This statement is useful mostly for producing
607more user-friendly error messages.
608
609In case of no exception caught the statement returns C<CODE>'s return value.
610
611Note that this is the only auto-exported function.
612
613=cut
614
615sub git_cmd_try(&$) {
616 my ($code, $errmsg) = @_;
617 my @result;
618 my $err;
619 my $array = wantarray;
620 try {
621 if ($array) {
622 @result = &$code;
623 } else {
624 $result[0] = &$code;
625 }
626 } catch Git::Error::Command with {
627 my $E = shift;
628 $err = $errmsg;
629 $err =~ s/\%s/$E->cmdline()/ge;
630 $err =~ s/\%d/$E->value()/ge;
631 # We can't croak here since Error.pm would mangle
632 # that to Error::Simple.
633 };
634 $err and croak $err;
635 return $array ? @result : $result[0];
636}
637
638
639=back
b1edc53d
PB
640
641=head1 COPYRIGHT
642
643Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
644
645This module is free software; it may be used, copied, modified
646and distributed under the terms of the GNU General Public Licence,
647either version 2, or (at your option) any later version.
648
649=cut
650
651
652# Take raw method argument list and return ($obj, @args) in case
653# the method was called upon an instance and (undef, @args) if
654# it was called directly.
655sub _maybe_self {
656 # This breaks inheritance. Oh well.
657 ref $_[0] eq 'Git' ? @_ : (undef, @_);
658}
659
d79850e1
PB
660# Check if the command id is something reasonable.
661sub _check_valid_cmd {
662 my ($cmd) = @_;
663 $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd");
664}
665
666# Common backend for the pipe creators.
667sub _command_common_pipe {
668 my $direction = shift;
d43ba468
PB
669 my ($self, @p) = _maybe_self(@_);
670 my (%opts, $cmd, @args);
671 if (ref $p[0]) {
672 ($cmd, @args) = @{shift @p};
673 %opts = ref $p[0] ? %{$p[0]} : @p;
674 } else {
675 ($cmd, @args) = @p;
676 }
d79850e1
PB
677 _check_valid_cmd($cmd);
678
a6065b54
PB
679 my $fh;
680 if ($^O eq '##INSERT_ACTIVESTATE_STRING_HERE##') {
681 # ActiveState Perl
682 #defined $opts{STDERR} and
683 # warn 'ignoring STDERR option - running w/ ActiveState';
684 $direction eq '-|' or
685 die 'input pipe for ActiveState not implemented';
686 tie ($fh, 'Git::activestate_pipe', $cmd, @args);
687
688 } else {
689 my $pid = open($fh, $direction);
690 if (not defined $pid) {
691 throw Error::Simple("open failed: $!");
692 } elsif ($pid == 0) {
693 if (defined $opts{STDERR}) {
694 close STDERR;
695 }
696 if ($opts{STDERR}) {
697 open (STDERR, '>&', $opts{STDERR})
698 or die "dup failed: $!";
699 }
700 _cmd_exec($self, $cmd, @args);
d43ba468 701 }
d79850e1
PB
702 }
703 return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh;
704}
705
b1edc53d
PB
706# When already in the subprocess, set up the appropriate state
707# for the given repository and execute the git command.
708sub _cmd_exec {
709 my ($self, @args) = @_;
710 if ($self) {
d5c7721d
PB
711 $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path();
712 $self->wc_path() and chdir($self->wc_path());
713 $self->wc_subdir() and chdir($self->wc_subdir());
b1edc53d 714 }
97b16c06
PB
715 _execv_git_cmd(@args);
716 die "exec failed: $!";
b1edc53d
PB
717}
718
8062f81c
PB
719# Execute the given Git command ($_[0]) with arguments ($_[1..])
720# by searching for it at proper places.
721# _execv_git_cmd(), implemented in Git.xs.
722
b1edc53d
PB
723# Close pipe to a subprocess.
724sub _cmd_close {
8b9150e3 725 my ($fh, $ctx) = @_;
b1edc53d
PB
726 if (not close $fh) {
727 if ($!) {
728 # It's just close, no point in fatalities
729 carp "error closing pipe: $!";
730 } elsif ($? >> 8) {
8b9150e3
PB
731 # The caller should pepper this.
732 throw Git::Error::Command($ctx, $? >> 8);
b1edc53d
PB
733 }
734 # else we might e.g. closed a live stream; the command
735 # dying of SIGPIPE would drive us here.
736 }
737}
738
739
740# Trickery for .xs routines: In order to avoid having some horrid
741# C code trying to do stuff with undefs and hashes, we gate all
742# xs calls through the following and in case we are being ran upon
743# an instance call a C part of the gate which will set up the
744# environment properly.
745sub _call_gate {
746 my $xsfunc = shift;
747 my ($self, @args) = _maybe_self(@_);
748
749 if (defined $self) {
750 # XXX: We ignore the WorkingCopy! To properly support
751 # that will require heavy changes in libgit.
752
753 # XXX: And we ignore everything else as well. libgit
754 # at least needs to be extended to let us specify
755 # the $GIT_DIR instead of looking it up in environment.
756 #xs_call_gate($self->{opts}->{Repository});
757 }
758
97b16c06
PB
759 # Having to call throw from the C code is a sure path to insanity.
760 local $SIG{__DIE__} = sub { throw Error::Simple("@_"); };
b1edc53d
PB
761 &$xsfunc(@args);
762}
763
764sub AUTOLOAD {
765 my $xsname;
766 our $AUTOLOAD;
767 ($xsname = $AUTOLOAD) =~ s/.*:://;
97b16c06 768 throw Error::Simple("&Git::$xsname not defined") if $xsname =~ /^xs_/;
b1edc53d
PB
769 $xsname = 'xs_'.$xsname;
770 _call_gate(\&$xsname, @_);
771}
772
773sub DESTROY { }
774
775
a6065b54
PB
776# Pipe implementation for ActiveState Perl.
777
778package Git::activestate_pipe;
779use strict;
780
781sub TIEHANDLE {
782 my ($class, @params) = @_;
783 # FIXME: This is probably horrible idea and the thing will explode
784 # at the moment you give it arguments that require some quoting,
785 # but I have no ActiveState clue... --pasky
786 my $cmdline = join " ", @params;
787 my @data = qx{$cmdline};
788 bless { i => 0, data => \@data }, $class;
789}
790
791sub READLINE {
792 my $self = shift;
793 if ($self->{i} >= scalar @{$self->{data}}) {
794 return undef;
795 }
796 return $self->{'data'}->[ $self->{i}++ ];
797}
798
799sub CLOSE {
800 my $self = shift;
801 delete $self->{data};
802 delete $self->{i};
803}
804
805sub EOF {
806 my $self = shift;
807 return ($self->{i} >= scalar @{$self->{data}});
808}
809
810
b1edc53d 8111; # Famous last words