diff options
author | Andy Wingo <wingo@pobox.com> | 2019-08-02 15:34:28 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-08-02 15:34:28 +0200 |
commit | 3869cdc59d39e97467ee215e02901594520d63a8 (patch) | |
tree | 33ec6a3ceffebdee64eff0519133c7b3d802908e | |
parent | 8ee6e766b8274726b341973c4132cec137dfd013 (diff) | |
parent | ab2fd70ef1e36c6532128b73082809ef3c056556 (diff) | |
download | guile-3869cdc59d39e97467ee215e02901594520d63a8.tar.gz |
Merge from stable-2.2
-rw-r--r-- | doc/ref/posix.texi | 10 | ||||
-rw-r--r-- | libguile/stime.c | 24 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/time.test | 35 | ||||
-rw-r--r-- | test-suite/tests/web-server.test | 118 |
5 files changed, 170 insertions, 18 deletions
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index d2730145c..b1b51d0d7 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -658,14 +658,20 @@ The GNU C Library Reference Manual}. @end deffn @findex fstat -@deffn {Scheme Procedure} stat object -@deffnx {C Function} scm_stat (object) +@deffn {Scheme Procedure} stat object [exception-on-error?] +@deffnx {C Function} scm_stat (object, exception_on_error) Return an object containing various information about the file determined by @var{object}. @var{object} can be a string containing a file name or a port or integer file descriptor which is open on a file (in which case @code{fstat} is used as the underlying system call). +If the optional @var{exception_on_error} argument is true, which +is the default, an exception will be raised if the underlying +system call returns an error, for example if the file is not +found or is not readable. Otherwise, an error will cause +@code{stat} to return @code{#f}. + The object returned by @code{stat} can be passed as a single parameter to the following procedures, all of which return integers: diff --git a/libguile/stime.c b/libguile/stime.c index 6c17eb931..c0ce8dcc5 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -664,9 +664,9 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, SCM_VALIDATE_STRING (1, format); bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); - /* Convert string to UTF-8 so that non-ASCII characters in the - format are passed through unchanged. */ - fmt = scm_to_utf8_stringn (format, &len); + /* Convert the format string to the locale encoding, as the underlying + 'strftime' C function expects. */ + fmt = scm_to_locale_stringn (format, &len); /* Ugly hack: strftime can return 0 if its buffer is too small, but some valid time strings (e.g. "%p") can sometimes produce @@ -729,7 +729,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #endif } - result = scm_from_utf8_string (tbuf + 1); + result = scm_from_locale_string (tbuf + 1); free (tbuf); free (myfmt); #if HAVE_STRUCT_TM_TM_ZONE @@ -756,16 +756,16 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, { struct tm t; char *fmt, *str, *rest; - size_t used_len; + SCM used_len; long zoff; SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (2, string); - /* Convert strings to UTF-8 so that non-ASCII characters are passed - through unchanged. */ - fmt = scm_to_utf8_string (format); - str = scm_to_utf8_string (string); + /* Convert strings to the locale encoding, as the underlying + 'strptime' C function expects. */ + fmt = scm_to_locale_string (format); + str = scm_to_locale_string (string); /* initialize the struct tm */ #define tm_init(field) t.field = 0 @@ -809,14 +809,14 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, zoff = 0; #endif - /* Compute the number of UTF-8 characters. */ - used_len = u8_strnlen ((uint8_t*) str, rest-str); + /* Compute the number of characters parsed. */ + used_len = scm_string_length (scm_from_locale_stringn (str, rest-str)); scm_remember_upto_here_2 (format, string); free (str); free (fmt); return scm_cons (filltime (&t, zoff, NULL), - scm_from_signed_integer (used_len)); + used_len); } #undef FUNC_NAME #endif /* HAVE_STRPTIME */ diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 0934dbb34..e15b92aff 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -196,6 +196,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/web-http.test \ tests/web-request.test \ tests/web-response.test \ + tests/web-server.test \ tests/web-uri.test EXTRA_DIST = \ diff --git a/test-suite/tests/time.test b/test-suite/tests/time.test index 2c829abfe..0291b6bdf 100644 --- a/test-suite/tests/time.test +++ b/test-suite/tests/time.test @@ -1,7 +1,7 @@ ;;;; time.test --- test suite for Guile's time functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004 ;;;; -;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2019 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 @@ -204,8 +204,9 @@ (pass-if-equal "strftime passes wide characters" "\u0100" - (let ((t (localtime (current-time)))) - (substring (strftime "\u0100%Z" t) 0 1))) + (with-locale "en_US.utf8" + (let ((t (localtime (current-time)))) + (substring (strftime "\u0100%Z" t) 0 1)))) (with-test-prefix "C99 %z format" @@ -229,7 +230,17 @@ (putenv "TZ=EST+5") (tzset) (let ((tm (localtime 86400))) - (strftime "%z" tm)))))) + (strftime "%z" tm)))) + + (pass-if-equal "strftime fr_FR.utf8" + " 1 février 1970" + (with-locale "fr_FR.utf8" + (strftime "%e %B %Y" (gmtime (* 31 24 3600))))) + + (pass-if-equal "strftime fr_FR.iso88591" ;<https://bugs.gnu.org/35920> + " 1 février 1970" + (with-locale "fr_FR.iso88591" + (strftime "%e %B %Y" (gmtime (* 31 24 3600))))))) ;;; ;;; strptime @@ -261,6 +272,22 @@ (let ((tm (car (strptime "%s" "86400")))) (eqv? 0 (tm:gmtoff tm)))) + (pass-if-equal "strftime fr_FR.utf8" + '(1 2 1999) + (with-locale "fr_FR.utf8" + (let ((tm (car (strptime "%e %B %Y" " 1 février 1999")))) + (list (tm:mday tm) + (+ 1 (tm:mon tm)) + (+ 1900 (tm:year tm)))))) + + (pass-if-equal "strftime fr_FR.iso88591" ;<https://bugs.gnu.org/35920> + '(1 2 1999) + (with-locale "fr_FR.iso88591" + (let ((tm (car (strptime "%e %B %Y" " 1 février 1999")))) + (list (tm:mday tm) + (+ 1 (tm:mon tm)) + (+ 1900 (tm:year tm)))))) + ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from ;; strptime (pass-if "gmtoff on EST+5" diff --git a/test-suite/tests/web-server.test b/test-suite/tests/web-server.test new file mode 100644 index 000000000..e2a563499 --- /dev/null +++ b/test-suite/tests/web-server.test @@ -0,0 +1,118 @@ +;;;; web-server.test --- HTTP server -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2019 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + + +(define-module (test-suite web-client) + #:use-module (web client) + #:use-module (web request) + #:use-module (web response) + #:use-module (web server) + #:use-module (web uri) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-11) + #:use-module (test-suite lib)) + +(define (handle-request request body) + (match (cons (request-method request) + (split-and-decode-uri-path + (uri-path (request-uri request)))) + (('GET) ;root + (values '((content-type . (text/plain (charset . "UTF-8")))) + "Hello, λ world!")) + (('GET "latin1") + (values '((content-type . (text/plain (charset . "ISO-8859-1")))) + "Écrit comme ça en Latin-1.")) + (('GET "user-agent") + (values '((content-type . (text/plain))) + (lambda (port) + (display (assq-ref (request-headers request) 'user-agent) + port)))) + (('GET "quit") + (values '() + (lambda (port) (pk 'quit) (throw 'quit)))) + (('GET _ ...) + (values (build-response #:code 404) "not found")) + (_ + (values (build-response #:code 403 + #:headers + '((content-type . (application/octet-stream)))) + (string->utf8 "forbidden"))))) + +(define %port-number 8885) +(define %server-base-uri "http://localhost:8885") + +(when (provided? 'threads) + ;; Run a local publishing server in a separate thread. + (call-with-new-thread + (lambda () + (run-server handle-request 'http `(#:port ,%port-number))))) + +(define-syntax-rule (expect method path code args ...) + (if (provided? 'threads) + (let-values (((response body) + (method (string-append %server-base-uri path) + #:decode-body? #t + #:keep-alive? #f args ...))) + (and (= code (response-code response)) + body)) + (throw 'unresolved))) + + +(pass-if-equal "GET /" + "Hello, λ world!" + (expect http-get "/" 200)) + +(pass-if-equal "GET /latin1" + "Écrit comme ça en Latin-1." + (expect http-get "/latin1" 200)) + +(pass-if-equal "GET /user-agent" + "GNU Guile" + (expect http-get "/user-agent" 200 + #:headers `((user-agent . "GNU Guile")))) + +(pass-if-equal "GET /does-not-exist" + "not found" + (expect http-get "/does-not-exist" 404)) + +(pass-if-equal "GET with keep-alive" + '("Hello, λ world!" + "Écrit comme ça en Latin-1." + "GNU Guile") + (if (provided? 'threads) + (let ((port (open-socket-for-uri %server-base-uri))) + (define result + (map (lambda (path) + (let-values (((response body) + (http-get (string-append %server-base-uri path) + #:port port + #:keep-alive? #t + #:headers + '((user-agent . "GNU Guile"))))) + (and (= (response-code response) 200) + body))) + '("/" "/latin1" "/user-agent"))) + (close-port port) + result))) + +(pass-if-equal "POST /" + "forbidden" + (utf8->string (expect http-post "/" 403))) |