1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
 2 
 3 ;;; Copyright (c) 2011, Hans Huebner.  All rights reserved.
 4 
 5 ;;; Redistribution and use in source and binary forms, with or without
 6 ;;; modification, are permitted provided that the following conditions
 7 ;;; are met:
 8 
 9 ;;;   * Redistributions of source code must retain the above copyright
10 ;;;     notice, this list of conditions and the following disclaimer.
11 
12 ;;;   * Redistributions in binary form must reproduce the above
13 ;;;     copyright notice, this list of conditions and the following
14 ;;;     disclaimer in the documentation and/or other materials
15 ;;;     provided with the distribution.
16 
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 
29 (in-package :cl-user)
30 
31 (defparameter *test-port* 4241)
32 
33 (asdf:oos 'asdf:load-op :hunchentoot-test)
34 
35 (defun run-tests ()
36   (format t "~&;; Starting web server on localhost:~A." *test-port*)
37   (force-output)
38   (let ((server (hunchentoot:start (make-instance 'hunchentoot:easy-acceptor :port *test-port*))))
39     (unwind-protect
40          (progn
41            (format t "~&;; Sleeping 2 seconds to give the server some time to start...")
42            (force-output)
43            (sleep 2)
44            (format t "~&;; Now running confidence tests.")
45            (force-output)
46            (hunchentoot-test:test-hunchentoot (format nil "http://localhost:~A" *test-port*)))
47       (format t "~&;; Stopping server.")
48       (force-output)
49       (hunchentoot:stop server)
50       (format t "~&;; Cleaning temporary files.")
51       (hunchentoot-test::clean-tmp-dir))))
52 
53 #-sbcl
54 (run-tests)
55 
56 ;;; KLUDGE (by Nikodemus Siivola)
57 ;;;
58 ;;; SBCL grabs a massive lock in WITH-COMPILATION-UNIT, which ASDF
59 ;;; uses in PERFORM-PLAN ... which makes spawning threads during testing
60 ;;; problematic to say the least.
61 ;;;
62 ;;; So, release the world lock for the duration. Nikodemus says that in this
63 ;;; specific usage this should be safe --- and promises that people who copy
64 ;;; this code and use it elsewhere will burn in hell for their sins.
65 ;;;
66 ;;; More promisingly, he swears up and down that that massive lock from
67 ;;; W-C-U will be gone by early 2012 at the latest, so this will not be
68 ;;; an eternal kludge, we hope.
69 (defun %call-without-world-lock-kludge (thunk)
70   #+(and sbcl sb-thread)
71   (let ((s (find-symbol "**WORLD-LOCK**" :sb-c)))
72     (if (and s (boundp s))
73         (let ((lock (symbol-value s)))
74           (unwind-protect
75                (progn
76                  (if (sb-thread:holding-mutex-p lock)
77                      (sb-thread:release-mutex lock)
78                      (setf lock nil))
79                  (funcall thunk))
80             (when lock
81               (sb-thread:grab-mutex lock))))
82         (funcall thunk)))
83   #-(and sbcl sb-thread)
84   (funcall thunk))
85 
86 #+sbcl
87 (%call-without-world-lock-kludge 'run-tests)