Merge branch 'jc/gitpm'
* jc/gitpm: (52 commits) Remove -fPIC which was only needed for Git.xs Git.pm: Kill Git.xs for now Revert "Make it possible to set up libgit directly (instead of from the environment)" Revert "Git.pm: Introduce fast get_object() method" Revert "Convert git-annotate to use Git.pm" Fix compilation with Sun CC pass DESTDIR to the generated perl/Makefile Eliminate Scalar::Util usage from private-Error.pm Convert git-annotate to use Git.pm Git.pm: Introduce fast get_object() method Make it possible to set up libgit directly (instead of from the environment) Work around sed and make interactions on the backslash at the end of line. Git.pm: Introduce ident() and ident_person() methods Convert git-send-email to use Git.pm Git.pm: Add config() method Use $GITPERLLIB instead of $RUNNING_GIT_TESTS and centralize @INC munging INSTALL: a tip for running after building but without installing. Perly Git: make sure we do test the freshly built one. Git.pm: Don't #define around die Git.xs: older perl do not know const char * ...
This commit is contained in:
Junio C Hamano
commit
69de8cc852
@ -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
|
||||
|
||||
13
INSTALL
13
INSTALL
@ -38,6 +38,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
|
||||
GITPERLLIB=`pwd`/perl/blib/lib
|
||||
export GIT_EXEC_PATH PATH GITPERLLIB
|
||||
|
||||
- Git is reasonably self-sufficient, but does depend on a few external
|
||||
programs and libraries:
|
||||
|
||||
|
||||
116
Makefile
116
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.
|
||||
#
|
||||
@ -60,6 +55,11 @@ 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 NEEDS_SSL_WITH_CRYPTO if you need -lcrypto with -lssl (Darwin).
|
||||
#
|
||||
# Define NEEDS_LIBICONV if linking with libc is not enough (Darwin).
|
||||
@ -84,13 +84,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.
|
||||
|
||||
@ -149,6 +149,12 @@ 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. (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 \
|
||||
git-cherry.sh git-clean.sh git-clone.sh git-commit.sh \
|
||||
@ -302,7 +308,7 @@ BUILTIN_OBJS = \
|
||||
builtin-write-tree.o
|
||||
|
||||
GITLIBS = $(LIB_FILE) $(XDIFF_LIB)
|
||||
LIBS = $(GITLIBS) -lz
|
||||
EXTLIBS = -lz
|
||||
|
||||
#
|
||||
# Platform specific tweaks
|
||||
@ -324,14 +330,14 @@ ifeq ($(uname_S),Darwin)
|
||||
NO_STRLCPY = YesPlease
|
||||
ifndef NO_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
|
||||
endif
|
||||
ifndef NO_DARWIN_PORTS
|
||||
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
|
||||
endif
|
||||
@ -353,7 +359,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
|
||||
@ -371,21 +377,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
|
||||
@ -399,9 +406,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
|
||||
@ -423,7 +430,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
|
||||
@ -444,13 +451,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
|
||||
@ -462,32 +469,32 @@ 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 =
|
||||
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
|
||||
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_C99_FORMAT
|
||||
ALL_CFLAGS += -DNO_C99_FORMAT
|
||||
endif
|
||||
ifdef NO_SYMLINK_HEAD
|
||||
ALL_CFLAGS += -DNO_SYMLINK_HEAD
|
||||
BASIC_CFLAGS += -DNO_SYMLINK_HEAD
|
||||
endif
|
||||
ifdef NO_STRCASESTR
|
||||
COMPAT_CFLAGS += -DNO_STRCASESTR
|
||||
@ -510,13 +517,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
|
||||
@ -527,7 +534,7 @@ ifdef NO_INET_PTON
|
||||
endif
|
||||
|
||||
ifdef NO_ICONV
|
||||
ALL_CFLAGS += -DNO_ICONV
|
||||
BASIC_CFLAGS += -DNO_ICONV
|
||||
endif
|
||||
|
||||
ifdef PPC_SHA1
|
||||
@ -543,12 +550,12 @@ ifdef MOZILLA_SHA1
|
||||
LIB_OBJS += mozilla-sha1/sha1.o
|
||||
else
|
||||
SHA1_HEADER = <openssl/sha.h>
|
||||
LIBS += $(LIB_4_CRYPTO)
|
||||
EXTLIBS += $(LIB_4_CRYPTO)
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
ifdef NO_ACCURATE_DIFF
|
||||
ALL_CFLAGS += -DNO_ACCURATE_DIFF
|
||||
BASIC_CFLAGS += -DNO_ACCURATE_DIFF
|
||||
endif
|
||||
|
||||
# Shell quote (do not use $(call) to accommodate ancient setups);
|
||||
@ -566,15 +573,24 @@ PERL_PATH_SQ = $(subst ','\'',$(PERL_PATH))
|
||||
PYTHON_PATH_SQ = $(subst ','\'',$(PYTHON_PATH))
|
||||
GIT_PYTHON_DIR_SQ = $(subst ','\'',$(GIT_PYTHON_DIR))
|
||||
|
||||
ALL_CFLAGS += -DSHA1_HEADER='$(SHA1_HEADER_SQ)' $(COMPAT_CFLAGS)
|
||||
LIBS = $(GITLIBS) $(EXTLIBS)
|
||||
|
||||
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
|
||||
|
||||
|
||||
### Build rules
|
||||
|
||||
all: $(ALL_PROGRAMS) $(BUILT_INS) git$X gitk gitweb/gitweb.cgi \
|
||||
git-merge-recur$X
|
||||
|
||||
all:
|
||||
all: perl/Makefile
|
||||
$(MAKE) -C perl
|
||||
$(MAKE) -C templates
|
||||
|
||||
strip: $(PROGRAMS) git$X
|
||||
@ -608,9 +624,18 @@ $(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)|' \
|
||||
INSTLIBDIR=`$(MAKE) -C perl -s --no-print-directory 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 >$@+
|
||||
chmod +x $@+
|
||||
@ -740,6 +765,10 @@ $(XDIFF_LIB): $(XDIFF_OBJS)
|
||||
rm -f $@ && $(AR) rcs $@ $(XDIFF_OBJS)
|
||||
|
||||
|
||||
perl/Makefile: perl/Git.pm perl/Makefile.PL GIT-CFLAGS
|
||||
(cd perl && $(PERL_PATH) Makefile.PL \
|
||||
PREFIX='$(prefix_SQ)')
|
||||
|
||||
doc:
|
||||
$(MAKE) -C Documentation all
|
||||
|
||||
@ -802,6 +831,7 @@ install: all
|
||||
$(INSTALL) $(ALL_PROGRAMS) '$(DESTDIR_SQ)$(gitexecdir_SQ)'
|
||||
$(INSTALL) git$X gitk '$(DESTDIR_SQ)$(bindir_SQ)'
|
||||
$(MAKE) -C templates DESTDIR='$(DESTDIR_SQ)' 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)'; \
|
||||
@ -872,7 +902,9 @@ clean:
|
||||
rm -f $(htmldocs).tar.gz $(manpages).tar.gz
|
||||
rm -f gitweb/gitweb.cgi
|
||||
$(MAKE) -C Documentation/ clean
|
||||
$(MAKE) -C templates 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
|
||||
|
||||
|
||||
@ -119,7 +119,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:
|
||||
free(repo_config);
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
# @configure_input@
|
||||
|
||||
CC = @CC@
|
||||
CFLAGS = @CFLAGS@
|
||||
AR = @AR@
|
||||
TAR = @TAR@
|
||||
#INSTALL = @INSTALL@ # needs install-sh or install.sh in sources
|
||||
|
||||
@ -94,7 +94,7 @@ AC_SUBST(PYTHON_PATH)
|
||||
## Checks for programs.
|
||||
AC_MSG_NOTICE([CHECKS for programs])
|
||||
#
|
||||
AC_PROG_CC
|
||||
AC_PROG_CC([cc gcc])
|
||||
#AC_PROG_INSTALL # needs install-sh or install.sh in sources
|
||||
AC_CHECK_TOOL(AR, ar, :)
|
||||
AC_CHECK_PROGS(TAR, [gtar tar])
|
||||
|
||||
@ -21,6 +21,7 @@ use warnings;
|
||||
use Term::ReadLine;
|
||||
use Getopt::Long;
|
||||
use Data::Dumper;
|
||||
use Git;
|
||||
|
||||
package FakeTerm;
|
||||
sub new {
|
||||
@ -92,6 +93,7 @@ my $smtp_server;
|
||||
# Example reply to:
|
||||
#$initial_reply_to = ''; #<20050203173208.GA23964@foobar.com>';
|
||||
|
||||
my $repo = Git->repository();
|
||||
my $term = eval {
|
||||
new Term::ReadLine 'git-send-email';
|
||||
};
|
||||
@ -132,33 +134,12 @@ 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 @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;
|
||||
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>) {
|
||||
@ -183,7 +164,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);
|
||||
@ -425,10 +406,7 @@ sub send_message
|
||||
my $date = format_2822_time($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
|
||||
|
||||
23
git.spec.in
23
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,12 +90,18 @@ 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
|
||||
rm -rf $RPM_BUILD_ROOT%{_mandir}
|
||||
%endif
|
||||
|
||||
%clean
|
||||
@ -129,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/
|
||||
|
||||
4
perl/.gitignore
vendored
Normal file
4
perl/.gitignore
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
Makefile
|
||||
blib
|
||||
blibdirs
|
||||
pm_to_blib
|
||||
837
perl/Git.pm
Normal file
837
perl/Git.pm
Normal file
@ -0,0 +1,837 @@
|
||||
=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_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, $c) = $repo->command_output_pipe('rev-list', '--since=last monday', '--all');
|
||||
my $lastrev = <$fh>; chomp $lastrev;
|
||||
$repo->command_close_pipe($fh, $c);
|
||||
|
||||
my $lastrev = $repo->command_oneline( [ 'rev-list', '--all' ],
|
||||
STDERR => 0 );
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
require Exporter;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT = qw(git_cmd_try);
|
||||
|
||||
# Methods which can be called as standalone functions as well:
|
||||
@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);
|
||||
|
||||
|
||||
=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.
|
||||
|
||||
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<wc_chdir()> method. (Note that
|
||||
the repository object is self-contained and will not change working directory
|
||||
of your process.)
|
||||
|
||||
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();
|
||||
|
||||
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); # but croak is bad - throw instead
|
||||
use Error qw(:try);
|
||||
use Cwd qw(abs_path);
|
||||
|
||||
}
|
||||
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item repository ( OPTIONS )
|
||||
|
||||
=item repository ( DIRECTORY )
|
||||
|
||||
=item repository ()
|
||||
|
||||
Construct a new repository object.
|
||||
C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
|
||||
Possible options are:
|
||||
|
||||
B<Repository> - Path to the Git repository.
|
||||
|
||||
B<WorkingCopy> - Path to the associated working copy; not strictly required
|
||||
as many commands will happily crunch on a bare repository.
|
||||
|
||||
B<WorkingSubdir> - Subdirectory in the working copy to work inside.
|
||||
Just left undefined if you do not want to limit the scope of operations.
|
||||
|
||||
B<Directory> - 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<WorkingCopy> is set to the directory containing
|
||||
it and C<Repository> to the C<.git> directory itself. If no C<.git>
|
||||
directory was found, the C<Directory> is assumed to be a bare repository,
|
||||
C<Repository> is set to point at it and C<WorkingCopy> is left undefined.
|
||||
If the C<$GIT_DIR> environment variable is set, things behave as expected
|
||||
as well.
|
||||
|
||||
You should not use both C<Directory> and either of C<Repository> and
|
||||
C<WorkingCopy> - 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<Directory> option
|
||||
field.
|
||||
|
||||
Calling the constructor with no options whatsoever is equivalent to
|
||||
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
|
||||
|
||||
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 throw Error::Simple("bad usage");
|
||||
%opts = ( Directory => $args[0] );
|
||||
} 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 ($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');
|
||||
$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)) = '';
|
||||
}
|
||||
$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 };
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item command ( COMMAND [, ARGUMENTS... ] )
|
||||
|
||||
=item command ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
|
||||
|
||||
Execute the given Git C<COMMAND> (specify it without the 'git-'
|
||||
prefix), optionally with the specified extra C<ARGUMENTS>.
|
||||
|
||||
The second more elaborate form can be used if you want to further adjust
|
||||
the command execution. Currently, only one option is supported:
|
||||
|
||||
B<STDERR> - How to deal with the command's error output. By default (C<undef>)
|
||||
it is delivered to the caller's C<STDERR>. 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<command()>, 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).
|
||||
|
||||
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, $ctx) = command_output_pipe(@_);
|
||||
|
||||
if (not defined wantarray) {
|
||||
# Nothing to pepper the possible exception with.
|
||||
_cmd_close($fh, $ctx);
|
||||
|
||||
} elsif (not wantarray) {
|
||||
local $/;
|
||||
my $text = <$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>;
|
||||
chomp @lines;
|
||||
try {
|
||||
_cmd_close($fh, $ctx);
|
||||
} catch Git::Error::Command with {
|
||||
my $E = shift;
|
||||
$E->{'-outputref'} = \@lines;
|
||||
throw $E;
|
||||
};
|
||||
return @lines;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=item command_oneline ( COMMAND [, ARGUMENTS... ] )
|
||||
|
||||
=item command_oneline ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
|
||||
|
||||
Execute the given C<COMMAND> 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, $ctx) = command_output_pipe(@_);
|
||||
|
||||
my $line = <$fh>;
|
||||
defined $line and 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;
|
||||
}
|
||||
|
||||
|
||||
=item command_output_pipe ( COMMAND [, ARGUMENTS... ] )
|
||||
|
||||
=item command_output_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
|
||||
|
||||
Execute the given C<COMMAND> 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<command_close_pipe()> for details.
|
||||
|
||||
=cut
|
||||
|
||||
sub command_output_pipe {
|
||||
_command_common_pipe('-|', @_);
|
||||
}
|
||||
|
||||
|
||||
=item command_input_pipe ( COMMAND [, ARGUMENTS... ] )
|
||||
|
||||
=item command_input_pipe ( [ COMMAND, ARGUMENTS... ], { Opt => Val ... } )
|
||||
|
||||
Execute the given C<COMMAND> 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<command_close_pipe()> for details.
|
||||
|
||||
=cut
|
||||
|
||||
sub command_input_pipe {
|
||||
_command_common_pipe('|-', @_);
|
||||
}
|
||||
|
||||
|
||||
=item command_close_pipe ( PIPE [, CTX ] )
|
||||
|
||||
Close the C<PIPE> as returned from C<command_*_pipe()>, checking
|
||||
whether the command finished successfuly. The optional C<CTX> argument
|
||||
is required if you want to see the command name in the error message,
|
||||
and it is the second value returned by C<command_*_pipe()> when
|
||||
called in array context. The call idiom is:
|
||||
|
||||
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<CTX>;
|
||||
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 ||= '<unknown>';
|
||||
_cmd_close($fh, $ctx);
|
||||
}
|
||||
|
||||
|
||||
=item command_noisy ( COMMAND [, ARGUMENTS... ] )
|
||||
|
||||
Execute the given C<COMMAND> 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(@_);
|
||||
_check_valid_cmd($cmd);
|
||||
|
||||
my $pid = fork;
|
||||
if (not defined $pid) {
|
||||
throw Error::Simple("fork failed: $!");
|
||||
} elsif ($pid == 0) {
|
||||
_cmd_exec($self, $cmd, @args);
|
||||
}
|
||||
if (waitpid($pid, 0) > 0 and $?>>8 != 0) {
|
||||
throw Git::Error::Command(join(' ', $cmd, @args), $? >> 8);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
=item version ()
|
||||
|
||||
Return the Git version in use.
|
||||
|
||||
=cut
|
||||
|
||||
sub version {
|
||||
my $verstr = command_oneline('--version');
|
||||
$verstr =~ s/^git version //;
|
||||
$verstr;
|
||||
}
|
||||
|
||||
|
||||
=item exec_path ()
|
||||
|
||||
Return path to the Git sub-command executables (the same as
|
||||
C<git --exec-path>). Useful mostly only internally.
|
||||
|
||||
=cut
|
||||
|
||||
sub exec_path { command_oneline('--exec-path') }
|
||||
|
||||
|
||||
=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<SUBDIR> 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 config ( VARIABLE )
|
||||
|
||||
Retrieve the configuration C<VARIABLE> in the same manner as C<repo-config>
|
||||
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 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<var GIT_type_IDENT> (thus
|
||||
C<TYPE> can be either I<author> or I<committer>; case is insignificant).
|
||||
|
||||
The C<ident> method retrieves the ident information from C<git-var>
|
||||
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<ident_person> returns the person part of the ident - name and email;
|
||||
it can take the same arguments as C<ident> or the array returned by C<ident>.
|
||||
|
||||
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 )
|
||||
|
||||
Compute the SHA1 object id of the given C<FILENAME> (or data waiting in
|
||||
C<FILEHANDLE>) considering it is of the C<TYPE> object type (C<blob>,
|
||||
C<commit>, C<tree>).
|
||||
|
||||
The method can be called without any instance or on a specified Git repository,
|
||||
it makes zero difference.
|
||||
|
||||
The function returns the SHA1 hash.
|
||||
|
||||
=cut
|
||||
|
||||
# TODO: Support for passing FILEHANDLE instead of FILENAME
|
||||
sub hash_object {
|
||||
my ($self, $type, $file) = _maybe_self(@_);
|
||||
command_oneline('hash-object', '-t', $type, $file);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 ERROR HANDLING
|
||||
|
||||
All functions are supposed to throw Perl exceptions in case of errors.
|
||||
See the L<Error> module on how to catch those. Most exceptions are mere
|
||||
L<Error::Simple> instances.
|
||||
|
||||
However, the C<command()>, C<command_oneline()> and C<command_noisy()>
|
||||
functions suite can throw C<Git::Error::Command> 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<stringify> and C<value> (command's exit code) methods and
|
||||
in addition also a C<cmd_output> method that returns either an array or a
|
||||
string with the captured command output (depending on the original function
|
||||
call context; C<command_noisy()> returns C<undef>) and $<cmdline> which
|
||||
returns the command and its arguments (but without proper quoting).
|
||||
|
||||
Note that the C<command_*_pipe()> 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<close> the pipe; if you want to have that automated,
|
||||
use C<command_close_pipe()>, 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<Git::Error::Command>
|
||||
exceptions thrown by C<CODE> and make your program die with C<ERRMSG>
|
||||
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<CODE>'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
|
||||
|
||||
Copyright 2006 by Petr Baudis E<lt>pasky@suse.czE<gt>.
|
||||
|
||||
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, @_);
|
||||
}
|
||||
|
||||
# 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, @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 $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);
|
||||
}
|
||||
}
|
||||
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 {
|
||||
my ($self, @args) = @_;
|
||||
if ($self) {
|
||||
$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: $!";
|
||||
}
|
||||
|
||||
# Execute the given Git command ($_[0]) with arguments ($_[1..])
|
||||
# by searching for it at proper places.
|
||||
sub _execv_git_cmd { exec('git', @_); }
|
||||
|
||||
# Close pipe to a subprocess.
|
||||
sub _cmd_close {
|
||||
my ($fh, $ctx) = @_;
|
||||
if (not close $fh) {
|
||||
if ($!) {
|
||||
# It's just close, no point in fatalities
|
||||
carp "error closing pipe: $!";
|
||||
} elsif ($? >> 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.
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
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
|
||||
28
perl/Makefile.PL
Normal file
28
perl/Makefile.PL
Normal file
@ -0,0 +1,28 @@
|
||||
use ExtUtils::MakeMaker;
|
||||
|
||||
sub MY::postamble {
|
||||
return <<'MAKE_FRAG';
|
||||
instlibdir:
|
||||
@echo '$(INSTALLSITELIB)'
|
||||
|
||||
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{'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,
|
||||
%extra
|
||||
);
|
||||
827
perl/private-Error.pm
Normal file
827
perl/private-Error.pm
Normal file
@ -0,0 +1,827 @@
|
||||
# Error.pm
|
||||
#
|
||||
# Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. 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
|
||||
# <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>.
|
||||
#
|
||||
# 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
|
||||
|
||||
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 <jglick@sig.bsh.com> and
|
||||
# Peter Seibel <peter@weblogic.com>
|
||||
|
||||
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 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;
|
||||
|
||||
$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(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 (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<Error> package provides two interfaces. Firstly C<Error> provides
|
||||
a procedural interface to exception handling. Secondly C<Error> 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<Error> should not be thrown directly, but the
|
||||
user should throw errors from a sub-class of C<Error>.
|
||||
|
||||
=head1 PROCEDURAL INTERFACE
|
||||
|
||||
C<Error> exports subroutines to perform exception handling. These will
|
||||
be exported if the C<:try> tag is used in the C<use> line.
|
||||
|
||||
=over 4
|
||||
|
||||
=item try BLOCK CLAUSES
|
||||
|
||||
C<try> 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<CLAUSES> 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-E<gt>isa(CLASS)>
|
||||
to be caught and handled by evaluating C<BLOCK>.
|
||||
|
||||
C<BLOCK> 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-E<gt>throw>
|
||||
|
||||
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<try> is looking for a handler, if an except clause is found
|
||||
C<BLOCK> 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<BLOCK>
|
||||
|
||||
When evaluated C<BLOCK> 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<BLOCK> either after the code in the try block has
|
||||
successfully completed, or if the try block throws an error then
|
||||
C<BLOCK> 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<Error> 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<Error> 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<Error> package
|
||||
to associate the error with the object.
|
||||
|
||||
The C<Error> 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<Error> object and throw an error, which will be caught
|
||||
by a surrounding C<try> block, if there is one. Otherwise it will cause
|
||||
the program to exit.
|
||||
|
||||
C<throw> may also be called on an existing error to re-throw it.
|
||||
|
||||
=item with ( [ ARGS ] )
|
||||
|
||||
Create a new C<Error> object and returns it. This is defined for
|
||||
syntactic sugar, eg
|
||||
|
||||
die with Some::Error ( ... );
|
||||
|
||||
=item record ( [ ARGS ] )
|
||||
|
||||
Create a new C<Error> 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<PACKAGE>
|
||||
|
||||
=item flush ( [ PACKAGE ] )
|
||||
|
||||
Flush the last error created, or the last error associated with
|
||||
C<PACKAGE>.It is necessary to clear the error stack before exiting the
|
||||
package or uncaught errors generated using C<record> 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<stacktrace> returns a string created by calling
|
||||
C<Carp::longmess>. If the variable was zero the C<stacktrace> 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<text> 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<at file line 1> 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 <gbarr@pobox.com>
|
||||
|
||||
The code that inspired me to write this was originally written by
|
||||
Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
|
||||
<jglick@sig.bsh.com>.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Shlomi Fish <shlomif@iglu.org.il>
|
||||
|
||||
=head1 PAST MAINTAINERS
|
||||
|
||||
Arun Kumar U <u_arunkumar@yahoo.com>
|
||||
|
||||
=cut
|
||||
@ -218,6 +218,8 @@ PYTHON=`sed -e '1{
|
||||
PYTHONPATH=$(pwd)/../compat
|
||||
export PYTHONPATH
|
||||
}
|
||||
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?"
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user