security-and-privacy/gnupg
security-and-privacy
/
gnupg
mirror of git://git.gnupg.org/gnupg.git
1
0
Fork 0
Code Releases Activity

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@g10code.com>
This commit is contained in:
Justus Winter 2016-11-18 13:36:23 +01:00
parent 404e8a4136
commit e7429b1ced
6 changed files with 122 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
tests/gpgscm/ffi.scm
View File

@ -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*)))

62
tests/gpgscm/init.scm
View File

@ -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

21
tests/gpgscm/main.c
View File

@ -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;
}

9
tests/gpgscm/repl.scm
View File

@ -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)))))))))

45
tests/gpgscm/scheme.c
View File

@ -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);
}

11
tests/gpgscm/tests.scm
View File

@ -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))