From ccbd77f6dc0b8440e7d80bddce2c8f950674eb46 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 28 Apr 2011 19:41:08 +0200 Subject: [PATCH] guile: Fix tests to match the `exit' behavior introduced in Guile 2.0.1. This fix makes tests behave correctly wrt. to the Guile bug fix at . --- guile/modules/Makefile.am | 3 +- guile/modules/gnutls/build/tests.scm | 41 ++++++++++++++++++++++++++++++++++ guile/tests/anonymous-auth.scm | 18 +++++---------- guile/tests/errors.scm | 22 ++++++----------- guile/tests/openpgp-auth.scm | 18 +++++---------- guile/tests/openpgp-keyring.scm | 24 ++++++------------- guile/tests/openpgp-keys.scm | 35 +++++++++++----------------- guile/tests/pkcs-import-export.scm | 32 ++++++++++---------------- guile/tests/session-record-port.scm | 26 ++++++++------------- guile/tests/srp-base64.scm | 15 +++++++----- guile/tests/x509-auth.scm | 18 +++++---------- guile/tests/x509-certificates.scm | 41 ++++++++++++++------------------- 12 files changed, 139 insertions(+), 154 deletions(-) create mode 100644 guile/modules/gnutls/build/tests.scm diff --git a/guile/modules/Makefile.am b/guile/modules/Makefile.am index c1829ed..d1b1cac 100644 --- a/guile/modules/Makefile.am +++ b/guile/modules/Makefile.am @@ -1,5 +1,5 @@ # GnuTLS --- Guile bindings for GnuTLS. -# Copyright (C) 2007, 2010 Free Software Foundation, Inc. +# Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. # # GnuTLS is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public @@ -25,4 +25,5 @@ documentation_modules = system/documentation/README \ EXTRA_DIST = gnutls/build/enums.scm gnutls/build/smobs.scm \ gnutls/build/utils.scm gnutls/build/priorities.scm \ + gnutls/build/tests.scm \ $(documentation_modules) diff --git a/guile/modules/gnutls/build/tests.scm b/guile/modules/gnutls/build/tests.scm new file mode 100644 index 0000000..ca3985f --- /dev/null +++ b/guile/modules/gnutls/build/tests.scm @@ -0,0 +1,41 @@ +;;; GnuTLS --- Guile bindings for GnuTLS. +;;; Copyright (C) 2011 Free Software Foundation, Inc. +;;; +;;; GnuTLS is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Lesser General Public +;;; License as published by the Free Software Foundation; either +;;; version 2.1 of the License, or (at your option) any later version. +;;; +;;; GnuTLS is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with GnuTLS; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Written by Ludovic Courtès . + +(define-module (gnutls build tests) + #:export (run-test)) + +(define (run-test thunk) + "Call `(exit (THUNK))'. If THUNK raises an exception, then call `(exit 1)' and +display a backtrace. Otherwise, return THUNK's return value." + (exit + (catch #t + thunk + (lambda (key . args) + ;; Never reached. + (exit 1)) + (lambda (key . args) + (dynamic-wind ;; to be on the safe side + (lambda () #t) + (lambda () + (format (current-error-port) + "~%throw to `~a' with args ~s~%" key args) + (display-backtrace (make-stack #t) (current-output-port))) + (lambda () + (exit 1))) + (exit 1))))) diff --git a/guile/tests/anonymous-auth.scm b/guile/tests/anonymous-auth.scm index 17f5e80..63616a6 100644 --- a/guile/tests/anonymous-auth.scm +++ b/guile/tests/anonymous-auth.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -24,6 +24,7 @@ ;;; (use-modules (gnutls) + (gnutls build tests) (srfi srfi-4)) @@ -54,10 +55,7 @@ ;; (set-log-procedure! (lambda (level str) ;; (format #t "[~a|~a] ~a" (getpid) level str))) -(dynamic-wind - (lambda () - #t) - +(run-test (lambda () (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) (pid (primitive-fork))) @@ -80,7 +78,7 @@ (record-send client %message) (bye client close-request/rdwr) - (exit)) + (primitive-exit)) (let ((server (make-session connection-end/server))) ;; server-side @@ -103,11 +101,7 @@ (let* ((buf (make-u8vector (u8vector-length %message))) (amount (record-receive! server buf))) (bye server close-request/rdwr) - (exit (= amount (u8vector-length %message)) - (equal? buf %message))))))) - - (lambda () - ;; failure - (exit 1))) + (and (= amount (u8vector-length %message)) + (equal? buf %message)))))))) ;;; arch-tag: 8c98de24-0a53-4290-974e-4b071ad162a0 diff --git a/guile/tests/errors.scm b/guile/tests/errors.scm index cec6491..65b4ae9 100644 --- a/guile/tests/errors.scm +++ b/guile/tests/errors.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -22,25 +22,19 @@ ;;; Test the error/exception mechanism. ;;; -(use-modules (gnutls)) - -(dynamic-wind - (lambda () - #t) +(use-modules (gnutls) + (gnutls build tests)) +(run-test (lambda () (let ((s (make-session connection-end/server))) (catch 'gnutls-error (lambda () (handshake s)) (lambda (key err function . currently-unused) - (exit (and (eq? key 'gnutls-error) - err - (string? (error->string err)) - (eq? function 'handshake))))))) - - (lambda () - ;; failure - (exit 1))) + (and (eq? key 'gnutls-error) + err + (string? (error->string err)) + (eq? function 'handshake))))))) ;;; arch-tag: 73ed6229-378d-4a12-a5c6-4c2586c6e3a2 diff --git a/guile/tests/openpgp-auth.scm b/guile/tests/openpgp-auth.scm index 3db9e42..4b43c90 100644 --- a/guile/tests/openpgp-auth.scm +++ b/guile/tests/openpgp-auth.scm @@ -1,5 +1,5 @@ ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA. -;;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2008, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS-extra is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -25,6 +25,7 @@ (use-modules (gnutls) (gnutls extra) + (gnutls build tests) (srfi srfi-4)) @@ -63,10 +64,7 @@ ;; (set-log-procedure! (lambda (level str) ;; (format #t "[~a|~a] ~a" (getpid) level str))) -(dynamic-wind - (lambda () - #t) - +(run-test (lambda () (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) (pub (import-key import-openpgp-certificate @@ -96,7 +94,7 @@ (write %message (session-record-port client)) (bye client close-request/rdwr) - (exit)) + (primitive-exit)) (let ((server (make-session connection-end/server)) (rsa (import-rsa-params "rsa-parameters.pem")) @@ -123,11 +121,7 @@ (let ((msg (read (session-record-port server))) (auth-type (session-authentication-type server))) (bye server close-request/rdwr) - (exit (and (eq? auth-type credentials/certificate) - (equal? msg %message))))))))) - - (lambda () - ;; failure - (exit 1))) + (and (eq? auth-type credentials/certificate) + (equal? msg %message))))))))) ;;; arch-tag: 1a973ed5-f45d-45a4-8160-900b6a8c27ff diff --git a/guile/tests/openpgp-keyring.scm b/guile/tests/openpgp-keyring.scm index e5cffc5..576a9db 100644 --- a/guile/tests/openpgp-keyring.scm +++ b/guile/tests/openpgp-keyring.scm @@ -1,5 +1,5 @@ ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS-extra is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -24,6 +24,7 @@ ;;; (use-modules (gnutls extra) (gnutls) + (gnutls build tests) (srfi srfi-1) (srfi srfi-4)) @@ -59,21 +60,12 @@ (openpgp-keyring-contains-key-id? keyring id)) %ids-in-keyring))))) -(dynamic-wind - - (lambda () - #t) - - (lambda () - (exit - (every valid-keyring? - (list %raw-keyring-file - %ascii-keyring-file) - (list openpgp-certificate-format/raw - openpgp-certificate-format/base64)))) - +(run-test (lambda () - ;; failure - (exit 1))) + (every valid-keyring? + (list %raw-keyring-file + %ascii-keyring-file) + (list openpgp-certificate-format/raw + openpgp-certificate-format/base64)))) ;;; arch-tag: 516bf608-5c8b-4787-abe9-5f7b6e6d660b diff --git a/guile/tests/openpgp-keys.scm b/guile/tests/openpgp-keys.scm index 6049984..2ded32d 100644 --- a/guile/tests/openpgp-keys.scm +++ b/guile/tests/openpgp-keys.scm @@ -1,5 +1,5 @@ ;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS-extra is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -25,6 +25,7 @@ (use-modules (gnutls) (gnutls extra) + (gnutls build tests) (srfi srfi-1) (srfi srfi-4) (srfi srfi-11)) @@ -43,11 +44,7 @@ (stat:size (stat file))) -(dynamic-wind - - (lambda () - #t) - +(run-test (lambda () (let ((raw-pubkey (make-u8vector (file-size %certificate-file))) (raw-privkey (make-u8vector (file-size %private-key-file)))) @@ -60,20 +57,16 @@ (sec (import-openpgp-private-key raw-privkey openpgp-certificate-format/base64))) - (exit (and (openpgp-certificate? pub) - (openpgp-private-key? sec) - (equal? (openpgp-certificate-id pub) %key-id) - (u8vector? (openpgp-certificate-fingerprint pub)) - (every string? (openpgp-certificate-names pub)) - (member (openpgp-certificate-version pub) '(3 4)) - (list? (openpgp-certificate-usage pub)) - (let-values (((pk bits) - (openpgp-certificate-algorithm pub))) - (and (string? (pk-algorithm->string pk)) - (number? bits)))))))) - - (lambda () - ;; failure - (exit 1))) + (and (openpgp-certificate? pub) + (openpgp-private-key? sec) + (equal? (openpgp-certificate-id pub) %key-id) + (u8vector? (openpgp-certificate-fingerprint pub)) + (every string? (openpgp-certificate-names pub)) + (member (openpgp-certificate-version pub) '(3 4)) + (list? (openpgp-certificate-usage pub)) + (let-values (((pk bits) + (openpgp-certificate-algorithm pub))) + (and (string? (pk-algorithm->string pk)) + (number? bits)))))))) ;;; arch-tag: 2ee2a377-7f4d-4031-92a8-275090e4f83d diff --git a/guile/tests/pkcs-import-export.scm b/guile/tests/pkcs-import-export.scm index 8900f15..4121b18 100644 --- a/guile/tests/pkcs-import-export.scm +++ b/guile/tests/pkcs-import-export.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -23,6 +23,7 @@ ;;; (use-modules (gnutls) + (gnutls build tests) (srfi srfi-4)) (define (import-something import-proc file fmt) @@ -36,25 +37,16 @@ (import-something pkcs3-import-dh-parameters file x509-certificate-format/pem)) -(dynamic-wind - - (lambda () - #t) - - (lambda () - (exit - (let* ((dh-params (import-dh-params "dh-parameters.pem")) - (export - (pkcs3-export-dh-parameters dh-params - x509-certificate-format/pem))) - (and (u8vector? export) - (let ((import - (pkcs3-import-dh-parameters export - x509-certificate-format/pem))) - (dh-parameters? import)))))) - +(run-test (lambda () - ;; failure - (exit 1))) + (let* ((dh-params (import-dh-params "dh-parameters.pem")) + (export + (pkcs3-export-dh-parameters dh-params + x509-certificate-format/pem))) + (and (u8vector? export) + (let ((import + (pkcs3-import-dh-parameters export + x509-certificate-format/pem))) + (dh-parameters? import)))))) ;;; arch-tag: adff0f07-479e-421e-b47f-8956e06b9902 diff --git a/guile/tests/session-record-port.scm b/guile/tests/session-record-port.scm index a41ea2c..1d53d9b 100644 --- a/guile/tests/session-record-port.scm +++ b/guile/tests/session-record-port.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -24,6 +24,7 @@ ;;; (use-modules (gnutls) + (gnutls build tests) (srfi srfi-4)) @@ -54,10 +55,7 @@ ;; (set-log-procedure! (lambda (level str) ;; (format #t "[~a|~a] ~a" (getpid) level str))) -(dynamic-wind - (lambda () - #t) - +(run-test (lambda () ;; Stress the GC. In 0.0, this triggered an abort due to ;; "scm_unprotect_object called during GC". @@ -104,7 +102,7 @@ (uniform-vector-write %message (session-record-port client)) (bye client close-request/rdwr) - (exit)) + (primitive-exit)) (let ((server (make-session connection-end/server))) ;; server-side @@ -130,15 +128,11 @@ (bye server close-request/rdwr) ;; Make sure we got everything right. - (exit (eq? (session-record-port server) - (session-record-port server)) - (= amount (u8vector-length %message)) - (equal? buf %message) - (eof-object? - (read-char (session-record-port server))))))))) - - (lambda () - ;; failure - (exit 1))) + (and (eq? (session-record-port server) + (session-record-port server)) + (= amount (u8vector-length %message)) + (equal? buf %message) + (eof-object? + (read-char (session-record-port server)))))))))) ;;; arch-tag: e873226a-d0b6-4a93-87ec-a1b5ad2ae8a2 diff --git a/guile/tests/srp-base64.scm b/guile/tests/srp-base64.scm index c928f25..484288a 100644 --- a/guile/tests/srp-base64.scm +++ b/guile/tests/srp-base64.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -22,7 +22,8 @@ ;;; Test SRP base64 encoding and decoding. ;;; -(use-modules (gnutls)) +(use-modules (gnutls) + (gnutls build tests)) (define %message "GnuTLS is free software; you can redistribute it and/or @@ -30,10 +31,12 @@ modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version.") -(exit (let ((encoded (srp-base64-encode %message))) - (and (string? encoded) - (string=? (srp-base64-decode encoded) - %message)))) +(run-test + (lambda () + (let ((encoded (srp-base64-encode %message))) + (and (string? encoded) + (string=? (srp-base64-decode encoded) + %message))))) ;;; arch-tag: ea1534a5-d513-4208-9a75-54bd4710f915 diff --git a/guile/tests/x509-auth.scm b/guile/tests/x509-auth.scm index 83cf423..e5c3437 100644 --- a/guile/tests/x509-auth.scm +++ b/guile/tests/x509-auth.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -24,6 +24,7 @@ ;;; (use-modules (gnutls) + (gnutls build tests) (srfi srfi-4)) @@ -62,10 +63,7 @@ ;; (set-log-procedure! (lambda (level str) ;; (format #t "[~a|~a] ~a" (getpid) level str))) -(dynamic-wind - (lambda () - #t) - +(run-test (lambda () (let ((socket-pair (socketpair PF_UNIX SOCK_STREAM 0)) (pub (import-key import-x509-certificate @@ -95,7 +93,7 @@ (write %message (session-record-port client)) (bye client close-request/rdwr) - (exit)) + (primitive-exit)) (let ((server (make-session connection-end/server)) (rsa (import-rsa-params "rsa-parameters.pem")) @@ -128,11 +126,7 @@ (let ((msg (read (session-record-port server))) (auth-type (session-authentication-type server))) (bye server close-request/rdwr) - (exit (and (eq? auth-type credentials/certificate) - (equal? msg %message))))))))) - - (lambda () - ;; failure - (exit 1))) + (and (eq? auth-type credentials/certificate) + (equal? msg %message))))))))) ;;; arch-tag: 1f88f835-a5c8-4fd6-94b6-5a13571ba03d diff --git a/guile/tests/x509-certificates.scm b/guile/tests/x509-certificates.scm index fda227b..67c1885 100644 --- a/guile/tests/x509-certificates.scm +++ b/guile/tests/x509-certificates.scm @@ -1,5 +1,5 @@ ;;; GnuTLS --- Guile bindings for GnuTLS. -;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc. +;;; Copyright (C) 2007, 2010, 2011 Free Software Foundation, Inc. ;;; ;;; GnuTLS is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -23,6 +23,7 @@ ;;; (use-modules (gnutls) + (gnutls build tests) (srfi srfi-4) (srfi srfi-11)) @@ -45,11 +46,7 @@ (stat:size (stat file))) -(dynamic-wind - - (lambda () - #t) - +(run-test (lambda () (let ((raw-certificate (make-u8vector (file-size %certificate-file))) (raw-privkey (make-u8vector (file-size %private-key-file)))) @@ -64,23 +61,19 @@ (sec (import-x509-private-key raw-privkey x509-certificate-format/pem))) - (exit (and (x509-certificate? cert) - (x509-private-key? sec) - (string? (x509-certificate-dn cert)) - (string? (x509-certificate-issuer-dn cert)) - (string=? (x509-certificate-dn-oid cert 0) %first-oid) - (eq? (x509-certificate-signature-algorithm cert) - %signature-algorithm) - (x509-certificate-matches-hostname? cert "localhost") - (let-values (((type name) - (x509-certificate-subject-alternative-name - cert 0))) - (and (string? name) - (string? - (x509-subject-alternative-name->string type))))))))) - - (lambda () - ;; failure - (exit 1))) + (and (x509-certificate? cert) + (x509-private-key? sec) + (string? (x509-certificate-dn cert)) + (string? (x509-certificate-issuer-dn cert)) + (string=? (x509-certificate-dn-oid cert 0) %first-oid) + (eq? (x509-certificate-signature-algorithm cert) + %signature-algorithm) + (x509-certificate-matches-hostname? cert "localhost") + (let-values (((type name) + (x509-certificate-subject-alternative-name + cert 0))) + (and (string? name) + (string? + (x509-subject-alternative-name->string type))))))))) ;;; arch-tag: eef09b52-30e8-472a-8b93-cb636434f6eb -- 1.7.4.1