[Guile-commits] GNU Guile branch, master, updated. v2.1.0-194-gd5e1f82

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d5e1f8224068c3c579b9a6d77450d50af512aa52

The branch, master has been updated
       via  d5e1f8224068c3c579b9a6d77450d50af512aa52 (commit)
       via  da23abd9706390d655b120eb1384236113238b19 (commit)
       via  89d45e850725e232ae685803ee476da5b046c2b0 (commit)
       via  9effafa444a021d1564800aa81a35098651c5fec (commit)
       via  8b49b6b1f5522dfbb78c9249cf219a29264df490 (commit)
       via  e0dc497832fbd175538bfe60b468fcb43c49aaae (commit)
       via  02360ed6050833d5436ea4f1b9b4f10f3783491b (commit)
       via  aaaa0eef9cfdb426f0b0fb4423fc25b655b722a4 (commit)
       via  9adbf27f4e0656f489c8c9fa941da023ee4201ec (commit)
      from  52d2472441891cbb85ec23d16e685d91c5ed8bfd (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit d5e1f8224068c3c579b9a6d77450d50af512aa52
Merge: da23abd 89d45e8
Author: Andy Wingo <address@hidden>
Date:   Mon Mar 12 17:00:09 2012 +0100

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

commit da23abd9706390d655b120eb1384236113238b19
Merge: 9effafa 52d2472
Author: Andy Wingo <address@hidden>
Date:   Mon Mar 12 17:00:02 2012 +0100

    Merge branch 'master' of git.sv.gnu.org:/srv/git/guile

commit 9effafa444a021d1564800aa81a35098651c5fec
Author: Andy Wingo <address@hidden>
Date:   Sun Mar 11 11:06:39 2012 +0100

    fix bad-request-printer
    
    * module/web/request.scm (bad-request-printer): Fix printer to expect
      args as a list.

commit 8b49b6b1f5522dfbb78c9249cf219a29264df490
Merge: e0dc497 02360ed
Author: Andy Wingo <address@hidden>
Date:   Sun Mar 11 11:06:14 2012 +0100

    Merge remote-tracking branch 'local-2.0/stable-2.0'
    
    Conflicts:
        configure.ac

commit e0dc497832fbd175538bfe60b468fcb43c49aaae
Author: Andy Wingo <address@hidden>
Date:   Sun Mar 11 10:57:05 2012 +0100

    add bad-request printer
    
    * module/web/request.scm (bad-request-printer): Add printer for these
      exceptions.

commit aaaa0eef9cfdb426f0b0fb4423fc25b655b722a4
Author: Andy Wingo <address@hidden>
Date:   Sun Mar 11 10:24:08 2012 +0100

    add exception printers for bad-header, bad-header-component
    
    * module/web/http.scm (bad-header-component): Throw
      'bad-header-component instead of 'bad-header.
      (bad-header-printer, bad-header-component-printer): Add exception
      printers.

-----------------------------------------------------------------------

Summary of changes:
 configure.ac               |    2 +-
 libguile/gc.c              |    8 ++++++++
 module/web/http.scm        |   19 +++++++++++++++++--
 module/web/request.scm     |   13 ++++++++++++-
 module/web/server/http.scm |   16 ++++++++++++++--
 5 files changed, 52 insertions(+), 6 deletions(-)

diff --git a/configure.ac b/configure.ac
index f79c671..e2ccb8c 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1232,7 +1232,7 @@ save_LIBS="$LIBS"
 LIBS="$BDW_GC_LIBS $LIBS"
 CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
 
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit 
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask 
GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link 
GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap 
GC_get_unmapped_bytes GC_set_finalizer_notifier])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit 
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask 
GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link 
GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap 
GC_get_unmapped_bytes GC_set_finalizer_notifier GC_set_finalize_on_demand])
 
 # Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
 # declared, and has a different type (returning void instead of
diff --git a/libguile/gc.c b/libguile/gc.c
index df93d32..71efd03 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -611,6 +611,14 @@ scm_getenv_int (const char *var, int def)
   return res;
 }
 
+#ifndef HAVE_GC_SET_FINALIZE_ON_DEMAND
+static void
+GC_set_finalize_on_demand (int foo)
+{
+  GC_finalize_on_demand = foo;
+}
+#endif
+
 void
 scm_storage_prehistory ()
 {
diff --git a/module/web/http.scm b/module/web/http.scm
index 10c5fcf..d579c52 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -240,7 +240,22 @@ ordered alist."
 (define (bad-header sym val)
   (throw 'bad-header sym val))
 (define (bad-header-component sym val)
-  (throw 'bad-header sym val))
+  (throw 'bad-header-component sym val))
+
+(define (bad-header-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header: ~a\n" (header->string sym) val))
+           (_ (default-printer)))
+         args))
+(define (bad-header-component-printer port key args default-printer)
+  (apply (case-lambda
+           ((sym val)
+            (format port "Bad ~a header component: ~a\n" sym val))
+           (_ (default-printer)))
+         args))
+(set-exception-printer! 'bad-header bad-header-printer)
+(set-exception-printer! 'bad-header-component bad-header-component-printer)
 
 (define (parse-opaque-string str)
   str)
@@ -785,7 +800,7 @@ ordered alist."
              port)
     (display-digits (date-day date) 2 port)
     (display (case (date-month date)
-               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Ma ")
+               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Mar ")
                ((4)  " Apr ") ((5)  " May ") ((6)  " Jun ")
                ((7)  " Jul ") ((8)  " Aug ") ((9)  " Sep ")
                ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
diff --git a/module/web/request.scm b/module/web/request.scm
index 8259887..40d4a66 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -1,6 +1,6 @@
 ;;; HTTP request objects
 
-;; Copyright (C)  2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012 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
@@ -131,6 +131,17 @@
 (define (bad-request message . args)
   (throw 'bad-request message args))
 
+(define (bad-request-printer port key args default-printer)
+  (apply (case-lambda
+           ((msg args)
+            (display "Bad request: " port)
+            (apply format port msg args)
+            (newline port))
+           (_ (default-printer)))
+         args))
+
+(set-exception-printer! 'bad-request bad-request-printer)
+
 (define (non-negative-integer? n)
   (and (number? n) (>= n 0) (exact? n) (integer? n)))
                                     
diff --git a/module/web/server/http.scm b/module/web/server/http.scm
index a9a9049..cda44f4 100644
--- a/module/web/server/http.scm
+++ b/module/web/server/http.scm
@@ -1,6 +1,6 @@
 ;;; Web I/O: HTTP
 
-;; Copyright (C)  2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012 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,6 +69,11 @@
     (poll-set-add! poll-set socket *events*)
     (make-http-server socket 0 poll-set)))
 
+(define (bad-request port)
+  (write-response (build-response #:version '(1 . 0) #:code 400
+                                  #:headers '((content-length . 0)))
+                  port))
+
 ;; -> (client request body | #f #f #f)
 (define (http-read server)
   (let* ((poll-set (http-poll-set server)))
@@ -123,7 +128,14 @@
                            req
                            (read-request-body req))))
                (lambda (k . args)
-                 (false-if-exception (close-port port)))))))))))))
+                 (define-syntax-rule (cleanup-catch statement)
+                   (catch #t
+                     (lambda () statement)
+                     (lambda (k . args)
+                       (format (current-error-port) "In ~a:\n" 'statement)
+                       (print-exception (current-error-port) #f k args))))
+                 (cleanup-catch (bad-request port))
+                 (cleanup-catch (close-port port)))))))))))))
 
 (define (keep-alive? response)
   (let ((v (response-version response)))


hooks/post-receive
-- 
GNU Guile