[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-23-g449ca87
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-23-g449ca87 |
|
Date: |
Tue, 15 Jan 2013 15:41:05 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=449ca87bdb5ba9ad384c32a306e36c2946c5b832
The branch, master has been updated
via 449ca87bdb5ba9ad384c32a306e36c2946c5b832 (commit)
via e5cef86e9c8169bed78cb894a17a68ab014560ae (commit)
via 686df5162d17d976a0aa7eec75fed42fb3e23eee (commit)
via b39685c6da974d5edc5629495c559ab8e1137103 (commit)
via d1b9f8ace937085e084e0d9afbbc5e2944141413 (commit)
via e2551947dd94bdd8ecde441b19884c4730d0ee3b (commit)
via 93c4fa21745d31812b2f5a225f407e5f1b0e3665 (commit)
via 08467a7e6116de5e21e9622b79657e113ce4b072 (commit)
via 99d716b6f681f5d39288efffd0ee534bb9866fa9 (commit)
via 8c76a8971ba92ebdf657199b74506f607987b523 (commit)
via b4fa6cc90961c87b28e26b469863f19a1be26ce2 (commit)
via 18c5bffe96947ee82a29b115e758d7357cefbbe9 (commit)
via 5ed4ea90a9abe64c024bbc0c664476b0673556b3 (commit)
via 990b11c53f8da2a6c14e1190bc4e76939db32d07 (commit)
via 2ac3c0a590ec93f40b2c1ce34bd24b83f1ae1a5d (commit)
via 67e5ab8ac64dffe814e1ea3b08eeab679899b924 (commit)
via 8cb9a30c17827bc875516b2abedee36a05f886e0 (commit)
via f05bb8494c9636cd7a44aaf7d4e08f4b66004b6e (commit)
via b194b59fa10574868f7b1663a1f2d447baa18c5e (commit)
via 921cd222b992f719dc870239bc196688b8d3d507 (commit)
via 03a2f59851ff9e9ae751c92c5608ef2a197c4938 (commit)
via ed3e8b8e06adaaa1df5085a0f730d42efa3f5c30 (commit)
via 4dbac5e08b13e4aa4ddb40e16034605757057290 (commit)
from e0c211bb2e80605b4ae3fb121c34136f6e266b70 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 449ca87bdb5ba9ad384c32a306e36c2946c5b832
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 15:09:48 2013 +0100
ASCII is not ISO-8859-1
* libguile/ports.c (scm_i_set_default_port_encoding): An encoding of
ASCII is not the same as ISO-8859-1, because it does not allow
characters above 128. Fix this.
commit e5cef86e9c8169bed78cb894a17a68ab014560ae
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 15:08:20 2013 +0100
fix string->bytevector for utf-8 and non-error conversion strategies
* module/ice-9/iconv.scm (call-with-encoded-output-string):
(string->bytevector, bytevector->string): Only call string->utf8 and
utf8->string if the conversion strategy is `error'.
commit 686df5162d17d976a0aa7eec75fed42fb3e23eee
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 15:07:15 2013 +0100
string->utf8 implementation uses scm_from_utf8_stringn
* libguile/bytevectors.c (UTF_TO_STRING): Use scm_from_utf8_stringn.
commit b39685c6da974d5edc5629495c559ab8e1137103
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 15:06:37 2013 +0100
scm_from_stringn and scm_to_stringn encoding args are never NULL
* libguile/strings.c (scm_from_stringn, scm_to_stringn): Encoding
argument cannot be NULL. Instead check that the encoding was
ISO-8859-1.
commit d1b9f8ace937085e084e0d9afbbc5e2944141413
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 15:05:40 2013 +0100
Port encodings cannot be NULL
* libguile/ports.c (scm_c_read_unlocked, scm_ungetc_unlocked):
* libguile/read.c (scm_read_character):
* libguile/vports.c (sf_fill_input): Port encodings cannot be NULL any
more, now that encodings are canonicalized, so simplify these.
commit e2551947dd94bdd8ecde441b19884c4730d0ee3b
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 16:28:22 2013 +0100
All r6rs ports are both textual and binary
* module/rnrs/io/ports.scm (binary-port?): All ports are binary _and_
textual. Bytevectors and strings may be written to or read from
either.
(port-transcoder): All textual ports (all ports) have transcoders of
some sort.
* test-suite/tests/r6rs-ports.test ("8.2.6 Input and output ports"):
Remove test that binary ports don't have transcoders, because binary
ports are also textual.
commit 93c4fa21745d31812b2f5a225f407e5f1b0e3665
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 14:31:49 2013 +0100
Port encodings are case-insensitive, but normalized to upper-case.
* libguile/ports.c (ascii_toupper, encoding_matches)
(canonicalize_encoding): New helpers.
(scm_c_make_port_with_encoding):
(scm_i_set_default_port_encoding):
(scm_i_set_port_encoding_x): Use the new helpers to be
case-insensitive and also to canonicalize the internal representation
to upper-case ASCII names.
(scm_i_default_port_encoding): Never return NULL.
(scm_port_encoding): The encoding is always a string.
* libguile/read.c (scm_i_scan_for_encoding): Use a locale-independent
check instead of isalnum. Don't upcase the result: the port code will
handle that.
* test-suite/tests/web-response.test ("example-1"): Adapt test to expect
normalized (upper-case) encoding for the response port.
commit 08467a7e6116de5e21e9622b79657e113ce4b072
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 14:41:26 2013 +0100
add scm_from_port_string and friends
* doc/ref/api-data.texi (Conversion to/from C):
* libguile/strings.h:
* libguile/strings.c (scm_from_port_string, scm_from_port_stringn):
(scm_to_port_string, scm_to_port_stringn): New functions.
* guile-readline/readline.c (internal_readline):
* libguile/strports.c (scm_strport_to_string):
* libguile/read.c (scm_read_number, scm_read_mixed_case_symbol):
(scm_read_number_and_radix, scm_read_character): Use the new
functions.
commit 99d716b6f681f5d39288efffd0ee534bb9866fa9
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 16:26:06 2013 +0100
UTF-8 string ports in ecmascript test
* test-suite/tests/ecmascript.test (eread, eread/1): Make sure we can
render the temporary string ports by specifying UTF-8.
commit 8c76a8971ba92ebdf657199b74506f607987b523
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 11:01:10 2013 +0100
fix bug where scm_from_utf8_stringn would not detect bad utf-8
* libguile/strings.c (scm_from_utf8_stringn):
* libguile/symbols.c (utf8_string_equals_wide_string): The "bad UTF8"
return from u8_mbtouc is a 0xfffd character, not a negative byte
length. Fixes a bug in which invalid UTF-8 would not be caught.
* libguile/bytevectors.c (scm_utf8_to_string): Use scm_from_utf8_stringn
directly. Just a little cleanup.
* test-suite/tests/iconv.test ("narrow non-ascii string"): Add test for
parsing bad utf-8 with substitution.
commit b4fa6cc90961c87b28e26b469863f19a1be26ce2
Merge: e0c211b 18c5bff
Author: Andy Wingo <address@hidden>
Date: Tue Jan 15 10:45:39 2013 +0100
Merge remote-tracking branch 'origin/stable-2.0'
There is a failing test due to a scm_from_utf8_stringn bug brought out
by the iconv test that will be fixed in the next commit.
Conflicts:
libguile/deprecated.h
module/ice-9/deprecated.scm
-----------------------------------------------------------------------
Summary of changes:
doc/guile-api.alist | 1 -
doc/ref/api-data.texi | 99 ++++++-
doc/ref/api-procedures.texi | 22 +-
doc/ref/web.texi | 66 +++-
guile-readline/readline.c | 9 +-
libguile/__scm.h | 2 +-
libguile/bytevectors.c | 8 +-
libguile/deprecated.h | 3 +-
libguile/feature.c | 2 +-
libguile/ports.c | 134 +++++----
libguile/posix.c | 25 +--
libguile/read.c | 38 ++--
libguile/strings.c | 51 +++-
libguile/strings.h | 7 +-
libguile/strports.c | 5 +-
libguile/symbols.c | 4 +-
libguile/vports.c | 4 +-
module/Makefile.am | 3 +-
module/ice-9/deprecated.scm | 2 +-
module/ice-9/iconv.scm | 95 ++++++
module/ice-9/popen.scm | 18 +-
module/ice-9/slib.scm | 37 +--
module/rnrs/io/ports.scm | 30 +-
module/web/client.scm | 327 +++++++++++++++++----
module/web/http.scm | 23 +-
module/web/response.scm | 10 +-
module/web/server.scm | 40 +---
test-suite/Makefile.am | 3 +-
test-suite/tests/ecmascript.test | 8 +-
test-suite/tests/iconv.test | 125 ++++++++
test-suite/tests/r6rs-ports.test | 3 -
test-suite/tests/regexp.test | 23 +-
test-suite/tests/web-client.test | 577 ++++++++++++++++++++++++++++++++++++
test-suite/tests/web-response.test | 4 +-
34 files changed, 1484 insertions(+), 324 deletions(-)
create mode 100644 module/ice-9/iconv.scm
create mode 100644 test-suite/tests/iconv.test
create mode 100644 test-suite/tests/web-client.test
diff --git a/doc/guile-api.alist b/doc/guile-api.alist
index 5f73cae..5830c91 100644
--- a/doc/guile-api.alist
+++ b/doc/guile-api.alist
@@ -466,7 +466,6 @@
(char-ci=? (groups Scheme) (scan-data "#<primitive-procedure char-ci=?>"))
(char-ci>=? (groups Scheme) (scan-data "#<primitive-procedure char-ci>=?>"))
(char-ci>? (groups Scheme) (scan-data "#<primitive-procedure char-ci>?>"))
-(char-code-limit (groups Scheme) (scan-data ""))
(char-downcase (groups Scheme) (scan-data "#<primitive-procedure
char-downcase>"))
(char-is-both? (groups Scheme) (scan-data "#<primitive-procedure
char-is-both?>"))
(char-lower-case? (groups Scheme) (scan-data "#<primitive-procedure
char-lower-case?>"))
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 6d8de2b..28160c8 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010, 2011, 2012
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010, 2011, 2012, 2013
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -2881,6 +2881,7 @@ Guile provides all procedures of SRFI-13 and a few more.
* Reversing and Appending Strings:: Appending strings to form a new string.
* Mapping Folding and Unfolding:: Iterating over strings.
* Miscellaneous String Operations:: Replicating, insertion, parsing, ...
+* Representing Strings as Bytes:: Encoding and decoding strings.
* Conversion to/from C::
* String Internals:: The storage strategy for strings.
@end menu
@@ -4163,6 +4164,76 @@ a predicate, if it is a character, it is tested for
equality and if it
is a character set, it is tested for membership.
@end deffn
address@hidden Representing Strings as Bytes
address@hidden Representing Strings as Bytes
+
+Out in the cold world outside of Guile, not all strings are treated in
+the same way. Out there there are only bytes, and there are many ways
+of representing a strings (sequences of characters) as binary data
+(sequences of bytes).
+
+As a user, usually you don't have to think about this very much. When
+you type on your keyboard, your system encodes your keystrokes as bytes
+according to the locale that you have configured on your computer.
+Guile uses the locale to decode those bytes back into characters --
+hopefully the same characters that you typed in.
+
+All is not so clear when dealing with a system with multiple users, such
+as a web server. Your web server might get a request from one user for
+data encoded in the ISO-8859-1 character set, and then another request
+from a different user for UTF-8 data.
+
address@hidden iconv
address@hidden character encoding
+Guile provides an @dfn{iconv} module for converting between strings and
+sequences of bytes. @xref{Bytevectors}, for more on how Guile
+represents raw byte sequences. This module gets its name from the
+common @sc{unix} command of the same name.
+
+Note that often it is sufficient to just read and write strings from
+ports instead of using these functions. To do this, specify the port
+encoding using @code{set-port-encoding!}. @xref{Ports}, for more on
+ports and character encodings.
+
+Unlike the rest of the procedures in this section, you have to load the
address@hidden module before having access to these procedures:
+
address@hidden
+(use-modules (ice-9 iconv))
address@hidden example
+
address@hidden string->bytevector string encoding [conversion-strategy]
+Encode @var{string} as a sequence of bytes.
+
+The string will be encoded in the character set specified by the
address@hidden string. If the string has characters that cannot be
+represented in the encoding, by default this procedure raises an
address@hidden Pass a @var{conversion-strategy} argument to
+specify other behaviors.
+
+The return value is a bytevector. @xref{Bytevectors}, for more on
+bytevectors. @xref{Ports}, for more on character encodings and
+conversion strategies.
address@hidden deffn
+
address@hidden bytevector->string bytevector encoding [conversion-strategy]
+Decode @var{bytevector} into a string.
+
+The bytes will be decoded from the character set by the @var{encoding}
+string. If the bytes do not form a valid encoding, by default this
+procedure raises an @code{decoding-error}. As with
address@hidden>bytevector}, pass the optional @var{conversion-strategy}
+argument to modify this behavior. @xref{Ports}, for more on character
+encodings and conversion strategies.
address@hidden deffn
+
address@hidden call-with-output-encoded-string encoding proc
[conversion-strategy]
+Like @code{call-with-output-string}, but instead of returning a string,
+returns a encoding of the string according to @var{encoding}, as a
+bytevector. This procedure can be more efficient than collecting a
+string and then converting it via @code{string->bytevector}.
address@hidden deffn
+
@node Conversion to/from C
@subsubsection Conversion to/from C
@@ -4172,9 +4243,9 @@ important.
In C, a string is just a sequence of bytes, and the character encoding
describes the relation between these bytes and the actual characters
-that make up the string. For Scheme strings, character encoding is
-not an issue (most of the time), since in Scheme you never get to see
-the bytes, only the characters.
+that make up the string. For Scheme strings, character encoding is not
+an issue (most of the time), since in Scheme you usually treat strings
+as character sequences, not byte sequences.
Converting to C and converting from C each have their own challenges.
@@ -4305,6 +4376,9 @@ into @var{encoding}.
If @var{lenp} is @code{NULL}, this function will return a null-terminated C
string. It will throw an error if the string contains a null
character.
+
+The Scheme interface to this function is @code{string->bytevector}, from the
address@hidden iconv} module. @xref{Representing Strings as Bytes}.
@end deftypefn
@deftypefn {C Function} SCM scm_from_stringn (const char *str, size_t len,
const char *encoding, scm_t_string_failed_conversion_handler handler)
@@ -4313,6 +4387,9 @@ length in bytes of the C string is input as @var{len}.
The encoding of the C
string is passed as the ASCII, null-terminated C string @code{encoding}.
The @var{handler} parameters suggests a strategy for dealing with
unconvertable characters.
+
+The Scheme interface to this function is @code{bytevector->string}.
address@hidden Strings as Bytes}.
@end deftypefn
The following conversion functions are provided as a convenience for the
@@ -4351,6 +4428,19 @@ returned is the number of bytes for
@code{scm_to_latin1_stringn} and
for @code{scm_to_utf32_stringn}.
@end deftypefn
+It is not often the case, but sometimes when you are dealing with the
+implementation details of a port, you need to encode and decode strings
+according to the encoding and conversion strategy of the port. There
+are some convenience functions for that purpose as well.
+
address@hidden {C Function} SCM scm_from_port_string (const char *str, SCM port)
address@hidden {C Function} SCM scm_from_port_stringn (const char *str, size_t
len, SCM port)
address@hidden {C Function} char* scm_to_port_string (SCM str, SCM port)
address@hidden {C Function} char* scm_to_port_stringn (SCM str, size_t *lenp,
SCM port)
+Like @code{scm_from_stringn} and friends, except they take their
+encoding and conversion strategy from a given port object.
address@hidden deftypefn
+
@node String Internals
@subsubsection String Internals
@@ -4810,6 +4900,7 @@ the host's native endianness.
Bytevector contents can also be interpreted as Unicode strings encoded
in one of the most commonly available encoding formats.
address@hidden Strings as Bytes}, for a more generic interface.
@lisp
(utf8->string (u8-list->bytevector '(99 97 102 101)))
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index d77a2bd..e749fdc 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -274,7 +274,9 @@ sense at certain points in the program, delimited by these
Return an association list describing the arguments that @var{program}
accepts, or
@code{#f} if the information cannot be obtained.
-For example:
+The alist keys that are currently defined are `required', `optional',
+`keyword', `allow-other-keys?', and `rest'. For example:
+
@example
(program-arguments-alist
(lambda* (a b #:optional c #:key (d 1) #:rest e)
@@ -285,17 +287,19 @@ For example:
(allow-other-keys? . #f)
(rest . d))
@end example
address@hidden deffn
-The alist keys that are currently defined are `required', `optional',
-`keyword', `allow-other-keys?', and `rest'.
address@hidden {Scheme Procedure} program-lambda-list program [ip]
+Return a representation of the arguments of @var{program} as a lambda
+list, or @code{#f} if this information is not available.
address@hidden {Scheme Procedure} program-lambda-list program [ip]
-Accessors for a representation of the arguments of a program, with both
-names and types (ie. either required, optional or keywords)
+For example:
address@hidden returns this information in the form of
-an association list while @code{program-lambda-list} returns the same
-information in a form similar to a lambda definition.
address@hidden
+(program-lambda-alist
+ (lambda* (a b #:optional c #:key (d 1) #:rest e)
+ #t)) @result{}
address@hidden example
@end deffn
@node Optional Arguments
diff --git a/doc/ref/web.texi b/doc/ref/web.texi
index e892453..0f69089 100644
--- a/doc/ref/web.texi
+++ b/doc/ref/web.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
address@hidden Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
@c See the file guile.texi for copying conditions.
@node Web
@@ -1388,23 +1388,59 @@ the lower-level HTTP, request, and response modules.
Return an open input/output port for a connection to URI.
@end deffn
address@hidden {Scheme Procedure} http-get uri [#:port=(open-socket-for-uri
uri)] [#:version='(1 . 1)] [#:keep-alive?=#f] [#:extra-headers='()]
[#:decode-body?=#t]
-Connect to the server corresponding to @var{uri} and ask for the
-resource, using the @code{GET} method. If you already have a port open,
-pass it as @var{port}. The port will be closed at the end of the
-request unless @var{keep-alive?} is true. Any extra headers in the
-alist @var{extra-headers} will be added to the request.
address@hidden {Scheme Procedure} http-get uri arg...
address@hidden {Scheme Procedure} http-head uri arg...
address@hidden {Scheme Procedure} http-post uri arg...
address@hidden {Scheme Procedure} http-put uri arg...
address@hidden {Scheme Procedure} http-delete uri arg...
address@hidden {Scheme Procedure} http-trace uri arg...
address@hidden {Scheme Procedure} http-options uri arg...
+
+Connect to the server corresponding to @var{uri} and make a request over
+HTTP, using the appropriate method (@code{GET}, @code{HEAD}, etc.).
+
+All of these procedures have the same prototype: a URI followed by an
+optional sequence of keyword arguments. These keyword arguments allow
+you to modify the requests in various ways, for example attaching a body
+to the request, or setting specific headers. The following table lists
+the keyword arguments and their default values.
+
address@hidden @code
address@hidden #:body #f
address@hidden #:port (open-socket-for-uri @var{uri})]
address@hidden #:version '(1 . 1)
address@hidden #:keep-alive? #f
address@hidden #:headers '()
address@hidden #:decode-body? #t
address@hidden #:streaming? #f
address@hidden table
+
+If you already have a port open, pass it as @var{port}. Otherwise, a
+connection will be opened to the server corresponding to @var{uri}. Any
+extra headers in the alist @var{headers} will be added to the request.
+
+If @var{body} is not #f, a message body will also be sent with the HTTP
+request. If @var{body} is a string, it is encoded according to the
+content-type in @var{headers}, defaulting to UTF-8. Otherwise
address@hidden should be a bytevector, or @code{#f} for no body. Although a
+message body may be sent with any request, usually only @code{POST} and
address@hidden requests have bodies.
If @var{decode-body?} is true, as is the default, the body of the
response will be decoded to string, if it is a textual content-type.
Otherwise it will be returned as a bytevector.
address@hidden deffn
address@hidden {Scheme Procedure} http-get* uri [#:port=(open-socket-for-uri
uri)] [#:version='(1 . 1)] [#:keep-alive?=#f] [#:extra-headers='()]
[#:decode-body?=#t]
-Like @code{http-get}, but return an input port from which to read. When
address@hidden is true, as is the default, the returned port has its
-encoding set appropriately if the data at @var{uri} is textual. Closing the
-returned port closes @var{port}, unless @var{keep-alive?} is true.
+However, if @var{streaming?} is true, instead of eagerly reading the
+response body from the server, this function only reads off the headers.
+The response body will be returned as a port on which the data may be
+read.
+
+Unless @var{keep-alive?} is true, the port will be closed after the full
+response body has been read.
+
+Returns two values: the response read from the server, and the response
+body as a string, bytevector, #f value, or as a port (if
address@hidden is true).
@end deffn
@code{http-get} is useful for making one-off requests to web sites. If
@@ -1415,10 +1451,6 @@ fetcher, similar in structure to the web server
(@pxref{Web Server}).
Another option, good but not as performant, would be to use threads,
possibly via par-map or futures.
-More helper procedures for the other common HTTP verbs would be a good
-addition to this module. Send your code to
address@hidden@@gnu.org}.
-
@node Web Server
@subsection Web Server
diff --git a/guile-readline/readline.c b/guile-readline/readline.c
index 0e4ad29..1e697eb 100644
--- a/guile-readline/readline.c
+++ b/guile-readline/readline.c
@@ -1,6 +1,6 @@
/* readline.c --- line editing support for Guile */
-/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
+/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, 2009,
2010, 2013 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -257,12 +257,7 @@ internal_readline (SCM text)
promptp = 1;
s = readline (prompt);
if (s)
- {
- scm_t_port *pt = SCM_PTAB_ENTRY (output_port);
-
- ret = scm_from_stringn (s, strlen (s), pt->encoding,
- SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
- }
+ ret = scm_from_port_string (s, output_port);
else
ret = SCM_EOF_VAL;
diff --git a/libguile/__scm.h b/libguile/__scm.h
index da11858..b42b823 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -4,7 +4,7 @@
#define SCM___SCM_H
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2006,
- * 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2007, 2008, 2009, 2010, 2011, 2012, 2013 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
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index db132d4..9093f49 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010, 2011, 2012, 2013 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
@@ -2028,8 +2028,7 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32",
scm_list_1 (utf), err); \
else \
{ \
- str = scm_from_stringn (c_str, c_strlen, "UTF-8", \
- SCM_FAILED_CONVERSION_ERROR); \
+ str = scm_from_utf8_stringn (c_str, c_strlen); \
free (c_str); \
} \
return (str);
@@ -2050,8 +2049,7 @@ SCM_DEFINE (scm_utf8_to_string, "utf8->string",
c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
- str = scm_from_stringn (c_utf, c_utf_len, "UTF-8",
- SCM_FAILED_CONVERSION_ERROR);
+ str = scm_from_utf8_stringn (c_utf, c_utf_len);
return (str);
}
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 8588c19..d02fc79 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -5,7 +5,7 @@
#ifndef SCM_DEPRECATED_H
#define SCM_DEPRECATED_H
-/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011, 2012 Free
Software Foundation, Inc.
+/* Copyright (C) 2003,2004, 2005, 2006, 2007, 2009, 2010, 2011, 2012, 2013
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
@@ -92,6 +92,7 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard
before,
scm_cons ((e0),\
SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8)))
+#define SCM_CHAR_CODE_LIMIT SCM_CHAR_CODE_LIMIT__GONE__REPLACE_WITH__256L
#define SCM_OPDIRP SCM_OPDIRP__GONE__REPLACE_WITH__SCM_DIRP_and_SCM_DIR_OPEN_P
#define SCM_PROCEDURE SCM_PROCEDURE__GONE__REPLACE_WITH__scm_procedure
#define SCM_PROCEDURE_WITH_SETTER_P
SCM_PROCEDURE_WITH_SETTER_P__GONE__REPLACE_WITH__scm_is_true__scm_procedure_with_setter_p
diff --git a/libguile/feature.c b/libguile/feature.c
index c11cb5e..9eb82ee 100644
--- a/libguile/feature.c
+++ b/libguile/feature.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
- * 2006, 2007, 2009, 2011 Free Software Foundation, Inc.
+ * 2006, 2007, 2009, 2011, 2013 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
diff --git a/libguile/ports.c b/libguile/ports.c
index e7187d3..0aacacc 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -90,6 +90,56 @@
#endif
+/* Port encodings are case-insensitive ASCII strings. */
+static char
+ascii_toupper (char c)
+{
+ return (c < 'a' || c > 'z') ? c : ('A' + (c - 'a'));
+}
+
+/* It is only necessary to use this function on encodings that come from
+ the user and have not been canonicalized yet. Encodings that are set
+ on ports or in the default encoding fluid are in upper-case, and can
+ be compared with strcmp. */
+static int
+encoding_matches (const char *enc, const char *upper)
+{
+ if (!enc)
+ enc = "ISO-8859-1";
+
+ while (*enc)
+ if (ascii_toupper (*enc++) != *upper++)
+ return 0;
+
+ return !*upper;
+}
+
+static char*
+canonicalize_encoding (const char *enc)
+{
+ char *ret;
+ int i;
+
+ if (!enc)
+ return "ISO-8859-1";
+
+ ret = scm_gc_strdup (enc, "port");
+
+ for (i = 0; ret[i]; i++)
+ {
+ if (ret[i] > 127)
+ /* Restrict to ASCII. */
+ scm_misc_error (NULL, "invalid character encoding ~s",
+ scm_list_1 (scm_from_latin1_string (enc)));
+ else
+ ret[i] = ascii_toupper (ret[i]);
+ }
+
+ return ret;
+}
+
+
+
/* The port kind table --- a dynamically resized array of port types. */
@@ -603,13 +653,23 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned
long mode_bits,
entry->rw_active = SCM_PORT_NEITHER;
entry->port = ret;
entry->stream = stream;
- entry->encoding = encoding ? scm_gc_strdup (encoding, "port") : NULL;
- if (encoding && strcmp (encoding, "UTF-8") == 0)
- entry->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
- else if (!encoding || strcmp (encoding, "ISO-8859-1") == 0)
- entry->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+
+ if (encoding_matches (encoding, "UTF-8"))
+ {
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ entry->encoding = "UTF-8";
+ }
+ else if (encoding_matches (encoding, "ISO-8859-1"))
+ {
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+ entry->encoding = "ISO-8859-1";
+ }
else
- entry->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ {
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ entry->encoding = canonicalize_encoding (encoding);
+ }
+
entry->ilseq_handler = handler;
entry->iconv_descriptors = NULL;
@@ -806,44 +866,28 @@ scm_i_set_default_port_encoding (const char *encoding)
scm_misc_error (NULL, "tried to set port encoding fluid before it is
initialized",
SCM_EOL);
- if (encoding == NULL
- || !strcmp (encoding, "ASCII")
- || !strcmp (encoding, "ANSI_X3.4-1968")
- || !strcmp (encoding, "ISO-8859-1"))
+ if (encoding_matches (encoding, "ISO-8859-1"))
scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
else
- {
- SCM str;
- size_t i;
-
- str = scm_from_latin1_string (encoding);
-
- /* Restrict to ASCII. */
- for (i = 0; encoding[i]; i++)
- if (encoding[i] > 127)
- scm_misc_error ("scm_i_set_default_port_encoding",
- "invalid character encoding ~s", scm_list_1 (str));
-
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), str);
- }
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
+ scm_from_latin1_string (canonicalize_encoding
(encoding)));
}
-/* Return the name of the default encoding for newly created ports; a
- return value of NULL means "ISO-8859-1". */
+/* Return the name of the default encoding for newly created ports. */
const char *
scm_i_default_port_encoding (void)
{
if (!scm_port_encoding_init)
- return NULL;
+ return "ISO-8859-1";
else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
- return NULL;
+ return "ISO-8859-1";
else
{
SCM encoding;
encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
if (!scm_is_string (encoding))
- return NULL;
+ return "ISO-8859-1";
else
return scm_i_string_chars (encoding);
}
@@ -1041,13 +1085,13 @@ scm_i_set_port_encoding_x (SCM port, const char
*encoding)
pt = SCM_PTAB_ENTRY (port);
prev = pt->iconv_descriptors;
- if (encoding && strcmp (encoding, "UTF-8") == 0)
+ if (encoding_matches (encoding, "UTF-8"))
{
pt->encoding = "UTF-8";
pt->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
pt->iconv_descriptors = NULL;
}
- else if (!encoding || strcmp (encoding, "ISO-8859-1") == 0)
+ else if (encoding_matches (encoding, "ISO-8859-1"))
{
pt->encoding = "ISO-8859-1";
pt->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
@@ -1056,11 +1100,12 @@ scm_i_set_port_encoding_x (SCM port, const char
*encoding)
else
{
/* Open descriptors before mutating the port. */
+ char *gc_encoding = canonicalize_encoding (encoding);
pt->iconv_descriptors =
- open_iconv_descriptors (encoding,
+ open_iconv_descriptors (gc_encoding,
SCM_INPUT_PORT_P (port),
SCM_OUTPUT_PORT_P (port));
- pt->encoding = scm_gc_strdup (encoding, "port");
+ pt->encoding = gc_encoding;
pt->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
}
@@ -1074,17 +1119,9 @@ SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
"uses to interpret its input and output.\n")
#define FUNC_NAME s_scm_port_encoding
{
- scm_t_port *pt;
- const char *enc;
-
SCM_VALIDATE_PORT (1, port);
- pt = SCM_PTAB_ENTRY (port);
- enc = pt->encoding;
- if (enc)
- return scm_from_latin1_string (pt->encoding);
- else
- return SCM_BOOL_F;
+ return scm_from_latin1_string (SCM_PTAB_ENTRY (port)->encoding);
}
#undef FUNC_NAME
@@ -1333,7 +1370,8 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size)
requested number of bytes. (Note that a single scm_fill_input
call does not guarantee to fill the whole of the port's read
buffer.) */
- if (pt->read_buf_size <= 1 && pt->encoding == NULL)
+ if (pt->read_buf_size <= 1
+ && pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
{
/* The port that we are reading from is unbuffered - i.e. does
not have its own persistent buffer - but we have a buffer,
@@ -1878,17 +1916,11 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port)
scm_t_port *pt = SCM_PTAB_ENTRY (port);
char *result;
char result_buf[10];
- const char *encoding;
size_t len;
int i;
- if (pt->encoding != NULL)
- encoding = pt->encoding;
- else
- encoding = "ISO-8859-1";
-
len = sizeof (result_buf);
- result = u32_conv_to_encoding (encoding,
+ result = u32_conv_to_encoding (pt->encoding,
(enum iconv_ilseq_handler) pt->ilseq_handler,
(uint32_t *) &c, 1, NULL,
result_buf, &len);
diff --git a/libguile/posix.c b/libguile/posix.c
index baa711b..7c87f3f 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software
Foundation, Inc.
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -1364,7 +1364,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
if (pid)
/* Parent. */
{
- SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F, port;
+ SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F;
/* There is no sense in catching errors on close(). */
if (reading)
@@ -1380,25 +1380,8 @@ scm_open_process (SCM mode, SCM prog, SCM args)
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));
+ return scm_values
+ (scm_list_3 (read_port, write_port, scm_from_int (pid)));
}
/* The child. */
diff --git a/libguile/read.c b/libguile/read.c
index d977cff..7c003b4 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -25,7 +25,6 @@
#endif
#include <stdio.h>
-#include <ctype.h>
#include <string.h>
#include <unistd.h>
#include <unicase.h>
@@ -704,7 +703,6 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts
*opts)
SCM result, str = SCM_EOL;
char local_buffer[READER_BUFFER_SIZE], *buffer;
size_t bytes_read;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
@@ -714,7 +712,7 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts
*opts)
buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&bytes_read);
- str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, bytes_read, port);
result = scm_string_to_number (str, SCM_UNDEFINED);
if (scm_is_false (result))
@@ -739,7 +737,6 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
size_t bytes_read;
int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX);
char local_buffer[READER_BUFFER_SIZE], *buffer;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
scm_ungetc_unlocked (chr, port);
@@ -750,8 +747,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
if (postfix && ends_with_colon && (bytes_read > 1))
{
- str = scm_from_stringn (buffer, bytes_read - 1,
- pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, bytes_read - 1, port);
if (opts->case_insensitive_p)
str = scm_string_downcase_x (str);
@@ -759,8 +755,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
}
else
{
- str = scm_from_stringn (buffer, bytes_read,
- pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, bytes_read, port);
if (opts->case_insensitive_p)
str = scm_string_downcase_x (str);
@@ -780,7 +775,6 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
char local_buffer[READER_BUFFER_SIZE], *buffer;
unsigned int radix;
SCM str;
- scm_t_port *pt;
switch (chr)
{
@@ -813,8 +807,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&read);
- pt = SCM_PTAB_ENTRY (port);
- str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler);
+ str = scm_from_port_stringn (buffer, read, port);
result = scm_string_to_number (str, scm_from_uint (radix));
@@ -998,7 +991,9 @@ scm_read_character (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
/* Simple ASCII characters can be processed immediately. Also, simple
ISO-8859-1 characters can be processed immediately if the encoding for
this
port is ISO-8859-1. */
- if (bytes_read == 1 && ((unsigned char) buffer[0] <= 127 || pt->encoding ==
NULL))
+ if (bytes_read == 1 &&
+ ((unsigned char) buffer[0] <= 127
+ || pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1))
{
SCM_COL (port) += 1;
return SCM_MAKE_CHAR (buffer[0]);
@@ -1006,8 +1001,7 @@ scm_read_character (scm_t_wchar chr, SCM port,
scm_t_read_opts *opts)
/* Otherwise, convert the buffer into a proper scheme string for
processing. */
- charname = scm_from_stringn (buffer, bytes_read, pt->encoding,
- pt->ilseq_handler);
+ charname = scm_from_port_stringn (buffer, bytes_read, port);
charname_len = scm_i_string_length (charname);
SCM_COL (port) += charname_len;
cp = scm_i_string_ref (charname, 0);
@@ -1956,6 +1950,15 @@ scm_get_hash_procedure (int c)
#define SCM_ENCODING_SEARCH_SIZE (500)
+static int
+is_encoding_char (char c)
+{
+ if (c >= 'a' && c <= 'z') return 1;
+ if (c >= 'A' && c <= 'Z') return 1;
+ if (c >= '0' && c <= '9') return 1;
+ return strchr ("_-.:/,+=()", c) != NULL;
+}
+
/* Search the first few hundred characters of a file for an Emacs-like coding
declaration. Returns either NULL or a string whose storage has been
allocated with `scm_gc_malloc ()'. */
@@ -2041,8 +2044,7 @@ scm_i_scan_for_encoding (SCM port)
i = 0;
while (encoding_start + i - header <= SCM_ENCODING_SEARCH_SIZE
&& encoding_start + i - header < bytes_read
- && (isalnum ((int) encoding_start[i])
- || strchr ("_-.:/,+=()", encoding_start[i]) != NULL))
+ && is_encoding_char (encoding_start[i]))
i++;
encoding_length = i;
@@ -2050,8 +2052,6 @@ scm_i_scan_for_encoding (SCM port)
return NULL;
encoding = scm_gc_strndup (encoding_start, encoding_length, "encoding");
- for (i = 0; i < encoding_length; i++)
- encoding[i] = toupper ((int) encoding[i]);
/* push backwards to make sure we were in a comment */
in_comment = 0;
@@ -2083,7 +2083,7 @@ scm_i_scan_for_encoding (SCM port)
/* This wasn't in a comment */
return NULL;
- if (utf8_bom && strcmp(encoding, "UTF-8"))
+ if (utf8_bom && strcasecmp (encoding, "UTF-8"))
scm_misc_error (NULL,
"the port input declares the encoding ~s but is encoded as
UTF-8",
scm_list_1 (scm_from_locale_string (encoding)));
diff --git a/libguile/strings.c b/libguile/strings.c
index 5130cb3..85a6c48 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011,
2012 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011,
2012, 2013 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
@@ -1524,9 +1524,10 @@ scm_from_stringn (const char *str, size_t len, const
char *encoding,
if (len == (size_t) -1)
len = strlen (str);
- if (encoding == NULL || len == 0)
+ if (strcmp (encoding, "ISO-8859-1") == 0 || len == 0)
return scm_from_latin1_stringn (str, len);
- else if (strcmp (encoding, "UTF-8") == 0)
+ else if (strcmp (encoding, "UTF-8") == 0
+ && handler == SCM_FAILED_CONVERSION_ERROR)
return scm_from_utf8_stringn (str, len);
u32len = 0;
@@ -1639,7 +1640,7 @@ scm_from_utf8_stringn (const char *str, size_t len)
nbytes = u8_mbtouc (&c, ustr + i, len - i);
- if (nbytes < 0)
+ if (c == 0xfffd)
/* Bad UTF-8. */
decoding_error (__func__, errno, str, len);
@@ -1711,6 +1712,26 @@ scm_from_utf32_stringn (const scm_t_wchar *str, size_t
len)
return result;
}
+SCM
+scm_from_port_string (const char *str, SCM port)
+{
+ return scm_from_port_stringn (str, -1, port);
+}
+
+SCM
+scm_from_port_stringn (const char *str, size_t len, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+ return scm_from_latin1_stringn (str, len);
+ else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
+ && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR)
+ return scm_from_utf8_stringn (str, len);
+ else
+ return scm_from_stringn (str, len, pt->encoding, pt->ilseq_handler);
+}
+
/* Create a new scheme string from the C string STR. The memory of
STR may be used directly as storage for the new string. */
/* FIXME: GC-wise, the only way to use the memory area pointed to by STR
@@ -2096,6 +2117,26 @@ scm_to_utf32_stringn (SCM str, size_t *lenp)
}
#undef FUNC_NAME
+char *
+scm_to_port_string (SCM str, SCM port)
+{
+ return scm_to_port_stringn (str, NULL, port);
+}
+
+char *
+scm_to_port_stringn (SCM str, size_t *lenp, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1
+ && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR)
+ return scm_to_latin1_stringn (str, lenp);
+ else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ return scm_to_utf8_stringn (str, lenp);
+ else
+ return scm_to_stringn (str, lenp, pt->encoding, pt->ilseq_handler);
+}
+
/* Return a malloc(3)-allocated buffer containing the contents of STR encoded
according to ENCODING. If LENP is non-NULL, set it to the size in bytes of
the returned buffer. If the conversion to ENCODING fails, apply the
strategy
@@ -2129,7 +2170,7 @@ scm_to_stringn (SCM str, size_t *lenp, const char
*encoding,
"string contains #\\nul character: ~S",
scm_list_1 (str));
- if (scm_i_is_narrow_string (str) && (encoding == NULL))
+ if (scm_i_is_narrow_string (str) && strcmp (encoding, "ISO-8859-1") == 0)
{
/* If using native Latin-1 encoding, just copy the string
contents. */
diff --git a/libguile/strings.h b/libguile/strings.h
index 04a9762..445d9c8 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -3,7 +3,7 @@
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009,
2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009,
2010, 2011, 2013 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
@@ -153,6 +153,11 @@ SCM_API scm_t_wchar *scm_to_utf32_stringn (SCM str, size_t
*lenp);
SCM_API SCM scm_from_utf32_string (const scm_t_wchar *str);
SCM_API SCM scm_from_utf32_stringn (const scm_t_wchar *str, size_t len);
+SCM_API char *scm_to_port_string (SCM str, SCM port);
+SCM_API char *scm_to_port_stringn (SCM str, size_t *lenp, SCM port);
+SCM_API SCM scm_from_port_string (const char *str, SCM port);
+SCM_API SCM scm_from_port_stringn (const char *str, size_t len, SCM port);
+
SCM_API char *scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
scm_t_string_failed_conversion_handler handler);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
diff --git a/libguile/strports.c b/libguile/strports.c
index 7020227..425b089 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006,
- * 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ * 2009, 2010, 2011, 2012, 2013 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
@@ -318,8 +318,7 @@ scm_strport_to_string (SCM port)
if (pt->read_buf_size == 0)
return scm_nullstr;
- return scm_from_stringn ((char *)pt->read_buf, pt->read_buf_size,
- pt->encoding, pt->ilseq_handler);
+ return scm_from_port_stringn ((char *)pt->read_buf, pt->read_buf_size, port);
}
SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
diff --git a/libguile/symbols.c b/libguile/symbols.c
index fd7e214..f93833b 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004,
- * 2006, 2009, 2011 Free Software Foundation, Inc.
+ * 2006, 2009, 2011, 2013 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
@@ -167,7 +167,7 @@ utf8_string_equals_wide_string (const scm_t_uint8 *narrow,
size_t nlen,
nbytes = u8_mbtouc (&c, narrow + byte_idx, nlen - byte_idx);
if (nbytes == 0)
break;
- else if (nbytes < 0)
+ else if (c == 0xfffd)
/* Bad UTF-8. */
return 0;
else if (c != wide[char_idx])
diff --git a/libguile/vports.c b/libguile/vports.c
index 4ff13f2..a886e36 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010,
2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010,
2011, 2013 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
@@ -94,7 +94,7 @@ sf_fill_input (SCM port)
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
pt = SCM_PTAB_ENTRY (port);
- if (pt->encoding == NULL)
+ if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
diff --git a/module/Makefile.am b/module/Makefile.am
index 0998703..d04a118 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+## Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation,
Inc.
##
## This file is part of GUILE.
##
@@ -209,6 +209,7 @@ ICE_9_SOURCES = \
ice-9/getopt-long.scm \
ice-9/hcons.scm \
ice-9/i18n.scm \
+ ice-9/iconv.scm \
ice-9/lineio.scm \
ice-9/ls.scm \
ice-9/mapping.scm \
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 85d07e8..9835c12 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012 Free Software
Foundation, Inc.
+;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012, 2013 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
diff --git a/module/ice-9/iconv.scm b/module/ice-9/iconv.scm
new file mode 100644
index 0000000..88af90d
--- /dev/null
+++ b/module/ice-9/iconv.scm
@@ -0,0 +1,95 @@
+;;; Encoding and decoding byte representations of strings
+
+;; Copyright (C) 2013 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
+
+;;; Code:
+
+(define-module (ice-9 iconv)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module ((ice-9 rdelim) #:select (read-delimited))
+ #:export (string->bytevector
+ bytevector->string
+ call-with-encoded-output-string))
+
+;; Like call-with-output-string, but actually closes the port.
+(define (call-with-output-string* proc)
+ (let ((port (open-output-string)))
+ (proc port)
+ (let ((str (get-output-string port)))
+ (close-port port)
+ str)))
+
+(define (call-with-output-bytevector* proc)
+ (call-with-values (lambda () (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (proc port)
+ (let ((bv (get-bytevector)))
+ (close-port port)
+ bv))))
+
+(define* (call-with-encoded-output-string encoding proc
+ #:optional
+ (conversion-strategy 'error))
+ "Call PROC on a fresh port. Encode the resulting string as a
+bytevector according to ENCODING, and return the bytevector."
+ (if (and (string-ci=? encoding "utf-8")
+ (eq? conversion-strategy 'error))
+ ;; I don't know why, but this appears to be faster; at least for
+ ;; serving examples/debug-sxml.scm (1464 reqs/s versus 850
+ ;; reqs/s).
+ (string->utf8 (call-with-output-string* proc))
+ (call-with-output-bytevector*
+ (lambda (port)
+ (set-port-encoding! port encoding)
+ (if conversion-strategy
+ (set-port-conversion-strategy! port conversion-strategy))
+ (proc port)))))
+
+;; TODO: Provide C implementations that call scm_from_stringn and
+;; friends?
+
+(define* (string->bytevector str encoding
+ #:optional (conversion-strategy 'error))
+ "Encode STRING according to ENCODING, which should be a string naming
+a character encoding, like \"utf-8\"."
+ (if (and (string-ci=? encoding "utf-8")
+ (eq? conversion-strategy 'error))
+ (string->utf8 str)
+ (call-with-encoded-output-string
+ encoding
+ (lambda (port)
+ (display str port))
+ conversion-strategy)))
+
+(define* (bytevector->string bv encoding
+ #:optional (conversion-strategy 'error))
+ "Decode the string represented by BV. The bytes in the bytevector
+will be interpreted according to ENCODING, which should be a string
+naming a character encoding, like \"utf-8\"."
+ (if (and (string-ci=? encoding "utf-8")
+ (eq? conversion-strategy 'error))
+ (utf8->string bv)
+ (let ((p (open-bytevector-input-port bv)))
+ (set-port-encoding! p encoding)
+ (if conversion-strategy
+ (set-port-conversion-strategy! p conversion-strategy))
+ (let ((res (read-delimited "" p)))
+ (close-port p)
+ (if (eof-object? res)
+ ""
+ res)))))
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 7ca4868..7d0549e 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, 2012 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012, 2013
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
@@ -49,11 +49,17 @@ A port to the process (based on pipes) is created and
returned.
@var{mode} specifies whether an input, an output or an input-output
port to the process is created: it should be the value of
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
- (let* ((port/pid (apply open-process mode command args))
- (port (car port/pid)))
- (pipe-guardian port)
- (hashq-set! port/pid-table port (cdr port/pid))
- port))
+ (call-with-values (lambda ()
+ (apply open-process mode command args))
+ (lambda (read-port write-port pid)
+ (let ((port (or (and read-port write-port
+ (make-rw-port read-port write-port))
+ read-port
+ write-port
+ (%make-void-port mode))))
+ (pipe-guardian port)
+ (hashq-set! port/pid-table port pid)
+ port))))
(define (open-pipe command mode)
"Executes the shell command @var{command} (a string) in a subprocess.
diff --git a/module/ice-9/slib.scm b/module/ice-9/slib.scm
index 78c734e..7664180 100644
--- a/module/ice-9/slib.scm
+++ b/module/ice-9/slib.scm
@@ -1,6 +1,6 @@
;;;; slib.scm --- definitions needed to get SLIB to work with Guile
;;;;
-;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, 2007 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2013
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
@@ -16,27 +16,18 @@
;;;; 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 (ice-9 slib)
- :export (slib:load slib:load-source defmacro:load
- implementation-vicinity library-vicinity home-vicinity
- scheme-implementation-type scheme-implementation-version
- output-port-width output-port-height array-indexes
- make-random-state
- -1+ <? <=? =? >? >=?
- require slib:error slib:exit slib:warn slib:eval
- defmacro:eval logical:logand logical:logior logical:logxor
- logical:lognot logical:ash logical:logcount logical:integer-length
- logical:bit-extract logical:integer-expt logical:ipow-by-squaring
- slib:eval-load slib:tab slib:form-feed difftime offset-time
- software-type)
- :no-backtrace)
-
-;; Initialize SLIB.
-(load-from-path "slib/guile.init")
+;;; Look for slib.init in the $datadir, in /usr/share, and finally in
+;;; the load path. It's not usually in the load path on common distros,
+;;; but it could be if the user put it there. The init file takes care
+;;; of defining the module.
-;; SLIB redefines a few core symbols based on their default definition.
-;; Thus, we only replace them at this point so that their previous definition
-;; is visible when `guile.init' is loaded.
-(module-replace! (current-module)
- '(delete-file open-file provide provided? system))
+(let ((try-load (lambda (dir)
+ (let ((init (string-append dir "/slib/guile.init")))
+ (and (file-exists? init)
+ (begin
+ (load init)
+ #t))))))
+ (or (try-load (assq-ref %guile-build-info 'datadir))
+ (try-load "/usr/share")
+ (load-from-path "slib/guile.init")))
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 7c17b0c..8e04f5d 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -220,24 +220,22 @@
(define (port-transcoder port)
"Return the transcoder object associated with @var{port}, or @code{#f}
if the port has no transcoder."
- (cond ((port-encoding port)
- => (lambda (encoding)
- (make-transcoder
- encoding
- (native-eol-style)
- (case (port-conversion-strategy port)
- ((error) 'raise)
- ((substitute) 'replace)
- (else
- (assertion-violation 'port-transcoder
- "unsupported error handling mode"))))))
- (else
- #f)))
+ (and (textual-port? port)
+ ;; All textual ports have transcoders.
+ (make-transcoder
+ (port-encoding port)
+ (native-eol-style)
+ (case (port-conversion-strategy port)
+ ((error) 'raise)
+ ((substitute) 'replace)
+ (else
+ (assertion-violation 'port-transcoder
+ "unsupported error handling mode"))))))
(define (binary-port? port)
- "Returns @code{#t} if @var{port} does not have an associated encoding,
address@hidden otherwise."
- (not (port-encoding port)))
+ "Always returns @code{#t}, as all ports can be used for binary I/O in
+Guile."
+ (equal? (port-encoding port) "ISO-8859-1"))
(define (textual-port? port)
"Always returns @code{#t}, as all ports can be used for textual I/O in
diff --git a/module/web/client.scm b/module/web/client.scm
index 6aedb75..ce93cd8 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -1,6 +1,6 @@
;;; Web client
-;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012, 2013 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
@@ -34,6 +34,7 @@
(define-module (web client)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 iconv)
#:use-module (ice-9 rdelim)
#:use-module (web request)
#:use-module (web response)
@@ -41,10 +42,23 @@
#:use-module (srfi srfi-1)
#:export (open-socket-for-uri
http-get
- http-get*))
+ http-get*
+ http-head
+ http-post
+ http-put
+ http-delete
+ http-trace
+ http-options))
-(define (open-socket-for-uri uri)
+(define (ensure-uri uri-or-string)
+ (cond
+ ((string? uri-or-string) (string->uri uri-or-string))
+ ((uri? uri-or-string) uri-or-string)
+ (else (error "Invalid URI" uri-or-string))))
+
+(define (open-socket-for-uri uri-or-string)
"Return an open input/output port for a connection to URI."
+ (define uri (ensure-uri uri-or-string))
(define addresses
(let ((port (uri-port uri)))
(delete-duplicates
@@ -78,17 +92,79 @@
(apply throw args)
(loop (cdr addresses))))))))
-(define (decode-string bv encoding)
- (if (string-ci=? encoding "utf-8")
- (utf8->string bv)
- (let ((p (open-bytevector-input-port bv)))
- (set-port-encoding! p encoding)
- (let ((res (read-delimited "" p)))
- (close-port p)
- res))))
+(define (extend-request r k v . additional)
+ (let ((r (build-request (request-uri r) #:version (request-version r)
+ #:headers
+ (assoc-set! (copy-tree (request-headers r))
+ k v)
+ #:port (request-port r))))
+ (if (null? additional)
+ r
+ (apply extend-request r additional))))
+
+;; -> request body
+(define (sanitize-request request body)
+ "\"Sanitize\" the given request and body, ensuring that they are
+complete and coherent. This method is most useful for methods that send
+data to the server, like POST, but can be used for any method. Return
+two values: a request and a bytevector, possibly the same ones that were
+passed as arguments.
+
+If BODY is a string, encodes the string to a bytevector, in an encoding
+appropriate for REQUEST. Adds a âcontent-lengthâ and âcontent-typeâ
+header, as necessary.
+
+If BODY is a procedure, it is called with a port as an argument, and the
+output collected as a bytevector. In the future we might try to instead
+use a compressing, chunk-encoded port, and call this procedure later.
+Authors are advised not to rely on the procedure being called at any
+particular time.
+
+Note that we rely on the request itself already having been validated,
+as is the case by default with a request returned by `build-request'."
+ (cond
+ ((not body)
+ (let ((length (request-content-length request)))
+ (if length
+ (unless (zero? length)
+ (error "content-length, but no body"))
+ (when (assq 'transfer-encoding (request-headers request))
+ (error "transfer-encoding not allowed with no body")))
+ (values request #vu8())))
+ ((string? body)
+ (let* ((type (request-content-type request '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
+ (charset (or declared-charset "utf-8")))
+ (sanitize-request
+ (if declared-charset
+ request
+ (extend-request request 'content-type
+ `(,@type (charset . ,charset))))
+ (string->bytevector body charset))))
+ ((procedure? body)
+ (let* ((type (request-content-type request
+ '(text/plain)))
+ (declared-charset (assq-ref (cdr type) 'charset))
+ (charset (or declared-charset "utf-8")))
+ (sanitize-request
+ (if declared-charset
+ request
+ (extend-request request 'content-type
+ `(,@type (charset . ,charset))))
+ (call-with-encoded-output-string charset body))))
+ ((not (bytevector? body))
+ (error "unexpected body type"))
+ (else
+ (values (let ((rlen (request-content-length request))
+ (blen (bytevector-length body)))
+ (cond
+ (rlen (if (= rlen blen)
+ request
+ (error "bad content-length" rlen blen)))
+ ((zero? blen) request)
+ (else (extend-request request 'content-length blen))))
+ body))))
-;; Logically the inverse of (web server)'s `sanitize-response'.
-;;
(define (decode-response-body response body)
;; `body' is either #f or a bytevector.
(cond
@@ -103,61 +179,196 @@
=> (lambda (type)
(cond
((text-content-type? (car type))
- (decode-string body (or (assq-ref (cdr type) 'charset)
- "iso-8859-1")))
+ ;; RFC 2616 3.7.1: "When no explicit charset parameter is
+ ;; provided by the sender, media subtypes of the "text"
+ ;; type are defined to have a default charset value of
+ ;; "ISO-8859-1" when received via HTTP."
+ (bytevector->string body (or (assq-ref (cdr type) 'charset)
+ "iso-8859-1")))
(else body))))
(else body))))
(else
(error "unexpected body type" body))))
-(define* (http-get uri #:key (port (open-socket-for-uri uri))
- (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
- (decode-body? #t))
+;; We could expose this to user code if there is demand.
+(define* (request uri #:key
+ (body #f)
+ (port (open-socket-for-uri uri))
+ (method "GET")
+ (version '(1 . 1))
+ (keep-alive? #f)
+ (headers '())
+ (decode-body? #t)
+ (streaming? #f)
+ (request
+ (build-request
+ (ensure-uri uri)
+ #:method method
+ #:version version
+ #:headers (if keep-alive?
+ headers
+ (cons '(connection close) headers))
+ #:port port)))
+ (call-with-values (lambda () (sanitize-request request body))
+ (lambda (request body)
+ (let ((request (write-request request port)))
+ (when body
+ (write-request-body request body))
+ (force-output (request-port request))
+ (let ((response (read-response port)))
+ (cond
+ ((equal? (request-method request) "HEAD")
+ (unless keep-alive?
+ (close-port port))
+ (values response #f))
+ (streaming?
+ (values response
+ (response-body-port response
+ #:keep-alive? keep-alive?
+ #:decode? decode-body?)))
+ (else
+ (let ((body (read-response-body response)))
+ (unless keep-alive?
+ (close-port port))
+ (values response
+ (if decode-body?
+ (decode-response-body response body)
+ body))))))))))
+
+(define* (http-get uri #:key
+ (body #f)
+ (port (open-socket-for-uri uri))
+ (version '(1 . 1)) (keep-alive? #f)
+ ;; #:headers is the new name of #:extra-headers.
+ (extra-headers #f) (headers (or extra-headers '()))
+ (decode-body? #t) (streaming? #f))
"Connect to the server corresponding to URI and ask for the
resource, using the âGETâ method. If you already have a port open,
pass it as PORT. The port will be closed at the end of the
request unless KEEP-ALIVE? is true. Any extra headers in the
-alist EXTRA-HEADERS will be added to the request.
+alist HEADERS will be added to the request.
+
+If BODY is not #f, a message body will also be sent with the HTTP
+request. If BODY is a string, it is encoded according to the
+content-type in HEADERS, defaulting to UTF-8. Otherwise BODY should be
+a bytevector, or #f for no body. Although it's allowed to send a
+message body along with any request, usually only POST and PUT requests
+have bodies. See âhttp-putâ and âhttp-postâ documentation, for more.
If DECODE-BODY? is true, as is the default, the body of the
response will be decoded to string, if it is a textual content-type.
-Otherwise it will be returned as a bytevector."
- (let ((req (build-request uri #:version version
- #:headers (if keep-alive?
- extra-headers
- (cons '(connection close)
- extra-headers)))))
- (write-request req port)
- (force-output port)
- (if (not keep-alive?)
- (shutdown port 1))
- (let* ((res (read-response port))
- (body (read-response-body res)))
- (if (not keep-alive?)
- (close-port port))
- (values res
- (if decode-body?
- (decode-response-body res body)
- body)))))
-
-(define* (http-get* uri #:key (port (open-socket-for-uri uri))
- (version '(1 . 1)) (keep-alive? #f) (extra-headers '())
+Otherwise it will be returned as a bytevector.
+
+However, if STREAMING? is true, instead of eagerly reading the response
+body from the server, this function only reads off the headers. The
+response body will be returned as a port on which the data may be read.
+Unless KEEP-ALIVE? is true, the port will be closed after the full
+response body has been read.
+
+Returns two values: the response read from the server, and the response
+body as a string, bytevector, #f value, or as a port (if STREAMING? is
+true)."
+ (when extra-headers
+ (issue-deprecation-warning
+ "The #:extra-headers argument to http-get has been renamed to #:headers. "
+ "Please update your code."))
+ (request uri #:method "GET" #:body body
+ #:port port #:version version #:keep-alive? keep-alive?
+ #:headers headers #:decode-body? decode-body?
+ #:streaming? streaming?))
+
+(define* (http-get* uri #:key
+ (body #f)
+ (port (open-socket-for-uri uri))
+ (version '(1 . 1)) (keep-alive? #f)
+ ;; #:headers is the new name of #:extra-headers.
+ (extra-headers #f) (headers (or extra-headers '()))
(decode-body? #t))
- "Like âhttp-getâ, but return an input port from which to read. When
-DECODE-BODY? is true, as is the default, the returned port has its
-encoding set appropriately if the data at URI is textual. Closing the
-returned port closes PORT, unless KEEP-ALIVE? is true."
- (let ((req (build-request uri #:version version
- #:headers (if keep-alive?
- extra-headers
- (cons '(connection close)
- extra-headers)))))
- (write-request req port)
- (force-output port)
- (unless keep-alive?
- (shutdown port 1))
- (let* ((res (read-response port))
- (body (response-body-port res
- #:keep-alive? keep-alive?
- #:decode? decode-body?)))
- (values res body))))
+ "Deprecated in favor of (http-get #:streaming? #t)."
+ (when extra-headers
+ (issue-deprecation-warning
+ "`http-get*' has been deprecated. "
+ "Instead, use `http-get' with the #:streaming? #t keyword argument."))
+ (http-get uri #:body body
+ #:port port #:version version #:keep-alive? keep-alive?
+ #:headers headers #:decode-body? #t #:streaming? #t))
+
+(define-syntax-rule (define-http-verb http-verb method doc)
+ (define* (http-verb uri #:key
+ (body #f)
+ (port (open-socket-for-uri uri))
+ (version '(1 . 1))
+ (keep-alive? #f)
+ (headers '())
+ (decode-body? #t)
+ (streaming? #f))
+ doc
+ (request uri
+ #:body body #:method method
+ #:port port #:version version #:keep-alive? keep-alive?
+ #:headers headers #:decode-body? decode-body?
+ #:streaming? streaming?)))
+
+(define-http-verb http-head
+ "HEAD"
+ "Fetch message headers for the given URI using the HTTP \"HEAD\"
+method.
+
+This function is similar to âhttp-getâ, except it uses the \"HEAD\"
+method. See âhttp-getâ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values: the resulting response, and #f. Responses to HEAD
+requests do not have a body. The second value is only returned so that
+other procedures can treat all of the http-foo verbs identically.")
+
+(define-http-verb http-post
+ "POST"
+ "Post data to the given URI using the HTTP \"POST\" method.
+
+This function is similar to âhttp-getâ, except it uses the \"POST\"
+method. See âhttp-getâ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-put
+ "PUT"
+ "Put data at the given URI using the HTTP \"PUT\" method.
+
+This function is similar to âhttp-getâ, except it uses the \"PUT\"
+method. See âhttp-getâ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-delete
+ "DELETE"
+ "Delete data at the given URI using the HTTP \"DELETE\" method.
+
+This function is similar to âhttp-getâ, except it uses the \"DELETE\"
+method. See âhttp-getâ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-trace
+ "TRACE"
+ "Send an HTTP \"TRACE\" request.
+
+This function is similar to âhttp-getâ, except it uses the \"TRACE\"
+method. See âhttp-getâ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
+
+(define-http-verb http-options
+ "OPTIONS"
+ "Query characteristics of an HTTP resource using the HTTP \"OPTIONS\"
+method.
+
+This function is similar to âhttp-getâ, except it uses the \"OPTIONS\"
+method. See âhttp-getâ for full documentation on the various keyword
+arguments that are accepted by this function.
+
+Returns two values: the resulting response, and the response body.")
diff --git a/module/web/http.scm b/module/web/http.scm
index 216fddd..c79d57d 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
;;; HTTP messages
-;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012, 2013 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
@@ -69,13 +69,6 @@
make-chunked-output-port))
-;;; TODO
-;;;
-;;; Look at quality lists with more insight.
-;;; Think about `accept' a bit more.
-;;;
-
-
(define (string->header name)
"Parse NAME to a symbolic header name."
(string->symbol (string-downcase name)))
@@ -1307,9 +1300,19 @@ treated specially, and is just returned as a plain
string."
;; Connection = "Connection" ":" 1#(connection-token)
;; connection-token = token
;; e.g.
-;; Connection: close, foo-header
+;; Connection: close, Foo-Header
;;
-(declare-header-list-header! "Connection")
+(declare-header! "Connection"
+ split-header-names
+ list-of-header-names?
+ (lambda (val port)
+ (write-list val port
+ (lambda (x port)
+ (display (if (eq? x 'close)
+ "close"
+ (header->string x))
+ port))
+ ", ")))
;; Date = "Date" ":" HTTP-date
;; e.g.
diff --git a/module/web/response.scm b/module/web/response.scm
index 5ca7274..7e14f4d 100644
--- a/module/web/response.scm
+++ b/module/web/response.scm
@@ -1,6 +1,6 @@
;;; HTTP response objects
-;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012, 2013 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
@@ -294,7 +294,13 @@ response port."
(define (read-response-body r)
"Reads the response body from R, as a bytevector. Returns
â#fâ if there was no response body."
- (and=> (response-body-port r #:decode? #f) get-bytevector-all))
+ (let ((body (and=> (response-body-port r #:decode? #f)
+ get-bytevector-all)))
+ ;; Reading a body of length 0 will result in get-bytevector-all
+ ;; returning the EOF object.
+ (if (eof-object? body)
+ #vu8()
+ body)))
(define (write-response-body r bv)
"Write BV, a bytevector, to the port corresponding to the HTTP
diff --git a/module/web/server.scm b/module/web/server.scm
index 0e34179..affc2e6 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -1,6 +1,6 @@
;;; Web server
-;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012, 2013 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
@@ -80,6 +80,7 @@
#:use-module (web response)
#:use-module (system repl error-handling)
#:use-module (ice-9 control)
+ #:use-module (ice-9 iconv)
#:export (define-server-impl
lookup-server-impl
open-server
@@ -162,41 +163,6 @@ values."
#:on-error (if (batch-mode?) 'backtrace 'debug)
#:post-error (lambda _ (values #f #f #f))))
-;; like call-with-output-string, but actually closes the port (doh)
-(define (call-with-output-string* proc)
- (let ((port (open-output-string)))
- (proc port)
- (let ((str (get-output-string port)))
- (close-port port)
- str)))
-
-(define (call-with-output-bytevector* proc)
- (call-with-values
- (lambda ()
- (open-bytevector-output-port))
- (lambda (port get-bytevector)
- (proc port)
- (let ((bv (get-bytevector)))
- (close-port port)
- bv))))
-
-(define (call-with-encoded-output-string charset proc)
- (if (string-ci=? charset "utf-8")
- ;; I don't know why, but this appears to be faster; at least for
- ;; examples/debug-sxml.scm (1464 reqs/s versus 850 reqs/s).
- (string->utf8 (call-with-output-string* proc))
- (call-with-output-bytevector*
- (lambda (port)
- (set-port-encoding! port charset)
- (proc port)))))
-
-(define (encode-string str charset)
- (if (string-ci=? charset "utf-8")
- (string->utf8 str)
- (call-with-encoded-output-string charset
- (lambda (port)
- (display str port)))))
-
(define (extend-response r k v . additional)
(define (extend-alist alist k v)
(let ((pair (assq k alist)))
@@ -251,7 +217,7 @@ on the procedure being called at any particular time."
response
(extend-response response 'content-type
`(,@type (charset . ,charset))))
- (encode-string body charset))))
+ (string->bytevector body charset))))
((procedure? body)
(let* ((type (response-content-type response
'(text/plain)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 2413259..9fba7b8 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-## 2010, 2011, 2012 Software Foundation, Inc.
+## 2010, 2011, 2012, 2013 Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -63,6 +63,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/hash.test \
tests/hooks.test \
tests/i18n.test \
+ tests/iconv.test \
tests/import.test \
tests/interp.test \
tests/keywords.test \
diff --git a/test-suite/tests/ecmascript.test b/test-suite/tests/ecmascript.test
index 8b5dd82..f15499c 100644
--- a/test-suite/tests/ecmascript.test
+++ b/test-suite/tests/ecmascript.test
@@ -1,6 +1,6 @@
;;;; ecmascript.test --- ECMAScript. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2013 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
@@ -23,9 +23,11 @@
(define (eread str)
- (call-with-input-string str read-ecmascript))
+ (with-fluids ((%default-port-encoding "utf-8"))
+ (call-with-input-string str read-ecmascript)))
(define (eread/1 str)
- (call-with-input-string str read-ecmascript/1))
+ (with-fluids ((%default-port-encoding "utf-8"))
+ (call-with-input-string str read-ecmascript/1)))
(define-syntax parse
(syntax-rules ()
diff --git a/test-suite/tests/iconv.test b/test-suite/tests/iconv.test
new file mode 100644
index 0000000..be36336
--- /dev/null
+++ b/test-suite/tests/iconv.test
@@ -0,0 +1,125 @@
+;;;; iconv.test --- Exercise the iconv API. -*- coding: utf-8; mode: scheme;
-*-
+;;;;
+;;;; Copyright (C) 2013 Free Software Foundation, Inc.
+;;;; Andy Wingo
+;;;;
+;;;; 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 iconv)
+ #:use-module (ice-9 iconv)
+ #:use-module (rnrs bytevectors)
+ #:use-module (test-suite lib))
+
+
+(define exception:encoding-error
+ '(encoding-error . ""))
+
+(define exception:decoding-error
+ '(decoding-error . ""))
+
+
+(with-test-prefix "ascii string"
+ (let ((s "Hello, World!"))
+ ;; For ASCII, all of these encodings should be the same.
+
+ (pass-if "to ascii bytevector"
+ (equal? (string->bytevector s "ASCII")
+ #vu8(72 101 108 108 111 44 32 87 111 114 108 100 33)))
+
+ (pass-if "to ascii bytevector (length check)"
+ (equal? (string-length s)
+ (bytevector-length (string->bytevector s "ascii"))))
+
+ (pass-if "from ascii bytevector"
+ (equal? s
+ (bytevector->string (string->bytevector s "ascii") "ascii")))
+
+ (pass-if "to utf-8 bytevector"
+ (equal? (string->bytevector s "ASCII")
+ (string->bytevector s "utf-8")))
+
+ (pass-if "to UTF-8 bytevector (testing encoding case sensitivity)"
+ (equal? (string->bytevector s "ascii")
+ (string->bytevector s "UTF-8")))
+
+ (pass-if "from utf-8 bytevector"
+ (equal? s
+ (bytevector->string (string->bytevector s "utf-8") "utf-8")))
+
+ (pass-if "to latin1 bytevector"
+ (equal? (string->bytevector s "ASCII")
+ (string->bytevector s "latin1")))
+
+ (pass-if "from latin1 bytevector"
+ (equal? s
+ (bytevector->string (string->bytevector s "utf-8") "utf-8")))))
+
+(with-test-prefix "narrow non-ascii string"
+ (let ((s "été"))
+ (pass-if "to latin1 bytevector"
+ (equal? (string->bytevector s "latin1")
+ #vu8(233 116 233)))
+
+ (pass-if "to latin1 bytevector (length check)"
+ (equal? (string-length s)
+ (bytevector-length (string->bytevector s "latin1"))))
+
+ (pass-if "from latin1 bytevector"
+ (equal? s
+ (bytevector->string (string->bytevector s "latin1") "latin1")))
+
+ (pass-if "to utf-8 bytevector"
+ (equal? (string->bytevector s "utf-8")
+ #vu8(195 169 116 195 169)))
+
+ (pass-if "from utf-8 bytevector"
+ (equal? s
+ (bytevector->string (string->bytevector s "utf-8") "utf-8")))
+
+ (pass-if-exception "encode latin1 as ascii" exception:encoding-error
+ (string->bytevector s "ascii"))
+
+ (pass-if-exception "misparse latin1 as utf8" exception:decoding-error
+ (bytevector->string (string->bytevector s "latin1") "utf-8"))
+
+ (pass-if "misparse latin1 as utf8 with substitutions"
+ (equal? (bytevector->string (string->bytevector s "latin1")
+ "utf-8" 'substitute)
+ "?t?"))
+
+ (pass-if-exception "misparse latin1 as ascii" exception:decoding-error
+ (bytevector->string (string->bytevector s "latin1") "ascii"))))
+
+
+(with-test-prefix "wide non-ascii string"
+ (let ((s "ΧÎÎΣ"))
+ (pass-if "to utf-8 bytevector"
+ (equal? (string->bytevector s "utf-8")
+ #vu8(206 167 206 145 206 159 206 163) ))
+
+ (pass-if "from utf-8 bytevector"
+ (equal? s
+ (bytevector->string (string->bytevector s "utf-8") "utf-8")))
+
+ (pass-if-exception "encode as ascii" exception:encoding-error
+ (string->bytevector s "ascii"))
+
+ (pass-if-exception "encode as latin1" exception:encoding-error
+ (string->bytevector s "latin1"))
+
+ (pass-if "encode as ascii with substitutions"
+ (equal? (make-string (string-length s) #\?)
+ (bytevector->string (string->bytevector s "ascii" 'substitute)
+ "ascii")))))
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index ed49598..3e36cca 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -693,9 +693,6 @@
(put-string tp "The letter λ cannot be represented in Latin-1.")
#f))))
- (pass-if "port-transcoder [binary port]"
- (not (port-transcoder (open-bytevector-input-port #vu8()))))
-
(pass-if "port-transcoder [transcoded port]"
(let* ((p (transcoded-port (open-bytevector-input-port (string->utf8
"foo"))
(make-transcoder (utf-8-codec))))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index eba4153..6799423 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -2,7 +2,7 @@
;;;; Jim Blandy <address@hidden> --- September 1999
;;;;
;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010,
-;;;; 2012 Free Software Foundation, Inc.
+;;;; 2012, 2013 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
@@ -173,10 +173,10 @@
(let ((lst `((regexp/basic ,regexp/basic)
(regexp/extended ,regexp/extended)))
- ;; string of all characters, except #\nul which doesn't work because
- ;; it's the usual end-of-string for the underlying C regexec()
- (allchars (list->string (map integer->char
- (cdr (iota char-code-limit))))))
+ ;; String of all latin-1 characters, except #\nul which doesn't
+ ;; work because it's the usual end-of-string for the underlying
+ ;; C regexec().
+ (allchars (list->string (map integer->char (cdr (iota 256))))))
(for-each
(lambda (elem)
(let ((name (car elem))
@@ -184,9 +184,9 @@
(with-test-prefix name
- ;; try on each individual character, except #\nul
+ ;; Try on each individual latin-1 character, except #\nul.
(do ((i 1 (1+ i)))
- ((>= i char-code-limit))
+ ((>= i 256))
(let* ((c (integer->char i))
(s (string c)))
(pass-if (list "char" i (format #f "~s ~s" c s))
@@ -196,11 +196,12 @@
(and (= 0 (match:start m))
(= 1 (match:end m))))))))
- ;; try on pattern "aX" where X is each character, except #\nul
- ;; this exposes things like "?" which are special only when they
- ;; follow a pattern to repeat or whatever ("a" in this case)
+ ;; Try on pattern "aX" where X is each latin-1 character,
+ ;; except #\nul. This exposes things like "?" which are
+ ;; special only when they follow a pattern to repeat or
+ ;; whatever ("a" in this case).
(do ((i 1 (1+ i)))
- ((>= i char-code-limit))
+ ((>= i 256))
(let* ((c (integer->char i))
(s (string #\a c))
(q (with-unicode (regexp-quote s))))
diff --git a/test-suite/tests/web-client.test b/test-suite/tests/web-client.test
new file mode 100644
index 0000000..3133b73
--- /dev/null
+++ b/test-suite/tests/web-client.test
@@ -0,0 +1,577 @@
+;;;; web-client.test --- HTTP client -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2013 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 (ice-9 iconv)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (test-suite lib))
+
+
+(define get-request-headers:www.gnu.org/software/guile/
+ "GET /software/guile/ HTTP/1.1
+Host: www.gnu.org
+Connection: close
+
+")
+
+(define get-response-headers:www.gnu.org/software/guile/
+ "HTTP/1.1 200 OK
+Date: Fri, 11 Jan 2013 10:59:11 GMT
+Server: Apache/2.2.14
+Accept-Ranges: bytes
+Cache-Control: max-age=0
+Expires: Fri, 11 Jan 2013 10:59:11 GMT
+Vary: Accept-Encoding
+Content-Length: 8077
+Connection: close
+Content-Type: text/html
+Content-Language: en
+
+")
+
+(define get-response-body:www.gnu.org/software/guile/
+ "<!DOCTYPE html PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
+<html>
+<head>
+ <title>GNU Guile (About Guile)</title>
+ <link rel=\"stylesheet\" type=\"text/css\" href=\"/gnu.css\">
+ <link rel=\"stylesheet\" type=\"text/css\"
href=\"/software/guile/guile.css\">
+ <link rev=\"made\" href=\"mailto:address@hidden";>
+</head>
+
+<!-- If you edit these html pages directly, you're not doing yourself any
+ favors - these pages get updated programaticly from a pair of files. Edit
+ the files under the template directory instead -->
+
+<!-- Text black on white, unvisited links blue, visited links navy,
+ active links red -->
+
+<body bgcolor=\"#ffffff\" text=\"#000000\" link=\"#1f00ff\" alink=\"#ff0000\"
vlink=\"#000080\">
+ <a name=\"top\"></a>
+ <table cellpadding=\"10\">
+ <tr>
+ <td>
+\t<a href=\"/software/guile/\">
+\t <img src=\"/software/guile/graphics/guile-banner.small.png\" alt=\"Guile\">
+\t</a>
+ </td>
+ <td valign=\"bottom\">
+\t<h4 align=\"right\">The GNU extension language</h4>
+\t<h4 align=\"right\">About Guile</h4>
+ </td>
+ </tr>
+ </table>
+ <br />
+ <table border=\"0\">
+
+ <!-- Table with 2 columns. One along the left (navbar) and one along the
+\t right (body). On the main page, the left links to anchors on the right,
+\t or to other pages. The left has 2 sections. Top is global navigation,
+\t the bottom is local nav. -->
+
+ <tr>
+ <td class=\"sidebar\">
+\t<table cellpadding=\"4\">
+\t <tr>
+\t <!-- Global Nav -->
+
+\t <td nowrap=\"\">
+\t <p><b>About Guile</b><br />
+\t\t<a href=\"/software/guile/guile.html\">What is Guile?</a><br />
+\t\t<a href=\"/software/guile/news.html\">News</a><br />
+\t\t<a href=\"/software/guile/community.html\">Community</a><br />
+\t </p>
+\t
+\t <p><b>Documentation</b><br />
+\t\t<a href=\"/software/guile/docs/docs.html\">Manuals</a><br />
+\t\t<a href=\"/software/guile/docs/faq/guile-faq.html\">FAQ's</a><br />
+\t </p>
+
+\t <p><b>Download</b><br />
+\t\t<a href=\"/software/guile/download.html#releases\">Releases</a><br />
+\t\t<a href=\"/software/guile/download.html#git\">Repository</a><br />
+\t\t<a href=\"/software/guile/download.html#snapshots\">Snapshots</a><br />
+\t </p>
+
+\t <p><b>Projects</b><br />
+\t\t<a href=\"/software/guile/gnu-guile-projects.html#Core\">Core</a><br />
+\t\t<a href=\"/software/guile/gnu-guile-projects.html#GUI\">GUI</a><br />
+\t\t<a href=\"/software/guile/gnu-guile-projects.html#File-Formats\">File
Formats</a><br />
+\t\t<a
href=\"/software/guile/gnu-guile-projects.html#Networking\">Networking</a><br />
+\t\t<a href=\"/software/guile/gnu-guile-projects.html#Tools\">Tools</a><br />
+\t\t<a
href=\"/software/guile/gnu-guile-projects.html#Applications\">Applications</a><br
/>
+\t </p>
+\t
+\t <p><b>Development</b><br />
+\t\t<a href=\"http://savannah.gnu.org/projects/guile/\";>Project summary</a><br
/>
+\t\t<a href=\"/software/guile/developers.html\">Helping out</a><br />
+\t\t<a href=\"/software/guile/ideas.html\">Cool ideas</a><br />
+\t </p>
+
+\t <p><b>Resources</b><br>
+\t\t<a href=\"/software/guile/resources.html#guile_resources\">Guile
Resources</a><br />
+\t\t<a href=\"/software/guile/resources.html##scheme_resources\">Scheme
Resources</a><br />
+\t </p>
+\t </td>
+\t </tr>
+\t <tr>
+
+\t <!-- Global Nav End -->
+\t
+ <tr>
+ <td>
+ <p><a href=\"http://www.gnu.org/\";>GNU Project home page</a></p>
+ <p><a href=\"#whatisit\">What is Guile?</a></p>
+ <p><a href=\"#get\">Getting Guile</a></p>
+ </td>
+ </tr>
+
+
+\t </tr>
+\t</table>
+ </td>
+
+ <td class=\"rhs-body\">
+
+\t
+ <a name=\"whatisit\"><h3 align=\"left\">What is Guile? What can it do for
you?</h3></a>
+ <p>
+ Guile is the <em>GNU Ubiquitous Intelligent Language for Extensions</em>,
+ the official extension language for the
+ <a href=\"http://www.gnu.org/\";>GNU operating system</a>.
+ </p>
+
+ <p>
+ Guile is a library designed to help programmers create flexible
+ applications. Using Guile in an application allows the application's
+ functionality to be <em>extended</em> by users or other programmers with
+ plug-ins, modules, or scripts. Guile provides what might be described as
+ \"practical software freedom,\" making it possible for users to customize
an
+ application to meet their needs without digging into the application's
+ internals.
+ </p>
+
+ <p>
+ There is a long list of proven applications that employ extension
languages.
+ Successful and long-lived examples of Free Software projects that use
+ Guile are <a href=\"http://www.texmacs.org/\";>TeXmacs</a>,
+ <a href=\"http://lilypond.org/\";>LilyPond</a>, and
+ <a href=\"http://www.gnucash.org/\";>GnuCash</a>.
+ </p>
+
+ <h3>Guile is a programming language</h3>
+
+ <p>
+ Guile is an interpreter and compiler for
+ the <a href=\"http://schemers.org/\";>Scheme</a> programming language, a
clean
+ and elegant dialect of Lisp. Guile is up to date with recent Scheme
+ standards, supporting the
+ <a
href=\"http://www.schemers.org/Documents/Standards/R5RS/\";>Revised<sup>5</sup></a>
+ and most of the <a href=\"http://www.r6rs.org/\";>Revised<sup>6</sup></a>
language
+ reports (including hygienic macros), as well as many
+ <a href=\"http://srfi.schemers.org/\";>SRFIs</a>. It also comes with a
library
+ of modules that offer additional features, like an HTTP server and client,
+ XML parsing, and object-oriented programming.
+ </p>
+
+ <h3>Guile is an extension language platform</h3>
+
+ <p>
+ Guile is an efficient virtual machine that executes a portable instruction
+ set generated by its optimizing compiler, and integrates very easily with C
+ and C++ application code. In addition to Scheme, Guile includes compiler
+ front-ends for
+ <a
href=\"http://www.ecma-international.org/publications/standards/Ecma-262.htm\";>ECMAScript</a>
+ and <a href=\"http://www.emacswiki.org/cgi-bin/wiki?EmacsLisp\";>Emacs
Lisp</a>
+ (support for <a href=\"http://www.lua.org/\";>Lua</a> is underway), which
means
+ your application can be extended in the language (or languages) most
+ appropriate for your user base. And Guile's tools for parsing and
compiling
+ are exposed as part of its standard module set, so support for additional
+ languages can be added without writing a single line of C.
+ </p>
+
+ <h3>Guile gives your programs more power</h3>
+
+ <p>
+ Using Guile with your program makes it more usable. Users don't
+ need to learn the plumbing of your application to customize it; they just
+ need to understand Guile, and the access you've provided. They can easily
+ trade and share features by downloading and creating scripts, instead of
+ trading complex patches and recompiling their applications. They don't
need
+ to coordinate with you or anyone else. Using Guile, your application has a
+ full-featured scripting language right from the beginning, so you can focus
+ on the novel and attention-getting parts of your application.
+ </p>
+
+ <a name=\"get\"><h2 align=\"center\">How do I get Guile?</h2></a>
+
+ <ul>
+ <li>The current <em>stable</em> release is
+ <a href=\"ftp://ftp.gnu.org/gnu/guile/guile-2.0.7.tar.gz\";>2.0.7</a>.
+ </li>
+ </ul>
+
+ <p>
+ See the <a href=\"download.html\">Download</a> page for additional ways of
+ getting Guile.
+ </p>
+
+
+
+ </td>
+ </tr>
+ </table>
+
+ <br />
+ <div class=\"copyright\">
+
+ <p>
+ Please send FSF & GNU inquiries & questions to
+ <a href=\"mailto:address@hidden";><em>address@hidden</em></a>. There are
also
+ <a href=\"/home.html#ContactInfo\">other ways to contact</a> the FSF.
+ </p>
+
+ <p>
+ Please send comments on these web pages to
+ <a href=\"mailto:address@hidden";><em>address@hidden</em></a>, send
+ other questions to <a
href=\"mailto:address@hidden";><em>address@hidden</em></a>.
+ </p>
+
+ <p>
+ Copyright (C) 2012 Free Software Foundation, Inc.
+ </p>
+
+ <p>
+ Verbatim copying and distribution of this entire web page is
+ permitted in any medium, provided this notice is preserved.<P>
+ Updated:
+
+ <!-- timestamp start -->
+ $Date: 2012/11/30 00:16:15 $ $Author: civodul $
+ <!-- timestamp end -->
+ </p>
+
+ </div>
+
+</body>
+</html>
+")
+
+(define head-request-headers:www.gnu.org/software/guile/
+ "HEAD /software/guile/ HTTP/1.1
+Host: www.gnu.org
+Connection: close
+
+")
+
+(define head-response-headers:www.gnu.org/software/guile/
+ "HTTP/1.1 200 OK
+Date: Fri, 11 Jan 2013 11:03:14 GMT
+Server: Apache/2.2.14
+Accept-Ranges: bytes
+Cache-Control: max-age=0
+Expires: Fri, 11 Jan 2013 11:03:14 GMT
+Vary: Accept-Encoding
+Content-Length: 8077
+Connection: close
+Content-Type: text/html
+Content-Language: en
+
+")
+
+;; Unfortunately, POST to http://www.gnu.org/software/guile/ succeeds!
+(define post-request-headers:www.apache.org/
+ "POST / HTTP/1.1
+Host: www.apache.org
+Connection: close
+
+")
+
+(define post-response-headers:www.apache.org/
+ "HTTP/1.1 405 Method Not Allowed
+Date: Fri, 11 Jan 2013 11:04:34 GMT
+Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g
+Allow: TRACE
+Content-Length: 314
+Connection: close
+Content-Type: text/html; charset=iso-8859-1
+
+")
+
+(define post-response-body:www.apache.org/
+"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
+<html><head>
+<title>405 Method Not Allowed</title>
+</head><body>
+<h1>Method Not Allowed</h1>
+<p>The requested method POST is not allowed for the URL /.</p>
+<hr>
+<address>Apache/2.4.3 (Unix) OpenSSL/1.0.0g Server at www.apache.org Port
80</address>
+</body></html>
+")
+
+(define put-request-headers:www.apache.org/
+ "PUT / HTTP/1.1
+Host: www.apache.org
+Connection: close
+
+")
+
+(define put-response-headers:www.apache.org/
+ "HTTP/1.1 405 Method Not Allowed
+Date: Fri, 11 Jan 2013 11:04:34 GMT
+Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g
+Allow: TRACE
+Content-Length: 313
+Connection: close
+Content-Type: text/html; charset=iso-8859-1
+
+")
+
+(define put-response-body:www.apache.org/
+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
+<html><head>
+<title>405 Method Not Allowed</title>
+</head><body>
+<h1>Method Not Allowed</h1>
+<p>The requested method PUT is not allowed for the URL /.</p>
+<hr>
+<address>Apache/2.4.3 (Unix) OpenSSL/1.0.0g Server at www.apache.org Port
80</address>
+</body></html>
+")
+
+(define delete-request-headers:www.apache.org/
+ "DELETE / HTTP/1.1
+Host: www.apache.org
+Connection: close
+
+")
+
+(define delete-response-headers:www.apache.org/
+ "HTTP/1.1 405 Method Not Allowed
+Date: Fri, 11 Jan 2013 11:07:19 GMT
+Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g
+Allow: TRACE
+Content-Length: 316
+Connection: close
+Content-Type: text/html; charset=iso-8859-1
+
+")
+
+
+
+(define delete-response-body:www.apache.org/
+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">
+<html><head>
+<title>405 Method Not Allowed</title>
+</head><body>
+<h1>Method Not Allowed</h1>
+<p>The requested method DELETE is not allowed for the URL /.</p>
+<hr>
+<address>Apache/2.4.3 (Unix) OpenSSL/1.0.0g Server at www.apache.org Port
80</address>
+</body></html>
+")
+
+(define options-request-headers:www.apache.org/
+ "OPTIONS / HTTP/1.1
+Host: www.apache.org
+Connection: close
+
+")
+
+(define options-response-headers:www.apache.org/
+ "HTTP/1.1 200 OK
+Date: Fri, 11 Jan 2013 11:08:31 GMT
+Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g
+Allow: OPTIONS,GET,HEAD,POST,TRACE
+Cache-Control: max-age=3600
+Expires: Fri, 11 Jan 2013 12:08:31 GMT
+Content-Length: 0
+Connection: close
+Content-Type: text/html; charset=utf-8
+
+")
+
+;; This depends on the exact request that we send. I copied this off
+;; the console with an "nc" session, so it doesn't include the CR bytes.
+;; But that's OK -- we just have to decode the body as an HTTP request
+;; and check that it's the same.
+(define trace-request-headers:www.apache.org/
+ "TRACE / HTTP/1.1\r
+Host: www.apache.org\r
+Connection: close\r
+\r
+")
+
+(define trace-response-headers:www.apache.org/
+ "HTTP/1.1 200 OK\r
+Date: Fri, 11 Jan 2013 12:36:13 GMT\r
+Server: Apache/2.4.3 (Unix) OpenSSL/1.0.0g\r
+Connection: close\r
+Transfer-Encoding: chunked\r
+Content-Type: message/http\r
+\r
+")
+
+(define trace-response-body:www.apache.org/
+ "3d\r
+TRACE / HTTP/1.1\r
+Host: www.apache.org\r
+Connection: close\r
+\r
+\r
+0\r
+\r
+")
+
+(define (requests-equal? r1 r2)
+ (and (equal? (request-method r1) (request-method r2))
+ (equal? (request-uri r1) (request-uri r2))
+ (equal? (request-version r1) (request-version r2))
+ (equal? (request-headers r1) (request-headers r2))))
+
+(define (responses-equal? r1 r2)
+ (and (equal? (response-code r1) (response-code r2))
+ (equal? (response-version r1) (response-version r2))
+ (equal? (response-headers r1) (response-headers r2))))
+
+(define* (run-with-http-transcript
+ expected-request expected-request-body request-body-encoding
+ response response-body response-body-encoding
+ proc)
+ (let ((reading? #f)
+ (writing? #t)
+ (response-port (open-input-string response))
+ (response-body-port (open-bytevector-input-port
+ (string->bytevector response-body
+ response-body-encoding))))
+ (call-with-values (lambda () (open-bytevector-output-port))
+ (lambda (request-port get-bytevector)
+ (define (put-char c)
+ (unless writing?
+ (error "Port closed for writing"))
+ (put-u8 request-port (char->integer c)))
+ (define (put-string s)
+ (string-for-each put-char s))
+ (define (flush)
+ (set! writing? #f)
+ (set! reading? #t)
+ (let* ((p (open-bytevector-input-port (get-bytevector)))
+ (actual-request (read-request p))
+ (actual-body (read-request-body actual-request)))
+ (pass-if "requests equal"
+ (requests-equal? actual-request
+ (call-with-input-string expected-request
+ read-request)))
+ (pass-if "request bodies equal"
+ (equal? (or actual-body #vu8())
+ (string->bytevector expected-request-body
+ request-body-encoding)))))
+ (define (get-char)
+ (unless reading?
+ (error "Port closed for reading"))
+ (let ((c (read-char response-port)))
+ (if (char? c)
+ c
+ (let ((u8 (get-u8 response-body-port)))
+ (if (eof-object? u8)
+ u8
+ (integer->char u8))))))
+ (define (close)
+ (when writing?
+ (unless (eof-object? (get-u8 response-body-port))
+ (error "Failed to consume all of body"))))
+ (proc (make-soft-port (vector put-char put-string flush get-char close)
+ "rw"))))))
+
+(define* (check-transaction method uri
+ request-headers request-body request-body-encoding
+ response-headers response-body
response-body-encoding
+ proc
+ #:key (response-body-comparison response-body))
+ (with-test-prefix (string-append method " " uri)
+ (run-with-http-transcript
+ request-headers request-body request-body-encoding
+ response-headers response-body response-body-encoding
+ (lambda (port)
+ (call-with-values (lambda ()
+ (proc uri #:port port))
+ (lambda (response body)
+ (pass-if "response equal"
+ (responses-equal?
+ response
+ (call-with-input-string response-headers read-response)))
+ (pass-if "response body equal"
+ (equal? (or body "") response-body-comparison))))))))
+
+(check-transaction
+ "GET" "http://www.gnu.org/software/guile/";
+ get-request-headers:www.gnu.org/software/guile/ "" "iso-8859-1"
+ get-response-headers:www.gnu.org/software/guile/
+ get-response-body:www.gnu.org/software/guile/ "iso-8859-1"
+ http-get)
+
+(check-transaction
+ "HEAD" "http://www.gnu.org/software/guile/";
+ head-request-headers:www.gnu.org/software/guile/ "" "iso-8859-1"
+ head-response-headers:www.gnu.org/software/guile/ "" "iso-8859-1"
+ http-head)
+
+(check-transaction
+ "POST" "http://www.apache.org/";
+ post-request-headers:www.apache.org/ "" "iso-8859-1"
+ post-response-headers:www.apache.org/
+ post-response-body:www.apache.org/ "iso-8859-1"
+ http-post)
+
+(check-transaction
+ "PUT" "http://www.apache.org/";
+ put-request-headers:www.apache.org/ "" "iso-8859-1"
+ put-response-headers:www.apache.org/
+ put-response-body:www.apache.org/ "iso-8859-1"
+ http-put)
+
+(check-transaction
+ "DELETE" "http://www.apache.org/";
+ delete-request-headers:www.apache.org/ "" "iso-8859-1"
+ delete-response-headers:www.apache.org/
+ delete-response-body:www.apache.org/ "iso-8859-1"
+ http-delete)
+
+(check-transaction
+ "OPTIONS" "http://www.apache.org/";
+ options-request-headers:www.apache.org/ "" "utf-8"
+ options-response-headers:www.apache.org/ "" "utf-8"
+ http-options)
+
+(check-transaction
+ "TRACE" "http://www.apache.org/";
+ trace-request-headers:www.apache.org/ "" "iso-8859-1"
+ trace-response-headers:www.apache.org/
+ trace-response-body:www.apache.org/ "iso-8859-1"
+ http-trace
+ #:response-body-comparison
+ ;; The body will be message/http, which is logically a sequence of
+ ;; bytes, not characters. It happens that iso-8859-1 can encode our
+ ;; body and is compatible with the headers as well.
+ (string->bytevector trace-request-headers:www.apache.org/
+ "iso-8859-1"))
diff --git a/test-suite/tests/web-response.test
b/test-suite/tests/web-response.test
index f9679f5..4f88aa6 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding:
utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013 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
@@ -113,7 +113,7 @@ consectetur adipisicing elit,\r
(response-content-encoding r))
(pass-if-equal "response-body-port"
- `("utf-8" ,body)
+ `("UTF-8" ,body)
(with-fluids ((%default-port-encoding #f))
(let* ((r (read-response (open-input-string example-1)))
(p (response-body-port r)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-23-g449ca87,
Andy Wingo <=