[Pkg-gnupg-commit] [gnupg2] 78/180: gpgscm: Better error reporting.
Daniel Kahn Gillmor
dkg at fifthhorseman.net
Sat Dec 24 22:29:10 UTC 2016
This is an automated email from the git hooks/post-receive script.
dkg pushed a commit to branch master
in repository gnupg2.
commit e7429b1ced0c69fa7901f888f8dc25f00fc346a4
Author: Justus Winter <justus at g10code.com>
Date: Fri Nov 18 13:36:23 2016 +0100
gpgscm: Better error reporting.
* tests/gpgscm/ffi.scm: Move the customized exception handling and
atexit logic...
* tests/gpgscm/init.scm: ... here.
(throw): Record the current history.
(throw'): New function that is history-aware.
(rethrow): New function.
(*error-hook*): Use the new throw'.
* tests/gpgscm/main.c (load): Fix error handling.
(main): Save and use the 'sc->retcode' as exit code.
* tests/gpgscm/repl.scm (repl): Print call history.
* tests/gpgscm/scheme.c (_Error_1): Make a snapshot of the history,
use it to provide a accurate location of the expression causing the
error at runtime, and hand the history trace to the '*error-hook*'.
(opexe_5): Tag all lists at parse time with the current location.
* tests/gpgscm/tests.scm: Update calls to 'throw', use 'rethrow'.
Signed-off-by: Justus Winter <justus at g10code.com>
---
tests/gpgscm/ffi.scm | 36 -----------------------------
tests/gpgscm/init.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++-----
tests/gpgscm/main.c | 21 ++++++++++-------
tests/gpgscm/repl.scm | 9 +++++++-
tests/gpgscm/scheme.c | 45 +++++++++++++++++++++++++++++++-----
tests/gpgscm/tests.scm | 11 +++++----
6 files changed, 122 insertions(+), 62 deletions(-)
diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm
index c5f373c..b62fd1f 100644
--- a/tests/gpgscm/ffi.scm
+++ b/tests/gpgscm/ffi.scm
@@ -47,39 +47,3 @@
;; Low-level mechanism to terminate the process.
(ffi-define (_exit status))
-
-;; High-level mechanism to terminate the process is to throw an error
-;; of the form (*interpreter-exit* status). This gives automatic
-;; resource management a chance to clean up.
-(define *interpreter-exit* (gensym))
-(define (throw . x)
- (cond
- ((more-handlers?)
- (apply (pop-handler) x))
- ((and (= 2 (length x)) (equal? *interpreter-exit* (car x)))
- (*run-atexit-handlers*)
- (_exit (cadr x)))
- (else
- (apply error x))))
-(set! *error-hook* throw)
-
-;; Terminate the process returning STATUS to the parent.
-(define (exit status)
- (throw *interpreter-exit* status))
-
-;; A list of functions run at interpreter shutdown.
-(define *atexit-handlers* (list))
-
-;; Execute all these functions.
-(define (*run-atexit-handlers*)
- (unless (null? *atexit-handlers*)
- (let ((proc (car *atexit-handlers*)))
- ;; Drop proc from the list so that it will not get
- ;; executed again even if it raises an exception.
- (set! *atexit-handlers* (cdr *atexit-handlers*))
- (proc)
- (*run-atexit-handlers*))))
-
-;; Register a function to be run at interpreter shutdown.
-(define (atexit proc)
- (set! *atexit-handlers* (cons proc *atexit-handlers*)))
diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
index b03eb43..04f088c 100644
--- a/tests/gpgscm/init.scm
+++ b/tests/gpgscm/init.scm
@@ -567,7 +567,7 @@
; "Catch" establishes a scope spanning multiple call-frames until
; another "catch" is encountered. Within the recovery expression
; the thrown exception is bound to *error*. Errors can be rethrown
-; using (apply throw *error*).
+; using (rethrow *error*).
;
; Exceptions are thrown with:
;
@@ -588,10 +588,30 @@
(define (more-handlers?)
(pair? *handlers*))
-(define (throw . x)
- (if (more-handlers?)
- (apply (pop-handler) x)
- (apply error x)))
+;; This throws an exception.
+(define (throw message . args)
+ (throw' message args (cdr (*vm-history*))))
+
+;; This is used by the vm to throw exceptions.
+(define (throw' message args history)
+ (cond
+ ((more-handlers?)
+ ((pop-handler) message args history))
+ ((and args (= 2 (length args)) (equal? *interpreter-exit* (car args)))
+ (*run-atexit-handlers*)
+ (quit (cadr args)))
+ (else
+ (display message)
+ (if args (begin
+ (display ": ")
+ (write args)))
+ (newline)
+ (vm-history-print history)
+ (quit 1))))
+
+;; Convenience function to rethrow the error.
+(define (rethrow e)
+ (apply throw' e))
(macro (catch form)
(let ((label (gensym)))
@@ -601,8 +621,38 @@
(pop-handler)
,label)))))
-(define *error-hook* throw)
+;; Make the vm use throw'.
+(define *error-hook* throw')
+
+
+
+;; High-level mechanism to terminate the process is to throw an error
+;; of the form (*interpreter-exit* status). This gives automatic
+;; resource management a chance to clean up.
+(define *interpreter-exit* (gensym))
+
+;; Terminate the process returning STATUS to the parent.
+(define (exit status)
+ (throw "interpreter exit" *interpreter-exit* status))
+
+;; A list of functions run at interpreter shutdown.
+(define *atexit-handlers* (list))
+
+;; Execute all these functions.
+(define (*run-atexit-handlers*)
+ (unless (null? *atexit-handlers*)
+ (let ((proc (car *atexit-handlers*)))
+ ;; Drop proc from the list so that it will not get
+ ;; executed again even if it raises an exception.
+ (set! *atexit-handlers* (cdr *atexit-handlers*))
+ (proc)
+ (*run-atexit-handlers*))))
+
+;; Register a function to be run at interpreter shutdown.
+(define (atexit proc)
+ (set! *atexit-handlers* (cons proc *atexit-handlers*)))
+
;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c
index 2f77ac5..c96dcf1 100644
--- a/tests/gpgscm/main.c
+++ b/tests/gpgscm/main.c
@@ -150,7 +150,10 @@ load (scheme *sc, char *file_name,
h = fopen (qualified_name, "r");
if (h)
- break;
+ {
+ err = 0;
+ break;
+ }
if (n > 1)
{
@@ -170,23 +173,23 @@ load (scheme *sc, char *file_name,
fprintf (stderr,
"Consider using GPGSCM_PATH to specify the location "
"of the Scheme library.\n");
- return err;
+ goto leave;
}
if (verbose > 1)
fprintf (stderr, "Loading %s...\n", qualified_name);
scheme_load_named_file (sc, h, qualified_name);
fclose (h);
- if (sc->retcode)
+ if (sc->retcode && sc->nesting)
{
- if (sc->nesting)
- fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
- return gpg_error (GPG_ERR_GENERAL);
+ fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
+ err = gpg_error (GPG_ERR_GENERAL);
}
+ leave:
if (file_name != qualified_name)
free (qualified_name);
- return 0;
+ return err;
}
@@ -194,6 +197,7 @@ load (scheme *sc, char *file_name,
int
main (int argc, char **argv)
{
+ int retcode;
gpg_error_t err;
char *argv0;
ARGPARSE_ARGS pargs;
@@ -291,8 +295,9 @@ main (int argc, char **argv)
log_fatal ("%s: %s", script, gpg_strerror (err));
}
+ retcode = sc->retcode;
scheme_load_string (sc, "(*run-atexit-handlers*)");
scheme_deinit (sc);
xfree (sc);
- return EXIT_SUCCESS;
+ return retcode;
}
diff --git a/tests/gpgscm/repl.scm b/tests/gpgscm/repl.scm
index 78b8151..84454dc 100644
--- a/tests/gpgscm/repl.scm
+++ b/tests/gpgscm/repl.scm
@@ -34,7 +34,14 @@
(read (open-input-string next)))))
(if (not (eof-object? c))
(begin
- (catch (echo "Error:" *error*)
+ (catch (begin
+ (display (car *error*))
+ (when (and (cadr *error*)
+ (not (null? (cadr *error*))))
+ (display ": ")
+ (write (cadr *error*)))
+ (newline)
+ (vm-history-print (caddr *error*)))
(echo " ===>" (eval c environment)))
(exit (loop ""))))
(exit (loop next)))))))))
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
index 60b5a41..3abe12a 100644
--- a/tests/gpgscm/scheme.c
+++ b/tests/gpgscm/scheme.c
@@ -2656,6 +2656,7 @@ static INLINE pointer slot_value_in_env(pointer slot)
static pointer _Error_1(scheme *sc, const char *s, pointer a) {
const char *str = s;
+ pointer history;
#if USE_ERROR_HOOK
pointer x;
pointer hdl=sc->ERROR_HOOK;
@@ -2663,19 +2664,34 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
#if SHOW_ERROR_LINE
char sbuf[STRBUFFSIZE];
+#endif
+
+ history = history_flatten(sc);
+#if SHOW_ERROR_LINE
/* make sure error is not in REPL */
if (sc->load_stack[sc->file_i].kind & port_file &&
sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
- int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
- const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+ pointer tag;
+ const char *fname;
+ int ln;
+
+ if (history != sc->NIL && has_tag(car(history))
+ && (tag = get_tag(sc, car(history)))
+ && is_string(car(tag)) && is_integer(cdr(tag))) {
+ fname = string_value(car(tag));
+ ln = ivalue_unchecked(cdr(tag));
+ } else {
+ fname = sc->load_stack[sc->file_i].rep.stdio.filename;
+ ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
+ }
/* should never happen */
if(!fname) fname = "<unknown>";
/* we started from 0 */
ln++;
- snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
+ snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
str = (const char*)sbuf;
}
@@ -2684,11 +2700,15 @@ static pointer _Error_1(scheme *sc, const char *s, pointer a) {
#if USE_ERROR_HOOK
x=find_slot_in_env(sc,sc->envir,hdl,1);
if (x != sc->NIL) {
+ sc->code = cons(sc, cons(sc, sc->QUOTE,
+ cons(sc, history, sc->NIL)),
+ sc->NIL);
if(a!=0) {
- sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
+ sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
+ sc->code);
} else {
- sc->code = sc->NIL;
- }
+ sc->code = cons(sc, sc->F, sc->code);
+ }
sc->code = cons(sc, mk_string(sc, str), sc->code);
setimmutable(car(sc->code));
sc->code = cons(sc, slot_value_in_env(x), sc->code);
@@ -4808,6 +4828,19 @@ static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
Error_0(sc,"syntax error: illegal dot expression");
} else {
sc->nesting_stack[sc->file_i]++;
+#if USE_TAGS && SHOW_ERROR_LINE
+ {
+ const char *filename =
+ sc->load_stack[sc->file_i].rep.stdio.filename;
+ int lineno =
+ sc->load_stack[sc->file_i].rep.stdio.curr_line;
+
+ s_save(sc, OP_TAG_VALUE,
+ cons(sc, mk_string(sc, filename),
+ cons(sc, mk_integer(sc, lineno), sc->NIL)),
+ sc->NIL);
+ }
+#endif
s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
s_thread_to(sc,OP_RDSEXPR);
}
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
index bd51819..bec1922 100644
--- a/tests/gpgscm/tests.scm
+++ b/tests/gpgscm/tests.scm
@@ -130,7 +130,8 @@
(let ((result (call-with-io what "")))
(if (= 0 (:retcode result))
(:stdout result)
- (throw (list what "failed:" (:stderr result))))))
+ (throw (string-append (stringify what) " failed")
+ (:stderr result)))))
(define (call-popen command input-string)
(let ((result (call-with-io command input-string)))
@@ -246,7 +247,7 @@
(let ((,result-sym
,(if (= 1 (length (cadr form)))
`(catch (begin (close ,(caaadr form))
- (apply throw *error*))
+ (rethrow *error*))
,@(cddr form))
`(letfd ,(cdadr form) ,@(cddr form)))))
(close ,(caaadr form))
@@ -257,7 +258,7 @@
`(let* ((,cwd-sym (getcwd))
(_ (if ,(cadr form) (chdir ,(cadr form))))
(,result-sym (catch (begin (chdir ,cwd-sym)
- (apply throw *error*))
+ (rethrow *error*))
,@(cddr form))))
(chdir ,cwd-sym)
,result-sym)))
@@ -281,7 +282,7 @@
(_ (chdir ,tmp-sym))
(,result-sym (catch (begin (chdir ,cwd-sym)
(unlink-recursively ,tmp-sym)
- (apply throw *error*))
+ (rethrow *error*))
,@(cdr form))))
(chdir ,cwd-sym)
(unlink-recursively ,tmp-sym)
@@ -312,7 +313,7 @@
(let ((,result-sym
,(if (= 1 (length (cadr form)))
`(catch (begin (remove-temporary-file ,(caadr form))
- (apply throw *error*))
+ (rethrow *error*))
,@(cddr form))
`(lettmp ,(cdadr form) ,@(cddr form)))))
(remove-temporary-file ,(caadr form))
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-gnupg/gnupg2.git
More information about the Pkg-gnupg-commit
mailing list