[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[SCM] GNU gnutls branch, master, updated. gnutls_2_99_1-2-gcd7b810
|
From: |
Ludovic Courtès |
|
Subject: |
[SCM] GNU gnutls branch, master, updated. gnutls_2_99_1-2-gcd7b810 |
|
Date: |
Thu, 28 Apr 2011 17:56:16 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU gnutls".
http://git.savannah.gnu.org/cgit/gnutls.git/commit/?id=cd7b8102316cd4151356c4b2b7909c7435593890
The branch, master has been updated
via cd7b8102316cd4151356c4b2b7909c7435593890 (commit)
from 8849df91785e5a28d72e6135604428ecc027778b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cd7b8102316cd4151356c4b2b7909c7435593890
Author: Ludovic Courtès <address@hidden>
Date: Thu Apr 28 19:41:08 2011 +0200
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>.
-----------------------------------------------------------------------
Summary of changes:
guile/modules/Makefile.am | 3 +-
.../gnutls/build/tests.scm} | 52 +++++++++----------
guile/tests/anonymous-auth.scm | 16 ++----
guile/tests/errors.scm | 22 +++-----
guile/tests/openpgp-auth.scm | 16 ++----
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, 121 insertions(+), 179 deletions(-)
copy guile/{src/make-session-priorities.scm => modules/gnutls/build/tests.scm}
(50%)
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/src/make-session-priorities.scm
b/guile/modules/gnutls/build/tests.scm
similarity index 50%
copy from guile/src/make-session-priorities.scm
copy to guile/modules/gnutls/build/tests.scm
index 8aeb820..ca3985f 100644
--- a/guile/src/make-session-priorities.scm
+++ b/guile/modules/gnutls/build/tests.scm
@@ -1,7 +1,5 @@
-;;; Help produce Guile wrappers for GnuTLS types.
-;;;
;;; GnuTLS --- Guile bindings for GnuTLS.
-;;; Copyright (C) 2007, 2010 Free Software Foundation, Inc.
+;;; 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
@@ -17,27 +15,27 @@
;;; 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 <address@hidden>.
-
-
-(use-modules (gnutls build priorities))
-
-
-;;;
-;;; The program.
-;;;
-
-(define (main . args)
- (let ((port (current-output-port)))
- (for-each (lambda (priority)
- (output-session-set-priority-function priority port))
- %gnutls-priorities)))
-
-(main)
-
-;;; Local Variables:
-;;; mode: scheme
-;;; coding: latin-1
-;;; End:
-
-;;; arch-tag: 026228de-e6d6-421b-bf2f-aaf9630d6b73
+;;; Written by Ludovic Courtès <address@hidden>.
+
+(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 be04fcd..8f5e5ae 100644
--- a/guile/tests/anonymous-auth.scm
+++ b/guile/tests/anonymous-auth.scm
@@ -24,6 +24,7 @@
;;;
(use-modules (gnutls)
+ (gnutls build tests)
(srfi srfi-4))
@@ -50,10 +51,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)))
@@ -71,7 +69,7 @@
(record-send client %message)
(bye client close-request/rdwr)
- (exit))
+ (primitive-exit))
(let ((server (make-session connection-end/server)))
;; server-side
@@ -89,11 +87,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 6148183..9e3a3e4 100644
--- a/guile/tests/openpgp-auth.scm
+++ b/guile/tests/openpgp-auth.scm
@@ -25,6 +25,7 @@
(use-modules (gnutls)
(gnutls extra)
+ (gnutls build tests)
(srfi srfi-4))
@@ -59,10 +60,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
@@ -87,7 +85,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"))
@@ -109,11 +107,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 5e06632..433b745 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
hooks/post-receive
--
GNU gnutls
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [SCM] GNU gnutls branch, master, updated. gnutls_2_99_1-2-gcd7b810,
Ludovic Courtès <=