From dff266059813d22d1e2ba7e77279999cd41ceb75 Mon Sep 17 00:00:00 2001 From: Justus Winter Date: Fri, 7 Oct 2016 12:53:25 +0200 Subject: gpgscm: Improve path handling. * tests/gpgscm/ffi.c (ffi_init): New Scheme variable '*win32*'. * tests/gpgscm/tests.scm (canonical-path): Correctly handle paths with drive letter on Windows. Use 'path-join'. (path-expand): Use 'path-join'. Signed-off-by: Justus Winter --- tests/gpgscm/ffi.c | 9 +++++++++ tests/gpgscm/tests.scm | 12 +++++++++--- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c index 44db6bb82..a0fbe2e64 100644 --- a/tests/gpgscm/ffi.c +++ b/tests/gpgscm/ffi.c @@ -1276,6 +1276,15 @@ ffi_init (scheme *sc, const char *argv0, const char *scriptname, ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':')); #endif + ffi_define (sc, "*win32*", +#if _WIN32 + sc->T +#else + sc->F +#endif + ); + + ffi_define (sc, "*stdin*", sc->vptr->mk_port_from_file (sc, stdin, port_input)); ffi_define (sc, "*stdout*", diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm index 71ca3692a..8986a705a 100644 --- a/tests/gpgscm/tests.scm +++ b/tests/gpgscm/tests.scm @@ -181,9 +181,15 @@ (assert (string=? (path-join "" "bar" "baz") "bar/baz")) (define (canonical-path path) - (if (char=? #\/ (string-ref path 0)) + (if (or (char=? #\/ (string-ref path 0)) + (and *win32* (char=? #\\ (string-ref path 0))) + (and *win32* + (char-alphabetic? (string-ref path 0)) + (char=? #\: (string-ref path 1)) + (or (char=? #\/ (string-ref path 2)) + (char=? #\\ (string-ref path 2))))) path - (string-append (getcwd) "/" path))) + (path-join (getcwd) path))) (define (in-srcdir . names) (canonical-path (apply path-join (cons (getenv "srcdir") names)))) @@ -194,7 +200,7 @@ (let loop ((path paths)) (if (null? path) (throw "Could not find" name "in" paths) - (let* ((qualified-name (string-append (car path) "/" name)) + (let* ((qualified-name (path-join (car path) name)) (file-exists (call-with-input-file qualified-name (lambda (x) #t)))) (if file-exists -- cgit v1.2.3