From b1edc53d062c4f6adae08a15be08d6e7bccd242e Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:29 +0200 Subject: Introduce Git.pm (v4) This patch introduces a very basic and barebone Git.pm module with a sketch of how the generic interface would look like; most functions are missing, but this should give some good base. I will continue expanding it. Most desirable now is more careful error reporting, generic_in() for feeding input to Git commands and the repository() constructor doing some poking with git-rev-parse to get the git directory and subdirectory prefix. Those three are basically the prerequisities for converting git-mv. I will send them as follow-ups to this patch. Currently Git.pm just wraps up exec()s of Git commands, but even that is not trivial to get right and various Git perl scripts do it in various inconsistent ways. In addition to Git.pm, there is now also Git.xs which provides barebone Git.xs for directly interfacing with libgit.a, and as an example providing the hash_object() function using libgit. This adds the Git module, integrates it to the build system and as an example converts the git-fmt-merge-msg.perl script to it (the result is not very impressive since its advantage is not quite apparent in this one, but I just picked up the simplest Git user around). Compared to v3, only very minor things were fixed in this patch (some whitespaces, a missing export, tiny bug in git-fmt-merge-msg.perl); at first I wanted to post them as a separate patch but since this is still only in pu, I decided that it will be cleaner to just resend the patch. My current working state is available all the time at http://pasky.or.cz/~xpasky/git-perl/Git.pm and an irregularily updated API documentation is at http://pasky.or.cz/~xpasky/git-perl/Git.html Many thanks to Jakub Narebski, Junio and others for their feedback. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index cde619c..730b38a 100644 --- a/Makefile +++ b/Makefile @@ -490,7 +490,8 @@ export prefix TAR INSTALL DESTDIR SHELL_PATH template_dir all: $(ALL_PROGRAMS) $(BUILT_INS) git$X gitk -all: +all: perl/Makefile + $(MAKE) -C perl $(MAKE) -C templates strip: $(PROGRAMS) git$X @@ -522,7 +523,7 @@ $(patsubst %.sh,%,$(SCRIPT_SH)) : % : %.sh $(patsubst %.perl,%,$(SCRIPT_PERL)) : % : %.perl rm -f $@ $@+ - sed -e '1s|#!.*perl|#!$(PERL_PATH_SQ)|' \ + sed -e '1s|#!.*perl\(.*\)|#!$(PERL_PATH_SQ)\1 -I'"$$(make -s -C perl instlibdir)"'|' \ -e 's/@@GIT_VERSION@@/$(GIT_VERSION)/g' \ $@.perl >$@+ chmod +x $@+ @@ -608,6 +609,9 @@ $(XDIFF_LIB): $(XDIFF_OBJS) rm -f $@ && $(AR) rcs $@ $(XDIFF_OBJS) +perl/Makefile: perl/Git.pm perl/Makefile.PL + (cd perl && $(PERL_PATH) Makefile.PL PREFIX="$(prefix)" DEFINE="$(ALL_CFLAGS)" LIBS="$(LIBS)") + doc: $(MAKE) -C Documentation all @@ -663,6 +667,7 @@ install: all $(INSTALL) $(ALL_PROGRAMS) '$(DESTDIR_SQ)$(gitexecdir_SQ)' $(INSTALL) git$X gitk '$(DESTDIR_SQ)$(bindir_SQ)' $(MAKE) -C templates install + $(MAKE) -C perl install $(INSTALL) -d -m755 '$(DESTDIR_SQ)$(GIT_PYTHON_DIR_SQ)' $(INSTALL) $(PYMODULES) '$(DESTDIR_SQ)$(GIT_PYTHON_DIR_SQ)' if test 'z$(bindir_SQ)' != 'z$(gitexecdir_SQ)'; \ @@ -730,7 +735,8 @@ clean: rm -f $(GIT_TARNAME).tar.gz git-core_$(GIT_VERSION)-*.tar.gz rm -f $(htmldocs).tar.gz $(manpages).tar.gz $(MAKE) -C Documentation/ clean - $(MAKE) -C templates clean + [ ! -e perl/Makefile ] || $(MAKE) -C perl/ clean + $(MAKE) -C templates/ clean $(MAKE) -C t/ clean rm -f GIT-VERSION-FILE GIT-CFLAGS diff --git a/git-fmt-merge-msg.perl b/git-fmt-merge-msg.perl index 5986e54..be2a48c 100755 --- a/git-fmt-merge-msg.perl +++ b/git-fmt-merge-msg.perl @@ -6,6 +6,9 @@ # by grouping branches and tags together to form a single line. use strict; +use Git; + +my $repo = Git->repository(); my @src; my %src; @@ -28,13 +31,12 @@ sub andjoin { } sub repoconfig { - my ($val) = qx{git-repo-config --get merge.summary}; + my ($val) = $repo->command_oneline('repo-config', '--get', 'merge.summary'); return $val; } sub current_branch { - my ($bra) = qx{git-symbolic-ref HEAD}; - chomp($bra); + my ($bra) = $repo->command_oneline('symbolic-ref', 'HEAD'); $bra =~ s|^refs/heads/||; if ($bra ne 'master') { $bra = " into $bra"; @@ -47,11 +49,10 @@ sub current_branch { sub shortlog { my ($tip) = @_; my @result; - foreach ( qx{git-log --no-merges --topo-order --pretty=oneline $tip ^HEAD} ) { + foreach ($repo->command('log', '--no-merges', '--topo-order', '--pretty=oneline', $tip, '^HEAD')) { s/^[0-9a-f]{40}\s+//; push @result, $_; } - die "git-log failed\n" if $?; return @result; } @@ -168,6 +169,6 @@ for (@origin) { print " ...\n"; last; } - print " $log"; + print " $log\n"; } } diff --git a/perl/.gitignore b/perl/.gitignore new file mode 100644 index 0000000..6d778f3 --- /dev/null +++ b/perl/.gitignore @@ -0,0 +1,7 @@ +Git.bs +Git.c +Makefile +blib +blibdirs +pm_to_blib +ppport.h diff --git a/perl/Git.pm b/perl/Git.pm new file mode 100644 index 0000000..8fff785 --- /dev/null +++ b/perl/Git.pm @@ -0,0 +1,408 @@ +=head1 NAME + +Git - Perl interface to the Git version control system + +=cut + + +package Git; + +use strict; + + +BEGIN { + +our ($VERSION, @ISA, @EXPORT, @EXPORT_OK); + +# Totally unstable API. +$VERSION = '0.01'; + + +=head1 SYNOPSIS + + use Git; + + my $version = Git::command_oneline('version'); + + Git::command_noisy('update-server-info'); + + my $repo = Git->repository (Directory => '/srv/git/cogito.git'); + + + my @revs = $repo->command('rev-list', '--since=last monday', '--all'); + + my $fh = $repo->command_pipe('rev-list', '--since=last monday', '--all'); + my $lastrev = <$fh>; chomp $lastrev; + close $fh; # You may want to test rev-list exit status here + + my $lastrev = $repo->command_oneline('rev-list', '--all'); + +=cut + + +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw(); + +# Methods which can be called as standalone functions as well: +@EXPORT_OK = qw(command command_oneline command_pipe command_noisy + hash_object); + + +=head1 DESCRIPTION + +This module provides Perl scripts easy way to interface the Git version control +system. The modules have an easy and well-tested way to call arbitrary Git +commands; in the future, the interface will also provide specialized methods +for doing easily operations which are not totally trivial to do over +the generic command interface. + +While some commands can be executed outside of any context (e.g. 'version' +or 'init-db'), most operations require a repository context, which in practice +means getting an instance of the Git object using the repository() constructor. +(In the future, we will also get a new_repository() constructor.) All commands +called as methods of the object are then executed in the context of the +repository. + +TODO: In the future, we might also do + + my $subdir = $repo->subdir('Documentation'); + # Gets called in the subdirectory context: + $subdir->command('status'); + + my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master'); + $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/'); + my @refs = $remoterepo->refs(); + +So far, all functions just die if anything goes wrong. If you don't want that, +make appropriate provisions to catch the possible deaths. Better error recovery +mechanisms will be provided in the future. + +Currently, the module merely wraps calls to external Git tools. In the future, +it will provide a much faster way to interact with Git by linking directly +to libgit. This should be completely opaque to the user, though (performance +increate nonwithstanding). + +=cut + + +use Carp qw(carp croak); + +require XSLoader; +XSLoader::load('Git', $VERSION); + +} + + +=head1 CONSTRUCTORS + +=over 4 + +=item repository ( OPTIONS ) + +=item repository ( DIRECTORY ) + +=item repository () + +Construct a new repository object. +C are passed in a hash like fashion, using key and value pairs. +Possible options are: + +B - Path to the Git repository. + +B - Path to the associated working copy; not strictly required +as many commands will happily crunch on a bare repository. + +B - Path to the Git working directory in its usual setup. This +is just for convenient setting of both C and C +at once: If the directory as a C<.git> subdirectory, C is pointed +to the subdirectory and the directory is assumed to be the working copy. +If the directory does not have the subdirectory, C is left +undefined and C is pointed to the directory itself. + +B - Path to the C binary executable. By default the C<$PATH> +is searched for it. + +You should not use both C and either of C and +C - the results of that are undefined. + +Alternatively, a directory path may be passed as a single scalar argument +to the constructor; it is equivalent to setting only the C option +field. + +Calling the constructor with no options whatsoever is equivalent to +calling it with C<< Directory => '.' >>. + +=cut + +sub repository { + my $class = shift; + my @args = @_; + my %opts = (); + my $self; + + if (defined $args[0]) { + if ($#args % 2 != 1) { + # Not a hash. + $#args == 0 or croak "bad usage"; + %opts = (Directory => $args[0]); + } else { + %opts = @args; + } + + if ($opts{Directory}) { + -d $opts{Directory} or croak "Directory not found: $!"; + if (-d $opts{Directory}."/.git") { + # TODO: Might make this more clever + $opts{WorkingCopy} = $opts{Directory}; + $opts{Repository} = $opts{Directory}."/.git"; + } else { + $opts{Repository} = $opts{Directory}; + } + delete $opts{Directory}; + } + } + + $self = { opts => \%opts }; + bless $self, $class; +} + + +=back + +=head1 METHODS + +=over 4 + +=item command ( COMMAND [, ARGUMENTS... ] ) + +Execute the given Git C (specify it without the 'git-' +prefix), optionally with the specified extra C. + +The method can be called without any instance or on a specified Git repository +(in that case the command will be run in the repository context). + +In scalar context, it returns all the command output in a single string +(verbatim). + +In array context, it returns an array containing lines printed to the +command's stdout (without trailing newlines). + +In both cases, the command's stdin and stderr are the same as the caller's. + +=cut + +sub command { + my $fh = command_pipe(@_); + + if (not defined wantarray) { + _cmd_close($fh); + + } elsif (not wantarray) { + local $/; + my $text = <$fh>; + _cmd_close($fh); + return $text; + + } else { + my @lines = <$fh>; + _cmd_close($fh); + chomp @lines; + return @lines; + } +} + + +=item command_oneline ( COMMAND [, ARGUMENTS... ] ) + +Execute the given C in the same way as command() +does but always return a scalar string containing the first line +of the command's standard output. + +=cut + +sub command_oneline { + my $fh = command_pipe(@_); + + my $line = <$fh>; + _cmd_close($fh); + + chomp $line; + return $line; +} + + +=item command_pipe ( COMMAND [, ARGUMENTS... ] ) + +Execute the given C in the same way as command() +does but return a pipe filehandle from which the command output can be +read. + +=cut + +sub command_pipe { + my ($self, $cmd, @args) = _maybe_self(@_); + + $cmd =~ /^[a-z0-9A-Z_-]+$/ or croak "bad command: $cmd"; + + my $pid = open(my $fh, "-|"); + if (not defined $pid) { + croak "open failed: $!"; + } elsif ($pid == 0) { + _cmd_exec($self, $cmd, @args); + } + return $fh; +} + + +=item command_noisy ( COMMAND [, ARGUMENTS... ] ) + +Execute the given C in the same way as command() does but do not +capture the command output - the standard output is not redirected and goes +to the standard output of the caller application. + +While the method is called command_noisy(), you might want to as well use +it for the most silent Git commands which you know will never pollute your +stdout but you want to avoid the overhead of the pipe setup when calling them. + +The function returns only after the command has finished running. + +=cut + +sub command_noisy { + my ($self, $cmd, @args) = _maybe_self(@_); + + $cmd =~ /^[a-z0-9A-Z_-]+$/ or croak "bad command: $cmd"; + + my $pid = fork; + if (not defined $pid) { + croak "fork failed: $!"; + } elsif ($pid == 0) { + _cmd_exec($self, $cmd, @args); + } + if (waitpid($pid, 0) > 0 and $? != 0) { + croak "exit status: $?"; + } +} + + +=item hash_object ( FILENAME [, TYPE ] ) + +=item hash_object ( FILEHANDLE [, TYPE ] ) + +Compute the SHA1 object id of the given C (or data waiting in +C) considering it is of the C object type (C +(default), C, C). + +In case of C passed instead of file name, all the data +available are read and hashed, and the filehandle is automatically +closed. The file handle should be freshly opened - if you have already +read anything from the file handle, the results are undefined (since +this function works directly with the file descriptor and internal +PerlIO buffering might have messed things up). + +The method can be called without any instance or on a specified Git repository, +it makes zero difference. + +The function returns the SHA1 hash. + +Implementation of this function is very fast; no external command calls +are involved. + +=cut + +# Implemented in Git.xs. + + +=back + +=head1 TODO + +This is still fairly crude. +We need some good way to report errors back except just dying. + +=head1 COPYRIGHT + +Copyright 2006 by Petr Baudis Epasky@suse.czE. + +This module is free software; it may be used, copied, modified +and distributed under the terms of the GNU General Public Licence, +either version 2, or (at your option) any later version. + +=cut + + +# Take raw method argument list and return ($obj, @args) in case +# the method was called upon an instance and (undef, @args) if +# it was called directly. +sub _maybe_self { + # This breaks inheritance. Oh well. + ref $_[0] eq 'Git' ? @_ : (undef, @_); +} + +# When already in the subprocess, set up the appropriate state +# for the given repository and execute the git command. +sub _cmd_exec { + my ($self, @args) = @_; + if ($self) { + $self->{opts}->{Repository} and $ENV{'GIT_DIR'} = $self->{opts}->{Repository}; + $self->{opts}->{WorkingCopy} and chdir($self->{opts}->{WorkingCopy}); + } + my $git = $self->{opts}->{GitPath}; + $git ||= 'git'; + exec ($git, @args) or croak "exec failed: $!"; +} + +# Close pipe to a subprocess. +sub _cmd_close { + my ($fh) = @_; + if (not close $fh) { + if ($!) { + # It's just close, no point in fatalities + carp "error closing pipe: $!"; + } elsif ($? >> 8) { + croak "exit status: ".($? >> 8); + } + # else we might e.g. closed a live stream; the command + # dying of SIGPIPE would drive us here. + } +} + + +# Trickery for .xs routines: In order to avoid having some horrid +# C code trying to do stuff with undefs and hashes, we gate all +# xs calls through the following and in case we are being ran upon +# an instance call a C part of the gate which will set up the +# environment properly. +sub _call_gate { + my $xsfunc = shift; + my ($self, @args) = _maybe_self(@_); + + if (defined $self) { + # XXX: We ignore the WorkingCopy! To properly support + # that will require heavy changes in libgit. + + # XXX: And we ignore everything else as well. libgit + # at least needs to be extended to let us specify + # the $GIT_DIR instead of looking it up in environment. + #xs_call_gate($self->{opts}->{Repository}); + } + + &$xsfunc(@args); +} + +sub AUTOLOAD { + my $xsname; + our $AUTOLOAD; + ($xsname = $AUTOLOAD) =~ s/.*:://; + croak "&Git::$xsname not defined" if $xsname =~ /^xs_/; + $xsname = 'xs_'.$xsname; + _call_gate(\&$xsname, @_); +} + +sub DESTROY { } + + +1; # Famous last words diff --git a/perl/Git.xs b/perl/Git.xs new file mode 100644 index 0000000..1b81ce2 --- /dev/null +++ b/perl/Git.xs @@ -0,0 +1,64 @@ +/* By carefully stacking #includes here (even if WE don't really need them) + * we strive to make the thing actually compile. Git header files aren't very + * nice. Perl headers are one of the signs of the coming apocalypse. */ +#include +/* Ok, it hasn't been so bad so far. */ + +/* libgit interface */ +#include "../cache.h" + +/* XS and Perl interface */ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" + + +MODULE = Git PACKAGE = Git + +PROTOTYPES: DISABLE + +# /* TODO: xs_call_gate(). See Git.pm. */ + +char * +xs_hash_object(file, type = "blob") + SV *file; + char *type; +CODE: +{ + unsigned char sha1[20]; + + if (SvTYPE(file) == SVt_RV) + file = SvRV(file); + + if (SvTYPE(file) == SVt_PVGV) { + /* Filehandle */ + PerlIO *pio; + + pio = IoIFP(sv_2io(file)); + if (!pio) + croak("You passed me something weird - a dir glob?"); + /* XXX: I just hope PerlIO didn't read anything from it yet. + * --pasky */ + if (index_pipe(sha1, PerlIO_fileno(pio), type, 0)) + croak("Unable to hash given filehandle"); + /* Avoid any nasty surprises. */ + PerlIO_close(pio); + + } else { + /* String */ + char *path = SvPV_nolen(file); + int fd = open(path, O_RDONLY); + struct stat st; + + if (fd < 0 || + fstat(fd, &st) < 0 || + index_fd(sha1, fd, &st, 0, type)) + croak("Unable to hash %s", path); + close(fd); + } + RETVAL = sha1_to_hex(sha1); +} +OUTPUT: + RETVAL diff --git a/perl/Makefile.PL b/perl/Makefile.PL new file mode 100644 index 0000000..dd61056 --- /dev/null +++ b/perl/Makefile.PL @@ -0,0 +1,21 @@ +use ExtUtils::MakeMaker; + +sub MY::postamble { + return <<'MAKE_FRAG'; +instlibdir: + @echo $(INSTALLSITELIB) + +MAKE_FRAG +} + +WriteMakefile( + NAME => 'Git', + VERSION_FROM => 'Git.pm', + MYEXTLIB => '../libgit.a', + INC => '-I. -I..', +); + + +use Devel::PPPort; + +-s 'ppport.h' or Devel::PPPort::WriteFile(); -- cgit v0.10.2-6-g49f6 From eca1f6fdb862e6ca07288ac385725c95fd96490e Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:31 +0200 Subject: Git.pm: Implement Git::exec_path() This patch implements Git::exec_path() (as a direct XS call). Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 8fff785..5c5ae12 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -48,7 +48,7 @@ require Exporter; # Methods which can be called as standalone functions as well: @EXPORT_OK = qw(command command_oneline command_pipe command_noisy - hash_object); + exec_path hash_object); =head1 DESCRIPTION @@ -288,6 +288,19 @@ sub command_noisy { } +=item exec_path () + +Return path to the git sub-command executables (the same as +C). Useful mostly only internally. + +Implementation of this function is very fast; no external command calls +are involved. + +=cut + +# Implemented in Git.xs. + + =item hash_object ( FILENAME [, TYPE ] ) =item hash_object ( FILEHANDLE [, TYPE ] ) diff --git a/perl/Git.xs b/perl/Git.xs index 1b81ce2..9e754d2 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -6,6 +6,7 @@ /* libgit interface */ #include "../cache.h" +#include "../exec_cmd.h" /* XS and Perl interface */ #include "EXTERN.h" @@ -21,6 +22,17 @@ PROTOTYPES: DISABLE # /* TODO: xs_call_gate(). See Git.pm. */ + +const char * +xs_exec_path() +CODE: +{ + RETVAL = git_exec_path(); +} +OUTPUT: + RETVAL + + char * xs_hash_object(file, type = "blob") SV *file; -- cgit v0.10.2-6-g49f6 From 8062f81c2d9df5e6552bf267b258ffcc5f647f93 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:34 +0200 Subject: Git.pm: Call external commands using execv_git_cmd() Instead of explicitly using the git wrapper to call external commands, use the execv_git_cmd() function which will directly call whatever needs to be called. GitBin option becomes useless so drop it. This actually means the exec_path() thing I planned to use worthless internally, but Jakub wants it in anyway and I don't mind, so... Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 5c5ae12..212337e 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -122,9 +122,6 @@ to the subdirectory and the directory is assumed to be the working copy. If the directory does not have the subdirectory, C is left undefined and C is pointed to the directory itself. -B - Path to the C binary executable. By default the C<$PATH> -is searched for it. - You should not use both C and either of C and C - the results of that are undefined. @@ -363,11 +360,14 @@ sub _cmd_exec { $self->{opts}->{Repository} and $ENV{'GIT_DIR'} = $self->{opts}->{Repository}; $self->{opts}->{WorkingCopy} and chdir($self->{opts}->{WorkingCopy}); } - my $git = $self->{opts}->{GitPath}; - $git ||= 'git'; - exec ($git, @args) or croak "exec failed: $!"; + xs__execv_git_cmd(@args); + croak "exec failed: $!"; } +# Execute the given Git command ($_[0]) with arguments ($_[1..]) +# by searching for it at proper places. +# _execv_git_cmd(), implemented in Git.xs. + # Close pipe to a subprocess. sub _cmd_close { my ($fh) = @_; diff --git a/perl/Git.xs b/perl/Git.xs index 9e754d2..6478f9c 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -33,6 +33,28 @@ OUTPUT: RETVAL +void +xs__execv_git_cmd(...) +CODE: +{ + const char **argv; + int i; + + argv = malloc(sizeof(const char *) * (items + 1)); + if (!argv) + croak("malloc failed"); + for (i = 0; i < items; i++) + argv[i] = strdup(SvPV_nolen(ST(i))); + argv[i] = NULL; + + execv_git_cmd(argv); + + for (i = 0; i < items; i++) + if (argv[i]) + free((char *) argv[i]); + free((char **) argv); +} + char * xs_hash_object(file, type = "blob") SV *file; -- cgit v0.10.2-6-g49f6 From 63df97ae7baeedc3ce04995139fa0f6bc5eea76c Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:36 +0200 Subject: Git.pm: Implement Git::version() Git::version() returns the Git version string. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 730b38a..dda9b9d 100644 --- a/Makefile +++ b/Makefile @@ -610,7 +610,10 @@ $(XDIFF_LIB): $(XDIFF_OBJS) perl/Makefile: perl/Git.pm perl/Makefile.PL - (cd perl && $(PERL_PATH) Makefile.PL PREFIX="$(prefix)" DEFINE="$(ALL_CFLAGS)" LIBS="$(LIBS)") + (cd perl && $(PERL_PATH) Makefile.PL \ + PREFIX="$(prefix)" \ + DEFINE="$(ALL_CFLAGS) -DGIT_VERSION=\\\"$(GIT_VERSION)\\\"" \ + LIBS="$(LIBS)") doc: $(MAKE) -C Documentation all diff --git a/perl/Git.pm b/perl/Git.pm index 212337e..dcd769b 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -48,7 +48,7 @@ require Exporter; # Methods which can be called as standalone functions as well: @EXPORT_OK = qw(command command_oneline command_pipe command_noisy - exec_path hash_object); + version exec_path hash_object); =head1 DESCRIPTION @@ -285,6 +285,18 @@ sub command_noisy { } +=item version () + +Return the Git version in use. + +Implementation of this function is very fast; no external command calls +are involved. + +=cut + +# Implemented in Git.xs. + + =item exec_path () Return path to the git sub-command executables (the same as diff --git a/perl/Git.xs b/perl/Git.xs index 6478f9c..d4608eb 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -24,6 +24,16 @@ PROTOTYPES: DISABLE const char * +xs_version() +CODE: +{ + RETVAL = GIT_VERSION; +} +OUTPUT: + RETVAL + + +const char * xs_exec_path() CODE: { -- cgit v0.10.2-6-g49f6 From 5c4082fd687bd0784d3a4d96550e8afab332b63a Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:40 +0200 Subject: Add Error.pm to the distribution I have been thinking about how to do the error reporting the best way and after scraping various overcomplicated concepts, I have decided that by far the most elegant way is to throw Error exceptions; the closest sane alternative is to catch the dies in Git.pm by enclosing the calls in eval{}s and that's really _quite_ ugly. The only "small" trouble is that Error.pm turns out sadly not to be part of the standard distribution, and installation from CPAN is a bother, especially if you can't install it system-wide. But since it is very small, I've decided to just bundle it. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Error.pm b/perl/Error.pm new file mode 100644 index 0000000..ebd0749 --- /dev/null +++ b/perl/Error.pm @@ -0,0 +1,821 @@ +# Error.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Based on my original Error.pm, and Exceptions.pm by Peter Seibel +# and adapted by Jesse Glick . +# +# but modified ***significantly*** + +package Error; + +use strict; +use vars qw($VERSION); +use 5.004; + +$VERSION = "0.15009"; + +use overload ( + '""' => 'stringify', + '0+' => 'value', + 'bool' => sub { return 1; }, + 'fallback' => 1 +); + +$Error::Depth = 0; # Depth to pass to caller() +$Error::Debug = 0; # Generate verbose stack traces +@Error::STACK = (); # Clause stack for try +$Error::THROWN = undef; # last error thrown, a workaround until die $ref works + +my $LAST; # Last error created +my %ERROR; # Last error associated with package + +sub throw_Error_Simple +{ + my $args = shift; + return Error::Simple->new($args->{'text'}); +} + +$Error::ObjectifyCallback = \&throw_Error_Simple; + + +# Exported subs are defined in Error::subs + +use Scalar::Util (); + +sub import { + shift; + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + Error::subs->import(@_); +} + +# I really want to use last for the name of this method, but it is a keyword +# which prevent the syntax last Error + +sub prior { + shift; # ignore + + return $LAST unless @_; + + my $pkg = shift; + return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef + unless ref($pkg); + + my $obj = $pkg; + my $err = undef; + if($obj->isa('HASH')) { + $err = $obj->{'__Error__'} + if exists $obj->{'__Error__'}; + } + elsif($obj->isa('GLOB')) { + $err = ${*$obj}{'__Error__'} + if exists ${*$obj}{'__Error__'}; + } + + $err; +} + +sub flush { + shift; #ignore + + unless (@_) { + $LAST = undef; + return; + } + + my $pkg = shift; + return unless ref($pkg); + + undef $ERROR{$pkg} if defined $ERROR{$pkg}; +} + +# Return as much information as possible about where the error +# happened. The -stacktrace element only exists if $Error::DEBUG +# was set when the error was created + +sub stacktrace { + my $self = shift; + + return $self->{'-stacktrace'} + if exists $self->{'-stacktrace'}; + + my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; + + $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) + unless($text =~ /\n$/s); + + $text; +} + +# Allow error propagation, ie +# +# $ber->encode(...) or +# return Error->prior($ber)->associate($ldap); + +sub associate { + my $err = shift; + my $obj = shift; + + return unless ref($obj); + + if($obj->isa('HASH')) { + $obj->{'__Error__'} = $err; + } + elsif($obj->isa('GLOB')) { + ${*$obj}{'__Error__'} = $err; + } + $obj = ref($obj); + $ERROR{ ref($obj) } = $err; + + return; +} + +sub new { + my $self = shift; + my($pkg,$file,$line) = caller($Error::Depth); + + my $err = bless { + '-package' => $pkg, + '-file' => $file, + '-line' => $line, + @_ + }, $self; + + $err->associate($err->{'-object'}) + if(exists $err->{'-object'}); + + # To always create a stacktrace would be very inefficient, so + # we only do it if $Error::Debug is set + + if($Error::Debug) { + require Carp; + local $Carp::CarpLevel = $Error::Depth; + my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; + my $trace = Carp::longmess($text); + # Remove try calls from the trace + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + $err->{'-stacktrace'} = $trace + } + + $@ = $LAST = $ERROR{$pkg} = $err; +} + +# Throw an error. this contains some very gory code. + +sub throw { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + # if we are not rethrow-ing then create the object to throw + $self = $self->new(@_) unless ref($self); + + die $Error::THROWN = $self; +} + +# syntactic sugar for +# +# die with Error( ... ); + +sub with { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + $self->new(@_); +} + +# syntactic sugar for +# +# record Error( ... ) and return; + +sub record { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + $self->new(@_); +} + +# catch clause for +# +# try { ... } catch CLASS with { ... } + +sub catch { + my $pkg = shift; + my $code = shift; + my $clauses = shift || {}; + my $catch = $clauses->{'catch'} ||= []; + + unshift @$catch, $pkg, $code; + + $clauses; +} + +# Object query methods + +sub object { + my $self = shift; + exists $self->{'-object'} ? $self->{'-object'} : undef; +} + +sub file { + my $self = shift; + exists $self->{'-file'} ? $self->{'-file'} : undef; +} + +sub line { + my $self = shift; + exists $self->{'-line'} ? $self->{'-line'} : undef; +} + +sub text { + my $self = shift; + exists $self->{'-text'} ? $self->{'-text'} : undef; +} + +# overload methods + +sub stringify { + my $self = shift; + defined $self->{'-text'} ? $self->{'-text'} : "Died"; +} + +sub value { + my $self = shift; + exists $self->{'-value'} ? $self->{'-value'} : undef; +} + +package Error::Simple; + +@Error::Simple::ISA = qw(Error); + +sub new { + my $self = shift; + my $text = "" . shift; + my $value = shift; + my(@args) = (); + + local $Error::Depth = $Error::Depth + 1; + + @args = ( -file => $1, -line => $2) + if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s); + push(@args, '-value', 0 + $value) + if defined($value); + + $self->SUPER::new(-text => $text, @args); +} + +sub stringify { + my $self = shift; + my $text = $self->SUPER::stringify; + $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) + unless($text =~ /\n$/s); + $text; +} + +########################################################################## +########################################################################## + +# Inspired by code from Jesse Glick and +# Peter Seibel + +package Error::subs; + +use Exporter (); +use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); + +@EXPORT_OK = qw(try with finally except otherwise); +%EXPORT_TAGS = (try => \@EXPORT_OK); + +@ISA = qw(Exporter); + +sub run_clauses ($$$\@) { + my($clauses,$err,$wantarray,$result) = @_; + my $code = undef; + + $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err); + + CATCH: { + + # catch + my $catch; + if(defined($catch = $clauses->{'catch'})) { + my $i = 0; + + CATCHLOOP: + for( ; $i < @$catch ; $i += 2) { + my $pkg = $catch->[$i]; + unless(defined $pkg) { + #except + splice(@$catch,$i,2,$catch->[$i+1]->()); + $i -= 2; + next CATCHLOOP; + } + elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { + $code = $catch->[$i+1]; + while(1) { + my $more = 0; + local($Error::THROWN); + my $ok = eval { + if($wantarray) { + @{$result} = $code->($err,\$more); + } + elsif(defined($wantarray)) { + @{$result} = (); + $result->[0] = $code->($err,\$more); + } + else { + $code->($err,\$more); + } + 1; + }; + if( $ok ) { + next CATCHLOOP if $more; + undef $err; + } + else { + $err = defined($Error::THROWN) + ? $Error::THROWN : $@; + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); + } + last CATCH; + }; + } + } + } + + # otherwise + my $owise; + if(defined($owise = $clauses->{'otherwise'})) { + my $code = $clauses->{'otherwise'}; + my $more = 0; + my $ok = eval { + if($wantarray) { + @{$result} = $code->($err,\$more); + } + elsif(defined($wantarray)) { + @{$result} = (); + $result->[0] = $code->($err,\$more); + } + else { + $code->($err,\$more); + } + 1; + }; + if( $ok ) { + undef $err; + } + else { + $err = defined($Error::THROWN) + ? $Error::THROWN : $@; + + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); + } + } + } + $err; +} + +sub try (&;$) { + my $try = shift; + my $clauses = @_ ? shift : {}; + my $ok = 0; + my $err = undef; + my @result = (); + + unshift @Error::STACK, $clauses; + + my $wantarray = wantarray(); + + do { + local $Error::THROWN = undef; + local $@ = undef; + + $ok = eval { + if($wantarray) { + @result = $try->(); + } + elsif(defined $wantarray) { + $result[0] = $try->(); + } + else { + $try->(); + } + 1; + }; + + $err = defined($Error::THROWN) ? $Error::THROWN : $@ + unless $ok; + }; + + shift @Error::STACK; + + $err = run_clauses($clauses,$err,wantarray,@result) + unless($ok); + + $clauses->{'finally'}->() + if(defined($clauses->{'finally'})); + + if (defined($err)) + { + if (Scalar::Util::blessed($err) && $err->can('throw')) + { + throw $err; + } + else + { + die $err; + } + } + + wantarray ? @result : $result[0]; +} + +# Each clause adds a sub to the list of clauses. The finally clause is +# always the last, and the otherwise clause is always added just before +# the finally clause. +# +# All clauses, except the finally clause, add a sub which takes one argument +# this argument will be the error being thrown. The sub will return a code ref +# if that clause can handle that error, otherwise undef is returned. +# +# The otherwise clause adds a sub which unconditionally returns the users +# code reference, this is why it is forced to be last. +# +# The catch clause is defined in Error.pm, as the syntax causes it to +# be called as a method + +sub with (&;$) { + @_ +} + +sub finally (&) { + my $code = shift; + my $clauses = { 'finally' => $code }; + $clauses; +} + +# The except clause is a block which returns a hashref or a list of +# key-value pairs, where the keys are the classes and the values are subs. + +sub except (&;$) { + my $code = shift; + my $clauses = shift || {}; + my $catch = $clauses->{'catch'} ||= []; + + my $sub = sub { + my $ref; + my(@array) = $code->($_[0]); + if(@array == 1 && ref($array[0])) { + $ref = $array[0]; + $ref = [ %$ref ] + if(UNIVERSAL::isa($ref,'HASH')); + } + else { + $ref = \@array; + } + @$ref + }; + + unshift @{$catch}, undef, $sub; + + $clauses; +} + +sub otherwise (&;$) { + my $code = shift; + my $clauses = shift || {}; + + if(exists $clauses->{'otherwise'}) { + require Carp; + Carp::croak("Multiple otherwise clauses"); + } + + $clauses->{'otherwise'} = $code; + + $clauses; +} + +1; +__END__ + +=head1 NAME + +Error - Error/exception handling in an OO-ish way + +=head1 SYNOPSIS + + use Error qw(:try); + + throw Error::Simple( "A simple error"); + + sub xyz { + ... + record Error::Simple("A simple error") + and return; + } + + unlink($file) or throw Error::Simple("$file: $!",$!); + + try { + do_some_stuff(); + die "error!" if $condition; + throw Error::Simple -text => "Oops!" if $other_condition; + } + catch Error::IO with { + my $E = shift; + print STDERR "File ", $E->{'-file'}, " had a problem\n"; + } + except { + my $E = shift; + my $general_handler=sub {send_message $E->{-description}}; + return { + UserException1 => $general_handler, + UserException2 => $general_handler + }; + } + otherwise { + print STDERR "Well I don't know what to say\n"; + } + finally { + close_the_garage_door_already(); # Should be reliable + }; # Don't forget the trailing ; or you might be surprised + +=head1 DESCRIPTION + +The C package provides two interfaces. Firstly C provides +a procedural interface to exception handling. Secondly C is a +base class for errors/exceptions that can either be thrown, for +subsequent catch, or can simply be recorded. + +Errors in the class C should not be thrown directly, but the +user should throw errors from a sub-class of C. + +=head1 PROCEDURAL INTERFACE + +C exports subroutines to perform exception handling. These will +be exported if the C<:try> tag is used in the C line. + +=over 4 + +=item try BLOCK CLAUSES + +C is the main subroutine called by the user. All other subroutines +exported are clauses to the try subroutine. + +The BLOCK will be evaluated and, if no error is throw, try will return +the result of the block. + +C are the subroutines below, which describe what to do in the +event of an error being thrown within BLOCK. + +=item catch CLASS with BLOCK + +This clauses will cause all errors that satisfy C<$err-Eisa(CLASS)> +to be caught and handled by evaluating C. + +C will be passed two arguments. The first will be the error +being thrown. The second is a reference to a scalar variable. If this +variable is set by the catch block then, on return from the catch +block, try will continue processing as if the catch block was never +found. + +To propagate the error the catch block may call C<$err-Ethrow> + +If the scalar reference by the second argument is not set, and the +error is not thrown. Then the current try block will return with the +result from the catch block. + +=item except BLOCK + +When C is looking for a handler, if an except clause is found +C is evaluated. The return value from this block should be a +HASHREF or a list of key-value pairs, where the keys are class names +and the values are CODE references for the handler of errors of that +type. + +=item otherwise BLOCK + +Catch any error by executing the code in C + +When evaluated C will be passed one argument, which will be the +error being processed. + +Only one otherwise block may be specified per try block + +=item finally BLOCK + +Execute the code in C either after the code in the try block has +successfully completed, or if the try block throws an error then +C will be executed after the handler has completed. + +If the handler throws an error then the error will be caught, the +finally block will be executed and the error will be re-thrown. + +Only one finally block may be specified per try block + +=back + +=head1 CLASS INTERFACE + +=head2 CONSTRUCTORS + +The C object is implemented as a HASH. This HASH is initialized +with the arguments that are passed to it's constructor. The elements +that are used by, or are retrievable by the C class are listed +below, other classes may add to these. + + -file + -line + -text + -value + -object + +If C<-file> or C<-line> are not specified in the constructor arguments +then these will be initialized with the file name and line number where +the constructor was called from. + +If the error is associated with an object then the object should be +passed as the C<-object> argument. This will allow the C package +to associate the error with the object. + +The C package remembers the last error created, and also the +last error associated with a package. This could either be the last +error created by a sub in that package, or the last error which passed +an object blessed into that package as the C<-object> argument. + +=over 4 + +=item throw ( [ ARGS ] ) + +Create a new C object and throw an error, which will be caught +by a surrounding C block, if there is one. Otherwise it will cause +the program to exit. + +C may also be called on an existing error to re-throw it. + +=item with ( [ ARGS ] ) + +Create a new C object and returns it. This is defined for +syntactic sugar, eg + + die with Some::Error ( ... ); + +=item record ( [ ARGS ] ) + +Create a new C object and returns it. This is defined for +syntactic sugar, eg + + record Some::Error ( ... ) + and return; + +=back + +=head2 STATIC METHODS + +=over 4 + +=item prior ( [ PACKAGE ] ) + +Return the last error created, or the last error associated with +C + +=item flush ( [ PACKAGE ] ) + +Flush the last error created, or the last error associated with +C.It is necessary to clear the error stack before exiting the +package or uncaught errors generated using C will be reported. + + $Error->flush; + +=cut + +=back + +=head2 OBJECT METHODS + +=over 4 + +=item stacktrace + +If the variable C<$Error::Debug> was non-zero when the error was +created, then C returns a string created by calling +C. If the variable was zero the C returns +the text of the error appended with the filename and line number of +where the error was created, providing the text does not end with a +newline. + +=item object + +The object this error was associated with + +=item file + +The file where the constructor of this error was called from + +=item line + +The line where the constructor of this error was called from + +=item text + +The text of the error + +=back + +=head2 OVERLOAD METHODS + +=over 4 + +=item stringify + +A method that converts the object into a string. This method may simply +return the same as the C method, or it may append more +information. For example the file name and line number. + +By default this method returns the C<-text> argument that was passed to +the constructor, or the string C<"Died"> if none was given. + +=item value + +A method that will return a value that can be associated with the +error. For example if an error was created due to the failure of a +system call, then this may return the numeric value of C<$!> at the +time. + +By default this method returns the C<-value> argument that was passed +to the constructor. + +=back + +=head1 PRE-DEFINED ERROR CLASSES + +=over 4 + +=item Error::Simple + +This class can be used to hold simple error strings and values. It's +constructor takes two arguments. The first is a text value, the second +is a numeric value. These values are what will be returned by the +overload methods. + +If the text value ends with C as $@ strings do, then +this infomation will be used to set the C<-file> and C<-line> arguments +of the error object. + +This class is used internally if an eval'd block die's with an error +that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified) + +=back + +=head1 $Error::ObjectifyCallback + +This variable holds a reference to a subroutine that converts errors that +are plain strings to objects. It is used by Error.pm to convert textual +errors to objects, and can be overrided by the user. + +It accepts a single argument which is a hash reference to named parameters. +Currently the only named parameter passed is C<'text'> which is the text +of the error, but others may be available in the future. + +For example the following code will cause Error.pm to throw objects of the +class MyError::Bar by default: + + sub throw_MyError_Bar + { + my $args = shift; + my $err = MyError::Bar->new(); + $err->{'MyBarText'} = $args->{'text'}; + return $err; + } + + { + local $Error::ObjectifyCallback = \&throw_MyError_Bar; + + # Error handling here. + } + +=head1 KNOWN BUGS + +None, but that does not mean there are not any. + +=head1 AUTHORS + +Graham Barr + +The code that inspired me to write this was originally written by +Peter Seibel and adapted by Jesse Glick +. + +=head1 MAINTAINER + +Shlomi Fish + +=head1 PAST MAINTAINERS + +Arun Kumar U + +=cut diff --git a/perl/Makefile.PL b/perl/Makefile.PL index dd61056..54e8b20 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -8,9 +8,19 @@ instlibdir: MAKE_FRAG } +my %pm = ('Git.pm' => '$(INST_LIBDIR)/Git.pm'); + +# We come with our own bundled Error.pm. It's not in the set of default +# Perl modules so install it if it's not available on the system yet. +eval { require 'Error' }; +if ($@) { + $pm{'Error.pm'} = '$(INST_LIBDIR)/Error.pm'; +} + WriteMakefile( NAME => 'Git', VERSION_FROM => 'Git.pm', + PM => \%pm, MYEXTLIB => '../libgit.a', INC => '-I. -I..', ); -- cgit v0.10.2-6-g49f6 From 97b16c067492506287a6f474e79ef6cbe0a30e49 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:42 +0200 Subject: Git.pm: Better error handling So far, errors just killed the whole program and in case of an error inside of libgit it would be totally uncatchable. This patch makes Git.pm throw standard Perl exceptions instead. In the future we might subclass Error to Git::Error or something but for now Error::Simple is more than enough. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index dcd769b..733fec9 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -88,7 +88,8 @@ increate nonwithstanding). =cut -use Carp qw(carp croak); +use Carp qw(carp); # croak is bad - throw instead +use Error qw(:try); require XSLoader; XSLoader::load('Git', $VERSION); @@ -143,14 +144,14 @@ sub repository { if (defined $args[0]) { if ($#args % 2 != 1) { # Not a hash. - $#args == 0 or croak "bad usage"; - %opts = (Directory => $args[0]); + $#args == 0 or throw Error::Simple("bad usage"); + %opts = ( Directory => $args[0] ); } else { %opts = @args; } if ($opts{Directory}) { - -d $opts{Directory} or croak "Directory not found: $!"; + -d $opts{Directory} or throw Error::Simple("Directory not found: $!"); if (-d $opts{Directory}."/.git") { # TODO: Might make this more clever $opts{WorkingCopy} = $opts{Directory}; @@ -242,11 +243,11 @@ read. sub command_pipe { my ($self, $cmd, @args) = _maybe_self(@_); - $cmd =~ /^[a-z0-9A-Z_-]+$/ or croak "bad command: $cmd"; + $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd"); my $pid = open(my $fh, "-|"); if (not defined $pid) { - croak "open failed: $!"; + throw Error::Simple("open failed: $!"); } elsif ($pid == 0) { _cmd_exec($self, $cmd, @args); } @@ -271,16 +272,17 @@ The function returns only after the command has finished running. sub command_noisy { my ($self, $cmd, @args) = _maybe_self(@_); - $cmd =~ /^[a-z0-9A-Z_-]+$/ or croak "bad command: $cmd"; + $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd"); my $pid = fork; if (not defined $pid) { - croak "fork failed: $!"; + throw Error::Simple("fork failed: $!"); } elsif ($pid == 0) { _cmd_exec($self, $cmd, @args); } if (waitpid($pid, 0) > 0 and $? != 0) { - croak "exit status: $?"; + # This is the best candidate for a custom exception class. + throw Error::Simple("exit status: $?"); } } @@ -340,10 +342,10 @@ are involved. =back -=head1 TODO +=head1 ERROR HANDLING -This is still fairly crude. -We need some good way to report errors back except just dying. +All functions are supposed to throw Perl exceptions in case of errors. +See L. =head1 COPYRIGHT @@ -372,8 +374,8 @@ sub _cmd_exec { $self->{opts}->{Repository} and $ENV{'GIT_DIR'} = $self->{opts}->{Repository}; $self->{opts}->{WorkingCopy} and chdir($self->{opts}->{WorkingCopy}); } - xs__execv_git_cmd(@args); - croak "exec failed: $!"; + _execv_git_cmd(@args); + die "exec failed: $!"; } # Execute the given Git command ($_[0]) with arguments ($_[1..]) @@ -388,7 +390,8 @@ sub _cmd_close { # It's just close, no point in fatalities carp "error closing pipe: $!"; } elsif ($? >> 8) { - croak "exit status: ".($? >> 8); + # This is the best candidate for a custom exception class. + throw Error::Simple("exit status: ".($? >> 8)); } # else we might e.g. closed a live stream; the command # dying of SIGPIPE would drive us here. @@ -415,6 +418,8 @@ sub _call_gate { #xs_call_gate($self->{opts}->{Repository}); } + # Having to call throw from the C code is a sure path to insanity. + local $SIG{__DIE__} = sub { throw Error::Simple("@_"); }; &$xsfunc(@args); } @@ -422,7 +427,7 @@ sub AUTOLOAD { my $xsname; our $AUTOLOAD; ($xsname = $AUTOLOAD) =~ s/.*:://; - croak "&Git::$xsname not defined" if $xsname =~ /^xs_/; + throw Error::Simple("&Git::$xsname not defined") if $xsname =~ /^xs_/; $xsname = 'xs_'.$xsname; _call_gate(\&$xsname, @_); } diff --git a/perl/Git.xs b/perl/Git.xs index d4608eb..9d247b7 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -8,6 +8,8 @@ #include "../cache.h" #include "../exec_cmd.h" +#define die perlyshadow_die__ + /* XS and Perl interface */ #include "EXTERN.h" #include "perl.h" @@ -15,11 +17,48 @@ #include "ppport.h" +#undef die + + +static char * +report_xs(const char *prefix, const char *err, va_list params) +{ + static char buf[4096]; + strcpy(buf, prefix); + vsnprintf(buf + strlen(prefix), 4096 - strlen(prefix), err, params); + return buf; +} + +void +die_xs(const char *err, va_list params) +{ + char *str; + str = report_xs("fatal: ", err, params); + croak(str); +} + +int +error_xs(const char *err, va_list params) +{ + char *str; + str = report_xs("error: ", err, params); + warn(str); + return -1; +} + MODULE = Git PACKAGE = Git PROTOTYPES: DISABLE + +BOOT: +{ + set_error_routine(error_xs); + set_die_routine(die_xs); +} + + # /* TODO: xs_call_gate(). See Git.pm. */ -- cgit v0.10.2-6-g49f6 From 8b9150e3e3cc6bf78b21b2e01dcc5e3ed45597a4 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:44 +0200 Subject: Git.pm: Handle failed commands' output Currently if an external command returns error exit code, a generic exception is thrown and there is no chance for the caller to retrieve the command's output. This patch introduces a Git::Error::Command exception class which is thrown in this case and contains both the error code and the captured command output. You can use the new git_cmd_try statement to fatally catch the exception while producing a user-friendly message. It also adds command_close_pipe() for easier checking of exit status of a command we have just a pipe handle of. It has partial forward dependency on the next patch, but basically only in the area of documentation. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/git-fmt-merge-msg.perl b/git-fmt-merge-msg.perl index be2a48c..f86231e 100755 --- a/git-fmt-merge-msg.perl +++ b/git-fmt-merge-msg.perl @@ -7,6 +7,7 @@ use strict; use Git; +use Error qw(:try); my $repo = Git->repository(); @@ -31,7 +32,17 @@ sub andjoin { } sub repoconfig { - my ($val) = $repo->command_oneline('repo-config', '--get', 'merge.summary'); + my $val; + try { + $val = $repo->command_oneline('repo-config', '--get', 'merge.summary'); + } catch Git::Error::Command with { + my ($E) = shift; + if ($E->value() == 1) { + return undef; + } else { + throw $E; + } + }; return $val; } diff --git a/perl/Git.pm b/perl/Git.pm index 733fec9..4205ac5 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -24,16 +24,17 @@ $VERSION = '0.01'; my $version = Git::command_oneline('version'); - Git::command_noisy('update-server-info'); + git_cmd_try { Git::command_noisy('update-server-info') } + '%s failed w/ code %d'; my $repo = Git->repository (Directory => '/srv/git/cogito.git'); my @revs = $repo->command('rev-list', '--since=last monday', '--all'); - my $fh = $repo->command_pipe('rev-list', '--since=last monday', '--all'); + my ($fh, $c) = $repo->command_pipe('rev-list', '--since=last monday', '--all'); my $lastrev = <$fh>; chomp $lastrev; - close $fh; # You may want to test rev-list exit status here + $repo->command_close_pipe($fh, $c); my $lastrev = $repo->command_oneline('rev-list', '--all'); @@ -44,11 +45,11 @@ require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(); +@EXPORT = qw(git_cmd_try); # Methods which can be called as standalone functions as well: @EXPORT_OK = qw(command command_oneline command_pipe command_noisy - version exec_path hash_object); + version exec_path hash_object git_cmd_try); =head1 DESCRIPTION @@ -88,7 +89,7 @@ increate nonwithstanding). =cut -use Carp qw(carp); # croak is bad - throw instead +use Carp qw(carp croak); # but croak is bad - throw instead use Error qw(:try); require XSLoader; @@ -193,21 +194,35 @@ In both cases, the command's stdin and stderr are the same as the caller's. =cut sub command { - my $fh = command_pipe(@_); + my ($fh, $ctx) = command_pipe(@_); if (not defined wantarray) { - _cmd_close($fh); + # Nothing to pepper the possible exception with. + _cmd_close($fh, $ctx); } elsif (not wantarray) { local $/; my $text = <$fh>; - _cmd_close($fh); + try { + _cmd_close($fh, $ctx); + } catch Git::Error::Command with { + # Pepper with the output: + my $E = shift; + $E->{'-outputref'} = \$text; + throw $E; + }; return $text; } else { my @lines = <$fh>; - _cmd_close($fh); chomp @lines; + try { + _cmd_close($fh, $ctx); + } catch Git::Error::Command with { + my $E = shift; + $E->{'-outputref'} = \@lines; + throw $E; + }; return @lines; } } @@ -222,12 +237,18 @@ of the command's standard output. =cut sub command_oneline { - my $fh = command_pipe(@_); + my ($fh, $ctx) = command_pipe(@_); my $line = <$fh>; - _cmd_close($fh); - chomp $line; + try { + _cmd_close($fh, $ctx); + } catch Git::Error::Command with { + # Pepper with the output: + my $E = shift; + $E->{'-outputref'} = \$line; + throw $E; + }; return $line; } @@ -251,7 +272,32 @@ sub command_pipe { } elsif ($pid == 0) { _cmd_exec($self, $cmd, @args); } - return $fh; + return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh; +} + + +=item command_close_pipe ( PIPE [, CTX ] ) + +Close the C as returned from C, checking +whether the command finished successfuly. The optional C argument +is required if you want to see the command name in the error message, +and it is the second value returned by C when +called in array context. The call idiom is: + + my ($fh, $ctx) = $r->command_pipe('status'); + while (<$fh>) { ... } + $r->command_close_pipe($fh, $ctx); + +Note that you should not rely on whatever actually is in C; +currently it is simply the command name but in future the context might +have more complicated structure. + +=cut + +sub command_close_pipe { + my ($self, $fh, $ctx) = _maybe_self(@_); + $ctx ||= ''; + _cmd_close($fh, $ctx); } @@ -280,9 +326,8 @@ sub command_noisy { } elsif ($pid == 0) { _cmd_exec($self, $cmd, @args); } - if (waitpid($pid, 0) > 0 and $? != 0) { - # This is the best candidate for a custom exception class. - throw Error::Simple("exit status: $?"); + if (waitpid($pid, 0) > 0 and $?>>8 != 0) { + throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8); } } @@ -340,12 +385,117 @@ are involved. # Implemented in Git.xs. + =back =head1 ERROR HANDLING All functions are supposed to throw Perl exceptions in case of errors. -See L. +See the L module on how to catch those. Most exceptions are mere +L instances. + +However, the C, C and C +functions suite can throw C exceptions as well: those are +thrown when the external command returns an error code and contain the error +code as well as access to the captured command's output. The exception class +provides the usual C and C (command's exit code) methods and +in addition also a C method that returns either an array or a +string with the captured command output (depending on the original function +call context; C returns C) and $ which +returns the command and its arguments (but without proper quoting). + +Note that the C function cannot throw this exception since +it has no idea whether the command failed or not. You will only find out +at the time you C the pipe; if you want to have that automated, +use C, which can throw the exception. + +=cut + +{ + package Git::Error::Command; + + @Git::Error::Command::ISA = qw(Error); + + sub new { + my $self = shift; + my $cmdline = '' . shift; + my $value = 0 + shift; + my $outputref = shift; + my(@args) = (); + + local $Error::Depth = $Error::Depth + 1; + + push(@args, '-cmdline', $cmdline); + push(@args, '-value', $value); + push(@args, '-outputref', $outputref); + + $self->SUPER::new(-text => 'command returned error', @args); + } + + sub stringify { + my $self = shift; + my $text = $self->SUPER::stringify; + $self->cmdline() . ': ' . $text . ': ' . $self->value() . "\n"; + } + + sub cmdline { + my $self = shift; + $self->{'-cmdline'}; + } + + sub cmd_output { + my $self = shift; + my $ref = $self->{'-outputref'}; + defined $ref or undef; + if (ref $ref eq 'ARRAY') { + return @$ref; + } else { # SCALAR + return $$ref; + } + } +} + +=over 4 + +=item git_cmd_try { CODE } ERRMSG + +This magical statement will automatically catch any C +exceptions thrown by C and make your program die with C +on its lips; the message will have %s substituted for the command line +and %d for the exit status. This statement is useful mostly for producing +more user-friendly error messages. + +In case of no exception caught the statement returns C's return value. + +Note that this is the only auto-exported function. + +=cut + +sub git_cmd_try(&$) { + my ($code, $errmsg) = @_; + my @result; + my $err; + my $array = wantarray; + try { + if ($array) { + @result = &$code; + } else { + $result[0] = &$code; + } + } catch Git::Error::Command with { + my $E = shift; + $err = $errmsg; + $err =~ s/\%s/$E->cmdline()/ge; + $err =~ s/\%d/$E->value()/ge; + # We can't croak here since Error.pm would mangle + # that to Error::Simple. + }; + $err and croak $err; + return $array ? @result : $result[0]; +} + + +=back =head1 COPYRIGHT @@ -384,14 +534,14 @@ sub _cmd_exec { # Close pipe to a subprocess. sub _cmd_close { - my ($fh) = @_; + my ($fh, $ctx) = @_; if (not close $fh) { if ($!) { # It's just close, no point in fatalities carp "error closing pipe: $!"; } elsif ($? >> 8) { - # This is the best candidate for a custom exception class. - throw Error::Simple("exit status: ".($? >> 8)); + # The caller should pepper this. + throw Git::Error::Command($ctx, $? >> 8); } # else we might e.g. closed a live stream; the command # dying of SIGPIPE would drive us here. -- cgit v0.10.2-6-g49f6 From d79850e1fd22abd44e447214a64e5a774ada311e Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:47 +0200 Subject: Git.pm: Enhance the command_pipe() mechanism Rename command_pipe() to command_output_pipe(), outsource the functionality to _command_common_pipe(). Add command_input_pipe(). Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 4205ac5..11ec62d 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -32,7 +32,7 @@ $VERSION = '0.01'; my @revs = $repo->command('rev-list', '--since=last monday', '--all'); - my ($fh, $c) = $repo->command_pipe('rev-list', '--since=last monday', '--all'); + my ($fh, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all'); my $lastrev = <$fh>; chomp $lastrev; $repo->command_close_pipe($fh, $c); @@ -48,7 +48,8 @@ require Exporter; @EXPORT = qw(git_cmd_try); # Methods which can be called as standalone functions as well: -@EXPORT_OK = qw(command command_oneline command_pipe command_noisy +@EXPORT_OK = qw(command command_oneline command_noisy + command_output_pipe command_input_pipe command_close_pipe version exec_path hash_object git_cmd_try); @@ -194,7 +195,7 @@ In both cases, the command's stdin and stderr are the same as the caller's. =cut sub command { - my ($fh, $ctx) = command_pipe(@_); + my ($fh, $ctx) = command_output_pipe(@_); if (not defined wantarray) { # Nothing to pepper the possible exception with. @@ -237,7 +238,7 @@ of the command's standard output. =cut sub command_oneline { - my ($fh, $ctx) = command_pipe(@_); + my ($fh, $ctx) = command_output_pipe(@_); my $line = <$fh>; chomp $line; @@ -253,40 +254,49 @@ sub command_oneline { } -=item command_pipe ( COMMAND [, ARGUMENTS... ] ) +=item command_output_pipe ( COMMAND [, ARGUMENTS... ] ) Execute the given C in the same way as command() does but return a pipe filehandle from which the command output can be read. +The function can return C<($pipe, $ctx)> in array context. +See C for details. + =cut -sub command_pipe { - my ($self, $cmd, @args) = _maybe_self(@_); +sub command_output_pipe { + _command_common_pipe('-|', @_); +} - $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd"); - my $pid = open(my $fh, "-|"); - if (not defined $pid) { - throw Error::Simple("open failed: $!"); - } elsif ($pid == 0) { - _cmd_exec($self, $cmd, @args); - } - return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh; +=item command_input_pipe ( COMMAND [, ARGUMENTS... ] ) + +Execute the given C in the same way as command_output_pipe() +does but return an input pipe filehandle instead; the command output +is not captured. + +The function can return C<($pipe, $ctx)> in array context. +See C for details. + +=cut + +sub command_input_pipe { + _command_common_pipe('|-', @_); } =item command_close_pipe ( PIPE [, CTX ] ) -Close the C as returned from C, checking +Close the C as returned from C, checking whether the command finished successfuly. The optional C argument is required if you want to see the command name in the error message, -and it is the second value returned by C when +and it is the second value returned by C when called in array context. The call idiom is: - my ($fh, $ctx) = $r->command_pipe('status'); - while (<$fh>) { ... } - $r->command_close_pipe($fh, $ctx); + my ($fh, $ctx) = $r->command_output_pipe('status'); + while (<$fh>) { ... } + $r->command_close_pipe($fh, $ctx); Note that you should not rely on whatever actually is in C; currently it is simply the command name but in future the context might @@ -317,8 +327,7 @@ The function returns only after the command has finished running. sub command_noisy { my ($self, $cmd, @args) = _maybe_self(@_); - - $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd"); + _check_valid_cmd($cmd); my $pid = fork; if (not defined $pid) { @@ -404,7 +413,7 @@ string with the captured command output (depending on the original function call context; C returns C) and $ which returns the command and its arguments (but without proper quoting). -Note that the C function cannot throw this exception since +Note that the C functions cannot throw this exception since it has no idea whether the command failed or not. You will only find out at the time you C the pipe; if you want to have that automated, use C, which can throw the exception. @@ -516,6 +525,27 @@ sub _maybe_self { ref $_[0] eq 'Git' ? @_ : (undef, @_); } +# Check if the command id is something reasonable. +sub _check_valid_cmd { + my ($cmd) = @_; + $cmd =~ /^[a-z0-9A-Z_-]+$/ or throw Error::Simple("bad command: $cmd"); +} + +# Common backend for the pipe creators. +sub _command_common_pipe { + my $direction = shift; + my ($self, $cmd, @args) = _maybe_self(@_); + _check_valid_cmd($cmd); + + my $pid = open(my $fh, $direction); + if (not defined $pid) { + throw Error::Simple("open failed: $!"); + } elsif ($pid == 0) { + _cmd_exec($self, $cmd, @args); + } + return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh; +} + # When already in the subprocess, set up the appropriate state # for the given repository and execute the git command. sub _cmd_exec { -- cgit v0.10.2-6-g49f6 From d43ba4680754c150124b6ac3cd9c6e52765c6881 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:49 +0200 Subject: Git.pm: Implement options for the command interface This gives the user a way to easily pass options to the command routines. Currently only the STDERR option is implemented and can be used to adjust what shall be done with error output of the called command (most usefully, it can be used to silence it). Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 11ec62d..e2b66c4 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -36,7 +36,8 @@ $VERSION = '0.01'; my $lastrev = <$fh>; chomp $lastrev; $repo->command_close_pipe($fh, $c); - my $lastrev = $repo->command_oneline('rev-list', '--all'); + my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ], + STDERR => 0 ); =cut @@ -178,9 +179,21 @@ sub repository { =item command ( COMMAND [, ARGUMENTS... ] ) +=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) + Execute the given Git C (specify it without the 'git-' prefix), optionally with the specified extra C. +The second more elaborate form can be used if you want to further adjust +the command execution. Currently, only one option is supported: + +B - How to deal with the command's error output. By default (C) +it is delivered to the caller's C. A false value (0 or '') will cause +it to be thrown away. If you want to process it, you can get it in a filehandle +you specify, but you must be extremely careful; if the error output is not +very short and you want to read it in the same process as where you called +C, you are set up for a nice deadlock! + The method can be called without any instance or on a specified Git repository (in that case the command will be run in the repository context). @@ -231,6 +244,8 @@ sub command { =item command_oneline ( COMMAND [, ARGUMENTS... ] ) +=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) + Execute the given C in the same way as command() does but always return a scalar string containing the first line of the command's standard output. @@ -256,6 +271,8 @@ sub command_oneline { =item command_output_pipe ( COMMAND [, ARGUMENTS... ] ) +=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) + Execute the given C in the same way as command() does but return a pipe filehandle from which the command output can be read. @@ -272,6 +289,8 @@ sub command_output_pipe { =item command_input_pipe ( COMMAND [, ARGUMENTS... ] ) +=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } ) + Execute the given C in the same way as command_output_pipe() does but return an input pipe filehandle instead; the command output is not captured. @@ -534,13 +553,27 @@ sub _check_valid_cmd { # Common backend for the pipe creators. sub _command_common_pipe { my $direction = shift; - my ($self, $cmd, @args) = _maybe_self(@_); + my ($self, @p) = _maybe_self(@_); + my (%opts, $cmd, @args); + if (ref $p[0]) { + ($cmd, @args) = @{shift @p}; + %opts = ref $p[0] ? %{$p[0]} : @p; + } else { + ($cmd, @args) = @p; + } _check_valid_cmd($cmd); my $pid = open(my $fh, $direction); if (not defined $pid) { throw Error::Simple("open failed: $!"); } elsif ($pid == 0) { + if (defined $opts{STDERR}) { + close STDERR; + } + if ($opts{STDERR}) { + open (STDERR, '>&', $opts{STDERR}) + or die "dup failed: $!"; + } _cmd_exec($self, $cmd, @args); } return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh; -- cgit v0.10.2-6-g49f6 From d5c7721d586225c46c675b893b7693220e28cfd5 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:51 +0200 Subject: Git.pm: Add support for subdirectories inside of working copies This patch adds support for subdirectories inside of working copies; you can specify them in the constructor either as the Directory option (it will just get autodetected using rev-parse) or explicitly using the WorkingSubdir option. This makes Git->repository() do the exact same path setup and repository lookup as the Git porcelain does. This patch also introduces repo_path(), wc_path() and wc_subdir() accessor methods and wc_chdir() mutator. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index e2b66c4..7bbb5be 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -69,20 +69,18 @@ means getting an instance of the Git object using the repository() constructor. called as methods of the object are then executed in the context of the repository. -TODO: In the future, we might also do +Part of the "repository state" is also information about path to the attached +working copy (unless you work with a bare repository). You can also navigate +inside of the working copy using the C method. (Note that +the repository object is self-contained and will not change working directory +of your process.) - my $subdir = $repo->subdir('Documentation'); - # Gets called in the subdirectory context: - $subdir->command('status'); +TODO: In the future, we might also do my $remoterepo = $repo->remote_repository (Name => 'cogito', Branch => 'master'); $remoterepo ||= Git->remote_repository ('http://git.or.cz/cogito.git/'); my @refs = $remoterepo->refs(); -So far, all functions just die if anything goes wrong. If you don't want that, -make appropriate provisions to catch the possible deaths. Better error recovery -mechanisms will be provided in the future. - Currently, the module merely wraps calls to external Git tools. In the future, it will provide a much faster way to interact with Git by linking directly to libgit. This should be completely opaque to the user, though (performance @@ -93,6 +91,7 @@ increate nonwithstanding). use Carp qw(carp croak); # but croak is bad - throw instead use Error qw(:try); +use Cwd qw(abs_path); require XSLoader; XSLoader::load('Git', $VERSION); @@ -119,12 +118,17 @@ B - Path to the Git repository. B - Path to the associated working copy; not strictly required as many commands will happily crunch on a bare repository. -B - Path to the Git working directory in its usual setup. This -is just for convenient setting of both C and C -at once: If the directory as a C<.git> subdirectory, C is pointed -to the subdirectory and the directory is assumed to be the working copy. -If the directory does not have the subdirectory, C is left -undefined and C is pointed to the directory itself. +B - Subdirectory in the working copy to work inside. +Just left undefined if you do not want to limit the scope of operations. + +B - Path to the Git working directory in its usual setup. +The C<.git> directory is searched in the directory and all the parent +directories; if found, C is set to the directory containing +it and C to the C<.git> directory itself. If no C<.git> +directory was found, the C is assumed to be a bare repository, +C is set to point at it and C is left undefined. +If the C<$GIT_DIR> environment variable is set, things behave as expected +as well. You should not use both C and either of C and C - the results of that are undefined. @@ -134,7 +138,10 @@ to the constructor; it is equivalent to setting only the C option field. Calling the constructor with no options whatsoever is equivalent to -calling it with C<< Directory => '.' >>. +calling it with C<< Directory => '.' >>. In general, if you are building +a standard porcelain command, simply doing C<< Git->repository() >> should +do the right thing and setup the object to reflect exactly where the user +is right now. =cut @@ -152,18 +159,59 @@ sub repository { } else { %opts = @args; } + } + + if (not defined $opts{Repository} and not defined $opts{WorkingCopy}) { + $opts{Directory} ||= '.'; + } + + if ($opts{Directory}) { + -d $opts{Directory} or throw Error::Simple("Directory not found: $!"); + + my $search = Git->repository(WorkingCopy => $opts{Directory}); + my $dir; + try { + $dir = $search->command_oneline(['rev-parse', '--git-dir'], + STDERR => 0); + } catch Git::Error::Command with { + $dir = undef; + }; - if ($opts{Directory}) { - -d $opts{Directory} or throw Error::Simple("Directory not found: $!"); - if (-d $opts{Directory}."/.git") { - # TODO: Might make this more clever - $opts{WorkingCopy} = $opts{Directory}; - $opts{Repository} = $opts{Directory}."/.git"; - } else { - $opts{Repository} = $opts{Directory}; + if ($dir) { + $opts{Repository} = abs_path($dir); + + # If --git-dir went ok, this shouldn't die either. + my $prefix = $search->command_oneline('rev-parse', '--show-prefix'); + $dir = abs_path($opts{Directory}) . '/'; + if ($prefix) { + if (substr($dir, -length($prefix)) ne $prefix) { + throw Error::Simple("rev-parse confused me - $dir does not have trailing $prefix"); + } + substr($dir, -length($prefix)) = ''; } - delete $opts{Directory}; + $opts{WorkingCopy} = $dir; + $opts{WorkingSubdir} = $prefix; + + } else { + # A bare repository? Let's see... + $dir = $opts{Directory}; + + unless (-d "$dir/refs" and -d "$dir/objects" and -e "$dir/HEAD") { + # Mimick git-rev-parse --git-dir error message: + throw Error::Simple('fatal: Not a git repository'); + } + my $search = Git->repository(Repository => $dir); + try { + $search->command('symbolic-ref', 'HEAD'); + } catch Git::Error::Command with { + # Mimick git-rev-parse --git-dir error message: + throw Error::Simple('fatal: Not a git repository'); + } + + $opts{Repository} = abs_path($dir); } + + delete $opts{Directory}; } $self = { opts => \%opts }; @@ -256,7 +304,7 @@ sub command_oneline { my ($fh, $ctx) = command_output_pipe(@_); my $line = <$fh>; - chomp $line; + defined $line and chomp $line; try { _cmd_close($fh, $ctx); } catch Git::Error::Command with { @@ -374,7 +422,7 @@ are involved. =item exec_path () -Return path to the git sub-command executables (the same as +Return path to the Git sub-command executables (the same as C). Useful mostly only internally. Implementation of this function is very fast; no external command calls @@ -385,6 +433,58 @@ are involved. # Implemented in Git.xs. +=item repo_path () + +Return path to the git repository. Must be called on a repository instance. + +=cut + +sub repo_path { $_[0]->{opts}->{Repository} } + + +=item wc_path () + +Return path to the working copy. Must be called on a repository instance. + +=cut + +sub wc_path { $_[0]->{opts}->{WorkingCopy} } + + +=item wc_subdir () + +Return path to the subdirectory inside of a working copy. Must be called +on a repository instance. + +=cut + +sub wc_subdir { $_[0]->{opts}->{WorkingSubdir} ||= '' } + + +=item wc_chdir ( SUBDIR ) + +Change the working copy subdirectory to work within. The C is +relative to the working copy root directory (not the current subdirectory). +Must be called on a repository instance attached to a working copy +and the directory must exist. + +=cut + +sub wc_chdir { + my ($self, $subdir) = @_; + + $self->wc_path() + or throw Error::Simple("bare repository"); + + -d $self->wc_path().'/'.$subdir + or throw Error::Simple("subdir not found: $!"); + # Of course we will not "hold" the subdirectory so anyone + # can delete it now and we will never know. But at least we tried. + + $self->{opts}->{WorkingSubdir} = $subdir; +} + + =item hash_object ( FILENAME [, TYPE ] ) =item hash_object ( FILEHANDLE [, TYPE ] ) @@ -584,8 +684,9 @@ sub _command_common_pipe { sub _cmd_exec { my ($self, @args) = @_; if ($self) { - $self->{opts}->{Repository} and $ENV{'GIT_DIR'} = $self->{opts}->{Repository}; - $self->{opts}->{WorkingCopy} and chdir($self->{opts}->{WorkingCopy}); + $self->repo_path() and $ENV{'GIT_DIR'} = $self->repo_path(); + $self->wc_path() and chdir($self->wc_path()); + $self->wc_subdir() and chdir($self->wc_subdir()); } _execv_git_cmd(@args); die "exec failed: $!"; -- cgit v0.10.2-6-g49f6 From 8f00660fc13df9ed22f059f032a65c60168a2057 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 04:34:53 +0200 Subject: Convert git-mv to use Git.pm Fairly straightforward. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/git-mv.perl b/git-mv.perl index 75aa8fe..f1bde43 100755 --- a/git-mv.perl +++ b/git-mv.perl @@ -10,6 +10,7 @@ use warnings; use strict; use Getopt::Std; +use Git; sub usage() { print <= 1 or usage; -my $GIT_DIR = `git rev-parse --git-dir`; -exit 1 if $?; # rev-parse would have given "not a git dir" message. -chomp($GIT_DIR); +my $repo = Git->repository(); my (@srcArgs, @dstArgs, @srcs, @dsts); my ($src, $dst, $base, $dstDir); @@ -62,11 +61,11 @@ else { $dstDir = ""; } -my $subdir_prefix = `git rev-parse --show-prefix`; -chomp($subdir_prefix); +my $subdir_prefix = $repo->wc_subdir(); # run in git base directory, so that git-ls-files lists all revisioned files -chdir "$GIT_DIR/.."; +chdir $repo->wc_path(); +$repo->wc_chdir(''); # normalize paths, needed to compare against versioned files and update-index # also, this is nicer to end-users by doing ".//a/./b/.//./c" ==> "a/b/c" @@ -84,12 +83,10 @@ my (@allfiles,@srcfiles,@dstfiles); my $safesrc; my (%overwritten, %srcForDst); -$/ = "\0"; -open(F, 'git-ls-files -z |') - or die "Failed to open pipe from git-ls-files: " . $!; - -@allfiles = map { chomp; $_; } ; -close(F); +{ + local $/ = "\0"; + @allfiles = $repo->command('ls-files', '-z'); +} my ($i, $bad); @@ -219,28 +216,28 @@ if ($opt_n) { } else { if (@changedfiles) { - open(H, "| git-update-index -z --stdin") - or die "git-update-index failed to update changed files with code $!\n"; + my ($fd, $ctx) = $repo->command_input_pipe('update-index', '-z', '--stdin'); foreach my $fileName (@changedfiles) { - print H "$fileName\0"; + print $fd "$fileName\0"; } - close(H); + git_cmd_try { $repo->command_close_pipe($fd, $ctx); } + 'git-update-index failed to update changed files with code %d'; } if (@addedfiles) { - open(H, "| git-update-index --add -z --stdin") - or die "git-update-index failed to add new names with code $!\n"; + my ($fd, $ctx) = $repo->command_input_pipe('update-index', '--add', '-z', '--stdin'); foreach my $fileName (@addedfiles) { - print H "$fileName\0"; + print $fd "$fileName\0"; } - close(H); + git_cmd_try { $repo->command_close_pipe($fd, $ctx); } + 'git-update-index failed to add new files with code %d'; } if (@deletedfiles) { - open(H, "| git-update-index --remove -z --stdin") - or die "git-update-index failed to remove old names with code $!\n"; + my ($fd, $ctx) = $repo->command_input_pipe('update-index', '--remove', '-z', '--stdin'); foreach my $fileName (@deletedfiles) { - print H "$fileName\0"; + print $fd "$fileName\0"; } - close(H); + git_cmd_try { $repo->command_close_pipe($fd, $ctx); } + 'git-update-index failed to remove old files with code %d'; } } -- cgit v0.10.2-6-g49f6 From f6af75d29c7e01e1d538dc3458c743e1a34defb6 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Fri, 23 Jun 2006 17:57:48 -0700 Subject: Perl interface: add build-time configuration to allow building with -fPIC On x86-64 it seems that Git.xs does not link without compiling the main git objects with -fPIC. Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index dda9b9d..aa0618e 100644 --- a/Makefile +++ b/Makefile @@ -1,11 +1,6 @@ # The default target of this Makefile is... all: -# Define MOZILLA_SHA1 environment variable when running make to make use of -# a bundled SHA1 routine coming from Mozilla. It is GPL'd and should be fast -# on non-x86 architectures (e.g. PowerPC), while the OpenSSL version (default -# choice) has very fast version optimized for i586. -# # Define NO_OPENSSL environment variable if you do not have OpenSSL. # This also implies MOZILLA_SHA1. # @@ -39,6 +34,14 @@ all: # Define ARM_SHA1 environment variable when running make to make use of # a bundled SHA1 routine optimized for ARM. # +# Define MOZILLA_SHA1 environment variable when running make to make use of +# a bundled SHA1 routine coming from Mozilla. It is GPL'd and should be fast +# on non-x86 architectures (e.g. PowerPC), while the OpenSSL version (default +# choice) has very fast version optimized for i586. +# +# Define USE_PIC if you need the main git objects to be built with -fPIC +# in order to build and link perl/Git.so. x86-64 seems to need this. +# # Define NEEDS_SSL_WITH_CRYPTO if you need -lcrypto with -lssl (Darwin). # # Define NEEDS_LIBICONV if linking with libc is not enough (Darwin). @@ -65,13 +68,13 @@ all: # Define COLLISION_CHECK below if you believe that SHA1's # 1461501637330902918203684832716283019655932542976 hashes do not give you # sufficient guarantee that no collisions between objects will ever happen. - +# # Define USE_NSEC below if you want git to care about sub-second file mtimes # and ctimes. Note that you need recent glibc (at least 2.2.4) for this, and # it will BREAK YOUR LOCAL DIFFS! show-diff and anything using it will likely # randomly break unless your underlying filesystem supports those sub-second # times (my ext3 doesn't). - +# # Define USE_STDEV below if you want git to care about the underlying device # change being considered an inode change from the update-cache perspective. @@ -464,6 +467,9 @@ else endif endif endif +ifdef USE_PIC + ALL_CFLAGS += -fPIC +endif ifdef NO_ACCURATE_DIFF ALL_CFLAGS += -DNO_ACCURATE_DIFF endif -- cgit v0.10.2-6-g49f6 From 5e6ab8607e4ae53c0abb5b3027904f1e3f539969 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Fri, 23 Jun 2006 17:56:11 -0700 Subject: Perl interface: make testsuite work again. Signed-off-by: Junio C Hamano diff --git a/t/test-lib.sh b/t/test-lib.sh index 05f6e79..fba0c51 100755 --- a/t/test-lib.sh +++ b/t/test-lib.sh @@ -206,6 +206,8 @@ PYTHON=`sed -e '1{ PYTHONPATH=$(pwd)/../compat export PYTHONPATH } +PERL5LIB=$(pwd)/../perl/blib/lib:$(pwd)/../perl/blib/arch/auto/Git +export PERL5LIB test -d ../templates/blt || { error "You haven't built things yet, have you?" } -- cgit v0.10.2-6-g49f6 From 523bbaa4580a103b0994b5e3c71efcb1a8c6a7db Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Sat, 24 Jun 2006 05:16:17 -0700 Subject: perl: fix make clean When perl/Makefile is stale with respect to perl/Makefile.PL, it prevents "make clean" from completing which is quite irritating. Fix it by calling subdirectory make clean twice as needed. Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index aa0618e..a76526a 100644 --- a/Makefile +++ b/Makefile @@ -744,7 +744,7 @@ clean: rm -f $(GIT_TARNAME).tar.gz git-core_$(GIT_VERSION)-*.tar.gz rm -f $(htmldocs).tar.gz $(manpages).tar.gz $(MAKE) -C Documentation/ clean - [ ! -e perl/Makefile ] || $(MAKE) -C perl/ clean + [ ! -e perl/Makefile ] || $(MAKE) -C perl/ clean || $(MAKE) -C perl/ clean $(MAKE) -C templates/ clean $(MAKE) -C t/ clean rm -f GIT-VERSION-FILE GIT-CFLAGS -- cgit v0.10.2-6-g49f6 From d595a473ee628d0f88989d06871d9752caafa7e9 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 24 Jun 2006 18:35:12 -0700 Subject: Git.pm: assorted build related fixes. - We passed our own *.a archives as LIBS to the submake that runs in perl/; separate LIBS and EXTLIBS and pass the latter which tells what the system libraries are used. - The quoting of preprocesor symbol definitions passed down to perl/ submake was loose and we lost double quotes around include directives. Use *_SQ to quote them properly. - The installation location of perl/ submake is not architecture neutral anymore, so use SITEARCH instead of SITELIB. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index a76526a..1371e79 100644 --- a/Makefile +++ b/Makefile @@ -235,7 +235,7 @@ BUILTIN_OBJS = \ builtin-update-ref.o GITLIBS = $(LIB_FILE) $(XDIFF_LIB) -LIBS = $(GITLIBS) -lz +EXTLIBS = -lz # # Platform specific tweaks @@ -393,14 +393,14 @@ ifdef NEEDS_LIBICONV else ICONV_LINK = endif - LIBS += $(ICONV_LINK) -liconv + EXTLIBS += $(ICONV_LINK) -liconv endif ifdef NEEDS_SOCKET - LIBS += -lsocket + EXTLIBS += -lsocket SIMPLE_LIB += -lsocket endif ifdef NEEDS_NSL - LIBS += -lnsl + EXTLIBS += -lnsl SIMPLE_LIB += -lnsl endif ifdef NO_D_TYPE_IN_DIRENT @@ -463,7 +463,7 @@ ifdef MOZILLA_SHA1 LIB_OBJS += mozilla-sha1/sha1.o else SHA1_HEADER = - LIBS += $(LIB_4_CRYPTO) + EXTLIBS += $(LIB_4_CRYPTO) endif endif endif @@ -489,9 +489,13 @@ PERL_PATH_SQ = $(subst ','\'',$(PERL_PATH)) PYTHON_PATH_SQ = $(subst ','\'',$(PYTHON_PATH)) GIT_PYTHON_DIR_SQ = $(subst ','\'',$(GIT_PYTHON_DIR)) +LIBS = $(GITLIBS) $(EXTLIBS) + ALL_CFLAGS += -DSHA1_HEADER='$(SHA1_HEADER_SQ)' $(COMPAT_CFLAGS) LIB_OBJS += $(COMPAT_OBJS) export prefix TAR INSTALL DESTDIR SHELL_PATH template_dir + + ### Build rules all: $(ALL_PROGRAMS) $(BUILT_INS) git$X gitk @@ -615,11 +619,15 @@ $(XDIFF_LIB): $(XDIFF_OBJS) rm -f $@ && $(AR) rcs $@ $(XDIFF_OBJS) -perl/Makefile: perl/Git.pm perl/Makefile.PL +PERL_DEFINE = $(ALL_CFLAGS) -DGIT_VERSION='"$(GIT_VERSION)"' +PERL_DEFINE_SQ = $(subst ','\'',$(PERL_DEFINE)) +PERL_LIBS = $(EXTLIBS) +PERL_LIBS_SQ = $(subst ','\'',$(PERL_LIBS)) +perl/Makefile: perl/Git.pm perl/Makefile.PL GIT-CFLAGS (cd perl && $(PERL_PATH) Makefile.PL \ - PREFIX="$(prefix)" \ - DEFINE="$(ALL_CFLAGS) -DGIT_VERSION=\\\"$(GIT_VERSION)\\\"" \ - LIBS="$(LIBS)") + PREFIX='$(prefix_SQ)' \ + DEFINE='$(PERL_DEFINE_SQ)' \ + LIBS='$(PERL_LIBS_SQ)') doc: $(MAKE) -C Documentation all diff --git a/perl/Git.xs b/perl/Git.xs index 9d247b7..8b06ebf 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -29,7 +29,7 @@ report_xs(const char *prefix, const char *err, va_list params) return buf; } -void +static void NORETURN die_xs(const char *err, va_list params) { char *str; @@ -37,13 +37,12 @@ die_xs(const char *err, va_list params) croak(str); } -int +static void error_xs(const char *err, va_list params) { char *str; str = report_xs("error: ", err, params); warn(str); - return -1; } diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 54e8b20..92c140d 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -3,7 +3,7 @@ use ExtUtils::MakeMaker; sub MY::postamble { return <<'MAKE_FRAG'; instlibdir: - @echo $(INSTALLSITELIB) + @echo $(INSTALLSITEARCH) MAKE_FRAG } -- cgit v0.10.2-6-g49f6 From f6276fe159fe985af2d5831f4629ceefb33d082e Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Sat, 24 Jun 2006 19:41:03 -0700 Subject: Git.pm: tentative fix to test the freshly built Git.pm Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 1371e79..9b9be59 100644 --- a/Makefile +++ b/Makefile @@ -531,9 +531,12 @@ $(patsubst %.sh,%,$(SCRIPT_SH)) : % : %.sh chmod +x $@+ mv $@+ $@ -$(patsubst %.perl,%,$(SCRIPT_PERL)) : % : %.perl +$(patsubst %.perl,%,$(SCRIPT_PERL)): perl/Makefile +$(patsubst %.perl,%,$(SCRIPT_PERL)): % : %.perl rm -f $@ $@+ - sed -e '1s|#!.*perl\(.*\)|#!$(PERL_PATH_SQ)\1 -I'"$$(make -s -C perl instlibdir)"'|' \ + INSTLIBDIR=$$(make -s -C perl instlibdir) && \ + sed -e '1s|#!.*perl\(.*\)|#!$(PERL_PATH_SQ)\1|' \ + -e 's|@@INSTLIBDIR@@|'"$$INSTLIBDIR"'|g' \ -e 's/@@GIT_VERSION@@/$(GIT_VERSION)/g' \ $@.perl >$@+ chmod +x $@+ diff --git a/git-fmt-merge-msg.perl b/git-fmt-merge-msg.perl index f86231e..e8fad02 100755 --- a/git-fmt-merge-msg.perl +++ b/git-fmt-merge-msg.perl @@ -5,6 +5,7 @@ # Read .git/FETCH_HEAD and make a human readable merge message # by grouping branches and tags together to form a single line. +unshift @INC, '@@INSTLIBDIR@@'; use strict; use Git; use Error qw(:try); -- cgit v0.10.2-6-g49f6 From a6065b548fc74ce4d8a655e17bfb1dba39540464 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sun, 25 Jun 2006 03:54:23 +0200 Subject: Git.pm: Try to support ActiveState output pipe The code is stolen from git-annotate and completely untested since I don't have access to any Microsoft operating system now. Someone ActiveState-savvy should look at it anyway and try to implement the input pipe as well, if it is possible at all; also, the implementation seems to be horribly whitespace-unsafe. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 7bbb5be..6173043 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -663,18 +663,29 @@ sub _command_common_pipe { } _check_valid_cmd($cmd); - my $pid = open(my $fh, $direction); - if (not defined $pid) { - throw Error::Simple("open failed: $!"); - } elsif ($pid == 0) { - if (defined $opts{STDERR}) { - close STDERR; - } - if ($opts{STDERR}) { - open (STDERR, '>&', $opts{STDERR}) - or die "dup failed: $!"; + my $fh; + if ($^O eq '##INSERT_ACTIVESTATE_STRING_HERE##') { + # ActiveState Perl + #defined $opts{STDERR} and + # warn 'ignoring STDERR option - running w/ ActiveState'; + $direction eq '-|' or + die 'input pipe for ActiveState not implemented'; + tie ($fh, 'Git::activestate_pipe', $cmd, @args); + + } else { + my $pid = open($fh, $direction); + if (not defined $pid) { + throw Error::Simple("open failed: $!"); + } elsif ($pid == 0) { + if (defined $opts{STDERR}) { + close STDERR; + } + if ($opts{STDERR}) { + open (STDERR, '>&', $opts{STDERR}) + or die "dup failed: $!"; + } + _cmd_exec($self, $cmd, @args); } - _cmd_exec($self, $cmd, @args); } return wantarray ? ($fh, join(' ', $cmd, @args)) : $fh; } @@ -749,4 +760,39 @@ sub AUTOLOAD { sub DESTROY { } +# Pipe implementation for ActiveState Perl. + +package Git::activestate_pipe; +use strict; + +sub TIEHANDLE { + my ($class, @params) = @_; + # FIXME: This is probably horrible idea and the thing will explode + # at the moment you give it arguments that require some quoting, + # but I have no ActiveState clue... --pasky + my $cmdline = join " ", @params; + my @data = qx{$cmdline}; + bless { i => 0, data => \@data }, $class; +} + +sub READLINE { + my $self = shift; + if ($self->{i} >= scalar @{$self->{data}}) { + return undef; + } + return $self->{'data'}->[ $self->{i}++ ]; +} + +sub CLOSE { + my $self = shift; + delete $self->{data}; + delete $self->{i}; +} + +sub EOF { + my $self = shift; + return ($self->{i} >= scalar @{$self->{data}}); +} + + 1; # Famous last words -- cgit v0.10.2-6-g49f6 From 24c4b7143639cc821b6d06f9e125429e65dad8cd Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sun, 25 Jun 2006 03:54:26 +0200 Subject: Git.pm: Swap hash_object() parameters I'm about to introduce get_object() and it will be better for consistency if the object type always goes first. And writing 'blob' there explicitly is not much bother. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 6173043..5ec7ef8 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -485,13 +485,13 @@ sub wc_chdir { } -=item hash_object ( FILENAME [, TYPE ] ) +=item hash_object ( TYPE, FILENAME ) -=item hash_object ( FILEHANDLE [, TYPE ] ) +=item hash_object ( TYPE, FILEHANDLE ) Compute the SHA1 object id of the given C (or data waiting in -C) considering it is of the C object type (C -(default), C, C). +C) considering it is of the C object type (C, +C, C). In case of C passed instead of file name, all the data available are read and hashed, and the filehandle is automatically diff --git a/perl/Git.xs b/perl/Git.xs index 8b06ebf..3030ba9 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -104,9 +104,9 @@ CODE: } char * -xs_hash_object(file, type = "blob") - SV *file; +xs_hash_object(type, file) char *type; + SV *file; CODE: { unsigned char sha1[20]; -- cgit v0.10.2-6-g49f6 From 71efe0ca3c9c8bc8e7863e583cd2a808769c3bab Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sun, 25 Jun 2006 03:54:28 +0200 Subject: Git.pm: Fix Git->repository("/somewhere/totally/elsewhere") Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 5ec7ef8..0581447 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -178,7 +178,8 @@ sub repository { }; if ($dir) { - $opts{Repository} = abs_path($dir); + $dir =~ m#^/# or $dir = $opts{Directory} . '/' . $dir; + $opts{Repository} = $dir; # If --git-dir went ok, this shouldn't die either. my $prefix = $search->command_oneline('rev-parse', '--show-prefix'); -- cgit v0.10.2-6-g49f6 From c2eeb4dcfece31a90f7de168092f4dfeaab96f95 Mon Sep 17 00:00:00 2001 From: Dennis Stosberg Date: Mon, 26 Jun 2006 10:27:54 +0200 Subject: "test" in Solaris' /bin/sh does not support -e Running "make clean" currently fails: [ ! -e perl/Makefile ] || make -C perl/ clean /bin/sh: test: argument expected make: *** [clean] Error 1 Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 9b9be59..13411ea 100644 --- a/Makefile +++ b/Makefile @@ -755,7 +755,7 @@ clean: rm -f $(GIT_TARNAME).tar.gz git-core_$(GIT_VERSION)-*.tar.gz rm -f $(htmldocs).tar.gz $(manpages).tar.gz $(MAKE) -C Documentation/ clean - [ ! -e perl/Makefile ] || $(MAKE) -C perl/ clean || $(MAKE) -C perl/ clean + [ ! -f perl/Makefile ] || $(MAKE) -C perl/ clean || $(MAKE) -C perl/ clean $(MAKE) -C templates/ clean $(MAKE) -C t/ clean rm -f GIT-VERSION-FILE GIT-CFLAGS -- cgit v0.10.2-6-g49f6 From de86e131b538a021c14d53c6cc98bd7f0330dc92 Mon Sep 17 00:00:00 2001 From: Dennis Stosberg Date: Tue, 27 Jun 2006 00:21:07 +0200 Subject: Makefile fix for Solaris Solaris' /bin/sh does not support $( )-style command substitution Signed-off-by: Dennis Stosberg Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 13411ea..1121d3e 100644 --- a/Makefile +++ b/Makefile @@ -534,7 +534,7 @@ $(patsubst %.sh,%,$(SCRIPT_SH)) : % : %.sh $(patsubst %.perl,%,$(SCRIPT_PERL)): perl/Makefile $(patsubst %.perl,%,$(SCRIPT_PERL)): % : %.perl rm -f $@ $@+ - INSTLIBDIR=$$(make -s -C perl instlibdir) && \ + INSTLIBDIR=`make -s -C perl instlibdir` && \ sed -e '1s|#!.*perl\(.*\)|#!$(PERL_PATH_SQ)\1|' \ -e 's|@@INSTLIBDIR@@|'"$$INSTLIBDIR"'|g' \ -e 's/@@GIT_VERSION@@/$(GIT_VERSION)/g' \ -- cgit v0.10.2-6-g49f6 From 8d7f586f13f5aac31dca22b1d726e1583e180cb5 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sun, 25 Jun 2006 03:47:03 +0200 Subject: Git.pm: Support for perl/ being built by a different compiler dst_ on #git reported that on Solaris 9, Perl was built by Sun CC and perl/ is therefore being built with it as well, while the rest of Git is built with gcc. The problem (the first one visible, anyway) is that we passed perl/ even various gcc-specific options. This separates those to a special variable. This is not really meant for an application yet since it's not clear if it will alone help anything. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 1121d3e..ee9508e 100644 --- a/Makefile +++ b/Makefile @@ -117,6 +117,11 @@ SPARSE_FLAGS = -D__BIG_ENDIAN__ -D__powerpc__ ### --- END CONFIGURATION SECTION --- +# Those must not be GNU-specific; they are shared with perl/ which may +# be built by a different compiler. +BASIC_CFLAGS = +BASIC_LDFLAGS = + SCRIPT_SH = \ git-bisect.sh git-branch.sh git-checkout.sh \ git-cherry.sh git-clean.sh git-clone.sh git-commit.sh \ @@ -254,13 +259,13 @@ ifeq ($(uname_S),Darwin) NO_STRLCPY = YesPlease ## fink ifeq ($(shell test -d /sw/lib && echo y),y) - ALL_CFLAGS += -I/sw/include - ALL_LDFLAGS += -L/sw/lib + BASIC_CFLAGS += -I/sw/include + BASIC_LDFLAGS += -L/sw/lib endif ## darwinports ifeq ($(shell test -d /opt/local/lib && echo y),y) - ALL_CFLAGS += -I/opt/local/include - ALL_LDFLAGS += -L/opt/local/lib + BASIC_CFLAGS += -I/opt/local/include + BASIC_LDFLAGS += -L/opt/local/lib endif endif ifeq ($(uname_S),SunOS) @@ -280,7 +285,7 @@ ifeq ($(uname_S),SunOS) endif INSTALL = ginstall TAR = gtar - ALL_CFLAGS += -D__EXTENSIONS__ + BASIC_CFLAGS += -D__EXTENSIONS__ endif ifeq ($(uname_O),Cygwin) NO_D_TYPE_IN_DIRENT = YesPlease @@ -298,21 +303,22 @@ ifeq ($(uname_O),Cygwin) endif ifeq ($(uname_S),FreeBSD) NEEDS_LIBICONV = YesPlease - ALL_CFLAGS += -I/usr/local/include - ALL_LDFLAGS += -L/usr/local/lib + BASIC_CFLAGS += -I/usr/local/include + BASIC_LDFLAGS += -L/usr/local/lib endif ifeq ($(uname_S),OpenBSD) NO_STRCASESTR = YesPlease NEEDS_LIBICONV = YesPlease - ALL_CFLAGS += -I/usr/local/include - ALL_LDFLAGS += -L/usr/local/lib + BASIC_CFLAGS += -I/usr/local/include + BASIC_LDFLAGS += -L/usr/local/lib endif ifeq ($(uname_S),NetBSD) ifeq ($(shell expr "$(uname_R)" : '[01]\.'),2) NEEDS_LIBICONV = YesPlease endif - ALL_CFLAGS += -I/usr/pkg/include - ALL_LDFLAGS += -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib + BASIC_CFLAGS += -I/usr/pkg/include + BASIC_LDFLAGS += -L/usr/pkg/lib + ALL_LDFLAGS += -Wl,-rpath,/usr/pkg/lib endif ifeq ($(uname_S),AIX) NO_STRCASESTR=YesPlease @@ -326,9 +332,9 @@ ifeq ($(uname_S),IRIX64) NO_STRLCPY = YesPlease NO_SOCKADDR_STORAGE=YesPlease SHELL_PATH=/usr/gnu/bin/bash - ALL_CFLAGS += -DPATH_MAX=1024 + BASIC_CFLAGS += -DPATH_MAX=1024 # for now, build 32-bit version - ALL_LDFLAGS += -L/usr/lib32 + BASIC_LDFLAGS += -L/usr/lib32 endif ifneq (,$(findstring arm,$(uname_M))) ARM_SHA1 = YesPlease @@ -349,7 +355,7 @@ endif ifndef NO_CURL ifdef CURLDIR # This is still problematic -- gcc does not always want -R. - ALL_CFLAGS += -I$(CURLDIR)/include + BASIC_CFLAGS += -I$(CURLDIR)/include CURL_LIBCURL = -L$(CURLDIR)/lib -R$(CURLDIR)/lib -lcurl else CURL_LIBCURL = -lcurl @@ -370,13 +376,13 @@ ifndef NO_OPENSSL OPENSSL_LIBSSL = -lssl ifdef OPENSSLDIR # Again this may be problematic -- gcc does not always want -R. - ALL_CFLAGS += -I$(OPENSSLDIR)/include + BASIC_CFLAGS += -I$(OPENSSLDIR)/include OPENSSL_LINK = -L$(OPENSSLDIR)/lib -R$(OPENSSLDIR)/lib else OPENSSL_LINK = endif else - ALL_CFLAGS += -DNO_OPENSSL + BASIC_CFLAGS += -DNO_OPENSSL MOZILLA_SHA1 = 1 OPENSSL_LIBSSL = endif @@ -388,7 +394,7 @@ endif ifdef NEEDS_LIBICONV ifdef ICONVDIR # Again this may be problematic -- gcc does not always want -R. - ALL_CFLAGS += -I$(ICONVDIR)/include + BASIC_CFLAGS += -I$(ICONVDIR)/include ICONV_LINK = -L$(ICONVDIR)/lib -R$(ICONVDIR)/lib else ICONV_LINK = @@ -404,13 +410,13 @@ ifdef NEEDS_NSL SIMPLE_LIB += -lnsl endif ifdef NO_D_TYPE_IN_DIRENT - ALL_CFLAGS += -DNO_D_TYPE_IN_DIRENT + BASIC_CFLAGS += -DNO_D_TYPE_IN_DIRENT endif ifdef NO_D_INO_IN_DIRENT - ALL_CFLAGS += -DNO_D_INO_IN_DIRENT + BASIC_CFLAGS += -DNO_D_INO_IN_DIRENT endif ifdef NO_SYMLINK_HEAD - ALL_CFLAGS += -DNO_SYMLINK_HEAD + BASIC_CFLAGS += -DNO_SYMLINK_HEAD endif ifdef NO_STRCASESTR COMPAT_CFLAGS += -DNO_STRCASESTR @@ -433,13 +439,13 @@ ifdef NO_MMAP COMPAT_OBJS += compat/mmap.o endif ifdef NO_IPV6 - ALL_CFLAGS += -DNO_IPV6 + BASIC_CFLAGS += -DNO_IPV6 endif ifdef NO_SOCKADDR_STORAGE ifdef NO_IPV6 - ALL_CFLAGS += -Dsockaddr_storage=sockaddr_in + BASIC_CFLAGS += -Dsockaddr_storage=sockaddr_in else - ALL_CFLAGS += -Dsockaddr_storage=sockaddr_in6 + BASIC_CFLAGS += -Dsockaddr_storage=sockaddr_in6 endif endif ifdef NO_INET_NTOP @@ -447,7 +453,7 @@ ifdef NO_INET_NTOP endif ifdef NO_ICONV - ALL_CFLAGS += -DNO_ICONV + BASIC_CFLAGS += -DNO_ICONV endif ifdef PPC_SHA1 @@ -471,7 +477,7 @@ ifdef USE_PIC ALL_CFLAGS += -fPIC endif ifdef NO_ACCURATE_DIFF - ALL_CFLAGS += -DNO_ACCURATE_DIFF + BASIC_CFLAGS += -DNO_ACCURATE_DIFF endif # Shell quote (do not use $(call) to accomodate ancient setups); @@ -491,8 +497,12 @@ GIT_PYTHON_DIR_SQ = $(subst ','\'',$(GIT_PYTHON_DIR)) LIBS = $(GITLIBS) $(EXTLIBS) -ALL_CFLAGS += -DSHA1_HEADER='$(SHA1_HEADER_SQ)' $(COMPAT_CFLAGS) +BASIC_CFLAGS += -DSHA1_HEADER='$(SHA1_HEADER_SQ)' $(COMPAT_CFLAGS) LIB_OBJS += $(COMPAT_OBJS) + +ALL_CFLAGS += $(BASIC_CFLAGS) +ALL_LDFLAGS += $(BASIC_LDFLAGS) + export prefix TAR INSTALL DESTDIR SHELL_PATH template_dir @@ -622,9 +632,9 @@ $(XDIFF_LIB): $(XDIFF_OBJS) rm -f $@ && $(AR) rcs $@ $(XDIFF_OBJS) -PERL_DEFINE = $(ALL_CFLAGS) -DGIT_VERSION='"$(GIT_VERSION)"' +PERL_DEFINE = $(BASIC_CFLAGS) -DGIT_VERSION='"$(GIT_VERSION)"' PERL_DEFINE_SQ = $(subst ','\'',$(PERL_DEFINE)) -PERL_LIBS = $(EXTLIBS) +PERL_LIBS = $(BASIC_LDFLAGS) $(EXTLIBS) PERL_LIBS_SQ = $(subst ','\'',$(PERL_LIBS)) perl/Makefile: perl/Git.pm perl/Makefile.PL GIT-CFLAGS (cd perl && $(PERL_PATH) Makefile.PL \ -- cgit v0.10.2-6-g49f6 From c9093fb38b48dcf09dbf1fb5cbf72e2b1f2c1258 Mon Sep 17 00:00:00 2001 From: Dennis Stosberg Date: Tue, 27 Jun 2006 00:23:08 +0200 Subject: Add possibility to pass CFLAGS and LDFLAGS specific to the perl subdir Signed-off-by: Dennis Stosberg Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index ee9508e..2f66ab1 100644 --- a/Makefile +++ b/Makefile @@ -94,6 +94,8 @@ CFLAGS = -g -O2 -Wall LDFLAGS = ALL_CFLAGS = $(CFLAGS) ALL_LDFLAGS = $(LDFLAGS) +PERL_CFLAGS = +PERL_LDFLAGS = STRIP ?= strip prefix = $(HOME) @@ -119,8 +121,8 @@ SPARSE_FLAGS = -D__BIG_ENDIAN__ -D__powerpc__ # Those must not be GNU-specific; they are shared with perl/ which may # be built by a different compiler. -BASIC_CFLAGS = -BASIC_LDFLAGS = +BASIC_CFLAGS = $(PERL_CFLAGS) +BASIC_LDFLAGS = $(PERL_LDFLAGS) SCRIPT_SH = \ git-bisect.sh git-branch.sh git-checkout.sh \ -- cgit v0.10.2-6-g49f6 From f1b8fd4abae7910d9227ae019220944e8fac6884 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Wed, 28 Jun 2006 03:17:07 -0700 Subject: Perly Git: arrange include path settings properly. Before "use Git" takes effect, we would need to set up the Perl library path to point at the local installation location. So that instruction needs to be in BEGIN{} block. Pointed out and fixed by Pavel Roskin. Signed-off-by: Junio C Hamano diff --git a/git-fmt-merge-msg.perl b/git-fmt-merge-msg.perl index e8fad02..1b23fa1 100755 --- a/git-fmt-merge-msg.perl +++ b/git-fmt-merge-msg.perl @@ -5,7 +5,7 @@ # Read .git/FETCH_HEAD and make a human readable merge message # by grouping branches and tags together to form a single line. -unshift @INC, '@@INSTLIBDIR@@'; +BEGIN { unshift @INC, '@@INSTLIBDIR@@'; } use strict; use Git; use Error qw(:try); diff --git a/git-mv.perl b/git-mv.perl index f1bde43..a604896 100755 --- a/git-mv.perl +++ b/git-mv.perl @@ -6,7 +6,7 @@ # This file is licensed under the GPL v2, or a later version # at the discretion of Linus Torvalds. - +BEGIN { unshift @INC, '@@INSTLIBDIR@@'; } use warnings; use strict; use Getopt::Std; -- cgit v0.10.2-6-g49f6 From c35ebc902fd5c48c978d0d4cfab52ccdb4b11f54 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Wed, 28 Jun 2006 22:08:54 -0700 Subject: Makefile: Set USE_PIC on x86-64 On some platforms, Git.xs refuses to link with the rest of git unless the latter is compiled with -fPIC, and we have USE_PIC control in the Makefile for the user to set it. At least we know x86-64 is such, so set it in the Makefile. The original suggestion by Marco Roeland conservatively did this only for Linux x86-64, but let's keep the Makefile simple and if it breaks somebody let them holler. Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 2f66ab1..3c25fb3 100644 --- a/Makefile +++ b/Makefile @@ -341,6 +341,9 @@ endif ifneq (,$(findstring arm,$(uname_M))) ARM_SHA1 = YesPlease endif +ifeq ($(uname_M),x86_64) + USE_PIC = YesPlease +endif -include config.mak -- cgit v0.10.2-6-g49f6 From 893973a6f271429fbe1973d61dc8e1d76753327e Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Thu, 29 Jun 2006 17:02:21 -0700 Subject: Perly git: work around buggy make implementations. FC4 uses gnumake 3.80 whose annoying "Entering directory..." messages are not silenced with -s alone. Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 3c25fb3..3810514 100644 --- a/Makefile +++ b/Makefile @@ -549,7 +549,7 @@ $(patsubst %.sh,%,$(SCRIPT_SH)) : % : %.sh $(patsubst %.perl,%,$(SCRIPT_PERL)): perl/Makefile $(patsubst %.perl,%,$(SCRIPT_PERL)): % : %.perl rm -f $@ $@+ - INSTLIBDIR=`make -s -C perl instlibdir` && \ + INSTLIBDIR=`$(MAKE) -C perl -s --no-print-directory instlibdir` && \ sed -e '1s|#!.*perl\(.*\)|#!$(PERL_PATH_SQ)\1|' \ -e 's|@@INSTLIBDIR@@|'"$$INSTLIBDIR"'|g' \ -e 's/@@GIT_VERSION@@/$(GIT_VERSION)/g' \ diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 92c140d..d401a66 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -3,7 +3,7 @@ use ExtUtils::MakeMaker; sub MY::postamble { return <<'MAKE_FRAG'; instlibdir: - @echo $(INSTALLSITEARCH) + @echo '$(INSTALLSITEARCH)' MAKE_FRAG } -- cgit v0.10.2-6-g49f6 From 3553309f5ba7f9fed61ac2767d53677c309826b2 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Fri, 30 Jun 2006 00:43:43 -0700 Subject: Git.pm: clean generated files. Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 3810514..7030167 100644 --- a/Makefile +++ b/Makefile @@ -771,6 +771,7 @@ clean: rm -f $(htmldocs).tar.gz $(manpages).tar.gz $(MAKE) -C Documentation/ clean [ ! -f perl/Makefile ] || $(MAKE) -C perl/ clean || $(MAKE) -C perl/ clean + rm -f perl/ppport.h perl/Makefile.old $(MAKE) -C templates/ clean $(MAKE) -C t/ clean rm -f GIT-VERSION-FILE GIT-CFLAGS -- cgit v0.10.2-6-g49f6 From 1d8c9dc47de0cbf3955ccc9408564cccbda8e348 Mon Sep 17 00:00:00 2001 From: Pavel Roskin Date: Fri, 30 Jun 2006 01:09:23 -0400 Subject: Fix probing for already installed Error.pm The syntax for 'require' was wrong, and it was always failing, which resulted in installing our own version of Error.pm anyways. Now we used to ship our own Error.pm in the same directory, so after fixing the syntax, 'require' always succeeds, but it does not test if the platform has Error.pm module installed anymore. So rename the source we ship to private-Error.pm, and install that as Error.pm when the platform does not have one already. Signed-off-by: Pavel Roskin Signed-off-by: Junio C Hamano diff --git a/perl/Error.pm b/perl/Error.pm deleted file mode 100644 index ebd0749..0000000 --- a/perl/Error.pm +++ /dev/null @@ -1,821 +0,0 @@ -# Error.pm -# -# Copyright (c) 1997-8 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# Based on my original Error.pm, and Exceptions.pm by Peter Seibel -# and adapted by Jesse Glick . -# -# but modified ***significantly*** - -package Error; - -use strict; -use vars qw($VERSION); -use 5.004; - -$VERSION = "0.15009"; - -use overload ( - '""' => 'stringify', - '0+' => 'value', - 'bool' => sub { return 1; }, - 'fallback' => 1 -); - -$Error::Depth = 0; # Depth to pass to caller() -$Error::Debug = 0; # Generate verbose stack traces -@Error::STACK = (); # Clause stack for try -$Error::THROWN = undef; # last error thrown, a workaround until die $ref works - -my $LAST; # Last error created -my %ERROR; # Last error associated with package - -sub throw_Error_Simple -{ - my $args = shift; - return Error::Simple->new($args->{'text'}); -} - -$Error::ObjectifyCallback = \&throw_Error_Simple; - - -# Exported subs are defined in Error::subs - -use Scalar::Util (); - -sub import { - shift; - local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; - Error::subs->import(@_); -} - -# I really want to use last for the name of this method, but it is a keyword -# which prevent the syntax last Error - -sub prior { - shift; # ignore - - return $LAST unless @_; - - my $pkg = shift; - return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef - unless ref($pkg); - - my $obj = $pkg; - my $err = undef; - if($obj->isa('HASH')) { - $err = $obj->{'__Error__'} - if exists $obj->{'__Error__'}; - } - elsif($obj->isa('GLOB')) { - $err = ${*$obj}{'__Error__'} - if exists ${*$obj}{'__Error__'}; - } - - $err; -} - -sub flush { - shift; #ignore - - unless (@_) { - $LAST = undef; - return; - } - - my $pkg = shift; - return unless ref($pkg); - - undef $ERROR{$pkg} if defined $ERROR{$pkg}; -} - -# Return as much information as possible about where the error -# happened. The -stacktrace element only exists if $Error::DEBUG -# was set when the error was created - -sub stacktrace { - my $self = shift; - - return $self->{'-stacktrace'} - if exists $self->{'-stacktrace'}; - - my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; - - $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) - unless($text =~ /\n$/s); - - $text; -} - -# Allow error propagation, ie -# -# $ber->encode(...) or -# return Error->prior($ber)->associate($ldap); - -sub associate { - my $err = shift; - my $obj = shift; - - return unless ref($obj); - - if($obj->isa('HASH')) { - $obj->{'__Error__'} = $err; - } - elsif($obj->isa('GLOB')) { - ${*$obj}{'__Error__'} = $err; - } - $obj = ref($obj); - $ERROR{ ref($obj) } = $err; - - return; -} - -sub new { - my $self = shift; - my($pkg,$file,$line) = caller($Error::Depth); - - my $err = bless { - '-package' => $pkg, - '-file' => $file, - '-line' => $line, - @_ - }, $self; - - $err->associate($err->{'-object'}) - if(exists $err->{'-object'}); - - # To always create a stacktrace would be very inefficient, so - # we only do it if $Error::Debug is set - - if($Error::Debug) { - require Carp; - local $Carp::CarpLevel = $Error::Depth; - my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; - my $trace = Carp::longmess($text); - # Remove try calls from the trace - $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; - $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; - $err->{'-stacktrace'} = $trace - } - - $@ = $LAST = $ERROR{$pkg} = $err; -} - -# Throw an error. this contains some very gory code. - -sub throw { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - # if we are not rethrow-ing then create the object to throw - $self = $self->new(@_) unless ref($self); - - die $Error::THROWN = $self; -} - -# syntactic sugar for -# -# die with Error( ... ); - -sub with { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - $self->new(@_); -} - -# syntactic sugar for -# -# record Error( ... ) and return; - -sub record { - my $self = shift; - local $Error::Depth = $Error::Depth + 1; - - $self->new(@_); -} - -# catch clause for -# -# try { ... } catch CLASS with { ... } - -sub catch { - my $pkg = shift; - my $code = shift; - my $clauses = shift || {}; - my $catch = $clauses->{'catch'} ||= []; - - unshift @$catch, $pkg, $code; - - $clauses; -} - -# Object query methods - -sub object { - my $self = shift; - exists $self->{'-object'} ? $self->{'-object'} : undef; -} - -sub file { - my $self = shift; - exists $self->{'-file'} ? $self->{'-file'} : undef; -} - -sub line { - my $self = shift; - exists $self->{'-line'} ? $self->{'-line'} : undef; -} - -sub text { - my $self = shift; - exists $self->{'-text'} ? $self->{'-text'} : undef; -} - -# overload methods - -sub stringify { - my $self = shift; - defined $self->{'-text'} ? $self->{'-text'} : "Died"; -} - -sub value { - my $self = shift; - exists $self->{'-value'} ? $self->{'-value'} : undef; -} - -package Error::Simple; - -@Error::Simple::ISA = qw(Error); - -sub new { - my $self = shift; - my $text = "" . shift; - my $value = shift; - my(@args) = (); - - local $Error::Depth = $Error::Depth + 1; - - @args = ( -file => $1, -line => $2) - if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s); - push(@args, '-value', 0 + $value) - if defined($value); - - $self->SUPER::new(-text => $text, @args); -} - -sub stringify { - my $self = shift; - my $text = $self->SUPER::stringify; - $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) - unless($text =~ /\n$/s); - $text; -} - -########################################################################## -########################################################################## - -# Inspired by code from Jesse Glick and -# Peter Seibel - -package Error::subs; - -use Exporter (); -use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); - -@EXPORT_OK = qw(try with finally except otherwise); -%EXPORT_TAGS = (try => \@EXPORT_OK); - -@ISA = qw(Exporter); - -sub run_clauses ($$$\@) { - my($clauses,$err,$wantarray,$result) = @_; - my $code = undef; - - $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err); - - CATCH: { - - # catch - my $catch; - if(defined($catch = $clauses->{'catch'})) { - my $i = 0; - - CATCHLOOP: - for( ; $i < @$catch ; $i += 2) { - my $pkg = $catch->[$i]; - unless(defined $pkg) { - #except - splice(@$catch,$i,2,$catch->[$i+1]->()); - $i -= 2; - next CATCHLOOP; - } - elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { - $code = $catch->[$i+1]; - while(1) { - my $more = 0; - local($Error::THROWN); - my $ok = eval { - if($wantarray) { - @{$result} = $code->($err,\$more); - } - elsif(defined($wantarray)) { - @{$result} = (); - $result->[0] = $code->($err,\$more); - } - else { - $code->($err,\$more); - } - 1; - }; - if( $ok ) { - next CATCHLOOP if $more; - undef $err; - } - else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; - $err = $Error::ObjectifyCallback->({'text' =>$err}) - unless ref($err); - } - last CATCH; - }; - } - } - } - - # otherwise - my $owise; - if(defined($owise = $clauses->{'otherwise'})) { - my $code = $clauses->{'otherwise'}; - my $more = 0; - my $ok = eval { - if($wantarray) { - @{$result} = $code->($err,\$more); - } - elsif(defined($wantarray)) { - @{$result} = (); - $result->[0] = $code->($err,\$more); - } - else { - $code->($err,\$more); - } - 1; - }; - if( $ok ) { - undef $err; - } - else { - $err = defined($Error::THROWN) - ? $Error::THROWN : $@; - - $err = $Error::ObjectifyCallback->({'text' =>$err}) - unless ref($err); - } - } - } - $err; -} - -sub try (&;$) { - my $try = shift; - my $clauses = @_ ? shift : {}; - my $ok = 0; - my $err = undef; - my @result = (); - - unshift @Error::STACK, $clauses; - - my $wantarray = wantarray(); - - do { - local $Error::THROWN = undef; - local $@ = undef; - - $ok = eval { - if($wantarray) { - @result = $try->(); - } - elsif(defined $wantarray) { - $result[0] = $try->(); - } - else { - $try->(); - } - 1; - }; - - $err = defined($Error::THROWN) ? $Error::THROWN : $@ - unless $ok; - }; - - shift @Error::STACK; - - $err = run_clauses($clauses,$err,wantarray,@result) - unless($ok); - - $clauses->{'finally'}->() - if(defined($clauses->{'finally'})); - - if (defined($err)) - { - if (Scalar::Util::blessed($err) && $err->can('throw')) - { - throw $err; - } - else - { - die $err; - } - } - - wantarray ? @result : $result[0]; -} - -# Each clause adds a sub to the list of clauses. The finally clause is -# always the last, and the otherwise clause is always added just before -# the finally clause. -# -# All clauses, except the finally clause, add a sub which takes one argument -# this argument will be the error being thrown. The sub will return a code ref -# if that clause can handle that error, otherwise undef is returned. -# -# The otherwise clause adds a sub which unconditionally returns the users -# code reference, this is why it is forced to be last. -# -# The catch clause is defined in Error.pm, as the syntax causes it to -# be called as a method - -sub with (&;$) { - @_ -} - -sub finally (&) { - my $code = shift; - my $clauses = { 'finally' => $code }; - $clauses; -} - -# The except clause is a block which returns a hashref or a list of -# key-value pairs, where the keys are the classes and the values are subs. - -sub except (&;$) { - my $code = shift; - my $clauses = shift || {}; - my $catch = $clauses->{'catch'} ||= []; - - my $sub = sub { - my $ref; - my(@array) = $code->($_[0]); - if(@array == 1 && ref($array[0])) { - $ref = $array[0]; - $ref = [ %$ref ] - if(UNIVERSAL::isa($ref,'HASH')); - } - else { - $ref = \@array; - } - @$ref - }; - - unshift @{$catch}, undef, $sub; - - $clauses; -} - -sub otherwise (&;$) { - my $code = shift; - my $clauses = shift || {}; - - if(exists $clauses->{'otherwise'}) { - require Carp; - Carp::croak("Multiple otherwise clauses"); - } - - $clauses->{'otherwise'} = $code; - - $clauses; -} - -1; -__END__ - -=head1 NAME - -Error - Error/exception handling in an OO-ish way - -=head1 SYNOPSIS - - use Error qw(:try); - - throw Error::Simple( "A simple error"); - - sub xyz { - ... - record Error::Simple("A simple error") - and return; - } - - unlink($file) or throw Error::Simple("$file: $!",$!); - - try { - do_some_stuff(); - die "error!" if $condition; - throw Error::Simple -text => "Oops!" if $other_condition; - } - catch Error::IO with { - my $E = shift; - print STDERR "File ", $E->{'-file'}, " had a problem\n"; - } - except { - my $E = shift; - my $general_handler=sub {send_message $E->{-description}}; - return { - UserException1 => $general_handler, - UserException2 => $general_handler - }; - } - otherwise { - print STDERR "Well I don't know what to say\n"; - } - finally { - close_the_garage_door_already(); # Should be reliable - }; # Don't forget the trailing ; or you might be surprised - -=head1 DESCRIPTION - -The C package provides two interfaces. Firstly C provides -a procedural interface to exception handling. Secondly C is a -base class for errors/exceptions that can either be thrown, for -subsequent catch, or can simply be recorded. - -Errors in the class C should not be thrown directly, but the -user should throw errors from a sub-class of C. - -=head1 PROCEDURAL INTERFACE - -C exports subroutines to perform exception handling. These will -be exported if the C<:try> tag is used in the C line. - -=over 4 - -=item try BLOCK CLAUSES - -C is the main subroutine called by the user. All other subroutines -exported are clauses to the try subroutine. - -The BLOCK will be evaluated and, if no error is throw, try will return -the result of the block. - -C are the subroutines below, which describe what to do in the -event of an error being thrown within BLOCK. - -=item catch CLASS with BLOCK - -This clauses will cause all errors that satisfy C<$err-Eisa(CLASS)> -to be caught and handled by evaluating C. - -C will be passed two arguments. The first will be the error -being thrown. The second is a reference to a scalar variable. If this -variable is set by the catch block then, on return from the catch -block, try will continue processing as if the catch block was never -found. - -To propagate the error the catch block may call C<$err-Ethrow> - -If the scalar reference by the second argument is not set, and the -error is not thrown. Then the current try block will return with the -result from the catch block. - -=item except BLOCK - -When C is looking for a handler, if an except clause is found -C is evaluated. The return value from this block should be a -HASHREF or a list of key-value pairs, where the keys are class names -and the values are CODE references for the handler of errors of that -type. - -=item otherwise BLOCK - -Catch any error by executing the code in C - -When evaluated C will be passed one argument, which will be the -error being processed. - -Only one otherwise block may be specified per try block - -=item finally BLOCK - -Execute the code in C either after the code in the try block has -successfully completed, or if the try block throws an error then -C will be executed after the handler has completed. - -If the handler throws an error then the error will be caught, the -finally block will be executed and the error will be re-thrown. - -Only one finally block may be specified per try block - -=back - -=head1 CLASS INTERFACE - -=head2 CONSTRUCTORS - -The C object is implemented as a HASH. This HASH is initialized -with the arguments that are passed to it's constructor. The elements -that are used by, or are retrievable by the C class are listed -below, other classes may add to these. - - -file - -line - -text - -value - -object - -If C<-file> or C<-line> are not specified in the constructor arguments -then these will be initialized with the file name and line number where -the constructor was called from. - -If the error is associated with an object then the object should be -passed as the C<-object> argument. This will allow the C package -to associate the error with the object. - -The C package remembers the last error created, and also the -last error associated with a package. This could either be the last -error created by a sub in that package, or the last error which passed -an object blessed into that package as the C<-object> argument. - -=over 4 - -=item throw ( [ ARGS ] ) - -Create a new C object and throw an error, which will be caught -by a surrounding C block, if there is one. Otherwise it will cause -the program to exit. - -C may also be called on an existing error to re-throw it. - -=item with ( [ ARGS ] ) - -Create a new C object and returns it. This is defined for -syntactic sugar, eg - - die with Some::Error ( ... ); - -=item record ( [ ARGS ] ) - -Create a new C object and returns it. This is defined for -syntactic sugar, eg - - record Some::Error ( ... ) - and return; - -=back - -=head2 STATIC METHODS - -=over 4 - -=item prior ( [ PACKAGE ] ) - -Return the last error created, or the last error associated with -C - -=item flush ( [ PACKAGE ] ) - -Flush the last error created, or the last error associated with -C.It is necessary to clear the error stack before exiting the -package or uncaught errors generated using C will be reported. - - $Error->flush; - -=cut - -=back - -=head2 OBJECT METHODS - -=over 4 - -=item stacktrace - -If the variable C<$Error::Debug> was non-zero when the error was -created, then C returns a string created by calling -C. If the variable was zero the C returns -the text of the error appended with the filename and line number of -where the error was created, providing the text does not end with a -newline. - -=item object - -The object this error was associated with - -=item file - -The file where the constructor of this error was called from - -=item line - -The line where the constructor of this error was called from - -=item text - -The text of the error - -=back - -=head2 OVERLOAD METHODS - -=over 4 - -=item stringify - -A method that converts the object into a string. This method may simply -return the same as the C method, or it may append more -information. For example the file name and line number. - -By default this method returns the C<-text> argument that was passed to -the constructor, or the string C<"Died"> if none was given. - -=item value - -A method that will return a value that can be associated with the -error. For example if an error was created due to the failure of a -system call, then this may return the numeric value of C<$!> at the -time. - -By default this method returns the C<-value> argument that was passed -to the constructor. - -=back - -=head1 PRE-DEFINED ERROR CLASSES - -=over 4 - -=item Error::Simple - -This class can be used to hold simple error strings and values. It's -constructor takes two arguments. The first is a text value, the second -is a numeric value. These values are what will be returned by the -overload methods. - -If the text value ends with C as $@ strings do, then -this infomation will be used to set the C<-file> and C<-line> arguments -of the error object. - -This class is used internally if an eval'd block die's with an error -that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified) - -=back - -=head1 $Error::ObjectifyCallback - -This variable holds a reference to a subroutine that converts errors that -are plain strings to objects. It is used by Error.pm to convert textual -errors to objects, and can be overrided by the user. - -It accepts a single argument which is a hash reference to named parameters. -Currently the only named parameter passed is C<'text'> which is the text -of the error, but others may be available in the future. - -For example the following code will cause Error.pm to throw objects of the -class MyError::Bar by default: - - sub throw_MyError_Bar - { - my $args = shift; - my $err = MyError::Bar->new(); - $err->{'MyBarText'} = $args->{'text'}; - return $err; - } - - { - local $Error::ObjectifyCallback = \&throw_MyError_Bar; - - # Error handling here. - } - -=head1 KNOWN BUGS - -None, but that does not mean there are not any. - -=head1 AUTHORS - -Graham Barr - -The code that inspired me to write this was originally written by -Peter Seibel and adapted by Jesse Glick -. - -=head1 MAINTAINER - -Shlomi Fish - -=head1 PAST MAINTAINERS - -Arun Kumar U - -=cut diff --git a/perl/Makefile.PL b/perl/Makefile.PL index d401a66..25ae54a 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -12,9 +12,9 @@ my %pm = ('Git.pm' => '$(INST_LIBDIR)/Git.pm'); # We come with our own bundled Error.pm. It's not in the set of default # Perl modules so install it if it's not available on the system yet. -eval { require 'Error' }; +eval { require Error }; if ($@) { - $pm{'Error.pm'} = '$(INST_LIBDIR)/Error.pm'; + $pm{'private-Error.pm'} = '$(INST_LIBDIR)/Error.pm'; } WriteMakefile( diff --git a/perl/private-Error.pm b/perl/private-Error.pm new file mode 100644 index 0000000..ebd0749 --- /dev/null +++ b/perl/private-Error.pm @@ -0,0 +1,821 @@ +# Error.pm +# +# Copyright (c) 1997-8 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Based on my original Error.pm, and Exceptions.pm by Peter Seibel +# and adapted by Jesse Glick . +# +# but modified ***significantly*** + +package Error; + +use strict; +use vars qw($VERSION); +use 5.004; + +$VERSION = "0.15009"; + +use overload ( + '""' => 'stringify', + '0+' => 'value', + 'bool' => sub { return 1; }, + 'fallback' => 1 +); + +$Error::Depth = 0; # Depth to pass to caller() +$Error::Debug = 0; # Generate verbose stack traces +@Error::STACK = (); # Clause stack for try +$Error::THROWN = undef; # last error thrown, a workaround until die $ref works + +my $LAST; # Last error created +my %ERROR; # Last error associated with package + +sub throw_Error_Simple +{ + my $args = shift; + return Error::Simple->new($args->{'text'}); +} + +$Error::ObjectifyCallback = \&throw_Error_Simple; + + +# Exported subs are defined in Error::subs + +use Scalar::Util (); + +sub import { + shift; + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + Error::subs->import(@_); +} + +# I really want to use last for the name of this method, but it is a keyword +# which prevent the syntax last Error + +sub prior { + shift; # ignore + + return $LAST unless @_; + + my $pkg = shift; + return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef + unless ref($pkg); + + my $obj = $pkg; + my $err = undef; + if($obj->isa('HASH')) { + $err = $obj->{'__Error__'} + if exists $obj->{'__Error__'}; + } + elsif($obj->isa('GLOB')) { + $err = ${*$obj}{'__Error__'} + if exists ${*$obj}{'__Error__'}; + } + + $err; +} + +sub flush { + shift; #ignore + + unless (@_) { + $LAST = undef; + return; + } + + my $pkg = shift; + return unless ref($pkg); + + undef $ERROR{$pkg} if defined $ERROR{$pkg}; +} + +# Return as much information as possible about where the error +# happened. The -stacktrace element only exists if $Error::DEBUG +# was set when the error was created + +sub stacktrace { + my $self = shift; + + return $self->{'-stacktrace'} + if exists $self->{'-stacktrace'}; + + my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; + + $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) + unless($text =~ /\n$/s); + + $text; +} + +# Allow error propagation, ie +# +# $ber->encode(...) or +# return Error->prior($ber)->associate($ldap); + +sub associate { + my $err = shift; + my $obj = shift; + + return unless ref($obj); + + if($obj->isa('HASH')) { + $obj->{'__Error__'} = $err; + } + elsif($obj->isa('GLOB')) { + ${*$obj}{'__Error__'} = $err; + } + $obj = ref($obj); + $ERROR{ ref($obj) } = $err; + + return; +} + +sub new { + my $self = shift; + my($pkg,$file,$line) = caller($Error::Depth); + + my $err = bless { + '-package' => $pkg, + '-file' => $file, + '-line' => $line, + @_ + }, $self; + + $err->associate($err->{'-object'}) + if(exists $err->{'-object'}); + + # To always create a stacktrace would be very inefficient, so + # we only do it if $Error::Debug is set + + if($Error::Debug) { + require Carp; + local $Carp::CarpLevel = $Error::Depth; + my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; + my $trace = Carp::longmess($text); + # Remove try calls from the trace + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; + $err->{'-stacktrace'} = $trace + } + + $@ = $LAST = $ERROR{$pkg} = $err; +} + +# Throw an error. this contains some very gory code. + +sub throw { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + # if we are not rethrow-ing then create the object to throw + $self = $self->new(@_) unless ref($self); + + die $Error::THROWN = $self; +} + +# syntactic sugar for +# +# die with Error( ... ); + +sub with { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + $self->new(@_); +} + +# syntactic sugar for +# +# record Error( ... ) and return; + +sub record { + my $self = shift; + local $Error::Depth = $Error::Depth + 1; + + $self->new(@_); +} + +# catch clause for +# +# try { ... } catch CLASS with { ... } + +sub catch { + my $pkg = shift; + my $code = shift; + my $clauses = shift || {}; + my $catch = $clauses->{'catch'} ||= []; + + unshift @$catch, $pkg, $code; + + $clauses; +} + +# Object query methods + +sub object { + my $self = shift; + exists $self->{'-object'} ? $self->{'-object'} : undef; +} + +sub file { + my $self = shift; + exists $self->{'-file'} ? $self->{'-file'} : undef; +} + +sub line { + my $self = shift; + exists $self->{'-line'} ? $self->{'-line'} : undef; +} + +sub text { + my $self = shift; + exists $self->{'-text'} ? $self->{'-text'} : undef; +} + +# overload methods + +sub stringify { + my $self = shift; + defined $self->{'-text'} ? $self->{'-text'} : "Died"; +} + +sub value { + my $self = shift; + exists $self->{'-value'} ? $self->{'-value'} : undef; +} + +package Error::Simple; + +@Error::Simple::ISA = qw(Error); + +sub new { + my $self = shift; + my $text = "" . shift; + my $value = shift; + my(@args) = (); + + local $Error::Depth = $Error::Depth + 1; + + @args = ( -file => $1, -line => $2) + if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s); + push(@args, '-value', 0 + $value) + if defined($value); + + $self->SUPER::new(-text => $text, @args); +} + +sub stringify { + my $self = shift; + my $text = $self->SUPER::stringify; + $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) + unless($text =~ /\n$/s); + $text; +} + +########################################################################## +########################################################################## + +# Inspired by code from Jesse Glick and +# Peter Seibel + +package Error::subs; + +use Exporter (); +use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); + +@EXPORT_OK = qw(try with finally except otherwise); +%EXPORT_TAGS = (try => \@EXPORT_OK); + +@ISA = qw(Exporter); + +sub run_clauses ($$$\@) { + my($clauses,$err,$wantarray,$result) = @_; + my $code = undef; + + $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err); + + CATCH: { + + # catch + my $catch; + if(defined($catch = $clauses->{'catch'})) { + my $i = 0; + + CATCHLOOP: + for( ; $i < @$catch ; $i += 2) { + my $pkg = $catch->[$i]; + unless(defined $pkg) { + #except + splice(@$catch,$i,2,$catch->[$i+1]->()); + $i -= 2; + next CATCHLOOP; + } + elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { + $code = $catch->[$i+1]; + while(1) { + my $more = 0; + local($Error::THROWN); + my $ok = eval { + if($wantarray) { + @{$result} = $code->($err,\$more); + } + elsif(defined($wantarray)) { + @{$result} = (); + $result->[0] = $code->($err,\$more); + } + else { + $code->($err,\$more); + } + 1; + }; + if( $ok ) { + next CATCHLOOP if $more; + undef $err; + } + else { + $err = defined($Error::THROWN) + ? $Error::THROWN : $@; + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); + } + last CATCH; + }; + } + } + } + + # otherwise + my $owise; + if(defined($owise = $clauses->{'otherwise'})) { + my $code = $clauses->{'otherwise'}; + my $more = 0; + my $ok = eval { + if($wantarray) { + @{$result} = $code->($err,\$more); + } + elsif(defined($wantarray)) { + @{$result} = (); + $result->[0] = $code->($err,\$more); + } + else { + $code->($err,\$more); + } + 1; + }; + if( $ok ) { + undef $err; + } + else { + $err = defined($Error::THROWN) + ? $Error::THROWN : $@; + + $err = $Error::ObjectifyCallback->({'text' =>$err}) + unless ref($err); + } + } + } + $err; +} + +sub try (&;$) { + my $try = shift; + my $clauses = @_ ? shift : {}; + my $ok = 0; + my $err = undef; + my @result = (); + + unshift @Error::STACK, $clauses; + + my $wantarray = wantarray(); + + do { + local $Error::THROWN = undef; + local $@ = undef; + + $ok = eval { + if($wantarray) { + @result = $try->(); + } + elsif(defined $wantarray) { + $result[0] = $try->(); + } + else { + $try->(); + } + 1; + }; + + $err = defined($Error::THROWN) ? $Error::THROWN : $@ + unless $ok; + }; + + shift @Error::STACK; + + $err = run_clauses($clauses,$err,wantarray,@result) + unless($ok); + + $clauses->{'finally'}->() + if(defined($clauses->{'finally'})); + + if (defined($err)) + { + if (Scalar::Util::blessed($err) && $err->can('throw')) + { + throw $err; + } + else + { + die $err; + } + } + + wantarray ? @result : $result[0]; +} + +# Each clause adds a sub to the list of clauses. The finally clause is +# always the last, and the otherwise clause is always added just before +# the finally clause. +# +# All clauses, except the finally clause, add a sub which takes one argument +# this argument will be the error being thrown. The sub will return a code ref +# if that clause can handle that error, otherwise undef is returned. +# +# The otherwise clause adds a sub which unconditionally returns the users +# code reference, this is why it is forced to be last. +# +# The catch clause is defined in Error.pm, as the syntax causes it to +# be called as a method + +sub with (&;$) { + @_ +} + +sub finally (&) { + my $code = shift; + my $clauses = { 'finally' => $code }; + $clauses; +} + +# The except clause is a block which returns a hashref or a list of +# key-value pairs, where the keys are the classes and the values are subs. + +sub except (&;$) { + my $code = shift; + my $clauses = shift || {}; + my $catch = $clauses->{'catch'} ||= []; + + my $sub = sub { + my $ref; + my(@array) = $code->($_[0]); + if(@array == 1 && ref($array[0])) { + $ref = $array[0]; + $ref = [ %$ref ] + if(UNIVERSAL::isa($ref,'HASH')); + } + else { + $ref = \@array; + } + @$ref + }; + + unshift @{$catch}, undef, $sub; + + $clauses; +} + +sub otherwise (&;$) { + my $code = shift; + my $clauses = shift || {}; + + if(exists $clauses->{'otherwise'}) { + require Carp; + Carp::croak("Multiple otherwise clauses"); + } + + $clauses->{'otherwise'} = $code; + + $clauses; +} + +1; +__END__ + +=head1 NAME + +Error - Error/exception handling in an OO-ish way + +=head1 SYNOPSIS + + use Error qw(:try); + + throw Error::Simple( "A simple error"); + + sub xyz { + ... + record Error::Simple("A simple error") + and return; + } + + unlink($file) or throw Error::Simple("$file: $!",$!); + + try { + do_some_stuff(); + die "error!" if $condition; + throw Error::Simple -text => "Oops!" if $other_condition; + } + catch Error::IO with { + my $E = shift; + print STDERR "File ", $E->{'-file'}, " had a problem\n"; + } + except { + my $E = shift; + my $general_handler=sub {send_message $E->{-description}}; + return { + UserException1 => $general_handler, + UserException2 => $general_handler + }; + } + otherwise { + print STDERR "Well I don't know what to say\n"; + } + finally { + close_the_garage_door_already(); # Should be reliable + }; # Don't forget the trailing ; or you might be surprised + +=head1 DESCRIPTION + +The C package provides two interfaces. Firstly C provides +a procedural interface to exception handling. Secondly C is a +base class for errors/exceptions that can either be thrown, for +subsequent catch, or can simply be recorded. + +Errors in the class C should not be thrown directly, but the +user should throw errors from a sub-class of C. + +=head1 PROCEDURAL INTERFACE + +C exports subroutines to perform exception handling. These will +be exported if the C<:try> tag is used in the C line. + +=over 4 + +=item try BLOCK CLAUSES + +C is the main subroutine called by the user. All other subroutines +exported are clauses to the try subroutine. + +The BLOCK will be evaluated and, if no error is throw, try will return +the result of the block. + +C are the subroutines below, which describe what to do in the +event of an error being thrown within BLOCK. + +=item catch CLASS with BLOCK + +This clauses will cause all errors that satisfy C<$err-Eisa(CLASS)> +to be caught and handled by evaluating C. + +C will be passed two arguments. The first will be the error +being thrown. The second is a reference to a scalar variable. If this +variable is set by the catch block then, on return from the catch +block, try will continue processing as if the catch block was never +found. + +To propagate the error the catch block may call C<$err-Ethrow> + +If the scalar reference by the second argument is not set, and the +error is not thrown. Then the current try block will return with the +result from the catch block. + +=item except BLOCK + +When C is looking for a handler, if an except clause is found +C is evaluated. The return value from this block should be a +HASHREF or a list of key-value pairs, where the keys are class names +and the values are CODE references for the handler of errors of that +type. + +=item otherwise BLOCK + +Catch any error by executing the code in C + +When evaluated C will be passed one argument, which will be the +error being processed. + +Only one otherwise block may be specified per try block + +=item finally BLOCK + +Execute the code in C either after the code in the try block has +successfully completed, or if the try block throws an error then +C will be executed after the handler has completed. + +If the handler throws an error then the error will be caught, the +finally block will be executed and the error will be re-thrown. + +Only one finally block may be specified per try block + +=back + +=head1 CLASS INTERFACE + +=head2 CONSTRUCTORS + +The C object is implemented as a HASH. This HASH is initialized +with the arguments that are passed to it's constructor. The elements +that are used by, or are retrievable by the C class are listed +below, other classes may add to these. + + -file + -line + -text + -value + -object + +If C<-file> or C<-line> are not specified in the constructor arguments +then these will be initialized with the file name and line number where +the constructor was called from. + +If the error is associated with an object then the object should be +passed as the C<-object> argument. This will allow the C package +to associate the error with the object. + +The C package remembers the last error created, and also the +last error associated with a package. This could either be the last +error created by a sub in that package, or the last error which passed +an object blessed into that package as the C<-object> argument. + +=over 4 + +=item throw ( [ ARGS ] ) + +Create a new C object and throw an error, which will be caught +by a surrounding C block, if there is one. Otherwise it will cause +the program to exit. + +C may also be called on an existing error to re-throw it. + +=item with ( [ ARGS ] ) + +Create a new C object and returns it. This is defined for +syntactic sugar, eg + + die with Some::Error ( ... ); + +=item record ( [ ARGS ] ) + +Create a new C object and returns it. This is defined for +syntactic sugar, eg + + record Some::Error ( ... ) + and return; + +=back + +=head2 STATIC METHODS + +=over 4 + +=item prior ( [ PACKAGE ] ) + +Return the last error created, or the last error associated with +C + +=item flush ( [ PACKAGE ] ) + +Flush the last error created, or the last error associated with +C.It is necessary to clear the error stack before exiting the +package or uncaught errors generated using C will be reported. + + $Error->flush; + +=cut + +=back + +=head2 OBJECT METHODS + +=over 4 + +=item stacktrace + +If the variable C<$Error::Debug> was non-zero when the error was +created, then C returns a string created by calling +C. If the variable was zero the C returns +the text of the error appended with the filename and line number of +where the error was created, providing the text does not end with a +newline. + +=item object + +The object this error was associated with + +=item file + +The file where the constructor of this error was called from + +=item line + +The line where the constructor of this error was called from + +=item text + +The text of the error + +=back + +=head2 OVERLOAD METHODS + +=over 4 + +=item stringify + +A method that converts the object into a string. This method may simply +return the same as the C method, or it may append more +information. For example the file name and line number. + +By default this method returns the C<-text> argument that was passed to +the constructor, or the string C<"Died"> if none was given. + +=item value + +A method that will return a value that can be associated with the +error. For example if an error was created due to the failure of a +system call, then this may return the numeric value of C<$!> at the +time. + +By default this method returns the C<-value> argument that was passed +to the constructor. + +=back + +=head1 PRE-DEFINED ERROR CLASSES + +=over 4 + +=item Error::Simple + +This class can be used to hold simple error strings and values. It's +constructor takes two arguments. The first is a text value, the second +is a numeric value. These values are what will be returned by the +overload methods. + +If the text value ends with C as $@ strings do, then +this infomation will be used to set the C<-file> and C<-line> arguments +of the error object. + +This class is used internally if an eval'd block die's with an error +that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified) + +=back + +=head1 $Error::ObjectifyCallback + +This variable holds a reference to a subroutine that converts errors that +are plain strings to objects. It is used by Error.pm to convert textual +errors to objects, and can be overrided by the user. + +It accepts a single argument which is a hash reference to named parameters. +Currently the only named parameter passed is C<'text'> which is the text +of the error, but others may be available in the future. + +For example the following code will cause Error.pm to throw objects of the +class MyError::Bar by default: + + sub throw_MyError_Bar + { + my $args = shift; + my $err = MyError::Bar->new(); + $err->{'MyBarText'} = $args->{'text'}; + return $err; + } + + { + local $Error::ObjectifyCallback = \&throw_MyError_Bar; + + # Error handling here. + } + +=head1 KNOWN BUGS + +None, but that does not mean there are not any. + +=head1 AUTHORS + +Graham Barr + +The code that inspired me to write this was originally written by +Peter Seibel and adapted by Jesse Glick +. + +=head1 MAINTAINER + +Shlomi Fish + +=head1 PAST MAINTAINERS + +Arun Kumar U + +=cut -- cgit v0.10.2-6-g49f6 From 1434dbce02aaa96ae5d0a1f4f000cce5727498fa Mon Sep 17 00:00:00 2001 From: Pavel Roskin Date: Fri, 30 Jun 2006 01:09:26 -0400 Subject: Delete manuals if compiling without docs Otherwise, rpm would complain about unpacked files. Signed-off-by: Pavel Roskin Signed-off-by: Junio C Hamano diff --git a/git.spec.in b/git.spec.in index 8ccd256..b8feda3 100644 --- a/git.spec.in +++ b/git.spec.in @@ -86,6 +86,8 @@ make %{_smp_mflags} DESTDIR=$RPM_BUILD_ROOT WITH_OWN_SUBPROCESS_PY=YesPlease \ (find $RPM_BUILD_ROOT%{_bindir} -type f | grep -vE "arch|svn|cvs|email|gitk" | sed -e s@^$RPM_BUILD_ROOT@@) > bin-man-doc-files %if %{!?_without_docs:1}0 (find $RPM_BUILD_ROOT%{_mandir} $RPM_BUILD_ROOT/Documentation -type f | grep -vE "arch|svn|git-cvs|email|gitk" | sed -e s@^$RPM_BUILD_ROOT@@ -e 's/$/*/' ) >> bin-man-doc-files +%else +rm -rf $RPM_BUILD_ROOT%{_mandir} %endif %clean -- cgit v0.10.2-6-g49f6 From b9795608c4d82ba119d78980b479d78bdfe753b6 Mon Sep 17 00:00:00 2001 From: Pavel Roskin Date: Fri, 30 Jun 2006 01:09:28 -0400 Subject: Make perl interface a separate package Install it as a vendor package. Remove .packlist, perllocal.pod, Git.bs. Require perl(Error) for building so that our Error.pm is not installed. Signed-off-by: Pavel Roskin Signed-off-by: Junio C Hamano diff --git a/git.spec.in b/git.spec.in index b8feda3..6d90034 100644 --- a/git.spec.in +++ b/git.spec.in @@ -9,7 +9,7 @@ URL: http://kernel.org/pub/software/scm/git/ Source: http://kernel.org/pub/software/scm/git/%{name}-%{version}.tar.gz BuildRequires: zlib-devel >= 1.2, openssl-devel, curl-devel, expat-devel %{!?_without_docs:, xmlto, asciidoc > 6.0.3} BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) -Requires: git-core, git-svn, git-cvs, git-arch, git-email, gitk +Requires: git-core, git-svn, git-cvs, git-arch, git-email, gitk, perl-Git %description This is a stupid (but extremely fast) directory content manager. It @@ -70,6 +70,16 @@ Requires: git-core = %{version}-%{release}, tk >= 8.4 %description -n gitk Git revision tree visualiser ('gitk') +%package -n perl-Git +Summary: Perl interface to Git +Group: Development/Libraries +Requires: git-core = %{version}-%{release} +Requires: perl(:MODULE_COMPAT_%(eval "`%{__perl} -V:version`"; echo $version)) +BuildRequires: perl(Error) + +%description -n perl-Git +Perl interface to Git + %prep %setup -q @@ -80,10 +90,14 @@ make %{_smp_mflags} CFLAGS="$RPM_OPT_FLAGS" WITH_OWN_SUBPROCESS_PY=YesPlease \ %install rm -rf $RPM_BUILD_ROOT make %{_smp_mflags} DESTDIR=$RPM_BUILD_ROOT WITH_OWN_SUBPROCESS_PY=YesPlease \ - prefix=%{_prefix} mandir=%{_mandir} \ + prefix=%{_prefix} mandir=%{_mandir} INSTALLDIRS=vendor \ install %{!?_without_docs: install-doc} +find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} ';' +find $RPM_BUILD_ROOT -type f -name '*.bs' -empty -exec rm -f {} ';' +find $RPM_BUILD_ROOT -type f -name perllocal.pod -exec rm -f {} ';' (find $RPM_BUILD_ROOT%{_bindir} -type f | grep -vE "arch|svn|cvs|email|gitk" | sed -e s@^$RPM_BUILD_ROOT@@) > bin-man-doc-files +(find $RPM_BUILD_ROOT%{perl_vendorarch} -type f | sed -e s@^$RPM_BUILD_ROOT@@) >> perl-files %if %{!?_without_docs:1}0 (find $RPM_BUILD_ROOT%{_mandir} $RPM_BUILD_ROOT/Documentation -type f | grep -vE "arch|svn|git-cvs|email|gitk" | sed -e s@^$RPM_BUILD_ROOT@@ -e 's/$/*/' ) >> bin-man-doc-files %else @@ -131,6 +145,9 @@ rm -rf $RPM_BUILD_ROOT %{!?_without_docs: %{_mandir}/man1/*gitk*.1*} %{!?_without_docs: %doc Documentation/*gitk*.html } +%files -n perl-Git -f perl-files +%defattr(-,root,root) + %files core -f bin-man-doc-files %defattr(-,root,root) %{_datadir}/git-core/ -- cgit v0.10.2-6-g49f6 From e6634ac9841f8df3ce1c0c461c677faf2d59af3e Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sun, 2 Jul 2006 01:38:56 +0200 Subject: Git.pm: Remove PerlIO usage from Git.xs PerlIO_*() is not portable before 5.7.3, according to ppport.h, and it's more clear what is going on when we do it in the Perl part of the Git module anyway. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 0581447..b4ee88b 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -511,7 +511,19 @@ are involved. =cut -# Implemented in Git.xs. +sub hash_object { + my ($self, $type, $file) = _maybe_self(@_); + + # hash_object_* implemented in Git.xs. + + if (ref($file) eq 'GLOB') { + my $hash = hash_object_pipe($type, fileno($file)); + close $file; + return $hash; + } else { + hash_object_file($type, $file); + } +} diff --git a/perl/Git.xs b/perl/Git.xs index 3030ba9..cb23261 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -104,42 +104,36 @@ CODE: } char * -xs_hash_object(type, file) +xs_hash_object_pipe(type, fd) char *type; - SV *file; + int fd; CODE: { unsigned char sha1[20]; - if (SvTYPE(file) == SVt_RV) - file = SvRV(file); - - if (SvTYPE(file) == SVt_PVGV) { - /* Filehandle */ - PerlIO *pio; - - pio = IoIFP(sv_2io(file)); - if (!pio) - croak("You passed me something weird - a dir glob?"); - /* XXX: I just hope PerlIO didn't read anything from it yet. - * --pasky */ - if (index_pipe(sha1, PerlIO_fileno(pio), type, 0)) - croak("Unable to hash given filehandle"); - /* Avoid any nasty surprises. */ - PerlIO_close(pio); - - } else { - /* String */ - char *path = SvPV_nolen(file); - int fd = open(path, O_RDONLY); - struct stat st; - - if (fd < 0 || - fstat(fd, &st) < 0 || - index_fd(sha1, fd, &st, 0, type)) - croak("Unable to hash %s", path); - close(fd); - } + if (index_pipe(sha1, fd, type, 0)) + croak("Unable to hash given filehandle"); + RETVAL = sha1_to_hex(sha1); +} +OUTPUT: + RETVAL + +char * +xs_hash_object_file(type, path) + char *type; + char *path; +CODE: +{ + unsigned char sha1[20]; + int fd = open(path, O_RDONLY); + struct stat st; + + if (fd < 0 || + fstat(fd, &st) < 0 || + index_fd(sha1, fd, &st, 0, type)) + croak("Unable to hash %s", path); + close(fd); + RETVAL = sha1_to_hex(sha1); } OUTPUT: -- cgit v0.10.2-6-g49f6 From e2a38710941775761298d0bd7e6be2e7039fcd3d Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sun, 2 Jul 2006 01:48:32 +0200 Subject: Git.pm: Avoid ppport.h This makes us not include ppport.h which seems not to give us anything real anyway; it is useful for checking for portability warts but since Devel::PPPort is a portability wart itself, we shouldn't require it for build. You can check for portability problems by calling make check in perl/. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.xs b/perl/Git.xs index cb23261..51bfac3 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -15,8 +15,6 @@ #include "perl.h" #include "XSUB.h" -#include "ppport.h" - #undef die diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 25ae54a..97ee9af 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -5,6 +5,11 @@ sub MY::postamble { instlibdir: @echo '$(INSTALLSITEARCH)' +check: + perl -MDevel::PPPort -le 'Devel::PPPort::WriteFile(".ppport.h")' && \ + perl .ppport.h --compat-version=5.6.0 Git.xs && \ + rm .ppport.h + MAKE_FRAG } @@ -24,8 +29,3 @@ WriteMakefile( MYEXTLIB => '../libgit.a', INC => '-I. -I..', ); - - -use Devel::PPPort; - --s 'ppport.h' or Devel::PPPort::WriteFile(); -- cgit v0.10.2-6-g49f6 From d78f099d8956947576cd5ccc1c5c13f94075b476 Mon Sep 17 00:00:00 2001 From: Johannes Schindelin Date: Sun, 2 Jul 2006 11:53:03 +0200 Subject: Git.xs: older perl do not know const char * Both of these casts _should_ be safe, since you do not want to muck around with the version or the path anyway. Signed-off-by: Johannes Schindelin Signed-off-by: Junio C Hamano diff --git a/perl/Git.xs b/perl/Git.xs index 51bfac3..c824210 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -59,7 +59,7 @@ BOOT: # /* TODO: xs_call_gate(). See Git.pm. */ -const char * +char * xs_version() CODE: { @@ -69,11 +69,11 @@ OUTPUT: RETVAL -const char * +char * xs_exec_path() CODE: { - RETVAL = git_exec_path(); + RETVAL = (char *)git_exec_path(); } OUTPUT: RETVAL -- cgit v0.10.2-6-g49f6 From 65a4e98a22eab9317a05d1485c7c5a9c5befd589 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sun, 2 Jul 2006 22:57:17 +0200 Subject: Git.pm: Don't #define around die Back in the old days, we called Git's die() from the .xs code, but we had to hijack Perl's die() for that. Now we don't call Git's die() so no need to do the hijacking and it silences a compiler warning. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.xs b/perl/Git.xs index c824210..2bbec43 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -8,15 +8,11 @@ #include "../cache.h" #include "../exec_cmd.h" -#define die perlyshadow_die__ - /* XS and Perl interface */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#undef die - static char * report_xs(const char *prefix, const char *err, va_list params) -- cgit v0.10.2-6-g49f6 From d3140f5c2a6b42361bca960f627b00264d5c7372 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Sun, 2 Jul 2006 16:49:12 -0700 Subject: Perly Git: make sure we do test the freshly built one. We could BEGIN { push @INC, '@@INSTLIBDIR@@'; } but that is not a good idea for normal execution. The would prevent a workaround for a user who is trying to override an old, faulty Git.pm installed on the system path with a newer version installed under $HOME/. Signed-off-by: Junio C Hamano diff --git a/git-fmt-merge-msg.perl b/git-fmt-merge-msg.perl index 1b23fa1..a9805dd 100755 --- a/git-fmt-merge-msg.perl +++ b/git-fmt-merge-msg.perl @@ -5,7 +5,11 @@ # Read .git/FETCH_HEAD and make a human readable merge message # by grouping branches and tags together to form a single line. -BEGIN { unshift @INC, '@@INSTLIBDIR@@'; } +BEGIN { + unless (exists $ENV{'RUNNING_GIT_TESTS'}) { + unshift @INC, '@@INSTLIBDIR@@'; + } +} use strict; use Git; use Error qw(:try); diff --git a/git-mv.perl b/git-mv.perl index a604896..5134b80 100755 --- a/git-mv.perl +++ b/git-mv.perl @@ -6,7 +6,11 @@ # This file is licensed under the GPL v2, or a later version # at the discretion of Linus Torvalds. -BEGIN { unshift @INC, '@@INSTLIBDIR@@'; } +BEGIN { + unless (exists $ENV{'RUNNING_GIT_TESTS'}) { + unshift @INC, '@@INSTLIBDIR@@'; + } +} use warnings; use strict; use Getopt::Std; diff --git a/t/test-lib.sh b/t/test-lib.sh index fba0c51..298c6ca 100755 --- a/t/test-lib.sh +++ b/t/test-lib.sh @@ -206,8 +206,9 @@ PYTHON=`sed -e '1{ PYTHONPATH=$(pwd)/../compat export PYTHONPATH } +RUNNING_GIT_TESTS=YesWeAre PERL5LIB=$(pwd)/../perl/blib/lib:$(pwd)/../perl/blib/arch/auto/Git -export PERL5LIB +export PERL5LIB RUNNING_GIT_TESTS test -d ../templates/blt || { error "You haven't built things yet, have you?" } -- cgit v0.10.2-6-g49f6 From 3c767a08243244b18d48315f8433ba07e435f654 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Sun, 2 Jul 2006 23:54:47 -0700 Subject: INSTALL: a tip for running after building but without installing. Signed-off-by: Junio C Hamano diff --git a/INSTALL b/INSTALL index f8337e2..ed502de 100644 --- a/INSTALL +++ b/INSTALL @@ -29,6 +29,19 @@ Issues of note: has been actively developed since 1997, and people have moved over to graphical file managers. + - You can use git after building but without installing if you + wanted to. Various git commands need to find other git + commands and scripts to do their work, so you would need to + arrange a few environment variables to tell them that their + friends will be found in your built source area instead of at + their standard installation area. Something like this works + for me: + + GIT_EXEC_PATH=`pwd` + PATH=`pwd`:$PATH + PERL5LIB=`pwd`/perl/blib/lib:`pwd`/perl/blib/arch/auto/Git + export GIT_EXEC_PATH PATH PERL5LIB + - Git is reasonably self-sufficient, but does depend on a few external programs and libraries: -- cgit v0.10.2-6-g49f6 From 6fcca938b05c33bcd8b502d6b6f178e377609fa3 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Mon, 3 Jul 2006 23:16:32 +0200 Subject: Use $GITPERLLIB instead of $RUNNING_GIT_TESTS and centralize @INC munging This makes the Git perl scripts check $GITPERLLIB instead of $RUNNING_GIT_TESTS, which makes more sense if you are setting up your shell environment to use a non-installed Git instance. It also weeds out the @INC munging from the individual scripts and makes Makefile add it during the .perl files processing, so that we can change just a single place when we modify this shared logic. It looks ugly in the scripts, too. ;-) And instead of doing arcane things with the @INC array, we just do 'use lib' instead, which is essentialy the same thing anyway. I first want to do three separate patches but it turned out that it's quite a lot neater when bundled together, so I hope it's ok. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/INSTALL b/INSTALL index ed502de..4e8f883 100644 --- a/INSTALL +++ b/INSTALL @@ -39,8 +39,8 @@ Issues of note: GIT_EXEC_PATH=`pwd` PATH=`pwd`:$PATH - PERL5LIB=`pwd`/perl/blib/lib:`pwd`/perl/blib/arch/auto/Git - export GIT_EXEC_PATH PATH PERL5LIB + GITPERLLIB=`pwd`/perl/blib/lib:`pwd`/perl/blib/arch/auto/Git + export GIT_EXEC_PATH PATH GITPERLLIB - Git is reasonably self-sufficient, but does depend on a few external programs and libraries: diff --git a/Makefile b/Makefile index 7030167..71657ec 100644 --- a/Makefile +++ b/Makefile @@ -550,7 +550,9 @@ $(patsubst %.perl,%,$(SCRIPT_PERL)): perl/Makefile $(patsubst %.perl,%,$(SCRIPT_PERL)): % : %.perl rm -f $@ $@+ INSTLIBDIR=`$(MAKE) -C perl -s --no-print-directory instlibdir` && \ - sed -e '1s|#!.*perl\(.*\)|#!$(PERL_PATH_SQ)\1|' \ + sed -e '1s|#!.*perl|#!$(PERL_PATH_SQ)|1' \ + -e '2i\ + use lib (split(/:/, $$ENV{GITPERLLIB} || '\'"$$INSTLIBDIR"\''));' \ -e 's|@@INSTLIBDIR@@|'"$$INSTLIBDIR"'|g' \ -e 's/@@GIT_VERSION@@/$(GIT_VERSION)/g' \ $@.perl >$@+ diff --git a/git-fmt-merge-msg.perl b/git-fmt-merge-msg.perl index a9805dd..f86231e 100755 --- a/git-fmt-merge-msg.perl +++ b/git-fmt-merge-msg.perl @@ -5,11 +5,6 @@ # Read .git/FETCH_HEAD and make a human readable merge message # by grouping branches and tags together to form a single line. -BEGIN { - unless (exists $ENV{'RUNNING_GIT_TESTS'}) { - unshift @INC, '@@INSTLIBDIR@@'; - } -} use strict; use Git; use Error qw(:try); diff --git a/git-mv.perl b/git-mv.perl index 5134b80..322b9fd 100755 --- a/git-mv.perl +++ b/git-mv.perl @@ -6,11 +6,6 @@ # This file is licensed under the GPL v2, or a later version # at the discretion of Linus Torvalds. -BEGIN { - unless (exists $ENV{'RUNNING_GIT_TESTS'}) { - unshift @INC, '@@INSTLIBDIR@@'; - } -} use warnings; use strict; use Getopt::Std; diff --git a/t/test-lib.sh b/t/test-lib.sh index 298c6ca..ad9796e 100755 --- a/t/test-lib.sh +++ b/t/test-lib.sh @@ -206,9 +206,8 @@ PYTHON=`sed -e '1{ PYTHONPATH=$(pwd)/../compat export PYTHONPATH } -RUNNING_GIT_TESTS=YesWeAre -PERL5LIB=$(pwd)/../perl/blib/lib:$(pwd)/../perl/blib/arch/auto/Git -export PERL5LIB RUNNING_GIT_TESTS +GITPERLLIB=$(pwd)/../perl/blib/lib:$(pwd)/../perl/blib/arch/auto/Git +export GITPERLLIB test -d ../templates/blt || { error "You haven't built things yet, have you?" } -- cgit v0.10.2-6-g49f6 From dc2613de8633cecb1c0759657eadf6a637cebfa5 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Mon, 3 Jul 2006 22:47:55 +0200 Subject: Git.pm: Add config() method This accessor will retrieve value(s) of the given configuration variable. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/Documentation/git-repo-config.txt b/Documentation/git-repo-config.txt index 803c0d5..cc72fa9 100644 --- a/Documentation/git-repo-config.txt +++ b/Documentation/git-repo-config.txt @@ -54,7 +54,8 @@ OPTIONS --get:: Get the value for a given key (optionally filtered by a regex - matching the value). + matching the value). Returns error code 1 if the key was not + found and error code 2 if multiple key values were found. --get-all:: Like get, but does not fail if the number of values for the key diff --git a/perl/Git.pm b/perl/Git.pm index b4ee88b..24fd7ce 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -473,7 +473,6 @@ and the directory must exist. sub wc_chdir { my ($self, $subdir) = @_; - $self->wc_path() or throw Error::Simple("bare repository"); @@ -486,6 +485,42 @@ sub wc_chdir { } +=item config ( VARIABLE ) + +Retrieve the configuration C in the same manner as C +does. In scalar context requires the variable to be set only one time +(exception is thrown otherwise), in array context returns allows the +variable to be set multiple times and returns all the values. + +Must be called on a repository instance. + +This currently wraps command('repo-config') so it is not so fast. + +=cut + +sub config { + my ($self, $var) = @_; + $self->repo_path() + or throw Error::Simple("not a repository"); + + try { + if (wantarray) { + return $self->command('repo-config', '--get-all', $var); + } else { + return $self->command_oneline('repo-config', '--get', $var); + } + } catch Git::Error::Command with { + my $E = shift; + if ($E->value() == 1) { + # Key not found. + return undef; + } else { + throw $E; + } + }; +} + + =item hash_object ( TYPE, FILENAME ) =item hash_object ( TYPE, FILEHANDLE ) diff --git a/repo-config.c b/repo-config.c index 743f02b..c7ed0ac 100644 --- a/repo-config.c +++ b/repo-config.c @@ -118,7 +118,7 @@ static int get_value(const char* key_, const char* regex_) if (do_all) ret = !seen; else - ret = (seen == 1) ? 0 : 1; + ret = (seen == 1) ? 0 : seen > 1 ? 2 : 1; free_strings: if (repo_config) -- cgit v0.10.2-6-g49f6 From 3cb8caf7294bf8909b924ab63ca7d8f90917e677 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Mon, 3 Jul 2006 22:47:58 +0200 Subject: Convert git-send-email to use Git.pm Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/git-send-email.perl b/git-send-email.perl index c5d9e73..e794e44 100755 --- a/git-send-email.perl +++ b/git-send-email.perl @@ -21,6 +21,7 @@ use warnings; use Term::ReadLine; use Getopt::Long; use Data::Dumper; +use Git; # most mail servers generate the Date: header, but not all... $ENV{LC_ALL} = 'C'; @@ -46,6 +47,8 @@ my $smtp_server; # Example reply to: #$initial_reply_to = ''; #<20050203173208.GA23964@foobar.com>'; +my $repo = Git->repository(); + my $term = new Term::ReadLine 'git-send-email'; # Begin by accumulating all the variables (defined above), that we will end up @@ -81,23 +84,9 @@ foreach my $entry (@bcclist) { # Now, let's fill any that aren't set in with defaults: -sub gitvar { - my ($var) = @_; - my $fh; - my $pid = open($fh, '-|'); - die "$!" unless defined $pid; - if (!$pid) { - exec('git-var', $var) or die "$!"; - } - my ($val) = <$fh>; - close $fh or die "$!"; - chomp($val); - return $val; -} - sub gitvar_ident { my ($name) = @_; - my $val = gitvar($name); + my $val = $repo->command('var', $name); my @field = split(/\s+/, $val); return join(' ', @field[0...(@field-3)]); } @@ -106,8 +95,8 @@ my ($author) = gitvar_ident('GIT_AUTHOR_IDENT'); my ($committer) = gitvar_ident('GIT_COMMITTER_IDENT'); my %aliases; -chomp(my @alias_files = `git-repo-config --get-all sendemail.aliasesfile`); -chomp(my $aliasfiletype = `git-repo-config sendemail.aliasfiletype`); +my @alias_files = $repo->config('sendemail.aliasesfile'); +my $aliasfiletype = $repo->config('sendemail.aliasfiletype'); my %parse_alias = ( # multiline formats can be supported in the future mutt => sub { my $fh = shift; while (<$fh>) { @@ -132,7 +121,7 @@ my %parse_alias = ( }}} ); -if (@alias_files && defined $parse_alias{$aliasfiletype}) { +if (@alias_files and $aliasfiletype and defined $parse_alias{$aliasfiletype}) { foreach my $file (@alias_files) { open my $fh, '<', $file or die "opening $file: $!\n"; $parse_alias{$aliasfiletype}->($fh); @@ -374,10 +363,7 @@ sub send_message my $date = strftime('%a, %d %b %Y %H:%M:%S %z', localtime($time++)); my $gitversion = '@@GIT_VERSION@@'; if ($gitversion =~ m/..GIT_VERSION../) { - $gitversion = `git --version`; - chomp $gitversion; - # keep only what's after the last space - $gitversion =~ s/^.* //; + $gitversion = Git::version(); } my $header = "From: $from -- cgit v0.10.2-6-g49f6 From c7a30e56840b089c1d110b312475f692b5c1b6a4 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Mon, 3 Jul 2006 22:48:01 +0200 Subject: Git.pm: Introduce ident() and ident_person() methods These methods can retrieve/parse the author/committer ident. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/git-send-email.perl b/git-send-email.perl index e794e44..79e82f5 100755 --- a/git-send-email.perl +++ b/git-send-email.perl @@ -84,15 +84,8 @@ foreach my $entry (@bcclist) { # Now, let's fill any that aren't set in with defaults: -sub gitvar_ident { - my ($name) = @_; - my $val = $repo->command('var', $name); - my @field = split(/\s+/, $val); - return join(' ', @field[0...(@field-3)]); -} - -my ($author) = gitvar_ident('GIT_AUTHOR_IDENT'); -my ($committer) = gitvar_ident('GIT_COMMITTER_IDENT'); +my ($author) = $repo->ident_person('author'); +my ($committer) = $repo->ident_person('committer'); my %aliases; my @alias_files = $repo->config('sendemail.aliasesfile'); diff --git a/perl/Git.pm b/perl/Git.pm index 24fd7ce..9ce9fcd 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -521,6 +521,55 @@ sub config { } +=item ident ( TYPE | IDENTSTR ) + +=item ident_person ( TYPE | IDENTSTR | IDENTARRAY ) + +This suite of functions retrieves and parses ident information, as stored +in the commit and tag objects or produced by C (thus +C can be either I or I; case is insignificant). + +The C method retrieves the ident information from C +and either returns it as a scalar string or as an array with the fields parsed. +Alternatively, it can take a prepared ident string (e.g. from the commit +object) and just parse it. + +C returns the person part of the ident - name and email; +it can take the same arguments as C or the array returned by C. + +The synopsis is like: + + my ($name, $email, $time_tz) = ident('author'); + "$name <$email>" eq ident_person('author'); + "$name <$email>" eq ident_person($name); + $time_tz =~ /^\d+ [+-]\d{4}$/; + +Both methods must be called on a repository instance. + +=cut + +sub ident { + my ($self, $type) = @_; + my $identstr; + if (lc $type eq lc 'committer' or lc $type eq lc 'author') { + $identstr = $self->command_oneline('var', 'GIT_'.uc($type).'_IDENT'); + } else { + $identstr = $type; + } + if (wantarray) { + return $identstr =~ /^(.*) <(.*)> (\d+ [+-]\d{4})$/; + } else { + return $identstr; + } +} + +sub ident_person { + my ($self, @ident) = @_; + $#ident == 0 and @ident = $self->ident($ident[0]); + return "$ident[0] <$ident[1]>"; +} + + =item hash_object ( TYPE, FILENAME ) =item hash_object ( TYPE, FILEHANDLE ) -- cgit v0.10.2-6-g49f6 From 998c4daaf4a921fb03d478b50d6e06223326d7ef Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Fri, 7 Jul 2006 13:04:35 -0700 Subject: Work around sed and make interactions on the backslash at the end of line. Traditionally 'i' and 'a' commands to sed have been unfriendly with make, primarily because different make implementations did unexpected things to backslashes at the end of lines. So work it around by not using 'i' command. Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 71657ec..01b9a94 100644 --- a/Makefile +++ b/Makefile @@ -550,9 +550,13 @@ $(patsubst %.perl,%,$(SCRIPT_PERL)): perl/Makefile $(patsubst %.perl,%,$(SCRIPT_PERL)): % : %.perl rm -f $@ $@+ INSTLIBDIR=`$(MAKE) -C perl -s --no-print-directory instlibdir` && \ - sed -e '1s|#!.*perl|#!$(PERL_PATH_SQ)|1' \ - -e '2i\ - use lib (split(/:/, $$ENV{GITPERLLIB} || '\'"$$INSTLIBDIR"\''));' \ + sed -e '1{' \ + -e ' s|#!.*perl|#!$(PERL_PATH_SQ)|' \ + -e ' h' \ + -e ' s=.*=use lib (split(/:/, $$ENV{GITPERLLIB} || "@@INSTLIBDIR@@"));=' \ + -e ' H' \ + -e ' x' \ + -e '}' \ -e 's|@@INSTLIBDIR@@|'"$$INSTLIBDIR"'|g' \ -e 's/@@GIT_VERSION@@/$(GIT_VERSION)/g' \ $@.perl >$@+ -- cgit v0.10.2-6-g49f6 From 0270083ded143fd49841e3d3d0cac5eb06081d2a Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Mon, 3 Jul 2006 22:48:03 +0200 Subject: Make it possible to set up libgit directly (instead of from the environment) This introduces a setup_git() function which is essentialy a (public) backend for setup_git_env() which lets anyone specify custom sources for the various paths instead of environment variables. Since the repositories may get switched on the fly, this also updates code that caches paths to invalidate them properly; I hope neither of those is a sweet spot. It is used by Git.xs' xs__call_gate() to set up per-repository data for libgit's consumption. No code actually takes advantage of it yet but get_object() will in the next patches. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/cache.h b/cache.h index 8719939..962f2fc 100644 --- a/cache.h +++ b/cache.h @@ -116,6 +116,9 @@ extern struct cache_entry **active_cache; extern unsigned int active_nr, active_alloc, active_cache_changed; extern struct cache_tree *active_cache_tree; +extern void setup_git(char *new_git_dir, char *new_git_object_dir, + char *new_git_index_file, char *new_git_graft_file); + #define GIT_DIR_ENVIRONMENT "GIT_DIR" #define DEFAULT_GIT_DIR_ENVIRONMENT ".git" #define DB_ENVIRONMENT "GIT_OBJECT_DIRECTORY" diff --git a/commit.c b/commit.c index e51ffa1..17f51c2 100644 --- a/commit.c +++ b/commit.c @@ -163,6 +163,14 @@ int register_commit_graft(struct commit_graft *graft, int ignore_dups) return 0; } +void free_commit_grafts(void) +{ + int pos = commit_graft_nr; + while (pos >= 0) + free(commit_graft[pos--]); + commit_graft_nr = 0; +} + struct commit_graft *read_graft_line(char *buf, int len) { /* The format is just "Commit Parent1 Parent2 ...\n" */ @@ -215,11 +223,18 @@ int read_graft_file(const char *graft_file) static void prepare_commit_graft(void) { static int commit_graft_prepared; - char *graft_file; + static char *last_graft_file; + char *graft_file = get_graft_file(); + + if (last_graft_file) { + if (!strcmp(graft_file, last_graft_file)) + return; + free_commit_grafts(); + } + if (last_graft_file) + free(last_graft_file); + last_graft_file = strdup(graft_file); - if (commit_graft_prepared) - return; - graft_file = get_graft_file(); read_graft_file(graft_file); commit_graft_prepared = 1; } diff --git a/environment.c b/environment.c index 3de8eb3..6b64d11 100644 --- a/environment.c +++ b/environment.c @@ -21,28 +21,61 @@ char git_commit_encoding[MAX_ENCODING_LENGTH] = "utf-8"; int shared_repository = PERM_UMASK; const char *apply_default_whitespace = NULL; +static int dyn_git_object_dir, dyn_git_index_file, dyn_git_graft_file; static char *git_dir, *git_object_dir, *git_index_file, *git_refs_dir, *git_graft_file; -static void setup_git_env(void) + +void setup_git(char *new_git_dir, char *new_git_object_dir, + char *new_git_index_file, char *new_git_graft_file) { - git_dir = getenv(GIT_DIR_ENVIRONMENT); + git_dir = new_git_dir; if (!git_dir) git_dir = DEFAULT_GIT_DIR_ENVIRONMENT; - git_object_dir = getenv(DB_ENVIRONMENT); + + if (dyn_git_object_dir) + free(git_object_dir); + git_object_dir = new_git_object_dir; if (!git_object_dir) { git_object_dir = xmalloc(strlen(git_dir) + 9); sprintf(git_object_dir, "%s/objects", git_dir); + dyn_git_object_dir = 1; + } else { + dyn_git_object_dir = 0; } + + if (git_refs_dir) + free(git_refs_dir); git_refs_dir = xmalloc(strlen(git_dir) + 6); sprintf(git_refs_dir, "%s/refs", git_dir); - git_index_file = getenv(INDEX_ENVIRONMENT); + + if (dyn_git_index_file) + free(git_index_file); + git_index_file = new_git_index_file; if (!git_index_file) { git_index_file = xmalloc(strlen(git_dir) + 7); sprintf(git_index_file, "%s/index", git_dir); + dyn_git_index_file = 1; + } else { + dyn_git_index_file = 0; } - git_graft_file = getenv(GRAFT_ENVIRONMENT); - if (!git_graft_file) + + if (dyn_git_graft_file) + free(git_graft_file); + git_graft_file = new_git_graft_file; + if (!git_graft_file) { git_graft_file = strdup(git_path("info/grafts")); + dyn_git_graft_file = 1; + } else { + dyn_git_graft_file = 0; + } +} + +static void setup_git_env(void) +{ + setup_git(getenv(GIT_DIR_ENVIRONMENT), + getenv(DB_ENVIRONMENT), + getenv(INDEX_ENVIRONMENT), + getenv(GRAFT_ENVIRONMENT)); } char *get_git_dir(void) diff --git a/perl/Git.pm b/perl/Git.pm index 9ce9fcd..9da15e9 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -98,6 +98,8 @@ XSLoader::load('Git', $VERSION); } +my $instance_id = 0; + =head1 CONSTRUCTORS @@ -215,7 +217,7 @@ sub repository { delete $opts{Directory}; } - $self = { opts => \%opts }; + $self = { opts => \%opts, id => $instance_id++ }; bless $self, $class; } @@ -833,11 +835,10 @@ sub _call_gate { if (defined $self) { # XXX: We ignore the WorkingCopy! To properly support # that will require heavy changes in libgit. + # For now, when we will need to do it we could temporarily + # chdir() there and then chdir() back after the call is done. - # XXX: And we ignore everything else as well. libgit - # at least needs to be extended to let us specify - # the $GIT_DIR instead of looking it up in environment. - #xs_call_gate($self->{opts}->{Repository}); + xs__call_gate($self->{id}, $self->repo_path()); } # Having to call throw from the C code is a sure path to insanity. diff --git a/perl/Git.xs b/perl/Git.xs index 2bbec43..6ed26a2 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -52,7 +52,21 @@ BOOT: } -# /* TODO: xs_call_gate(). See Git.pm. */ +void +xs__call_gate(repoid, git_dir) + long repoid; + char *git_dir; +CODE: +{ + static long last_repoid; + if (repoid != last_repoid) { + setup_git(git_dir, + getenv(DB_ENVIRONMENT), + getenv(INDEX_ENVIRONMENT), + getenv(GRAFT_ENVIRONMENT)); + last_repoid = repoid; + } +} char * diff --git a/sha1_file.c b/sha1_file.c index 8179630..ab64543 100644 --- a/sha1_file.c +++ b/sha1_file.c @@ -126,16 +126,22 @@ static void fill_sha1_path(char *pathbuf, const unsigned char *sha1) char *sha1_file_name(const unsigned char *sha1) { static char *name, *base; + static const char *last_objdir; + const char *sha1_file_directory = get_object_directory(); - if (!base) { - const char *sha1_file_directory = get_object_directory(); + if (!last_objdir || strcmp(last_objdir, sha1_file_directory)) { int len = strlen(sha1_file_directory); + if (base) + free(base); base = xmalloc(len + 60); memcpy(base, sha1_file_directory, len); memset(base+len, 0, 60); base[len] = '/'; base[len+3] = '/'; name = base + len + 1; + if (last_objdir) + free((char *) last_objdir); + last_objdir = strdup(sha1_file_directory); } fill_sha1_path(name, sha1); return base; @@ -145,14 +151,20 @@ char *sha1_pack_name(const unsigned char *sha1) { static const char hex[] = "0123456789abcdef"; static char *name, *base, *buf; + static const char *last_objdir; + const char *sha1_file_directory = get_object_directory(); int i; - if (!base) { - const char *sha1_file_directory = get_object_directory(); + if (!last_objdir || strcmp(last_objdir, sha1_file_directory)) { int len = strlen(sha1_file_directory); + if (base) + free(base); base = xmalloc(len + 60); sprintf(base, "%s/pack/pack-1234567890123456789012345678901234567890.pack", sha1_file_directory); name = base + len + 11; + if (last_objdir) + free((char *) last_objdir); + last_objdir = strdup(sha1_file_directory); } buf = name; @@ -170,14 +182,20 @@ char *sha1_pack_index_name(const unsigned char *sha1) { static const char hex[] = "0123456789abcdef"; static char *name, *base, *buf; + static const char *last_objdir; + const char *sha1_file_directory = get_object_directory(); int i; - if (!base) { - const char *sha1_file_directory = get_object_directory(); + if (!last_objdir || strcmp(last_objdir, sha1_file_directory)) { int len = strlen(sha1_file_directory); + if (base) + free(base); base = xmalloc(len + 60); sprintf(base, "%s/pack/pack-1234567890123456789012345678901234567890.idx", sha1_file_directory); name = base + len + 11; + if (last_objdir) + free((char *) last_objdir); + last_objdir = strdup(sha1_file_directory); } buf = name; diff --git a/sha1_name.c b/sha1_name.c index f2cbafa..c698c1b 100644 --- a/sha1_name.c +++ b/sha1_name.c @@ -12,15 +12,21 @@ static int find_short_object_filename(int len, const char *name, unsigned char * char hex[40]; int found = 0; static struct alternate_object_database *fakeent; + static const char *last_objdir; + const char *objdir = get_object_directory(); - if (!fakeent) { - const char *objdir = get_object_directory(); + if (!last_objdir || strcmp(last_objdir, objdir)) { int objdir_len = strlen(objdir); int entlen = objdir_len + 43; + if (fakeent) + free(fakeent); fakeent = xmalloc(sizeof(*fakeent) + entlen); memcpy(fakeent->base, objdir, objdir_len); fakeent->name = fakeent->base + objdir_len + 1; fakeent->name[-1] = '/'; + if (last_objdir) + free((char *) last_objdir); + last_objdir = strdup(objdir); } fakeent->next = alt_odb_list; -- cgit v0.10.2-6-g49f6 From 3c479c37f8651d09e1d08b8d6ea9757164ee1235 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Mon, 3 Jul 2006 22:48:05 +0200 Subject: Git.pm: Introduce fast get_object() method Direct .xs routine. Note that it does not work 100% correctly when you juggle multiple repository objects, but it is not that bad either. The trouble is that we might reuse packs information for another Git project; that is not an issue since Git depends on uniqueness of SHA1 ids so if we have found the object somewhere else, it is nevertheless going to be the same object. It merely makes object existence detection through this method unreliable; it is duly noted in the documentation. At least that's how I see it, I hope I didn't overlook any other potential problem. I tested it for memory leaks and it appears to be doing ok. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/Git.pm b/perl/Git.pm index 9da15e9..f2467bd 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -572,6 +572,24 @@ sub ident_person { } +=item get_object ( TYPE, SHA1 ) + +Return contents of the given object in a scalar string. If the object has +not been found, undef is returned; however, do not rely on this! Currently, +if you use multiple repositories at once, get_object() on one repository +_might_ return the object even though it exists only in another repository. +(But do not rely on this behaviour either.) + +The method must be called on a repository instance. + +Implementation of this method is very fast; no external command calls +are involved. That's why it is broken, too. ;-) + +=cut + +# Implemented in Git.xs. + + =item hash_object ( TYPE, FILENAME ) =item hash_object ( TYPE, FILEHANDLE ) diff --git a/perl/Git.xs b/perl/Git.xs index 6ed26a2..226dd4f 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -111,6 +111,30 @@ CODE: free((char **) argv); } + +SV * +xs_get_object(type, id) + char *type; + char *id; +CODE: +{ + unsigned char sha1[20]; + unsigned long size; + void *buf; + + if (strlen(id) != 40 || get_sha1_hex(id, sha1) < 0) + XSRETURN_UNDEF; + + buf = read_sha1_file(sha1, type, &size); + if (!buf) + XSRETURN_UNDEF; + RETVAL = newSVpvn(buf, size); + free(buf); +} +OUTPUT: + RETVAL + + char * xs_hash_object_pipe(type, fd) char *type; -- cgit v0.10.2-6-g49f6 From 7fb39d5f58efd05e982fe148630edc97ded753b6 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Mon, 3 Jul 2006 22:48:07 +0200 Subject: Convert git-annotate to use Git.pm Together with the other converted scripts, this is probably still pu material; it appears to work fine for me, though. The speed gain from get_object() is about 10% (I expected more...). Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/git-annotate.perl b/git-annotate.perl index a6a7a48..d924e87 100755 --- a/git-annotate.perl +++ b/git-annotate.perl @@ -11,6 +11,7 @@ use strict; use Getopt::Long; use POSIX qw(strftime gmtime); use File::Basename qw(basename dirname); +use Git; sub usage() { print STDERR "Usage: ${\basename $0} [-s] [-S revs-file] file [ revision ] @@ -29,7 +30,7 @@ sub usage() { exit(1); } -our ($help, $longrev, $rename, $rawtime, $starting_rev, $rev_file) = (0, 0, 1); +our ($help, $longrev, $rename, $rawtime, $starting_rev, $rev_file, $repo) = (0, 0, 1); my $rc = GetOptions( "long|l" => \$longrev, "time|t" => \$rawtime, @@ -52,6 +53,8 @@ my @stack = ( }, ); +$repo = Git->repository(); + our @filelines = (); if (defined $starting_rev) { @@ -102,15 +105,11 @@ while (my $bound = pop @stack) { push @revqueue, $head; init_claim( defined $starting_rev ? $head : 'dirty'); unless (defined $starting_rev) { - my $diff = open_pipe("git","diff","-R", "HEAD", "--",$filename) - or die "Failed to call git diff to check for dirty state: $!"; - - _git_diff_parse($diff, $head, "dirty", ( - 'author' => gitvar_name("GIT_AUTHOR_IDENT"), - 'author_date' => sprintf("%s +0000",time()), - ) - ); - close($diff); + my %ident; + @ident{'author', 'author_email', 'author_date'} = $repo->ident('author'); + my $diff = $repo->command_output_pipe('diff', '-R', 'HEAD', '--', $filename); + _git_diff_parse($diff, $head, "dirty", %ident); + $repo->command_close_pipe($diff); } handle_rev(); @@ -181,8 +180,7 @@ sub git_rev_list { open($revlist, '<' . $rev_file) or die "Failed to open $rev_file : $!"; } else { - $revlist = open_pipe("git-rev-list","--parents","--remove-empty",$rev,"--",$file) - or die "Failed to exec git-rev-list: $!"; + $revlist = $repo->command_output_pipe('rev-list', '--parents', '--remove-empty', $rev, '--', $file); } my @revs; @@ -191,7 +189,7 @@ sub git_rev_list { my ($rev, @parents) = split /\s+/, $line; push @revs, [ $rev, @parents ]; } - close($revlist); + $repo->command_close_pipe($revlist); printf("0 revs found for rev %s (%s)\n", $rev, $file) if (@revs == 0); return @revs; @@ -200,8 +198,7 @@ sub git_rev_list { sub find_parent_renames { my ($rev, $file) = @_; - my $patch = open_pipe("git-diff-tree", "-M50", "-r","--name-status", "-z","$rev") - or die "Failed to exec git-diff: $!"; + my $patch = $repo->command_output_pipe('diff-tree', '-M50', '-r', '--name-status', '-z', $rev); local $/ = "\0"; my %bound; @@ -227,7 +224,7 @@ sub find_parent_renames { } } } - close($patch); + $repo->command_close_pipe($patch); return \%bound; } @@ -236,14 +233,9 @@ sub find_parent_renames { sub git_find_parent { my ($rev, $filename) = @_; - my $revparent = open_pipe("git-rev-list","--remove-empty", "--parents","--max-count=1","$rev","--",$filename) - or die "Failed to open git-rev-list to find a single parent: $!"; - - my $parentline = <$revparent>; - chomp $parentline; - my ($revfound,$parent) = split m/\s+/, $parentline; - - close($revparent); + my $parentline = $repo->command_oneline('rev-list', '--remove-empty', + '--parents', '--max-count=1', $rev, '--', $filename); + my ($revfound, $parent) = split m/\s+/, $parentline; return $parent; } @@ -254,13 +246,13 @@ sub git_find_parent { sub git_diff_parse { my ($parent, $rev, %revinfo) = @_; - my $diff = open_pipe("git-diff-tree","-M","-p",$rev,$parent,"--", - $revs{$rev}{'filename'}, $revs{$parent}{'filename'}) - or die "Failed to call git-diff for annotation: $!"; + my $diff = $repo->command_output_pipe('diff-tree', '-M', '-p', + $rev, $parent, '--', + $revs{$rev}{'filename'}, $revs{$parent}{'filename'}); _git_diff_parse($diff, $parent, $rev, %revinfo); - close($diff); + $repo->command_close_pipe($diff); } sub _git_diff_parse { @@ -351,36 +343,25 @@ sub git_cat_file { my $blob = git_ls_tree($rev, $filename); die "Failed to find a blob for $filename in rev $rev\n" if !defined $blob; - my $catfile = open_pipe("git","cat-file", "blob", $blob) - or die "Failed to git-cat-file blob $blob (rev $rev, file $filename): " . $!; - - my @lines; - while(<$catfile>) { - chomp; - push @lines, $_; - } - close($catfile); - + my @lines = split(/\n/, $repo->get_object('blob', $blob)); + pop @lines unless $lines[$#lines]; # Trailing newline return @lines; } sub git_ls_tree { my ($rev, $filename) = @_; - my $lstree = open_pipe("git","ls-tree",$rev,$filename) - or die "Failed to call git ls-tree: $!"; - + my $lstree = $repo->command_output_pipe('ls-tree', $rev, $filename); my ($mode, $type, $blob, $tfilename); while(<$lstree>) { chomp; ($mode, $type, $blob, $tfilename) = split(/\s+/, $_, 4); last if ($tfilename eq $filename); } - close($lstree); + $repo->command_close_pipe($lstree); return $blob if ($tfilename eq $filename); die "git-ls-tree failed to find blob for $filename"; - } @@ -396,25 +377,17 @@ sub claim_line { sub git_commit_info { my ($rev) = @_; - my $commit = open_pipe("git-cat-file", "commit", $rev) - or die "Failed to call git-cat-file: $!"; + my $commit = $repo->get_object('commit', $rev); my %info; - while(<$commit>) { - chomp; - last if (length $_ == 0); - - if (m/^author (.*) <(.*)> (.*)$/) { - $info{'author'} = $1; - $info{'author_email'} = $2; - $info{'author_date'} = $3; - } elsif (m/^committer (.*) <(.*)> (.*)$/) { - $info{'committer'} = $1; - $info{'committer_email'} = $2; - $info{'committer_date'} = $3; + while ($commit =~ /(.*?)\n/g) { + my $line = $1; + if ($line =~ s/^author //) { + @info{'author', 'author_email', 'author_date'} = $repo->ident($line); + } elsif ($line =~ s/^committer//) { + @info{'committer', 'committer_email', 'committer_date'} = $repo->ident($line); } } - close($commit); return %info; } @@ -432,81 +405,3 @@ sub format_date { my $t = $timestamp + $minutes * 60; return strftime("%Y-%m-%d %H:%M:%S " . $timezone, gmtime($t)); } - -# Copied from git-send-email.perl - We need a Git.pm module.. -sub gitvar { - my ($var) = @_; - my $fh; - my $pid = open($fh, '-|'); - die "$!" unless defined $pid; - if (!$pid) { - exec('git-var', $var) or die "$!"; - } - my ($val) = <$fh>; - close $fh or die "$!"; - chomp($val); - return $val; -} - -sub gitvar_name { - my ($name) = @_; - my $val = gitvar($name); - my @field = split(/\s+/, $val); - return join(' ', @field[0...(@field-4)]); -} - -sub open_pipe { - if ($^O eq '##INSERT_ACTIVESTATE_STRING_HERE##') { - return open_pipe_activestate(@_); - } else { - return open_pipe_normal(@_); - } -} - -sub open_pipe_activestate { - tie *fh, "Git::ActiveStatePipe", @_; - return *fh; -} - -sub open_pipe_normal { - my (@execlist) = @_; - - my $pid = open my $kid, "-|"; - defined $pid or die "Cannot fork: $!"; - - unless ($pid) { - exec @execlist; - die "Cannot exec @execlist: $!"; - } - - return $kid; -} - -package Git::ActiveStatePipe; -use strict; - -sub TIEHANDLE { - my ($class, @params) = @_; - my $cmdline = join " ", @params; - my @data = qx{$cmdline}; - bless { i => 0, data => \@data }, $class; -} - -sub READLINE { - my $self = shift; - if ($self->{i} >= scalar @{$self->{data}}) { - return undef; - } - return $self->{'data'}->[ $self->{i}++ ]; -} - -sub CLOSE { - my $self = shift; - delete $self->{data}; - delete $self->{i}; -} - -sub EOF { - my $self = shift; - return ($self->{i} >= scalar @{$self->{data}}); -} -- cgit v0.10.2-6-g49f6 From 96bc4de85cf810db5c7cd94bf0688a98a64a0bc7 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Wed, 26 Jul 2006 03:03:58 +0200 Subject: Eliminate Scalar::Util usage from private-Error.pm We used just the blessed() routine so steal it from Scalar/Util.pm. Unfortunately, Scalar::Util is not bundled with older Perl versions. This is a newer much saner blessed() version by Randal L. Schwarz. Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/perl/private-Error.pm b/perl/private-Error.pm index ebd0749..8fff866 100644 --- a/perl/private-Error.pm +++ b/perl/private-Error.pm @@ -43,8 +43,6 @@ $Error::ObjectifyCallback = \&throw_Error_Simple; # Exported subs are defined in Error::subs -use Scalar::Util (); - sub import { shift; local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; @@ -290,6 +288,14 @@ use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); @ISA = qw(Exporter); + +sub blessed { + my $item = shift; + local $@; # don't kill an outer $@ + ref $item and eval { $item->can('can') }; +} + + sub run_clauses ($$$\@) { my($clauses,$err,$wantarray,$result) = @_; my $code = undef; @@ -312,7 +318,7 @@ sub run_clauses ($$$\@) { $i -= 2; next CATCHLOOP; } - elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { + elsif(blessed($err) && $err->isa($pkg)) { $code = $catch->[$i+1]; while(1) { my $more = 0; @@ -421,7 +427,7 @@ sub try (&;$) { if (defined($err)) { - if (Scalar::Util::blessed($err) && $err->can('throw')) + if (blessed($err) && $err->can('throw')) { throw $err; } -- cgit v0.10.2-6-g49f6 From 4c5cf8c44ce06a79da5bafd4a92e6d6f598cea2e Mon Sep 17 00:00:00 2001 From: Eric Wong Date: Sun, 13 Aug 2006 04:13:25 -0700 Subject: pass DESTDIR to the generated perl/Makefile Makes life for binary packagers easier, as the Perl modules will be installed inside DESTDIR. Signed-off-by: Eric Wong Signed-off-by: Junio C Hamano diff --git a/perl/Makefile.PL b/perl/Makefile.PL index 97ee9af..ef9d82d 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -22,10 +22,14 @@ if ($@) { $pm{'private-Error.pm'} = '$(INST_LIBDIR)/Error.pm'; } +my %extra; +$extra{DESTDIR} = $ENV{DESTDIR} if $ENV{DESTDIR}; + WriteMakefile( NAME => 'Git', VERSION_FROM => 'Git.pm', PM => \%pm, MYEXTLIB => '../libgit.a', INC => '-I. -I..', + %extra ); -- cgit v0.10.2-6-g49f6 From 60a144f28047b4fa0e4a795972c483fa85a7d3c8 Mon Sep 17 00:00:00 2001 From: Dennis Stosberg Date: Tue, 15 Aug 2006 11:01:31 +0200 Subject: Fix compilation with Sun CC - Add the CFLAGS variable to config.mak.in to override the Makefile's default, which is gcc-specific and won't work with Sun CC. - Prefer "cc" over "gcc", because Pasky's Git.pm will not compile with gcc on Solaris at all. On Linux and the free BSDs "cc" is linked to "gcc" anyway. - Set correct flag to generate position-independent code. - Add "-xO3" (= use default optimization level) to CFLAGS. Signed-off-by: Dennis Stosberg Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index ac42ae3..4e7a37a 100644 --- a/Makefile +++ b/Makefile @@ -112,6 +112,7 @@ uname_P := $(shell sh -c 'uname -p 2>/dev/null || echo not') # CFLAGS and LDFLAGS are for the users to override from the command line. CFLAGS = -g -O2 -Wall +PIC_FLAG = -fPIC LDFLAGS = ALL_CFLAGS = $(CFLAGS) ALL_LDFLAGS = $(LDFLAGS) @@ -402,6 +403,9 @@ endif ifneq (,$(findstring arm,$(uname_M))) ARM_SHA1 = YesPlease endif +ifeq ($(uname_M),sun4u) + USE_PIC = YesPlease +endif ifeq ($(uname_M),x86_64) USE_PIC = YesPlease endif @@ -544,7 +548,7 @@ endif endif endif ifdef USE_PIC - ALL_CFLAGS += -fPIC + ALL_CFLAGS += $(PIC_FLAG) endif ifdef NO_ACCURATE_DIFF BASIC_CFLAGS += -DNO_ACCURATE_DIFF diff --git a/config.mak.in b/config.mak.in index 369e611..addda4f 100644 --- a/config.mak.in +++ b/config.mak.in @@ -2,6 +2,8 @@ # @configure_input@ CC = @CC@ +CFLAGS = @CFLAGS@ +PIC_FLAG = @PIC_FLAG@ AR = @AR@ TAR = @TAR@ #INSTALL = @INSTALL@ # needs install-sh or install.sh in sources diff --git a/configure.ac b/configure.ac index 36f9cd9..0f93f6f 100644 --- a/configure.ac +++ b/configure.ac @@ -95,7 +95,14 @@ AC_SUBST(PYTHON_PATH) ## Checks for programs. AC_MSG_NOTICE([CHECKS for programs]) # -AC_PROG_CC +AC_PROG_CC([cc gcc]) +if test -n "$GCC"; then + PIC_FLAG="-fPIC" +else + AC_CHECK_DECL(__SUNPRO_C, [CFLAGS="$CFLAGS -xO3"; PIC_FLAG="-KPIC"]) +fi +AC_SUBST(PIC_FLAG) + #AC_PROG_INSTALL # needs install-sh or install.sh in sources AC_CHECK_TOOL(AR, ar, :) AC_CHECK_PROGS(TAR, [gtar tar]) -- cgit v0.10.2-6-g49f6 From 3c2f5886c78454276a045c1312eca652c11d98d6 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Sat, 2 Sep 2006 22:57:42 -0700 Subject: Revert "Convert git-annotate to use Git.pm" This reverts commit 7fb39d5f58efd05e982fe148630edc97ded753b6. diff --git a/git-annotate.perl b/git-annotate.perl index 742a51c..215ed26 100755 --- a/git-annotate.perl +++ b/git-annotate.perl @@ -11,7 +11,6 @@ use strict; use Getopt::Long; use POSIX qw(strftime gmtime); use File::Basename qw(basename dirname); -use Git; sub usage() { print STDERR "Usage: ${\basename $0} [-s] [-S revs-file] file [ revision ] @@ -30,7 +29,7 @@ sub usage() { exit(1); } -our ($help, $longrev, $rename, $rawtime, $starting_rev, $rev_file, $repo) = (0, 0, 1); +our ($help, $longrev, $rename, $rawtime, $starting_rev, $rev_file) = (0, 0, 1); my $rc = GetOptions( "long|l" => \$longrev, "time|t" => \$rawtime, @@ -53,8 +52,6 @@ my @stack = ( }, ); -$repo = Git->repository(); - our @filelines = (); if (defined $starting_rev) { @@ -105,11 +102,15 @@ while (my $bound = pop @stack) { push @revqueue, $head; init_claim( defined $starting_rev ? $head : 'dirty'); unless (defined $starting_rev) { - my %ident; - @ident{'author', 'author_email', 'author_date'} = $repo->ident('author'); - my $diff = $repo->command_output_pipe('diff', '-R', 'HEAD', '--', $filename); - _git_diff_parse($diff, [$head], "dirty", %ident); - $repo->command_close_pipe($diff); + my $diff = open_pipe("git","diff","HEAD", "--",$filename) + or die "Failed to call git diff to check for dirty state: $!"; + + _git_diff_parse($diff, [$head], "dirty", ( + 'author' => gitvar_name("GIT_AUTHOR_IDENT"), + 'author_date' => sprintf("%s +0000",time()), + ) + ); + close($diff); } handle_rev(); @@ -179,7 +180,8 @@ sub git_rev_list { open($revlist, '<' . $rev_file) or die "Failed to open $rev_file : $!"; } else { - $revlist = $repo->command_output_pipe('rev-list', '--parents', '--remove-empty', $rev, '--', $file); + $revlist = open_pipe("git-rev-list","--parents","--remove-empty",$rev,"--",$file) + or die "Failed to exec git-rev-list: $!"; } my @revs; @@ -188,7 +190,7 @@ sub git_rev_list { my ($rev, @parents) = split /\s+/, $line; push @revs, [ $rev, @parents ]; } - $repo->command_close_pipe($revlist); + close($revlist); printf("0 revs found for rev %s (%s)\n", $rev, $file) if (@revs == 0); return @revs; @@ -197,7 +199,8 @@ sub git_rev_list { sub find_parent_renames { my ($rev, $file) = @_; - my $patch = $repo->command_output_pipe('diff-tree', '-M50', '-r', '--name-status', '-z', $rev); + my $patch = open_pipe("git-diff-tree", "-M50", "-r","--name-status", "-z","$rev") + or die "Failed to exec git-diff: $!"; local $/ = "\0"; my %bound; @@ -223,7 +226,7 @@ sub find_parent_renames { } } } - $repo->command_close_pipe($patch); + close($patch); return \%bound; } @@ -232,9 +235,14 @@ sub find_parent_renames { sub git_find_parent { my ($rev, $filename) = @_; - my $parentline = $repo->command_oneline('rev-list', '--remove-empty', - '--parents', '--max-count=1', $rev, '--', $filename); - my ($revfound, $parent) = split m/\s+/, $parentline; + my $revparent = open_pipe("git-rev-list","--remove-empty", "--parents","--max-count=1","$rev","--",$filename) + or die "Failed to open git-rev-list to find a single parent: $!"; + + my $parentline = <$revparent>; + chomp $parentline; + my ($revfound,$parent) = split m/\s+/, $parentline; + + close($revparent); return $parent; } @@ -242,16 +250,29 @@ sub git_find_parent { sub git_find_all_parents { my ($rev) = @_; - my $parentline = $repo->command_oneline("rev-list","--remove-empty", "--parents","--max-count=1","$rev"); + my $revparent = open_pipe("git-rev-list","--remove-empty", "--parents","--max-count=1","$rev") + or die "Failed to open git-rev-list to find a single parent: $!"; + + my $parentline = <$revparent>; + chomp $parentline; my ($origrev, @parents) = split m/\s+/, $parentline; + close($revparent); + return @parents; } sub git_merge_base { my ($rev1, $rev2) = @_; - my $base = $repo->command_oneline("merge-base", $rev1, $rev2); + my $mb = open_pipe("git-merge-base", $rev1, $rev2) + or die "Failed to open git-merge-base: $!"; + + my $base = <$mb>; + chomp $base; + + close($mb); + return $base; } @@ -316,7 +337,7 @@ sub git_diff_parse { my ($parents, $rev, %revinfo) = @_; my @pseudo_parents; - my @command = ("diff-tree"); + my @command = ("git-diff-tree"); my $revision_spec; if (scalar @$parents == 1) { @@ -345,11 +366,12 @@ sub git_diff_parse { push @command, "-p", "-M", $revision_spec, "--", @filenames; - my $diff = $repo->command_output_pipe(@command); + my $diff = open_pipe( @command ) + or die "Failed to call git-diff for annotation: $!"; _git_diff_parse($diff, \@pseudo_parents, $rev, %revinfo); - $repo->command_close_pipe($diff); + close($diff); } sub _git_diff_parse { @@ -525,25 +547,36 @@ sub git_cat_file { my $blob = git_ls_tree($rev, $filename); die "Failed to find a blob for $filename in rev $rev\n" if !defined $blob; - my @lines = split(/\n/, $repo->get_object('blob', $blob)); - pop @lines unless $lines[$#lines]; # Trailing newline + my $catfile = open_pipe("git","cat-file", "blob", $blob) + or die "Failed to git-cat-file blob $blob (rev $rev, file $filename): " . $!; + + my @lines; + while(<$catfile>) { + chomp; + push @lines, $_; + } + close($catfile); + return @lines; } sub git_ls_tree { my ($rev, $filename) = @_; - my $lstree = $repo->command_output_pipe('ls-tree', $rev, $filename); + my $lstree = open_pipe("git","ls-tree",$rev,$filename) + or die "Failed to call git ls-tree: $!"; + my ($mode, $type, $blob, $tfilename); while(<$lstree>) { chomp; ($mode, $type, $blob, $tfilename) = split(/\s+/, $_, 4); last if ($tfilename eq $filename); } - $repo->command_close_pipe($lstree); + close($lstree); return $blob if ($tfilename eq $filename); die "git-ls-tree failed to find blob for $filename"; + } @@ -559,17 +592,25 @@ sub claim_line { sub git_commit_info { my ($rev) = @_; - my $commit = $repo->get_object('commit', $rev); + my $commit = open_pipe("git-cat-file", "commit", $rev) + or die "Failed to call git-cat-file: $!"; my %info; - while ($commit =~ /(.*?)\n/g) { - my $line = $1; - if ($line =~ s/^author //) { - @info{'author', 'author_email', 'author_date'} = $repo->ident($line); - } elsif ($line =~ s/^committer//) { - @info{'committer', 'committer_email', 'committer_date'} = $repo->ident($line); + while(<$commit>) { + chomp; + last if (length $_ == 0); + + if (m/^author (.*) <(.*)> (.*)$/) { + $info{'author'} = $1; + $info{'author_email'} = $2; + $info{'author_date'} = $3; + } elsif (m/^committer (.*) <(.*)> (.*)$/) { + $info{'committer'} = $1; + $info{'committer_email'} = $2; + $info{'committer_date'} = $3; } } + close($commit); return %info; } @@ -587,3 +628,81 @@ sub format_date { my $t = $timestamp + $minutes * 60; return strftime("%Y-%m-%d %H:%M:%S " . $timezone, gmtime($t)); } + +# Copied from git-send-email.perl - We need a Git.pm module.. +sub gitvar { + my ($var) = @_; + my $fh; + my $pid = open($fh, '-|'); + die "$!" unless defined $pid; + if (!$pid) { + exec('git-var', $var) or die "$!"; + } + my ($val) = <$fh>; + close $fh or die "$!"; + chomp($val); + return $val; +} + +sub gitvar_name { + my ($name) = @_; + my $val = gitvar($name); + my @field = split(/\s+/, $val); + return join(' ', @field[0...(@field-4)]); +} + +sub open_pipe { + if ($^O eq '##INSERT_ACTIVESTATE_STRING_HERE##') { + return open_pipe_activestate(@_); + } else { + return open_pipe_normal(@_); + } +} + +sub open_pipe_activestate { + tie *fh, "Git::ActiveStatePipe", @_; + return *fh; +} + +sub open_pipe_normal { + my (@execlist) = @_; + + my $pid = open my $kid, "-|"; + defined $pid or die "Cannot fork: $!"; + + unless ($pid) { + exec @execlist; + die "Cannot exec @execlist: $!"; + } + + return $kid; +} + +package Git::ActiveStatePipe; +use strict; + +sub TIEHANDLE { + my ($class, @params) = @_; + my $cmdline = join " ", @params; + my @data = qx{$cmdline}; + bless { i => 0, data => \@data }, $class; +} + +sub READLINE { + my $self = shift; + if ($self->{i} >= scalar @{$self->{data}}) { + return undef; + } + return $self->{'data'}->[ $self->{i}++ ]; +} + +sub CLOSE { + my $self = shift; + delete $self->{data}; + delete $self->{i}; +} + +sub EOF { + my $self = shift; + return ($self->{i} >= scalar @{$self->{data}}); +} -- cgit v0.10.2-6-g49f6 From 9594b326dcd6b879807fe6614f55ba50fa3d4551 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Sat, 2 Sep 2006 22:58:32 -0700 Subject: Revert "Git.pm: Introduce fast get_object() method" This reverts commit 3c479c37f8651d09e1d08b8d6ea9757164ee1235. diff --git a/perl/Git.pm b/perl/Git.pm index f2467bd..9da15e9 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -572,24 +572,6 @@ sub ident_person { } -=item get_object ( TYPE, SHA1 ) - -Return contents of the given object in a scalar string. If the object has -not been found, undef is returned; however, do not rely on this! Currently, -if you use multiple repositories at once, get_object() on one repository -_might_ return the object even though it exists only in another repository. -(But do not rely on this behaviour either.) - -The method must be called on a repository instance. - -Implementation of this method is very fast; no external command calls -are involved. That's why it is broken, too. ;-) - -=cut - -# Implemented in Git.xs. - - =item hash_object ( TYPE, FILENAME ) =item hash_object ( TYPE, FILEHANDLE ) diff --git a/perl/Git.xs b/perl/Git.xs index 226dd4f..6ed26a2 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -111,30 +111,6 @@ CODE: free((char **) argv); } - -SV * -xs_get_object(type, id) - char *type; - char *id; -CODE: -{ - unsigned char sha1[20]; - unsigned long size; - void *buf; - - if (strlen(id) != 40 || get_sha1_hex(id, sha1) < 0) - XSRETURN_UNDEF; - - buf = read_sha1_file(sha1, type, &size); - if (!buf) - XSRETURN_UNDEF; - RETVAL = newSVpvn(buf, size); - free(buf); -} -OUTPUT: - RETVAL - - char * xs_hash_object_pipe(type, fd) char *type; -- cgit v0.10.2-6-g49f6 From 81a71734bb73c2def1e86de88fb8de9fb6379cc5 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Sat, 2 Sep 2006 22:58:48 -0700 Subject: Revert "Make it possible to set up libgit directly (instead of from the environment)" This reverts commit 0270083ded143fd49841e3d3d0cac5eb06081d2a. diff --git a/cache.h b/cache.h index 2b8fafb..af77402 100644 --- a/cache.h +++ b/cache.h @@ -117,9 +117,6 @@ extern unsigned int active_nr, active_alloc, active_cache_changed; extern struct cache_tree *active_cache_tree; extern int cache_errno; -extern void setup_git(char *new_git_dir, char *new_git_object_dir, - char *new_git_index_file, char *new_git_graft_file); - #define GIT_DIR_ENVIRONMENT "GIT_DIR" #define DEFAULT_GIT_DIR_ENVIRONMENT ".git" #define DB_ENVIRONMENT "GIT_OBJECT_DIRECTORY" diff --git a/commit.c b/commit.c index 4d5c0c2..77f0ca1 100644 --- a/commit.c +++ b/commit.c @@ -163,14 +163,6 @@ int register_commit_graft(struct commit_graft *graft, int ignore_dups) return 0; } -void free_commit_grafts(void) -{ - int pos = commit_graft_nr; - while (pos >= 0) - free(commit_graft[pos--]); - commit_graft_nr = 0; -} - struct commit_graft *read_graft_line(char *buf, int len) { /* The format is just "Commit Parent1 Parent2 ...\n" */ @@ -223,18 +215,11 @@ int read_graft_file(const char *graft_file) static void prepare_commit_graft(void) { static int commit_graft_prepared; - static char *last_graft_file; - char *graft_file = get_graft_file(); - - if (last_graft_file) { - if (!strcmp(graft_file, last_graft_file)) - return; - free_commit_grafts(); - } - if (last_graft_file) - free(last_graft_file); - last_graft_file = strdup(graft_file); + char *graft_file; + if (commit_graft_prepared) + return; + graft_file = get_graft_file(); read_graft_file(graft_file); commit_graft_prepared = 1; } diff --git a/environment.c b/environment.c index 1ce3411..87162b2 100644 --- a/environment.c +++ b/environment.c @@ -25,61 +25,28 @@ int zlib_compression_level = Z_DEFAULT_COMPRESSION; int pager_in_use; int pager_use_color = 1; -static int dyn_git_object_dir, dyn_git_index_file, dyn_git_graft_file; static char *git_dir, *git_object_dir, *git_index_file, *git_refs_dir, *git_graft_file; - -void setup_git(char *new_git_dir, char *new_git_object_dir, - char *new_git_index_file, char *new_git_graft_file) +static void setup_git_env(void) { - git_dir = new_git_dir; + git_dir = getenv(GIT_DIR_ENVIRONMENT); if (!git_dir) git_dir = DEFAULT_GIT_DIR_ENVIRONMENT; - - if (dyn_git_object_dir) - free(git_object_dir); - git_object_dir = new_git_object_dir; + git_object_dir = getenv(DB_ENVIRONMENT); if (!git_object_dir) { git_object_dir = xmalloc(strlen(git_dir) + 9); sprintf(git_object_dir, "%s/objects", git_dir); - dyn_git_object_dir = 1; - } else { - dyn_git_object_dir = 0; } - - if (git_refs_dir) - free(git_refs_dir); git_refs_dir = xmalloc(strlen(git_dir) + 6); sprintf(git_refs_dir, "%s/refs", git_dir); - - if (dyn_git_index_file) - free(git_index_file); - git_index_file = new_git_index_file; + git_index_file = getenv(INDEX_ENVIRONMENT); if (!git_index_file) { git_index_file = xmalloc(strlen(git_dir) + 7); sprintf(git_index_file, "%s/index", git_dir); - dyn_git_index_file = 1; - } else { - dyn_git_index_file = 0; } - - if (dyn_git_graft_file) - free(git_graft_file); - git_graft_file = new_git_graft_file; - if (!git_graft_file) { + git_graft_file = getenv(GRAFT_ENVIRONMENT); + if (!git_graft_file) git_graft_file = strdup(git_path("info/grafts")); - dyn_git_graft_file = 1; - } else { - dyn_git_graft_file = 0; - } -} - -static void setup_git_env(void) -{ - setup_git(getenv(GIT_DIR_ENVIRONMENT), - getenv(DB_ENVIRONMENT), - getenv(INDEX_ENVIRONMENT), - getenv(GRAFT_ENVIRONMENT)); } char *get_git_dir(void) diff --git a/perl/Git.pm b/perl/Git.pm index 9da15e9..9ce9fcd 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -98,8 +98,6 @@ XSLoader::load('Git', $VERSION); } -my $instance_id = 0; - =head1 CONSTRUCTORS @@ -217,7 +215,7 @@ sub repository { delete $opts{Directory}; } - $self = { opts => \%opts, id => $instance_id++ }; + $self = { opts => \%opts }; bless $self, $class; } @@ -835,10 +833,11 @@ sub _call_gate { if (defined $self) { # XXX: We ignore the WorkingCopy! To properly support # that will require heavy changes in libgit. - # For now, when we will need to do it we could temporarily - # chdir() there and then chdir() back after the call is done. - xs__call_gate($self->{id}, $self->repo_path()); + # XXX: And we ignore everything else as well. libgit + # at least needs to be extended to let us specify + # the $GIT_DIR instead of looking it up in environment. + #xs_call_gate($self->{opts}->{Repository}); } # Having to call throw from the C code is a sure path to insanity. diff --git a/perl/Git.xs b/perl/Git.xs index 6ed26a2..2bbec43 100644 --- a/perl/Git.xs +++ b/perl/Git.xs @@ -52,21 +52,7 @@ BOOT: } -void -xs__call_gate(repoid, git_dir) - long repoid; - char *git_dir; -CODE: -{ - static long last_repoid; - if (repoid != last_repoid) { - setup_git(git_dir, - getenv(DB_ENVIRONMENT), - getenv(INDEX_ENVIRONMENT), - getenv(GRAFT_ENVIRONMENT)); - last_repoid = repoid; - } -} +# /* TODO: xs_call_gate(). See Git.pm. */ char * diff --git a/sha1_file.c b/sha1_file.c index ed52d71..842a6f3 100644 --- a/sha1_file.c +++ b/sha1_file.c @@ -126,22 +126,16 @@ static void fill_sha1_path(char *pathbuf, const unsigned char *sha1) char *sha1_file_name(const unsigned char *sha1) { static char *name, *base; - static const char *last_objdir; - const char *sha1_file_directory = get_object_directory(); - if (!last_objdir || strcmp(last_objdir, sha1_file_directory)) { + if (!base) { + const char *sha1_file_directory = get_object_directory(); int len = strlen(sha1_file_directory); - if (base) - free(base); base = xmalloc(len + 60); memcpy(base, sha1_file_directory, len); memset(base+len, 0, 60); base[len] = '/'; base[len+3] = '/'; name = base + len + 1; - if (last_objdir) - free((char *) last_objdir); - last_objdir = strdup(sha1_file_directory); } fill_sha1_path(name, sha1); return base; @@ -151,20 +145,14 @@ char *sha1_pack_name(const unsigned char *sha1) { static const char hex[] = "0123456789abcdef"; static char *name, *base, *buf; - static const char *last_objdir; - const char *sha1_file_directory = get_object_directory(); int i; - if (!last_objdir || strcmp(last_objdir, sha1_file_directory)) { + if (!base) { + const char *sha1_file_directory = get_object_directory(); int len = strlen(sha1_file_directory); - if (base) - free(base); base = xmalloc(len + 60); sprintf(base, "%s/pack/pack-1234567890123456789012345678901234567890.pack", sha1_file_directory); name = base + len + 11; - if (last_objdir) - free((char *) last_objdir); - last_objdir = strdup(sha1_file_directory); } buf = name; @@ -182,20 +170,14 @@ char *sha1_pack_index_name(const unsigned char *sha1) { static const char hex[] = "0123456789abcdef"; static char *name, *base, *buf; - static const char *last_objdir; - const char *sha1_file_directory = get_object_directory(); int i; - if (!last_objdir || strcmp(last_objdir, sha1_file_directory)) { + if (!base) { + const char *sha1_file_directory = get_object_directory(); int len = strlen(sha1_file_directory); - if (base) - free(base); base = xmalloc(len + 60); sprintf(base, "%s/pack/pack-1234567890123456789012345678901234567890.idx", sha1_file_directory); name = base + len + 11; - if (last_objdir) - free((char *) last_objdir); - last_objdir = strdup(sha1_file_directory); } buf = name; diff --git a/sha1_name.c b/sha1_name.c index ddabb04..c5a05fa 100644 --- a/sha1_name.c +++ b/sha1_name.c @@ -12,21 +12,15 @@ static int find_short_object_filename(int len, const char *name, unsigned char * char hex[40]; int found = 0; static struct alternate_object_database *fakeent; - static const char *last_objdir; - const char *objdir = get_object_directory(); - if (!last_objdir || strcmp(last_objdir, objdir)) { + if (!fakeent) { + const char *objdir = get_object_directory(); int objdir_len = strlen(objdir); int entlen = objdir_len + 43; - if (fakeent) - free(fakeent); fakeent = xmalloc(sizeof(*fakeent) + entlen); memcpy(fakeent->base, objdir, objdir_len); fakeent->name = fakeent->base + objdir_len + 1; fakeent->name[-1] = '/'; - if (last_objdir) - free((char *) last_objdir); - last_objdir = strdup(objdir); } fakeent->next = alt_odb_list; -- cgit v0.10.2-6-g49f6 From 18b0fc1ce1ef92716d4c5d5c7acd5d5a61a0a556 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Sat, 23 Sep 2006 20:20:47 +0200 Subject: Git.pm: Kill Git.xs for now This patch removes Git.xs from the repository for the time being. This should hopefully enable Git.pm to finally make its way to master. Git.xs is not going away forever. When the Git libification makes some progress, it will hopefully return (but most likely as an optional component, due to the portability woes) since the performance boosts are really important for applications like Gitweb or Cogito. It needs to go away now since it is not really reliable in case you use it for several repositories in the scope of a single process, and that is not possible to fix without some either very ugly or very intrusive core changes. Rest in peace. (While you can.) Signed-off-by: Petr Baudis Signed-off-by: Junio C Hamano diff --git a/Makefile b/Makefile index 4e7a37a..8a7f29b 100644 --- a/Makefile +++ b/Makefile @@ -116,8 +116,6 @@ PIC_FLAG = -fPIC LDFLAGS = ALL_CFLAGS = $(CFLAGS) ALL_LDFLAGS = $(LDFLAGS) -PERL_CFLAGS = -PERL_LDFLAGS = STRIP ?= strip prefix = $(HOME) @@ -154,9 +152,10 @@ SPARSE_FLAGS = -D__BIG_ENDIAN__ -D__powerpc__ ### --- END CONFIGURATION SECTION --- # Those must not be GNU-specific; they are shared with perl/ which may -# be built by a different compiler. -BASIC_CFLAGS = $(PERL_CFLAGS) -BASIC_LDFLAGS = $(PERL_LDFLAGS) +# be built by a different compiler. (Note that this is an artifact now +# but it still might be nice to keep that distinction.) +BASIC_CFLAGS = +BASIC_LDFLAGS = SCRIPT_SH = \ git-bisect.sh git-branch.sh git-checkout.sh \ @@ -753,15 +752,9 @@ $(XDIFF_LIB): $(XDIFF_OBJS) rm -f $@ && $(AR) rcs $@ $(XDIFF_OBJS) -PERL_DEFINE = $(BASIC_CFLAGS) -DGIT_VERSION='"$(GIT_VERSION)"' -PERL_DEFINE_SQ = $(subst ','\'',$(PERL_DEFINE)) -PERL_LIBS = $(BASIC_LDFLAGS) $(EXTLIBS) -PERL_LIBS_SQ = $(subst ','\'',$(PERL_LIBS)) perl/Makefile: perl/Git.pm perl/Makefile.PL GIT-CFLAGS (cd perl && $(PERL_PATH) Makefile.PL \ - PREFIX='$(prefix_SQ)' \ - DEFINE='$(PERL_DEFINE_SQ)' \ - LIBS='$(PERL_LIBS_SQ)') + PREFIX='$(prefix_SQ)') doc: $(MAKE) -C Documentation all diff --git a/perl/.gitignore b/perl/.gitignore index 6d778f3..e990cae 100644 --- a/perl/.gitignore +++ b/perl/.gitignore @@ -1,7 +1,4 @@ -Git.bs -Git.c Makefile blib blibdirs pm_to_blib -ppport.h diff --git a/perl/Git.pm b/perl/Git.pm index 9ce9fcd..2b26b65b 100644 --- a/perl/Git.pm +++ b/perl/Git.pm @@ -93,9 +93,6 @@ use Carp qw(carp croak); # but croak is bad - throw instead use Error qw(:try); use Cwd qw(abs_path); -require XSLoader; -XSLoader::load('Git', $VERSION); - } @@ -413,12 +410,13 @@ sub command_noisy { Return the Git version in use. -Implementation of this function is very fast; no external command calls -are involved. - =cut -# Implemented in Git.xs. +sub version { + my $verstr = command_oneline('--version'); + $verstr =~ s/^git version //; + $verstr; +} =item exec_path () @@ -426,12 +424,9 @@ are involved. Return path to the Git sub-command executables (the same as C). Useful mostly only internally. -Implementation of this function is very fast; no external command calls -are involved. - =cut -# Implemented in Git.xs. +sub exec_path { command_oneline('--exec-path') } =item repo_path () @@ -572,41 +567,21 @@ sub ident_person { =item hash_object ( TYPE, FILENAME ) -=item hash_object ( TYPE, FILEHANDLE ) - Compute the SHA1 object id of the given C (or data waiting in C) considering it is of the C object type (C, C, C). -In case of C passed instead of file name, all the data -available are read and hashed, and the filehandle is automatically -closed. The file handle should be freshly opened - if you have already -read anything from the file handle, the results are undefined (since -this function works directly with the file descriptor and internal -PerlIO buffering might have messed things up). - The method can be called without any instance or on a specified Git repository, it makes zero difference. The function returns the SHA1 hash. -Implementation of this function is very fast; no external command calls -are involved. - =cut +# TODO: Support for passing FILEHANDLE instead of FILENAME sub hash_object { my ($self, $type, $file) = _maybe_self(@_); - - # hash_object_* implemented in Git.xs. - - if (ref($file) eq 'GLOB') { - my $hash = hash_object_pipe($type, fileno($file)); - close $file; - return $hash; - } else { - hash_object_file($type, $file); - } + command_oneline('hash-object', '-t', $type, $file); } @@ -802,7 +777,7 @@ sub _cmd_exec { # Execute the given Git command ($_[0]) with arguments ($_[1..]) # by searching for it at proper places. -# _execv_git_cmd(), implemented in Git.xs. +sub _execv_git_cmd { exec('git', @_); } # Close pipe to a subprocess. sub _cmd_close { @@ -821,39 +796,6 @@ sub _cmd_close { } -# Trickery for .xs routines: In order to avoid having some horrid -# C code trying to do stuff with undefs and hashes, we gate all -# xs calls through the following and in case we are being ran upon -# an instance call a C part of the gate which will set up the -# environment properly. -sub _call_gate { - my $xsfunc = shift; - my ($self, @args) = _maybe_self(@_); - - if (defined $self) { - # XXX: We ignore the WorkingCopy! To properly support - # that will require heavy changes in libgit. - - # XXX: And we ignore everything else as well. libgit - # at least needs to be extended to let us specify - # the $GIT_DIR instead of looking it up in environment. - #xs_call_gate($self->{opts}->{Repository}); - } - - # Having to call throw from the C code is a sure path to insanity. - local $SIG{__DIE__} = sub { throw Error::Simple("@_"); }; - &$xsfunc(@args); -} - -sub AUTOLOAD { - my $xsname; - our $AUTOLOAD; - ($xsname = $AUTOLOAD) =~ s/.*:://; - throw Error::Simple("&Git::$xsname not defined") if $xsname =~ /^xs_/; - $xsname = 'xs_'.$xsname; - _call_gate(\&$xsname, @_); -} - sub DESTROY { } diff --git a/perl/Git.xs b/perl/Git.xs deleted file mode 100644 index 2bbec43..0000000 --- a/perl/Git.xs +++ /dev/null @@ -1,134 +0,0 @@ -/* By carefully stacking #includes here (even if WE don't really need them) - * we strive to make the thing actually compile. Git header files aren't very - * nice. Perl headers are one of the signs of the coming apocalypse. */ -#include -/* Ok, it hasn't been so bad so far. */ - -/* libgit interface */ -#include "../cache.h" -#include "../exec_cmd.h" - -/* XS and Perl interface */ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - - -static char * -report_xs(const char *prefix, const char *err, va_list params) -{ - static char buf[4096]; - strcpy(buf, prefix); - vsnprintf(buf + strlen(prefix), 4096 - strlen(prefix), err, params); - return buf; -} - -static void NORETURN -die_xs(const char *err, va_list params) -{ - char *str; - str = report_xs("fatal: ", err, params); - croak(str); -} - -static void -error_xs(const char *err, va_list params) -{ - char *str; - str = report_xs("error: ", err, params); - warn(str); -} - - -MODULE = Git PACKAGE = Git - -PROTOTYPES: DISABLE - - -BOOT: -{ - set_error_routine(error_xs); - set_die_routine(die_xs); -} - - -# /* TODO: xs_call_gate(). See Git.pm. */ - - -char * -xs_version() -CODE: -{ - RETVAL = GIT_VERSION; -} -OUTPUT: - RETVAL - - -char * -xs_exec_path() -CODE: -{ - RETVAL = (char *)git_exec_path(); -} -OUTPUT: - RETVAL - - -void -xs__execv_git_cmd(...) -CODE: -{ - const char **argv; - int i; - - argv = malloc(sizeof(const char *) * (items + 1)); - if (!argv) - croak("malloc failed"); - for (i = 0; i < items; i++) - argv[i] = strdup(SvPV_nolen(ST(i))); - argv[i] = NULL; - - execv_git_cmd(argv); - - for (i = 0; i < items; i++) - if (argv[i]) - free((char *) argv[i]); - free((char **) argv); -} - -char * -xs_hash_object_pipe(type, fd) - char *type; - int fd; -CODE: -{ - unsigned char sha1[20]; - - if (index_pipe(sha1, fd, type, 0)) - croak("Unable to hash given filehandle"); - RETVAL = sha1_to_hex(sha1); -} -OUTPUT: - RETVAL - -char * -xs_hash_object_file(type, path) - char *type; - char *path; -CODE: -{ - unsigned char sha1[20]; - int fd = open(path, O_RDONLY); - struct stat st; - - if (fd < 0 || - fstat(fd, &st) < 0 || - index_fd(sha1, fd, &st, 0, type)) - croak("Unable to hash %s", path); - close(fd); - - RETVAL = sha1_to_hex(sha1); -} -OUTPUT: - RETVAL diff --git a/perl/Makefile.PL b/perl/Makefile.PL index ef9d82d..de73235 100644 --- a/perl/Makefile.PL +++ b/perl/Makefile.PL @@ -3,12 +3,7 @@ use ExtUtils::MakeMaker; sub MY::postamble { return <<'MAKE_FRAG'; instlibdir: - @echo '$(INSTALLSITEARCH)' - -check: - perl -MDevel::PPPort -le 'Devel::PPPort::WriteFile(".ppport.h")' && \ - perl .ppport.h --compat-version=5.6.0 Git.xs && \ - rm .ppport.h + @echo '$(INSTALLSITELIB)' MAKE_FRAG } @@ -29,7 +24,5 @@ WriteMakefile( NAME => 'Git', VERSION_FROM => 'Git.pm', PM => \%pm, - MYEXTLIB => '../libgit.a', - INC => '-I. -I..', %extra ); -- cgit v0.10.2-6-g49f6 From f7661ce0b8ee068e53d57249625199dda2829e30 Mon Sep 17 00:00:00 2001 From: Junio C Hamano Date: Fri, 29 Sep 2006 00:34:51 -0700 Subject: Remove -fPIC which was only needed for Git.xs The distinction between BASIC_ vs ALL_ is still kept, since it is not Git.xs specific -- we could face the same issue when we do other language bindings (e.g. Python). Signed-off-by: Junio C Hamano diff --git a/INSTALL b/INSTALL index 0d432d7..fce6bc3 100644 --- a/INSTALL +++ b/INSTALL @@ -48,7 +48,7 @@ Issues of note: GIT_EXEC_PATH=`pwd` PATH=`pwd`:$PATH - GITPERLLIB=`pwd`/perl/blib/lib:`pwd`/perl/blib/arch/auto/Git + GITPERLLIB=`pwd`/perl/blib/lib export GIT_EXEC_PATH PATH GITPERLLIB - Git is reasonably self-sufficient, but does depend on a few external diff --git a/Makefile b/Makefile index 8a7f29b..1875965 100644 --- a/Makefile +++ b/Makefile @@ -60,9 +60,6 @@ all: # on non-x86 architectures (e.g. PowerPC), while the OpenSSL version (default # choice) has very fast version optimized for i586. # -# Define USE_PIC if you need the main git objects to be built with -fPIC -# in order to build and link perl/Git.so. x86-64 seems to need this. -# # Define NEEDS_SSL_WITH_CRYPTO if you need -lcrypto with -lssl (Darwin). # # Define NEEDS_LIBICONV if linking with libc is not enough (Darwin). @@ -112,7 +109,6 @@ uname_P := $(shell sh -c 'uname -p 2>/dev/null || echo not') # CFLAGS and LDFLAGS are for the users to override from the command line. CFLAGS = -g -O2 -Wall -PIC_FLAG = -fPIC LDFLAGS = ALL_CFLAGS = $(CFLAGS) ALL_LDFLAGS = $(LDFLAGS) @@ -402,12 +398,6 @@ endif ifneq (,$(findstring arm,$(uname_M))) ARM_SHA1 = YesPlease endif -ifeq ($(uname_M),sun4u) - USE_PIC = YesPlease -endif -ifeq ($(uname_M),x86_64) - USE_PIC = YesPlease -endif -include config.mak.autogen -include config.mak @@ -546,9 +536,6 @@ else endif endif endif -ifdef USE_PIC - ALL_CFLAGS += $(PIC_FLAG) -endif ifdef NO_ACCURATE_DIFF BASIC_CFLAGS += -DNO_ACCURATE_DIFF endif diff --git a/config.mak.in b/config.mak.in index addda4f..fecae80 100644 --- a/config.mak.in +++ b/config.mak.in @@ -3,7 +3,6 @@ CC = @CC@ CFLAGS = @CFLAGS@ -PIC_FLAG = @PIC_FLAG@ AR = @AR@ TAR = @TAR@ #INSTALL = @INSTALL@ # needs install-sh or install.sh in sources diff --git a/configure.ac b/configure.ac index 0f93f6f..8192826 100644 --- a/configure.ac +++ b/configure.ac @@ -96,13 +96,6 @@ AC_SUBST(PYTHON_PATH) AC_MSG_NOTICE([CHECKS for programs]) # AC_PROG_CC([cc gcc]) -if test -n "$GCC"; then - PIC_FLAG="-fPIC" -else - AC_CHECK_DECL(__SUNPRO_C, [CFLAGS="$CFLAGS -xO3"; PIC_FLAG="-KPIC"]) -fi -AC_SUBST(PIC_FLAG) - #AC_PROG_INSTALL # needs install-sh or install.sh in sources AC_CHECK_TOOL(AR, ar, :) AC_CHECK_PROGS(TAR, [gtar tar]) -- cgit v0.10.2-6-g49f6