diff options
author | Andy Wingo <wingo@pobox.com> | 2012-02-23 14:10:22 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-02-23 14:10:22 +0100 |
commit | 9d15db65ffd49fd8fda77dcb6b70c3c930ae5153 (patch) | |
tree | 3fa57da41d8f2629649c82428ad828f5f3147d2e | |
parent | 3c65e3fda512cda13de244e853afd0fa0e7b5962 (diff) | |
parent | a2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61 (diff) | |
download | guile-9d15db65ffd49fd8fda77dcb6b70c3c930ae5153.tar.gz |
Merge remote-tracking branch 'local-2.0/stable-2.0'
Conflicts:
module/language/tree-il/analyze.scm
-rw-r--r-- | gnulib-local/lib/localcharset.c.diff | 51 | ||||
-rw-r--r-- | lib/localcharset.c | 8 | ||||
-rw-r--r-- | libguile/posix.c | 208 | ||||
-rw-r--r-- | module/ice-9/popen.scm | 101 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 87 | ||||
-rw-r--r-- | module/web/uri.scm | 25 | ||||
-rw-r--r-- | test-suite/standalone/Makefile.am | 5 | ||||
-rwxr-xr-x | test-suite/standalone/test-command-line-encoding2 | 20 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 42 | ||||
-rw-r--r-- | test-suite/tests/web-uri.test | 6 |
10 files changed, 381 insertions, 172 deletions
diff --git a/gnulib-local/lib/localcharset.c.diff b/gnulib-local/lib/localcharset.c.diff index 2b27ee479..6f216ad80 100644 --- a/gnulib-local/lib/localcharset.c.diff +++ b/gnulib-local/lib/localcharset.c.diff @@ -5,28 +5,10 @@ rationale. --- a/lib/localcharset.c 2011-12-14 23:10:58.000000000 +0100 +++ b/lib/localcharset.c 2011-12-15 00:45:12.000000000 +0100 -@@ -527,6 +527,76 @@ locale_charset (void) - codeset = ""; +@@ -545,3 +545,74 @@ locale_charset (void) - /* Resolve alias. */ -+ for (aliases = get_charset_aliases (); -+ *aliases != '\0'; -+ aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1) -+ if (strcmp (codeset, aliases) == 0 -+ || (aliases[0] == '*' && aliases[1] == '\0')) -+ { -+ codeset = aliases + strlen (aliases) + 1; -+ break; -+ } -+ -+ /* Don't return an empty string. GNU libc and GNU libiconv interpret -+ the empty string as denoting "the locale's character encoding", -+ thus GNU libiconv would call this function a second time. */ -+ if (codeset[0] == '\0') -+ codeset = "ASCII"; -+ -+ return codeset; -+} + return codeset; + } + +/* A variant of the above, without calls to `setlocale', `nl_langinfo', + etc. */ @@ -71,14 +53,29 @@ rationale. + strcpy (buf, "ASCII"); + return buf; + } -+ -+ /* Resolve through the charset.alias file. */ -+ codeset = locale; ++ else ++ codeset = ""; + } + else + codeset = ""; + + /* Resolve alias. */ - for (aliases = get_charset_aliases (); - *aliases != '\0'; - aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1) ++ for (aliases = get_charset_aliases (); ++ *aliases != '\0'; ++ aliases += strlen (aliases) + 1, aliases += strlen (aliases) + 1) ++ if (strcmp (codeset, aliases) == 0 ++ || (aliases[0] == '*' && aliases[1] == '\0')) ++ { ++ codeset = aliases + strlen (aliases) + 1; ++ break; ++ } ++ ++ /* Don't return an empty string. GNU libc and GNU libiconv interpret ++ the empty string as denoting "the locale's character encoding", ++ thus GNU libiconv would call this function a second time. */ ++ if (codeset[0] == '\0') ++ /* Default to Latin-1, for backward compatibility with Guile 1.8. */ ++ codeset = "ISO-8859-1"; ++ ++ return codeset; ++} diff --git a/lib/localcharset.c b/lib/localcharset.c index 47a6e5d5b..2c06328cb 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -589,9 +589,8 @@ environ_locale_charset (void) strcpy (buf, "ASCII"); return buf; } - - /* Resolve through the charset.alias file. */ - codeset = locale; + else + codeset = ""; } else codeset = ""; @@ -611,7 +610,8 @@ environ_locale_charset (void) the empty string as denoting "the locale's character encoding", thus GNU libiconv would call this function a second time. */ if (codeset[0] == '\0') - codeset = "ASCII"; + /* Default to Latin-1, for backward compatibility with Guile 1.8. */ + codeset = "ISO-8859-1"; return codeset; } diff --git a/libguile/posix.c b/libguile/posix.c index f4d93f092..abb1a92dd 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1254,6 +1254,201 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, return scm_from_int (pid); } #undef FUNC_NAME + +/* Since Guile uses threads, we have to be very careful to avoid calling + functions that are not async-signal-safe in the child. That's why + this function is implemented in C. */ +static SCM +scm_open_process (SCM mode, SCM prog, SCM args) +#define FUNC_NAME "open-process" +{ + long mode_bits; + int reading, writing; + int c2p[2]; /* Child to parent. */ + int p2c[2]; /* Parent to child. */ + int in = -1, out = -1, err = -1; + int pid; + char *exec_file; + char **exec_argv; + int max_fd = 1024; + + exec_file = scm_to_locale_string (prog); + exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args)); + + mode_bits = scm_i_mode_bits (mode); + reading = mode_bits & SCM_RDNG; + writing = mode_bits & SCM_WRTNG; + + if (reading) + { + if (pipe (c2p)) + { + int errno_save = errno; + free (exec_file); + errno = errno_save; + SCM_SYSERROR; + } + out = c2p[1]; + } + + if (writing) + { + if (pipe (p2c)) + { + int errno_save = errno; + free (exec_file); + if (reading) + { + close (c2p[0]); + close (c2p[1]); + } + errno = errno_save; + SCM_SYSERROR; + } + in = p2c[0]; + } + + { + SCM port; + + if (SCM_OPOUTFPORTP ((port = scm_current_error_port ()))) + err = SCM_FPORT_FDES (port); + if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ()))) + out = SCM_FPORT_FDES (port); + if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ()))) + in = SCM_FPORT_FDES (port); + } + +#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE) + { + struct rlimit lim = { 0, 0 }; + if (getrlimit (RLIMIT_NOFILE, &lim) == 0) + max_fd = lim.rlim_cur; + } +#endif + + pid = fork (); + + if (pid == -1) + { + int errno_save = errno; + free (exec_file); + if (reading) + { + close (c2p[0]); + close (c2p[1]); + } + if (writing) + { + close (p2c[0]); + close (p2c[1]); + } + errno = errno_save; + SCM_SYSERROR; + } + + if (pid) + /* Parent. */ + { + SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F, port; + + /* There is no sense in catching errors on close(). */ + if (reading) + { + close (c2p[1]); + read_port = scm_fdes_to_port (c2p[0], "r", sym_read_pipe); + scm_setvbuf (read_port, scm_from_int (_IONBF), SCM_UNDEFINED); + } + if (writing) + { + close (p2c[0]); + write_port = scm_fdes_to_port (p2c[1], "w", sym_write_pipe); + scm_setvbuf (write_port, scm_from_int (_IONBF), SCM_UNDEFINED); + } + + if (reading && writing) + { + static SCM make_rw_port = SCM_BOOL_F; + + if (scm_is_false (make_rw_port)) + make_rw_port = scm_c_private_variable ("ice-9 popen", + "make-rw-port"); + + port = scm_call_2 (scm_variable_ref (make_rw_port), + read_port, write_port); + } + else if (reading) + port = read_port; + else if (writing) + port = write_port; + else + port = scm_sys_make_void_port (mode); + + return scm_cons (port, scm_from_int (pid)); + } + + /* The child. */ + if (reading) + close (c2p[0]); + if (writing) + close (p2c[1]); + + /* Close all file descriptors in ports inherited from the parent + except for in, out, and err. Heavy-handed, but robust. */ + while (max_fd--) + if (max_fd != in && max_fd != out && max_fd != err) + close (max_fd); + + /* Ignore errors on these open() calls. */ + if (in == -1) + in = open ("/dev/null", O_RDONLY); + if (out == -1) + out = open ("/dev/null", O_WRONLY); + if (err == -1) + err = open ("/dev/null", O_WRONLY); + + if (in > 0) + { + if (out == 0) + do out = dup (out); while (errno == EINTR); + if (err == 0) + do err = dup (err); while (errno == EINTR); + do dup2 (in, 0); while (errno == EINTR); + close (in); + } + if (out > 1) + { + if (err == 1) + do err = dup (err); while (errno == EINTR); + do dup2 (out, 1); while (errno == EINTR); + close (out); + } + if (err > 2) + { + do dup2 (err, 2); while (errno == EINTR); + close (err); + } + + execvp (exec_file, +#ifdef __MINGW32__ + /* extra "const" in mingw formals, provokes warning from gcc */ + (const char * const *) +#endif + exec_argv); + + /* The exec failed! There is nothing sensible to do. */ + if (err > 0) + { + char *msg = strerror (errno); + fprintf (fdopen (err, "a"), "In execlp of %s: %s\n", + exec_file, msg); + } + + _exit (EXIT_FAILURE); + /* Not reached. */ + return SCM_BOOL_F; +} +#undef FUNC_NAME #endif /* HAVE_FORK */ #ifdef __MINGW32__ @@ -2084,6 +2279,14 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, #endif /* HAVE_GETHOSTNAME */ +#ifdef HAVE_FORK +static void +scm_init_popen (void) +{ + scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process); +} +#endif + void scm_init_posix () { @@ -2172,6 +2375,11 @@ scm_init_posix () #include "libguile/cpp-SIG.c" #include "libguile/posix.x" + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_popen", + (scm_t_extension_init_func) scm_init_popen, + NULL); } /* diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index b9debd444..7ca486805 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -1,6 +1,6 @@ ;; popen emulation, for non-stdio based ports. -;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -21,6 +21,10 @@ :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe open-output-pipe open-input-output-pipe)) +(eval-when (load eval compile) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_popen")) + (define (make-rw-port read-port write-port) (make-soft-port (vector @@ -38,100 +42,6 @@ ;; a weak hash-table to store the process ids. (define port/pid-table (make-weak-key-hash-table 31)) -(define (ensure-fdes port mode) - (or (false-if-exception (fileno port)) - (open-fdes *null-device* mode))) - -;; run a process connected to an input, an output or an -;; input/output port -;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH -;; returns port/pid pair. -(define (open-process mode prog . args) - (let* ((reading (or (equal? mode OPEN_READ) - (equal? mode OPEN_BOTH))) - (writing (or (equal? mode OPEN_WRITE) - (equal? mode OPEN_BOTH))) - (c2p (if reading (pipe) #f)) ; child to parent - (p2c (if writing (pipe) #f))) ; parent to child - - (if c2p (setvbuf (cdr c2p) _IONBF)) - (if p2c (setvbuf (cdr p2c) _IONBF)) - (let ((pid (primitive-fork))) - (cond ((= pid 0) - ;; child - (ensure-batch-mode!) - - ;; select the three file descriptors to be used as - ;; standard descriptors 0, 1, 2 for the new - ;; process. They are pipes to/from the parent or taken - ;; from the current Scheme input/output/error ports if - ;; possible. - - (let ((input-fdes (if writing - (fileno (car p2c)) - (ensure-fdes (current-input-port) - O_RDONLY))) - (output-fdes (if reading - (fileno (cdr c2p)) - (ensure-fdes (current-output-port) - O_WRONLY))) - (error-fdes (ensure-fdes (current-error-port) - O_WRONLY))) - - ;; close all file descriptors in ports inherited from - ;; the parent except for the three selected above. - ;; this is to avoid causing problems for other pipes in - ;; the parent. - - ;; use low-level system calls, not close-port or the - ;; scsh routines, to avoid side-effects such as - ;; flushing port buffers or evicting ports. - - (port-for-each (lambda (pt-entry) - (false-if-exception - (let ((pt-fileno (fileno pt-entry))) - (if (not (or (= pt-fileno input-fdes) - (= pt-fileno output-fdes) - (= pt-fileno error-fdes))) - (close-fdes pt-fileno)))))) - - ;; Copy the three selected descriptors to the standard - ;; descriptors 0, 1, 2, if not already there - - (cond ((not (= input-fdes 0)) - (if (= output-fdes 0) - (set! output-fdes (dup->fdes 0))) - (if (= error-fdes 0) - (set! error-fdes (dup->fdes 0))) - (dup2 input-fdes 0) - ;; it's possible input-fdes is error-fdes - (if (not (= input-fdes error-fdes)) - (close-fdes input-fdes)))) - - (cond ((not (= output-fdes 1)) - (if (= error-fdes 1) - (set! error-fdes (dup->fdes 1))) - (dup2 output-fdes 1) - ;; it's possible output-fdes is error-fdes - (if (not (= output-fdes error-fdes)) - (close-fdes output-fdes)))) - - (cond ((not (= error-fdes 2)) - (dup2 error-fdes 2) - (close-fdes error-fdes))) - - (apply execlp prog prog args))) - - (else - ;; parent - (if c2p (close-port (cdr c2p))) - (if p2c (close-port (car p2c))) - (cons (cond ((not writing) (car c2p)) - ((not reading) (cdr p2c)) - (else (make-rw-port (car c2p) - (cdr p2c)))) - pid)))))) - (define (open-pipe* mode command . args) "Executes the program @var{command} with optional arguments @var{args} (all strings) in a subprocess. @@ -213,3 +123,4 @@ information on how to interpret this value." (define (open-input-output-pipe command) "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}" (open-pipe command OPEN_BOTH)) + diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 28312514a..11c19d8ec 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -1353,16 +1353,41 @@ accurate information is missing from a given `tree-il' element." min-count max-count)))) (else (error "computer bought the farm" state)))))) -(define (const-fmt x) - ;; Return the literal format pattern for X, or #f. +(define (proc-ref? exp proc special-name env) + "Return #t when EXP designates procedure PROC in ENV. As a last +resort, return #t when EXP refers to the global variable SPECIAL-NAME." + (match exp + (($ <toplevel-ref> _ name) + (let ((var (false-if-exception (module-variable env name)))) + (if var + (eq? (variable-ref var) proc) + (eq? name special-name)))) ; special hack to support local aliases + (($ <module-ref> _ module name public?) + (let ((m (false-if-exception (if public? + (resolve-interface module) + (resolve-module module))))) + (and m (eq? (false-if-exception (module-ref module name)) proc)))) + (_ #f))) + +(define gettext? (cut proc-ref? <> gettext '_ <>)) +(define ngettext? (cut proc-ref? <> ngettext 'N_ <>)) + +(define (const-fmt x env) + ;; Return the literal format string for X, or #f. (match x - (($ <const> _ exp) + (($ <const> _ (? string? exp)) exp) - (($ <call> _ - (or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_)) - (($ <const> _ (and (? string?) fmt)))) + (($ <call> _ (? (cut gettext? <> env)) + (($ <const> _ (? string? fmt)))) ;; Gettexted literals, like `(_ "foo")'. fmt) + (($ <call> _ (? (cut ngettext? <> env)) + (($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1)) + ;; Plural gettextized literals, like `(N_ "singular" "plural" n)'. + + ;; TODO: Check whether the singular and plural strings have the + ;; same format escapes. + fmt) (_ #f))) (define format-analysis @@ -1377,36 +1402,38 @@ accurate information is missing from a given `tree-il' element." (define (check-format-args args loc) (pmatch args ((,port ,fmt . ,rest) - (guard (const-fmt fmt)) + (guard (const-fmt fmt env)) (if (and (const? port) (not (boolean? (const-exp port)))) (warning 'format loc 'wrong-port (const-exp port))) - (let ((fmt (const-fmt fmt)) + (let ((fmt (const-fmt fmt env)) (count (length rest))) - (if (string? fmt) - (catch &syntax-error - (lambda () - (let-values (((min max) - (format-string-argument-count fmt))) - (and min max - (or (and (or (eq? min 'any) (>= count min)) - (or (eq? max 'any) (<= count max))) - (warning 'format loc 'wrong-format-arg-count - fmt min max count))))) - (lambda (_ key) - (warning 'format loc 'syntax-error key fmt))) - (warning 'format loc 'wrong-format-string fmt)))) + (catch &syntax-error + (lambda () + (let-values (((min max) + (format-string-argument-count fmt))) + (and min max + (or (and (or (eq? min 'any) (>= count min)) + (or (eq? max 'any) (<= count max))) + (warning 'format loc 'wrong-format-arg-count + fmt min max count))))) + (lambda (_ key) + (warning 'format loc 'syntax-error key fmt))))) ((,port ,fmt . ,rest) (if (and (const? port) (not (boolean? (const-exp port)))) (warning 'format loc 'wrong-port (const-exp port))) - ;; Warn on non-literal format strings, unless they refer to a - ;; lexical variable named "fmt". - (if (record-case fmt - ((<lexical-ref> name) - (not (eq? name 'fmt))) - (else #t)) - (warning 'format loc 'non-literal-format-string))) + + (match fmt + (($ <const> loc* (? (negate string?) fmt)) + (warning 'format (or loc* loc) 'wrong-format-string fmt)) + + ;; Warn on non-literal format strings, unless they refer to + ;; a lexical variable named "fmt". + (($ <lexical-ref> _ fmt) + #t) + ((? (negate const?)) + (warning 'format loc 'non-literal-format-string)))) (else (warning 'format loc 'wrong-num-args (length args))))) @@ -1436,8 +1463,8 @@ accurate information is missing from a given `tree-il' element." (warning 'format loc 'simple-format fmt (find (negate (cut memq <> allowed-chars)) opts)) #f)))) - ((port (($ <const> _ '_) fmt) args ...) - (check-simple-format-args `(,port ,fmt ,args) loc)) + ((port (= (cut const-fmt <> env) (? string? fmt)) args ...) + (check-simple-format-args `(,port ,(make-const loc fmt) ,args) loc)) (_ #t))) (define (resolve-toplevel name) diff --git a/module/web/uri.scm b/module/web/uri.scm index 67ecbaeb2..a2a930a6a 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -1,6 +1,6 @@ ;;;; (web uri) --- URI manipulation tools ;;;; -;;;; Copyright (C) 1997,2001,2002,2010,2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1997,2001,2002,2010,2011,2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -89,9 +89,9 @@ consistency checks to make sure that the constructed URI is valid." ;; 3490), and non-ASCII host names. ;; (define ipv4-regexp - (make-regexp "^([0-9.]+)")) + (make-regexp "^([0-9.]+)$")) (define ipv6-regexp - (make-regexp "^\\[([0-9a-fA-F:]+)\\]+")) + (make-regexp "^\\[([0-9a-fA-F:]+)\\]+$")) (define domain-label-regexp (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$")) (define top-label-regexp @@ -100,18 +100,17 @@ consistency checks to make sure that the constructed URI is valid." (define (valid-host? host) (cond ((regexp-exec ipv4-regexp host) - => (lambda (m) - (false-if-exception (inet-pton AF_INET (match:substring m 1))))) + (false-if-exception (inet-pton AF_INET host))) ((regexp-exec ipv6-regexp host) - => (lambda (m) - (false-if-exception (inet-pton AF_INET6 (match:substring m 1))))) + (false-if-exception (inet-pton AF_INET6 host))) (else - (let ((labels (reverse (string-split host #\.)))) - (and (pair? labels) - (regexp-exec top-label-regexp (car labels)) - (and-map (lambda (label) - (regexp-exec domain-label-regexp label)) - (cdr labels))))))) + (let lp ((start 0)) + (let ((end (string-index host #\. start))) + (if end + (and (regexp-exec domain-label-regexp + (substring host start end)) + (lp (1+ end))) + (regexp-exec top-label-regexp host start))))))) (define userinfo-pat "[a-zA-Z0-9_.!~*'();:&=+$,-]+") diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index d8cfafa25..daa3d0744 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, -## 2011 Free Software Foundation, Inc. +## 2011, 2012 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -85,6 +85,9 @@ EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \ check_SCRIPTS += test-command-line-encoding TESTS += test-command-line-encoding +check_SCRIPTS += test-command-line-encoding2 +TESTS += test-command-line-encoding2 + # test-num2integral test_num2integral_SOURCES = test-num2integral.c test_num2integral_CFLAGS = ${test_cflags} diff --git a/test-suite/standalone/test-command-line-encoding2 b/test-suite/standalone/test-command-line-encoding2 new file mode 100755 index 000000000..536945bc2 --- /dev/null +++ b/test-suite/standalone/test-command-line-encoding2 @@ -0,0 +1,20 @@ +#!/bin/sh + +# Choose a locale name that lacks a dot followed by the encoding name. +# This should not confuse `environ_locale_charset'. +# See <http://bugs.gnu.org/10742> for the original bug report. +LC_ALL="en_US" +export LC_ALL +unset LANG +unset LC_CTYPE + +exec guile -q -s "$0" "hello" +!# + +;; Make sure our argument was suitable decoded. +(exit (string=? (cadr (program-arguments)) "hello")) + +;; Local Variables: +;; mode: scheme +;; coding: iso-8859-1 +;; End: diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 78068ffcd..834ce5f47 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -2174,10 +2174,32 @@ (pass-if "non-literal format string using gettext" (null? (call-with-warnings (lambda () + (compile '(format #t (gettext "~A ~A!") "hello" "world") + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "non-literal format string using gettext as _" + (null? (call-with-warnings + (lambda () (compile '(format #t (_ "~A ~A!") "hello" "world") #:opts %opts-w-format #:to 'assembly))))) + (pass-if "non-literal format string using ngettext" + (null? (call-with-warnings + (lambda () + (compile '(format #t + (ngettext "~a thing" "~a things" n "dom") n) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "non-literal format string using ngettext as N_" + (null? (call-with-warnings + (lambda () + (compile '(format #t (N_ "~a thing" "~a things" n) n) + #:opts %opts-w-format + #:to 'assembly))))) + (pass-if "wrong format string" (let ((w (call-with-warnings (lambda () @@ -2219,7 +2241,7 @@ (pass-if "one missing argument, gettext" (let ((w (call-with-warnings (lambda () - (compile '(format some-port (_ "foo ~A~%")) + (compile '(format some-port (gettext "foo ~A~%")) #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) @@ -2551,4 +2573,22 @@ #:opts %opts-w-format #:to 'assembly))))) (and (= (length w) 1) + (number? (string-contains (car w) "unsupported format option"))))) + + (pass-if "unsupported, gettext" + (let ((w (call-with-warnings + (lambda () + (compile '(simple-format #t (gettext "foo ~2f~%") 3.14) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) "unsupported format option"))))) + + (pass-if "unsupported, ngettext" + (let ((w (call-with-warnings + (lambda () + (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) (number? (string-contains (car w) "unsupported format option")))))))) diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 9118eea4b..940fb3147 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -1,6 +1,6 @@ ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -143,6 +143,10 @@ (uri=? (string->uri "http://foo:/") #:scheme 'http #:host "foo" #:path "/")) + (pass-if "http://2012.jsconf.us/" + (uri=? (string->uri "http://2012.jsconf.us/") + #:scheme 'http #:host "2012.jsconf.us" #:path "/")) + (pass-if "http://foo:not-a-port" (not (string->uri "http://foo:not-a-port"))) |