mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

allow URIs of the form file:///etc/hosts

Browse source 
* module/web/uri.scm (parse-authority): Allow empty authorities, so that
  we accept URIs of the form, file:///etc/hosts.
* test-suite/tests/web-uri.test ("string->uri"): Add tests.
This commit is contained in:
Andy Wingo 2011-12-06 11:47:41 +01:00
parent fe0c202c0e
commit 679eea4f0e
2 changed files with 29 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

20
module/web/uri.scm
View file

@ -125,14 +125,18 @@ consistency checks to make sure that the constructed URI is valid."
userinfo-pat host-pat port-pat)))
(define (parse-authority authority fail)
(let ((m (regexp-exec authority-regexp authority)))
(if (and m (valid-host? (match:substring m 3)))
(values (match:substring m 2)
(match:substring m 3)
(let ((port (match:substring m 5)))
(and port (not (string-null? port))
(string->number port))))
(fail))))
(if (equal? authority "//")
;; Allow empty authorities: file:///etc/hosts is a synonym of
;; file:/etc/hosts.
(values #f #f #f)
(let ((m (regexp-exec authority-regexp authority)))
(if (and m (valid-host? (match:substring m 3)))
(values (match:substring m 2)
(match:substring m 3)
(let ((port (match:substring m 5)))
(and port (not (string-null? port))
(string->number port))))
(fail)))))
;;; RFC 3986, #3.

19
test-suite/tests/web-uri.test
View file

@ -1,6 +1,6 @@
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2010, 2011 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
@ -150,7 +150,22 @@
(not (string->uri "http://:10")))
(pass-if "http://foo@"
(not (string->uri "http://foo@"))))
(not (string->uri "http://foo@")))
(pass-if "file:/"
(uri=? (string->uri "file:/")
#:scheme 'file
#:path "/"))
(pass-if "file:/etc/hosts"
(uri=? (string->uri "file:/etc/hosts")
#:scheme 'file
#:path "/etc/hosts"))
(pass-if "file:///etc/hosts"
(uri=? (string->uri "file:///etc/hosts")
#:scheme 'file
#:path "/etc/hosts")))
(with-test-prefix "uri->string"
(pass-if "ftp:"