summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-08-02 15:34:28 +0200
committerAndy Wingo <wingo@pobox.com>2019-08-02 15:34:28 +0200
commit3869cdc59d39e97467ee215e02901594520d63a8 (patch)
tree33ec6a3ceffebdee64eff0519133c7b3d802908e
parent8ee6e766b8274726b341973c4132cec137dfd013 (diff)
parentab2fd70ef1e36c6532128b73082809ef3c056556 (diff)
downloadguile-3869cdc59d39e97467ee215e02901594520d63a8.tar.gz
Merge from stable-2.2
-rw-r--r--doc/ref/posix.texi10
-rw-r--r--libguile/stime.c24
-rw-r--r--test-suite/Makefile.am1
-rw-r--r--test-suite/tests/time.test35
-rw-r--r--test-suite/tests/web-server.test118
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)))