mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
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
This commit is contained in:
Andy Wingo 2013-01-15 10:45:39 +01:00
commit b4fa6cc909
21 changed files with 1276 additions and 204 deletions
Download patch file Download diff file Expand all files Collapse all files

1
doc/guile-api.alist
View file

@ -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?>"))

86
doc/ref/api-data.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012
@c 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
@node Representing Strings as Bytes
@subsubsection 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.
@cindex iconv
@cindex 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
@code{iconv} module before having access to these procedures:
@example
(use-modules (ice-9 iconv))
@end example
@deffn 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
@var{encoding} string. If the string has characters that cannot be
represented in the encoding, by default this procedure raises an
@code{encoding-error}. 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.
@end deffn
@deffn 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
@code{string->bytevector}, pass the optional @var{conversion-strategy}
argument to modify this behavior. @xref{Ports}, for more on character
encodings and conversion strategies.
@end deffn
@deffn 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}.
@end 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
@code{ice-9 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}.
@xref{Representing Strings as Bytes}.
@end deftypefn
The following conversion functions are provided as a convenience for the
@ -4810,6 +4887,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.
@xref{Representing Strings as Bytes}, for a more generic interface.
@lisp
(utf8->string (u8-list->bytevector '(99 97 102 101)))

22
doc/ref/api-procedures.texi
View file

@ -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
@end deffn
The alist keys that are currently defined are `required', `optional',
`keyword', `allow-other-keys?', and `rest'.
@deffn {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.
@deffnx {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:
@code{program-arguments-alist} 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.
@example
(program-lambda-alist
(lambda* (a b #:optional c #:key (d 1) #:rest e)
#t)) @result{}
@end example
@end deffn
@node Optional Arguments

66
doc/ref/web.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
@c 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
@deffn {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.
@deffn {Scheme Procedure} http-get uri arg...
@deffnx {Scheme Procedure} http-head uri arg...
@deffnx {Scheme Procedure} http-post uri arg...
@deffnx {Scheme Procedure} http-put uri arg...
@deffnx {Scheme Procedure} http-delete uri arg...
@deffnx {Scheme Procedure} http-trace uri arg...
@deffnx {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.
@table @code
@item #:body #f
@item #:port (open-socket-for-uri @var{uri})]
@item #:version '(1 . 1)
@item #:keep-alive? #f
@item #:headers '()
@item #:decode-body? #t
@item #:streaming? #f
@end 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
@var{body} 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
@code{PUT} 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.
@end deffn
@deffn {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
@var{decode-body?} 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
@var{streaming?} 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
@email{guile-user@@gnu.org}.
@node Web Server
@subsection Web Server

2
libguile/__scm.h
View file

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

3
libguile/deprecated.h
View file

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

2
libguile/feature.c
View file

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

25
libguile/posix.c
View file

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

3
module/Makefile.am
View file

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

2
module/ice-9/deprecated.scm
View file

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

92
module/ice-9/iconv.scm Normal file
View file

@ -0,0 +1,92 @@
;;; 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 (string-ci=? encoding "utf-8")
;; 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 (string-ci=? encoding "utf-8")
(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 (string-ci=? encoding "utf-8")
(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)))))

18
module/ice-9/popen.scm
View file

@ -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.

37
module/ice-9/slib.scm
View file

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

325
module/web/client.scm
View file

@ -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)))))
Otherwise it will be returned as a bytevector.
(define* (http-get* uri #:key (port (open-socket-for-uri uri))
(version '(1 . 1)) (keep-alive? #f) (extra-headers '())
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.")

23
module/web/http.scm
View file

@ -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.

10
module/web/response.scm
View file

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

40
module/web/server.scm
View file

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

3
test-suite/Makefile.am
View file

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

120
test-suite/tests/iconv.test Normal file
View file

@ -0,0 +1,120 @@
;;;; 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-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")))))

23
test-suite/tests/regexp.test
View file

@ -2,7 +2,7 @@
;;;; Jim Blandy <jimb@red-bean.com> --- 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))))

577
test-suite/tests/web-client.test Normal file
View file

@ -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:bug-guile@gnu.org\">
</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 &amp; GNU inquiries &amp; questions to
<a href=\"mailto:gnu@gnu.org\"><em>gnu@gnu.org</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:bug-guile@gnu.org\"><em>bug-guile@gnu.org</em></a>, send
other questions to <a href=\"mailto:gnu@gnu.org\"><em>gnu@gnu.org</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"))