Browse Source
* master: (99 commits) lock_ref_sha1_basic does not remove empty directories on BSD git-push: .git/remotes/ file does not require SP after colon git-mv: invalidate the removed path properly in cache-tree Makefile: install and clean merge-recur, still. GIT 1.4.3-rc1 gitweb: tree view: hash_base and hash are now context sensitive git-diff -B output fix. fetch: Reset remote refs list each time fetch_main is called Remove -fPIC which was only needed for Git.xs Fix approxidate() to understand 12:34 AM/PM are 00:34 and 12:34 git-diff -B output fix. Make cvsexportcommit remove files. diff --stat: ensure at least one '-' for deletions, and one '+' for additions diff --stat=width[,name-width]: allow custom diffstat output width. gitweb: History: blob and tree are first, then commitdiff, etc gitweb: Remove redundant "commit" from history http/ftp: optionally ask curl to not use EPSV command gitweb: Don't use quotemeta on internally generated strings gitweb: Add snapshot to shortlog gitweb: Factor out gitweb_have_snapshot() ...maint
Junio C Hamano
18 years ago
37 changed files with 3028 additions and 322 deletions
@ -0,0 +1,220 @@
@@ -0,0 +1,220 @@
|
||||
/* |
||||
* Copyright (C) 1996-2001 Internet Software Consortium. |
||||
* |
||||
* Permission to use, copy, modify, and distribute this software for any |
||||
* purpose with or without fee is hereby granted, provided that the above |
||||
* copyright notice and this permission notice appear in all copies. |
||||
* |
||||
* THE SOFTWARE IS PROVIDED "AS IS" AND INTERNET SOFTWARE CONSORTIUM |
||||
* DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL |
||||
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL |
||||
* INTERNET SOFTWARE CONSORTIUM BE LIABLE FOR ANY SPECIAL, DIRECT, |
||||
* INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING |
||||
* FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, |
||||
* NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION |
||||
* WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. |
||||
*/ |
||||
|
||||
#include <errno.h> |
||||
#include <sys/types.h> |
||||
#include <sys/socket.h> |
||||
#include <sys/socket.h> |
||||
#include <netinet/in.h> |
||||
#include <arpa/inet.h> |
||||
#include <stdio.h> |
||||
#include <string.h> |
||||
|
||||
#ifndef NS_INT16SZ |
||||
#define NS_INT16SZ 2 |
||||
#endif |
||||
|
||||
#ifndef NS_INADDRSZ |
||||
#define NS_INADDRSZ 4 |
||||
#endif |
||||
|
||||
#ifndef NS_IN6ADDRSZ |
||||
#define NS_IN6ADDRSZ 16 |
||||
#endif |
||||
|
||||
/* |
||||
* WARNING: Don't even consider trying to compile this on a system where |
||||
* sizeof(int) < 4. sizeof(int) > 4 is fine; all the world's not a VAX. |
||||
*/ |
||||
|
||||
static int inet_pton4(const char *src, unsigned char *dst); |
||||
static int inet_pton6(const char *src, unsigned char *dst); |
||||
|
||||
/* int |
||||
* inet_pton4(src, dst) |
||||
* like inet_aton() but without all the hexadecimal and shorthand. |
||||
* return: |
||||
* 1 if `src' is a valid dotted quad, else 0. |
||||
* notice: |
||||
* does not touch `dst' unless it's returning 1. |
||||
* author: |
||||
* Paul Vixie, 1996. |
||||
*/ |
||||
static int |
||||
inet_pton4(const char *src, unsigned char *dst) |
||||
{ |
||||
static const char digits[] = "0123456789"; |
||||
int saw_digit, octets, ch; |
||||
unsigned char tmp[NS_INADDRSZ], *tp; |
||||
|
||||
saw_digit = 0; |
||||
octets = 0; |
||||
*(tp = tmp) = 0; |
||||
while ((ch = *src++) != '\0') { |
||||
const char *pch; |
||||
|
||||
if ((pch = strchr(digits, ch)) != NULL) { |
||||
unsigned int new = *tp * 10 + (pch - digits); |
||||
|
||||
if (new > 255) |
||||
return (0); |
||||
*tp = new; |
||||
if (! saw_digit) { |
||||
if (++octets > 4) |
||||
return (0); |
||||
saw_digit = 1; |
||||
} |
||||
} else if (ch == '.' && saw_digit) { |
||||
if (octets == 4) |
||||
return (0); |
||||
*++tp = 0; |
||||
saw_digit = 0; |
||||
} else |
||||
return (0); |
||||
} |
||||
if (octets < 4) |
||||
return (0); |
||||
memcpy(dst, tmp, NS_INADDRSZ); |
||||
return (1); |
||||
} |
||||
|
||||
/* int |
||||
* inet_pton6(src, dst) |
||||
* convert presentation level address to network order binary form. |
||||
* return: |
||||
* 1 if `src' is a valid [RFC1884 2.2] address, else 0. |
||||
* notice: |
||||
* (1) does not touch `dst' unless it's returning 1. |
||||
* (2) :: in a full address is silently ignored. |
||||
* credit: |
||||
* inspired by Mark Andrews. |
||||
* author: |
||||
* Paul Vixie, 1996. |
||||
*/ |
||||
|
||||
#ifndef NO_IPV6 |
||||
static int |
||||
inet_pton6(const char *src, unsigned char *dst) |
||||
{ |
||||
static const char xdigits_l[] = "0123456789abcdef", |
||||
xdigits_u[] = "0123456789ABCDEF"; |
||||
unsigned char tmp[NS_IN6ADDRSZ], *tp, *endp, *colonp; |
||||
const char *xdigits, *curtok; |
||||
int ch, saw_xdigit; |
||||
unsigned int val; |
||||
|
||||
memset((tp = tmp), '\0', NS_IN6ADDRSZ); |
||||
endp = tp + NS_IN6ADDRSZ; |
||||
colonp = NULL; |
||||
/* Leading :: requires some special handling. */ |
||||
if (*src == ':') |
||||
if (*++src != ':') |
||||
return (0); |
||||
curtok = src; |
||||
saw_xdigit = 0; |
||||
val = 0; |
||||
while ((ch = *src++) != '\0') { |
||||
const char *pch; |
||||
|
||||
if ((pch = strchr((xdigits = xdigits_l), ch)) == NULL) |
||||
pch = strchr((xdigits = xdigits_u), ch); |
||||
if (pch != NULL) { |
||||
val <<= 4; |
||||
val |= (pch - xdigits); |
||||
if (val > 0xffff) |
||||
return (0); |
||||
saw_xdigit = 1; |
||||
continue; |
||||
} |
||||
if (ch == ':') { |
||||
curtok = src; |
||||
if (!saw_xdigit) { |
||||
if (colonp) |
||||
return (0); |
||||
colonp = tp; |
||||
continue; |
||||
} |
||||
if (tp + NS_INT16SZ > endp) |
||||
return (0); |
||||
*tp++ = (unsigned char) (val >> 8) & 0xff; |
||||
*tp++ = (unsigned char) val & 0xff; |
||||
saw_xdigit = 0; |
||||
val = 0; |
||||
continue; |
||||
} |
||||
if (ch == '.' && ((tp + NS_INADDRSZ) <= endp) && |
||||
inet_pton4(curtok, tp) > 0) { |
||||
tp += NS_INADDRSZ; |
||||
saw_xdigit = 0; |
||||
break; /* '\0' was seen by inet_pton4(). */ |
||||
} |
||||
return (0); |
||||
} |
||||
if (saw_xdigit) { |
||||
if (tp + NS_INT16SZ > endp) |
||||
return (0); |
||||
*tp++ = (unsigned char) (val >> 8) & 0xff; |
||||
*tp++ = (unsigned char) val & 0xff; |
||||
} |
||||
if (colonp != NULL) { |
||||
/* |
||||
* Since some memmove()'s erroneously fail to handle |
||||
* overlapping regions, we'll do the shift by hand. |
||||
*/ |
||||
const int n = tp - colonp; |
||||
int i; |
||||
|
||||
for (i = 1; i <= n; i++) { |
||||
endp[- i] = colonp[n - i]; |
||||
colonp[n - i] = 0; |
||||
} |
||||
tp = endp; |
||||
} |
||||
if (tp != endp) |
||||
return (0); |
||||
memcpy(dst, tmp, NS_IN6ADDRSZ); |
||||
return (1); |
||||
} |
||||
#endif |
||||
|
||||
/* int |
||||
* isc_net_pton(af, src, dst) |
||||
* convert from presentation format (which usually means ASCII printable) |
||||
* to network format (which is usually some kind of binary format). |
||||
* return: |
||||
* 1 if the address was valid for the specified address family |
||||
* 0 if the address wasn't valid (`dst' is untouched in this case) |
||||
* -1 if some other error occurred (`dst' is untouched in this case, too) |
||||
* author: |
||||
* Paul Vixie, 1996. |
||||
*/ |
||||
int |
||||
inet_pton(int af, const char *src, void *dst) |
||||
{ |
||||
switch (af) { |
||||
case AF_INET: |
||||
return (inet_pton4(src, dst)); |
||||
#ifndef NO_IPV6 |
||||
case AF_INET6: |
||||
return (inet_pton6(src, dst)); |
||||
#endif |
||||
default: |
||||
errno = EAFNOSUPPORT; |
||||
return (-1); |
||||
} |
||||
/* NOTREACHED */ |
||||
} |
||||
@ -0,0 +1,324 @@
@@ -0,0 +1,324 @@
|
||||
# |
||||
# bash completion support for core Git. |
||||
# |
||||
# Copyright (C) 2006 Shawn Pearce |
||||
# Conceptually based on gitcompletion (http://gitweb.hawaga.org.uk/). |
||||
# |
||||
# The contained completion routines provide support for completing: |
||||
# |
||||
# *) local and remote branch names |
||||
# *) local and remote tag names |
||||
# *) .git/remotes file names |
||||
# *) git 'subcommands' |
||||
# *) tree paths within 'ref:path/to/file' expressions |
||||
# |
||||
# To use these routines: |
||||
# |
||||
# 1) Copy this file to somewhere (e.g. ~/.git-completion.sh). |
||||
# 2) Added the following line to your .bashrc: |
||||
# source ~/.git-completion.sh |
||||
# |
||||
|
||||
__git_refs () |
||||
{ |
||||
local cmd i is_hash=y |
||||
if [ -d "$1" ]; then |
||||
cmd=git-peek-remote |
||||
else |
||||
cmd=git-ls-remote |
||||
fi |
||||
for i in $($cmd "$1" 2>/dev/null); do |
||||
case "$is_hash,$i" in |
||||
y,*) is_hash=n ;; |
||||
n,*^{}) is_hash=y ;; |
||||
n,refs/tags/*) is_hash=y; echo "${i#refs/tags/}" ;; |
||||
n,refs/heads/*) is_hash=y; echo "${i#refs/heads/}" ;; |
||||
n,*) is_hash=y; echo "$i" ;; |
||||
esac |
||||
done |
||||
} |
||||
|
||||
__git_refs2 () |
||||
{ |
||||
local cmd i is_hash=y |
||||
if [ -d "$1" ]; then |
||||
cmd=git-peek-remote |
||||
else |
||||
cmd=git-ls-remote |
||||
fi |
||||
for i in $($cmd "$1" 2>/dev/null); do |
||||
case "$is_hash,$i" in |
||||
y,*) is_hash=n ;; |
||||
n,*^{}) is_hash=y ;; |
||||
n,refs/tags/*) is_hash=y; echo "${i#refs/tags/}:${i#refs/tags/}" ;; |
||||
n,refs/heads/*) is_hash=y; echo "${i#refs/heads/}:${i#refs/heads/}" ;; |
||||
n,*) is_hash=y; echo "$i:$i" ;; |
||||
esac |
||||
done |
||||
} |
||||
|
||||
__git_remotes () |
||||
{ |
||||
local i REVERTGLOB=$(shopt -p nullglob) |
||||
shopt -s nullglob |
||||
for i in .git/remotes/*; do |
||||
echo ${i#.git/remotes/} |
||||
done |
||||
$REVERTGLOB |
||||
} |
||||
|
||||
__git_complete_file () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
case "$cur" in |
||||
?*:*) |
||||
local pfx ls ref="$(echo "$cur" | sed 's,:.*$,,')" |
||||
cur="$(echo "$cur" | sed 's,^.*:,,')" |
||||
case "$cur" in |
||||
?*/*) |
||||
pfx="$(echo "$cur" | sed 's,/[^/]*$,,')" |
||||
cur="$(echo "$cur" | sed 's,^.*/,,')" |
||||
ls="$ref:$pfx" |
||||
pfx="$pfx/" |
||||
;; |
||||
*) |
||||
ls="$ref" |
||||
;; |
||||
esac |
||||
COMPREPLY=($(compgen -P "$pfx" \ |
||||
-W "$(git-ls-tree "$ls" \ |
||||
| sed '/^100... blob /s,^.* ,, |
||||
/^040000 tree /{ |
||||
s,^.* ,, |
||||
s,$,/, |
||||
} |
||||
s/^.* //')" \ |
||||
-- "$cur")) |
||||
;; |
||||
*) |
||||
COMPREPLY=($(compgen -W "$(__git_refs .)" -- "$cur")) |
||||
;; |
||||
esac |
||||
} |
||||
|
||||
_git_branch () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
COMPREPLY=($(compgen -W "-l -f -d -D $(__git_refs .)" -- "$cur")) |
||||
} |
||||
|
||||
_git_cat_file () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
case "${COMP_WORDS[0]},$COMP_CWORD" in |
||||
git-cat-file*,1) |
||||
COMPREPLY=($(compgen -W "-p -t blob tree commit tag" -- "$cur")) |
||||
;; |
||||
git,2) |
||||
COMPREPLY=($(compgen -W "-p -t blob tree commit tag" -- "$cur")) |
||||
;; |
||||
*) |
||||
__git_complete_file |
||||
;; |
||||
esac |
||||
} |
||||
|
||||
_git_checkout () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
COMPREPLY=($(compgen -W "-l -b $(__git_refs .)" -- "$cur")) |
||||
} |
||||
|
||||
_git_diff () |
||||
{ |
||||
__git_complete_file |
||||
} |
||||
|
||||
_git_diff_tree () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
COMPREPLY=($(compgen -W "-r -p -M $(__git_refs .)" -- "$cur")) |
||||
} |
||||
|
||||
_git_fetch () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
|
||||
case "${COMP_WORDS[0]},$COMP_CWORD" in |
||||
git-fetch*,1) |
||||
COMPREPLY=($(compgen -W "$(__git_remotes)" -- "$cur")) |
||||
;; |
||||
git,2) |
||||
COMPREPLY=($(compgen -W "$(__git_remotes)" -- "$cur")) |
||||
;; |
||||
*) |
||||
case "$cur" in |
||||
*:*) |
||||
cur=$(echo "$cur" | sed 's/^.*://') |
||||
COMPREPLY=($(compgen -W "$(__git_refs .)" -- "$cur")) |
||||
;; |
||||
*) |
||||
local remote |
||||
case "${COMP_WORDS[0]}" in |
||||
git-fetch) remote="${COMP_WORDS[1]}" ;; |
||||
git) remote="${COMP_WORDS[2]}" ;; |
||||
esac |
||||
COMPREPLY=($(compgen -W "$(__git_refs2 "$remote")" -- "$cur")) |
||||
;; |
||||
esac |
||||
;; |
||||
esac |
||||
} |
||||
|
||||
_git_ls_remote () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
COMPREPLY=($(compgen -W "$(__git_remotes)" -- "$cur")) |
||||
} |
||||
|
||||
_git_ls_tree () |
||||
{ |
||||
__git_complete_file |
||||
} |
||||
|
||||
_git_log () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
case "$cur" in |
||||
*..*) |
||||
local pfx=$(echo "$cur" | sed 's/\.\..*$/../') |
||||
cur=$(echo "$cur" | sed 's/^.*\.\.//') |
||||
COMPREPLY=($(compgen -P "$pfx" -W "$(__git_refs .)" -- "$cur")) |
||||
;; |
||||
*) |
||||
COMPREPLY=($(compgen -W "$(__git_refs .)" -- "$cur")) |
||||
;; |
||||
esac |
||||
} |
||||
|
||||
_git_merge_base () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
COMPREPLY=($(compgen -W "$(__git_refs .)" -- "$cur")) |
||||
} |
||||
|
||||
_git_pull () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
|
||||
case "${COMP_WORDS[0]},$COMP_CWORD" in |
||||
git-pull*,1) |
||||
COMPREPLY=($(compgen -W "$(__git_remotes)" -- "$cur")) |
||||
;; |
||||
git,2) |
||||
COMPREPLY=($(compgen -W "$(__git_remotes)" -- "$cur")) |
||||
;; |
||||
*) |
||||
local remote |
||||
case "${COMP_WORDS[0]}" in |
||||
git-pull) remote="${COMP_WORDS[1]}" ;; |
||||
git) remote="${COMP_WORDS[2]}" ;; |
||||
esac |
||||
COMPREPLY=($(compgen -W "$(__git_refs "$remote")" -- "$cur")) |
||||
;; |
||||
esac |
||||
} |
||||
|
||||
_git_push () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
|
||||
case "${COMP_WORDS[0]},$COMP_CWORD" in |
||||
git-push*,1) |
||||
COMPREPLY=($(compgen -W "$(__git_remotes)" -- "$cur")) |
||||
;; |
||||
git,2) |
||||
COMPREPLY=($(compgen -W "$(__git_remotes)" -- "$cur")) |
||||
;; |
||||
*) |
||||
case "$cur" in |
||||
*:*) |
||||
local remote |
||||
case "${COMP_WORDS[0]}" in |
||||
git-push) remote="${COMP_WORDS[1]}" ;; |
||||
git) remote="${COMP_WORDS[2]}" ;; |
||||
esac |
||||
cur=$(echo "$cur" | sed 's/^.*://') |
||||
COMPREPLY=($(compgen -W "$(__git_refs "$remote")" -- "$cur")) |
||||
;; |
||||
*) |
||||
COMPREPLY=($(compgen -W "$(__git_refs2 .)" -- "$cur")) |
||||
;; |
||||
esac |
||||
;; |
||||
esac |
||||
} |
||||
|
||||
_git_show () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
COMPREPLY=($(compgen -W "$(__git_refs .)" -- "$cur")) |
||||
} |
||||
|
||||
_git () |
||||
{ |
||||
if [ $COMP_CWORD = 1 ]; then |
||||
COMPREPLY=($(compgen \ |
||||
-W "--version $(git help -a|egrep '^ ')" \ |
||||
-- "${COMP_WORDS[COMP_CWORD]}")) |
||||
else |
||||
case "${COMP_WORDS[1]}" in |
||||
branch) _git_branch ;; |
||||
cat-file) _git_cat_file ;; |
||||
checkout) _git_checkout ;; |
||||
diff) _git_diff ;; |
||||
diff-tree) _git_diff_tree ;; |
||||
fetch) _git_fetch ;; |
||||
log) _git_log ;; |
||||
ls-remote) _git_ls_remote ;; |
||||
ls-tree) _git_ls_tree ;; |
||||
pull) _git_pull ;; |
||||
push) _git_push ;; |
||||
show) _git_show ;; |
||||
show-branch) _git_log ;; |
||||
whatchanged) _git_log ;; |
||||
*) COMPREPLY=() ;; |
||||
esac |
||||
fi |
||||
} |
||||
|
||||
_gitk () |
||||
{ |
||||
local cur="${COMP_WORDS[COMP_CWORD]}" |
||||
COMPREPLY=($(compgen -W "--all $(__git_refs .)" -- "$cur")) |
||||
} |
||||
|
||||
complete -o default -o nospace -F _git git |
||||
complete -o default -F _gitk gitk |
||||
complete -o default -F _git_branch git-branch |
||||
complete -o default -o nospace -F _git_cat_file git-cat-file |
||||
complete -o default -F _git_checkout git-checkout |
||||
complete -o default -o nospace -F _git_diff git-diff |
||||
complete -o default -F _git_diff_tree git-diff-tree |
||||
complete -o default -o nospace -F _git_fetch git-fetch |
||||
complete -o default -o nospace -F _git_log git-log |
||||
complete -o default -F _git_ls_remote git-ls-remote |
||||
complete -o default -o nospace -F _git_ls_tree git-ls-tree |
||||
complete -o default -F _git_merge_base git-merge-base |
||||
complete -o default -o nospace -F _git_pull git-pull |
||||
complete -o default -o nospace -F _git_push git-push |
||||
complete -o default -F _git_show git-show |
||||
complete -o default -o nospace -F _git_log git-whatchanged |
||||
|
||||
# The following are necessary only for Cygwin, and only are needed |
||||
# when the user has tab-completed the executable name and consequently |
||||
# included the '.exe' suffix. |
||||
# |
||||
complete -o default -o nospace -F _git_cat_file git-cat-file.exe |
||||
complete -o default -o nospace -F _git_diff git-diff.exe |
||||
complete -o default -o nospace -F _git_diff_tree git-diff-tree.exe |
||||
complete -o default -o nospace -F _git_log git-log.exe |
||||
complete -o default -o nospace -F _git_ls_tree git-ls-tree.exe |
||||
complete -o default -F _git_merge_base git-merge-base.exe |
||||
complete -o default -o nospace -F _git_push git-push.exe |
||||
complete -o default -o nospace -F _git_log git-whatchanged.exe |
||||
@ -0,0 +1,4 @@
@@ -0,0 +1,4 @@
|
||||
Makefile |
||||
blib |
||||
blibdirs |
||||
pm_to_blib |
||||
@ -0,0 +1,837 @@
@@ -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 |
||||
@ -0,0 +1,28 @@
@@ -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 |
||||
); |
||||
@ -0,0 +1,827 @@
@@ -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 |
||||
Loading…
Reference in new issue