From 5a10e416e330a292cc60b625742a55a80d250386 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 10 Sep 2015 22:20:54 +0200 Subject: [PATCH] web: Fix 'close' method of delimited input ports. * module/web/response.scm (make-delimited-input-port)[close]: Replace erroneous self-recursive call with a call to 'close-port'. * test-suite/tests/web-response.test ("example-1")["response-body-port + close"]: New test. --- module/web/response.scm | 4 ++-- test-suite/tests/web-response.test | 14 ++++++++++++-- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/module/web/response.scm b/module/web/response.scm index 58e3f1141..614abcd55 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -1,6 +1,6 @@ ;;; HTTP response objects -;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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 @@ -265,7 +265,7 @@ closes PORT, unless KEEP-ALIVE? is true." (define close (and (not keep-alive?) (lambda () - (close port)))) + (close-port port)))) (make-custom-binary-input-port "delimited input port" read! #f #f close)) diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test index 99b129334..8957ba240 100644 --- a/test-suite/tests/web-response.test +++ b/test-suite/tests/web-response.test @@ -1,6 +1,6 @@ ;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2014, 2015 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 @@ -119,7 +119,17 @@ consectetur adipisicing elit,\r (with-fluids ((%default-port-encoding #f)) (let* ((r (read-response (open-input-string example-1))) (p (response-body-port r))) - (list (port-encoding p) (get-bytevector-all p))))))) + (list (port-encoding p) (get-bytevector-all p))))) + + (pass-if "response-body-port + close" + (with-fluids ((%default-port-encoding #f)) + (let* ((r (read-response (open-input-string example-1))) + (p (response-body-port r #:keep-alive? #f))) + ;; Before, calling 'close-port' here would yield a + ;; wrong-arg-num error when calling the delimited input port's + ;; 'close' procedure. + (close-port p) + (port-closed? p)))))) (with-test-prefix "example-2" (let* ((r (read-response (open-input-string example-2)))