philipp/nixpkgs
1
0
Fork 0
Code Issues Pull requests Projects Releases Activity
nixpkgs/pkgs/development/libraries/gnutls/fix-guile-tests.patch

633 lines
22 KiB
Diff
Raw Normal View History

GnuTLS 2.12.3. svn path=/nixpkgs/trunk/; revision=27039
2011-04-28 22:57:54 +02:00
From ccbd77f6dc0b8440e7d80bddce2c8f950674eb46 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
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
<http://git.sv.gnu.org/cgit/guile.git/commit/?id=e309f3bf9ee910c4772353ca3ff95f6f4ef466b5>.
---
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 <ludo@gnu.org>.
+
+(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
Reference in a new issue Copy permalink