summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-07-25 18:26:37 +0200
committerAndy Wingo <wingo@pobox.com>2011-07-25 18:26:37 +0200
commitab4bc85398a14b62b58694bab83c63be286b2fd5 (patch)
tree84bfe7b0b6064016bcfadb76ec95d07410654fe8 /module
parentf29c300507da21a667f5b82e75300f8009eab9cc (diff)
parentf4b7d918eff9770f09893b023fd834f5c0bc33d1 (diff)
downloadguile-ab4bc85398a14b62b58694bab83c63be286b2fd5.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: GUILE-VERSION test-suite/tests/srfi-4.test
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am3
-rw-r--r--module/ice-9/boot-9.scm14
-rw-r--r--module/oop/goops.scm87
-rw-r--r--module/scripts/PROGRAM.scm40
-rw-r--r--module/scripts/api-diff.scm5
-rw-r--r--module/scripts/autofrisk.scm5
-rw-r--r--module/scripts/compile.scm2
-rw-r--r--module/scripts/disassemble.scm4
-rw-r--r--module/scripts/display-commentary.scm4
-rw-r--r--module/scripts/doc-snarf.scm4
-rw-r--r--module/scripts/frisk.scm5
-rw-r--r--module/scripts/generate-autoload.scm5
-rw-r--r--module/scripts/help.scm148
-rw-r--r--module/scripts/lint.scm3
-rw-r--r--module/scripts/list.scm11
-rw-r--r--module/scripts/punify.scm3
-rw-r--r--module/scripts/read-rfc822.scm5
-rw-r--r--module/scripts/read-scheme-source.scm5
-rw-r--r--module/scripts/read-text-outline.scm5
-rw-r--r--module/scripts/scan-api.scm5
-rw-r--r--module/scripts/snarf-check-and-output-texi.scm5
-rw-r--r--module/scripts/snarf-guile-m4-docs.scm5
-rw-r--r--module/scripts/summarize-guile-TODO.scm5
-rw-r--r--module/scripts/use2dot.scm4
-rw-r--r--module/system/base/compile.scm14
-rw-r--r--module/system/repl/command.scm22
-rw-r--r--module/web/client.scm116
-rw-r--r--module/web/request.scm40
28 files changed, 438 insertions, 136 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index b21b73c77..0787f2004 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -146,7 +146,6 @@ BRAINFUCK_LANG_SOURCES = \
language/brainfuck/spec.scm
SCRIPTS_SOURCES = \
- scripts/PROGRAM.scm \
scripts/autofrisk.scm \
scripts/compile.scm \
scripts/disassemble.scm \
@@ -154,6 +153,7 @@ SCRIPTS_SOURCES = \
scripts/doc-snarf.scm \
scripts/frisk.scm \
scripts/generate-autoload.scm \
+ scripts/help.scm \
scripts/lint.scm \
scripts/list.scm \
scripts/punify.scm \
@@ -356,6 +356,7 @@ LIB_SOURCES = \
texinfo/serialize.scm
WEB_SOURCES = \
+ web/client.scm \
web/http.scm \
web/request.scm \
web/response.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 9c3a3e165..3bf492280 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3414,6 +3414,15 @@ module '(ice-9 q) '(make-q q-length))}."
'(#:warnings (unbound-variable arity-mismatch format)))
(define* (load-in-vicinity dir path #:optional reader)
+ (define (canonical->suffix canon)
+ (cond
+ ((string-prefix? "/" canon) canon)
+ ((and (> (string-length canon) 2)
+ (eqv? (string-ref canon 1) #\:))
+ ;; Paths like C:... transform to /C...
+ (string-append "/" (substring canon 0 1) (substring canon 2)))
+ (else canon)))
+
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out of
;; date, and auto-compilation is enabled, will try auto-compilation, just
@@ -3425,11 +3434,12 @@ module '(ice-9 q) '(make-q q-length))}."
;; partially duplicates functionality from (system base compile).
;;
(define (compiled-file-name canon-path)
+ ;; FIXME: would probably be better just to append SHA1(canon-path)
+ ;; to the %compile-fallback-path, to avoid deep directory stats.
(and %compile-fallback-path
(string-append
%compile-fallback-path
- ;; no need for '/' separator here, canon-path is absolute
- canon-path
+ (canonical->suffix canon-path)
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
(warn "invalid %load-compiled-extensions"
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index e48c220f2..a27aab5fb 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -398,13 +398,11 @@
names))
(goops-error "no prefixes supplied"))))
-(define (make-generic . name)
- (let ((name (and (pair? name) (car name))))
- (make <generic> #:name name)))
+(define* (make-generic #:optional name)
+ (make <generic> #:name name))
-(define (make-extended-generic gfs . name)
- (let* ((name (and (pair? name) (car name)))
- (gfs (if (pair? gfs) gfs (list gfs)))
+(define* (make-extended-generic gfs #:optional name)
+ (let* ((gfs (if (list? gfs) gfs (list gfs)))
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
(let ((ans (if gws?
(let* ((sname (and name (make-setter-name name)))
@@ -441,18 +439,17 @@
(delq! eg (slot-ref gf 'extended-by))))
gfs))
-(define (ensure-generic old-definition . name)
- (let ((name (and (pair? name) (car name))))
- (cond ((is-a? old-definition <generic>) old-definition)
- ((procedure-with-setter? old-definition)
- (make <generic-with-setter>
- #:name name
- #:default (procedure old-definition)
- #:setter (setter old-definition)))
- ((procedure? old-definition)
- (if (generic-capability? old-definition) old-definition
- (make <generic> #:name name #:default old-definition)))
- (else (make <generic> #:name name)))))
+(define* (ensure-generic old-definition #:optional name)
+ (cond ((is-a? old-definition <generic>) old-definition)
+ ((procedure-with-setter? old-definition)
+ (make <generic-with-setter>
+ #:name name
+ #:default (procedure old-definition)
+ #:setter (setter old-definition)))
+ ((procedure? old-definition)
+ (if (generic-capability? old-definition) old-definition
+ (make <generic> #:name name #:default old-definition)))
+ (else (make <generic> #:name name))))
;; same semantics as <generic>
(define-syntax define-accessor
@@ -466,34 +463,32 @@
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
-(define (make-accessor . name)
- (let ((name (and (pair? name) (car name))))
- (make <accessor>
- #:name name
- #:setter (make <generic>
- #:name (and name (make-setter-name name))))))
-
-(define (ensure-accessor proc . name)
- (let ((name (and (pair? name) (car name))))
- (cond ((and (is-a? proc <accessor>)
- (is-a? (setter proc) <generic>))
- proc)
- ((is-a? proc <generic-with-setter>)
- (upgrade-accessor proc (setter proc)))
- ((is-a? proc <generic>)
- (upgrade-accessor proc (make-generic name)))
- ((procedure-with-setter? proc)
- (make <accessor>
- #:name name
- #:default (procedure proc)
- #:setter (ensure-generic (setter proc) name)))
- ((procedure? proc)
- (ensure-accessor (if (generic-capability? proc)
- (make <generic> #:name name #:default proc)
- (ensure-generic proc name))
- name))
- (else
- (make-accessor name)))))
+(define* (make-accessor #:optional name)
+ (make <accessor>
+ #:name name
+ #:setter (make <generic>
+ #:name (and name (make-setter-name name)))))
+
+(define* (ensure-accessor proc #:optional name)
+ (cond ((and (is-a? proc <accessor>)
+ (is-a? (setter proc) <generic>))
+ proc)
+ ((is-a? proc <generic-with-setter>)
+ (upgrade-accessor proc (setter proc)))
+ ((is-a? proc <generic>)
+ (upgrade-accessor proc (make-generic name)))
+ ((procedure-with-setter? proc)
+ (make <accessor>
+ #:name name
+ #:default (procedure proc)
+ #:setter (ensure-generic (setter proc) name)))
+ ((procedure? proc)
+ (ensure-accessor (if (generic-capability? proc)
+ (make <generic> #:name name #:default proc)
+ (ensure-generic proc name))
+ name))
+ (else
+ (make-accessor name))))
(define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods))
diff --git a/module/scripts/PROGRAM.scm b/module/scripts/PROGRAM.scm
deleted file mode 100644
index 56e5cf334..000000000
--- a/module/scripts/PROGRAM.scm
+++ /dev/null
@@ -1,40 +0,0 @@
-;;; PROGRAM --- Does something
-
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
-;;
-;; This program 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, or
-;; (at your option) any later version.
-;;
-;; This program 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 software; see the file COPYING.LESSER. If
-;; not, write to the Free Software Foundation, Inc., 51 Franklin
-;; Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Author: J.R.Hacker
-
-;;; Commentary:
-
-;; Usage: PROGRAM [ARGS]
-;;
-;; PROGRAM does something.
-;;
-;; TODO: Write it!
-
-;;; Code:
-
-(define-module (scripts PROGRAM)
- :export (PROGRAM))
-
-(define (PROGRAM . args)
- #t)
-
-(define main PROGRAM)
-
-;;; PROGRAM ends here
diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm
index b842b03ff..b2527b9e9 100644
--- a/module/scripts/api-diff.scm
+++ b/module/scripts/api-diff.scm
@@ -1,6 +1,6 @@
;;; api-diff --- diff guile-api.alist files
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -46,6 +46,9 @@
:autoload (srfi srfi-13) (string-tokenize)
:export (api-diff))
+(define %include-in-guild-list #f)
+(define %summary "Show differences between two scan-api files.")
+
(define (read-alist-file file)
(with-input-from-file file
(lambda () (read))))
diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm
index 943c90227..9bce06e2a 100644
--- a/module/scripts/autofrisk.scm
+++ b/module/scripts/autofrisk.scm
@@ -1,6 +1,6 @@
;;; autofrisk --- Generate module checks for use with auto* tools
-;; Copyright (C) 2002, 2006, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2009, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -62,6 +62,9 @@
:use-module (scripts frisk)
:export (autofrisk))
+(define %include-in-guild-list #f)
+(define %summary "Generate snippets for use in configure.ac files.")
+
(define *recognized-keys* '(files-glob
non-critical-external
non-critical-internal
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index f9d6cca99..0651c6804 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -37,6 +37,8 @@
#:use-module (ice-9 format)
#:export (compile))
+(define %summary "Compile a file.")
+
(define (fail . messages)
(format (current-error-port) "error: ~{~a~}~%" messages)
diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm
index 8907f6d08..7dab2dde9 100644
--- a/module/scripts/disassemble.scm
+++ b/module/scripts/disassemble.scm
@@ -1,6 +1,6 @@
;;; Disassemble --- Disassemble .go files into something human-readable
-;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc.
+;; Copyright 2005, 2008, 2009, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -32,6 +32,8 @@
#:renamer (symbol-prefix-proc 'asm:))
#:export (disassemble))
+(define %summary "Disassemble a compiled .go file.")
+
(define (disassemble . files)
(for-each (lambda (file)
(asm:disassemble (load-objcode file)))
diff --git a/module/scripts/display-commentary.scm b/module/scripts/display-commentary.scm
index 5bd249ce9..81d7907af 100644
--- a/module/scripts/display-commentary.scm
+++ b/module/scripts/display-commentary.scm
@@ -1,6 +1,6 @@
;;; display-commentary --- As advertized
-;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -33,6 +33,8 @@
:use-module (ice-9 documentation)
:export (display-commentary))
+(define %summary "Display the Commentary section from a file or module.")
+
(define (display-commentary-one file)
(format #t "~A commentary:\n~A" file (file-commentary file)))
diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm
index b7fbc996e..fa3dfb312 100644
--- a/module/scripts/doc-snarf.scm
+++ b/module/scripts/doc-snarf.scm
@@ -1,6 +1,6 @@
;;; doc-snarf --- Extract documentation from source files
-;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -83,6 +83,8 @@ This procedure foos, or bars, depending on the argument @var{braz}.
:use-module (ice-9 rdelim)
:export (doc-snarf))
+(define %summary "Snarf out documentation from a file.")
+
(define command-synopsis
'((version (single-char #\v) (value #f))
(help (single-char #\h) (value #f))
diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm
index c452ede25..a8f79232d 100644
--- a/module/scripts/frisk.scm
+++ b/module/scripts/frisk.scm
@@ -1,6 +1,6 @@
;;; frisk --- Grok the module interfaces of a body of files
-;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -103,6 +103,9 @@
mod-up-ls mod-down-ls mod-int?
edge-type edge-up edge-down))
+(define %include-in-guild-list #f)
+(define %summary "Show dependency information for a module.")
+
(define *default-module* '(guile-user))
(define (grok-proc default-module note-use!)
diff --git a/module/scripts/generate-autoload.scm b/module/scripts/generate-autoload.scm
index 781931015..90f524b06 100644
--- a/module/scripts/generate-autoload.scm
+++ b/module/scripts/generate-autoload.scm
@@ -1,6 +1,6 @@
;;; generate-autoload --- Display define-module form with autoload info
-;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -59,6 +59,9 @@
(define-module (scripts generate-autoload)
:export (generate-autoload))
+(define %include-in-guild-list #f)
+(define %summary "Generate #:autoload clauses for a module.")
+
(define (autoload-info file)
(let ((p (open-input-file file)))
(let loop ((form (read p)) (module-name #f) (exports '()))
diff --git a/module/scripts/help.scm b/module/scripts/help.scm
new file mode 100644
index 000000000..107d39485
--- /dev/null
+++ b/module/scripts/help.scm
@@ -0,0 +1,148 @@
+;;; Help --- Show help on guild commands
+
+;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; 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
+
+;;; Commentary:
+
+;; Usage: help
+;;
+;; Show help for Guild scripts.
+
+;;; Code:
+
+(define-module (scripts help)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 documentation)
+ #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:export (main))
+
+(define %summary "Show a brief help message.")
+
+
+(define (directory-files dir)
+ (if (and (file-exists? dir) (file-is-directory? dir))
+ (let ((dir-stream (opendir dir)))
+ (let loop ((new (readdir dir-stream))
+ (acc '()))
+ (if (eof-object? new)
+ (begin
+ (closedir dir-stream)
+ acc)
+ (loop (readdir dir-stream)
+ (if (or (string=? "." new) ; ignore
+ (string=? ".." new)) ; ignore
+ acc
+ (cons new acc))))))
+ '()))
+
+(define (strip-extensions path)
+ (or-map (lambda (ext)
+ (and
+ (string-suffix? ext path)
+ ;; We really can't be adding e.g. ChangeLog-2008 to the set
+ ;; of runnable scripts, just because "" is a valid
+ ;; extension, by default. So hack around that here.
+ (not (string-null? ext))
+ (substring path 0
+ (- (string-length path) (string-length ext)))))
+ (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) l)
+ ((equal? (car l) (cadr l)) (unique (cdr l)))
+ (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+ (let ((shead (map symbol->string head)))
+ (unique
+ (sort
+ (append-map (lambda (path)
+ (fold (lambda (x rest)
+ (let ((stripped (strip-extensions x)))
+ (if stripped (cons stripped rest) rest)))
+ '()
+ (directory-files
+ (fold (lambda (x y) (in-vicinity y x)) path shead))))
+ %load-path)
+ string<?))))
+
+(define (list-commands all?)
+ (display "\
+Usage: guild COMMAND [ARGS]
+Run command-line scripts provided by GNU Guile and related programs.
+
+Commands:
+")
+
+ (for-each
+ (lambda (name)
+ (let* ((modname `(scripts ,(string->symbol name)))
+ (mod (resolve-module modname #:ensure #f))
+ (summary (and mod (and=> (module-variable mod '%summary)
+ variable-ref))))
+ (if (and mod
+ (or all?
+ (let ((v (module-variable mod '%include-in-guild-list)))
+ (if v (variable-ref v) #t))))
+ (if summary
+ (format #t " ~A ~23t~a\n" name summary)
+ (format #t " ~A\n" name)))))
+ (find-submodules '(scripts)))
+ (format #t "
+For help on a specific command, try \"guild help COMMAND\".
+
+Report guild bugs to ~a
+GNU Guile home page: <http://www.gnu.org/software/guile/>
+General help using GNU software: <http://www.gnu.org/gethelp/>
+For complete documentation, run: info guile 'Using Guile Tools'
+" %guile-bug-report-address))
+
+(define (module-commentary mod)
+ (file-commentary
+ (%search-load-path (module-filename mod))))
+
+(define (main . args)
+ (cond
+ ((null? args)
+ (list-commands #f))
+ ((or (equal? args '("--all")) (equal? args '("-a")))
+ (list-commands #t))
+ ((not (string-prefix? "-" (car args)))
+ ;; help for particular command
+ (let* ((name (car args))
+ (mod (resolve-module `(scripts ,(string->symbol name))
+ #:ensure #f)))
+ (if mod
+ (let ((commentary (module-commentary mod)))
+ (if commentary
+ (display commentary)
+ (format #t "No documentation found for command \"~a\".\n"
+ name)))
+ (begin
+ (format #t "No command named \"~a\".\n" name)
+ (exit 1)))))
+ (else
+ (display "Usage: guild help
+ guild help --all
+ guild help COMMAND
+
+Show a help on guild commands. With --all, show arcane incantations as
+well. With COMMAND, show more detailed help for a particular command.
+")
+ (exit 1))))
diff --git a/module/scripts/lint.scm b/module/scripts/lint.scm
index aa74fb6a7..cea425ea9 100644
--- a/module/scripts/lint.scm
+++ b/module/scripts/lint.scm
@@ -105,6 +105,9 @@
#:use-module (ice-9 format)
#:export (lint))
+(define %include-in-guild-list #f)
+(define %summary "Check for bugs and style errors in a Scheme file.")
+
(define (lint filename)
(let ((module-name (scan-file-for-module-name filename))
(free-vars (uniq (scan-file-for-free-variables filename))))
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
index c4891b6a8..0f1d715dd 100644
--- a/module/scripts/list.scm
+++ b/module/scripts/list.scm
@@ -26,9 +26,11 @@
;;; Code:
(define-module (scripts list)
- #:use-module ((srfi srfi-1) #:select (fold append-map))
#:export (list-scripts))
+(define %include-in-guild-list #f)
+(define %summary "An alias for \"help\".")
+
(define (directory-files dir)
(if (and (file-exists? dir) (file-is-directory? dir))
@@ -50,6 +52,10 @@
(or-map (lambda (ext)
(and
(string-suffix? ext path)
+ ;; We really can't be adding e.g. ChangeLog-2008 to the set
+ ;; of runnable scripts, just because "" is a valid
+ ;; extension, by default. So hack around that here.
+ (not (string-null? ext))
(substring path 0
(- (string-length path) (string-length ext)))))
(append %load-compiled-extensions %load-extensions)))
@@ -80,4 +86,5 @@
(format #t "~A\n" x))
(find-submodules '(scripts))))
-(define main list-scripts)
+(define (main . args)
+ (apply (@@ (scripts help) main) args))
diff --git a/module/scripts/punify.scm b/module/scripts/punify.scm
index 1627722d3..6b33ac5ee 100644
--- a/module/scripts/punify.scm
+++ b/module/scripts/punify.scm
@@ -41,6 +41,9 @@
(define-module (scripts punify)
:export (punify))
+(define %include-in-guild-list #f)
+(define %summary "Strip comments and whitespace from a Scheme file.")
+
(define (write-punily form)
(cond ((and (list? form) (not (null? form)))
(let ((first (car form)))
diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm
index c0a54f28c..08f3fb9a1 100644
--- a/module/scripts/read-rfc822.scm
+++ b/module/scripts/read-rfc822.scm
@@ -1,6 +1,6 @@
;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
-;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2004, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -49,6 +49,9 @@
:autoload (srfi srfi-13) (string-join)
:export (read-rfc822 read-rfc822-silently))
+(define %include-in-guild-list #f)
+(define %summary "Validate an RFC822-style file.")
+
(define from-line-rx (make-regexp "^From "))
(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
(define header-cont-rx (make-regexp "^[ \t]+"))
diff --git a/module/scripts/read-scheme-source.scm b/module/scripts/read-scheme-source.scm
index b48a88f9b..1bca6a4c4 100644
--- a/module/scripts/read-scheme-source.scm
+++ b/module/scripts/read-scheme-source.scm
@@ -1,6 +1,6 @@
;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
-;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -91,6 +91,9 @@
quoted?
clump))
+(define %include-in-guild-list #f)
+(define %summary "Print a parsed representation of a Scheme file.")
+
;; Try to figure out what FORM is and its various attributes.
;; Call proc NOTE! with key (a symbol) and value.
;;
diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm
index 64221fbe1..d0933bb0b 100644
--- a/module/scripts/read-text-outline.scm
+++ b/module/scripts/read-text-outline.scm
@@ -1,6 +1,6 @@
;;; read-text-outline --- Read a text outline and display it as a sexp
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -118,6 +118,9 @@
:autoload (ice-9 rdelim) (read-line)
:autoload (ice-9 getopt-long) (getopt-long))
+(define %include-in-guild-list #f)
+(define %summary "Convert textual outlines to s-expressions.")
+
(define (?? symbol)
(let ((name (symbol->string symbol)))
(string=? "?" (substring name (1- (string-length name))))))
diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm
index 9236f8742..86d07fc3e 100644
--- a/module/scripts/scan-api.scm
+++ b/module/scripts/scan-api.scm
@@ -1,6 +1,6 @@
;;; scan-api --- Scan and group interpreter and libguile interface elements
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -65,6 +65,9 @@
:use-module (ice-9 regex)
:export (scan-api))
+(define %include-in-guild-list #f)
+(define %summary "Generate an API description for a Guile extension.")
+
(define put set-object-property!)
(define get object-property)
diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm
index f92c833ed..6ca07a1f4 100644
--- a/module/scripts/snarf-check-and-output-texi.scm
+++ b/module/scripts/snarf-check-and-output-texi.scm
@@ -1,6 +1,6 @@
;;; snarf-check-and-output-texi --- called by the doc snarfer.
-;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -26,6 +26,9 @@
:use-module (ice-9 match)
:export (snarf-check-and-output-texi))
+(define %include-in-guild-list #f)
+(define %summary "Transform snarfed .doc files into texinfo documentation.")
+
;;; why aren't these in some module?
(define-macro (when cond . body)
diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm
index 05c305ebd..4e59f536d 100644
--- a/module/scripts/snarf-guile-m4-docs.scm
+++ b/module/scripts/snarf-guile-m4-docs.scm
@@ -1,6 +1,6 @@
;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -35,6 +35,9 @@
:use-module (ice-9 rdelim)
:export (snarf-guile-m4-docs))
+(define %include-in-guild-list #f)
+(define %summary "Snarf out texinfo documentation from .m4 files.")
+
(define (display-texi lines)
(display "@deffn {Autoconf Macro}")
(for-each (lambda (line)
diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm
index ee4f88c1f..8b119e0ec 100644
--- a/module/scripts/summarize-guile-TODO.scm
+++ b/module/scripts/summarize-guile-TODO.scm
@@ -1,6 +1,6 @@
;;; summarize-guile-TODO --- Display Guile TODO list in various ways
-;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -73,6 +73,9 @@
:autoload (ice-9 common-list) (remove-if-not)
:export (summarize-guile-TODO))
+(define %include-in-guild-list #f)
+(define %summary "A quaint relic of the past.")
+
(define put set-object-property!)
(define get object-property)
diff --git a/module/scripts/use2dot.scm b/module/scripts/use2dot.scm
index ab97afbc7..975a9c4a4 100644
--- a/module/scripts/use2dot.scm
+++ b/module/scripts/use2dot.scm
@@ -1,6 +1,6 @@
;;; use2dot --- Display module dependencies as a DOT specification
-;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
@@ -53,6 +53,8 @@
:select (make-frisker edge-type edge-up edge-down))
:export (use2dot))
+(define %summary "Print a module's dependencies in graphviz format.")
+
(define *default-module* '(guile-user))
(define (q s) ; quote
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 1b6e73f32..943999040 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -103,6 +103,16 @@
;;;
;;; See also boot-9.scm:load.
(define (compiled-file-name file)
+ ;; FIXME: would probably be better just to append SHA1(canon-path)
+ ;; to the %compile-fallback-path, to avoid deep directory stats.
+ (define (canonical->suffix canon)
+ (cond
+ ((string-prefix? "/" canon) canon)
+ ((and (> (string-length canon) 2)
+ (eqv? (string-ref canon 1) #\:))
+ ;; Paths like C:... transform to /C...
+ (string-append "/" (substring canon 0 1) (substring canon 2)))
+ (else canon)))
(define (compiled-extension)
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
@@ -113,9 +123,7 @@
(and %compile-fallback-path
(let ((f (string-append
%compile-fallback-path
- ;; no need for '/' separator here, canonicalize-path
- ;; will give us an absolute path
- (canonicalize-path file)
+ (canonical->suffix (canonicalize-path file))
(compiled-extension))))
(and (false-if-exception (ensure-writable-dir (dirname f)))
f))))
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 109b533f8..a2f2a6f84 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -485,21 +485,19 @@ Disassemble a file."
"time EXP
Time execution."
(let* ((gc-start (gc-run-time))
- (tms-start (times))
+ (real-start (get-internal-real-time))
+ (run-start (get-internal-run-time))
(result (repl-eval repl (repl-parse repl form)))
- (tms-end (times))
+ (run-end (get-internal-run-time))
+ (real-end (get-internal-real-time))
(gc-end (gc-run-time)))
- (define (get proc start end)
- (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
+ (define (diff start end)
+ (/ (- end start) 1.0 internal-time-units-per-second))
(repl-print repl result)
- (display "clock utime stime cutime cstime gctime\n")
- (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
- (get tms:clock tms-start tms-end)
- (get tms:utime tms-start tms-end)
- (get tms:stime tms-start tms-end)
- (get tms:cutime tms-start tms-end)
- (get tms:cstime tms-start tms-end)
- (get identity gc-start gc-end))
+ (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n"
+ (diff real-start real-end)
+ (diff run-start run-end)
+ (diff gc-start gc-end))
result))
(define-meta-command (profile repl (form) . opts)
diff --git a/module/web/client.scm b/module/web/client.scm
new file mode 100644
index 000000000..6a04497cf
--- /dev/null
+++ b/module/web/client.scm
@@ -0,0 +1,116 @@
+;;; Web client
+
+;; Copyright (C) 2011 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; 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
+
+;;; Commentary:
+;;;
+;;; (web client) is a simple HTTP URL fetcher for Guile.
+;;;
+;;; In its current incarnation, (web client) is synchronous. If you
+;;; want to fetch a number of URLs at once, probably the best thing to
+;;; do is to write an event-driven URL fetcher, similar in structure to
+;;; the web server.
+;;;
+;;; Another option, good but not as performant, would be to use threads,
+;;; possibly via par-map or futures.
+;;;
+;;; Code:
+
+(define-module (web client)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 rdelim)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:export (open-socket-for-uri
+ http-get))
+
+(define (open-socket-for-uri uri)
+ (let* ((ai (car (getaddrinfo (uri-host uri)
+ (cond
+ ((uri-port uri) => number->string)
+ (else (symbol->string (uri-scheme uri)))))))
+ (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+ (addrinfo:protocol ai))))
+ (set-port-encoding! s "ISO-8859-1")
+ (connect s (addrinfo:addr ai))
+ ;; Buffer input and output on this port.
+ (setvbuf s _IOFBF)
+ ;; Enlarge the receive buffer.
+ (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+ s))
+
+(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 (text-type? type)
+ (let ((type (symbol->string type)))
+ (or (string-prefix? "text/" type)
+ (string-suffix? "/xml" type)
+ (string-suffix? "+xml" type))))
+
+;; Logically the inverse of (web server)'s `sanitize-response'.
+;;
+(define (decode-response-body response body)
+ ;; `body' is either #f or a bytevector.
+ (cond
+ ((not body) body)
+ ((bytevector? body)
+ (let ((rlen (response-content-length response))
+ (blen (bytevector-length body)))
+ (cond
+ ((and rlen (not (= rlen blen)))
+ (error "bad content-length" rlen blen))
+ ((response-content-type response)
+ => (lambda (type)
+ (cond
+ ((text-type? (car type))
+ (decode-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))
+ (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)))))
diff --git a/module/web/request.scm b/module/web/request.scm
index 84119205f..c9204a4bf 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -151,21 +151,31 @@
(validate-headers? #t))
"Construct an HTTP request object. If @var{validate-headers?} is true,
the headers are each run through their respective validators."
- (cond
- ((not (and (pair? version)
- (non-negative-integer? (car version))
- (non-negative-integer? (cdr version))))
- (bad-request "Bad version: ~a" version))
- ((not (uri? uri))
- (bad-request "Bad uri: ~a" uri))
- ((and (not port) (memq method '(POST PUT)))
- (bad-request "Missing port for message ~a" method))
- ((not (list? meta))
- (bad-request "Bad metadata alist" meta))
- (else
- (if validate-headers?
- (validate-headers headers))))
- (make-request method uri version headers meta port))
+ (let ((needs-host? (and (equal? version '(1 . 1))
+ (not (assq-ref headers 'host)))))
+ (cond
+ ((not (and (pair? version)
+ (non-negative-integer? (car version))
+ (non-negative-integer? (cdr version))))
+ (bad-request "Bad version: ~a" version))
+ ((not (uri? uri))
+ (bad-request "Bad uri: ~a" uri))
+ ((and (not port) (memq method '(POST PUT)))
+ (bad-request "Missing port for message ~a" method))
+ ((not (list? meta))
+ (bad-request "Bad metadata alist" meta))
+ ((and needs-host? (not (uri-host uri)))
+ (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a"
+ uri))
+ (else
+ (if validate-headers?
+ (validate-headers headers))))
+ (make-request method uri version
+ (if needs-host?
+ (acons 'host (cons (uri-host uri) (uri-port uri))
+ headers)
+ headers)
+ meta port)))
(define* (read-request port #:optional (meta '()))
"Read an HTTP request from @var{port}, optionally attaching the given