Merge from stable-2.2

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:

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 */

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 = \

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"

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)))