lispworks.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
   2 ;;; $Header: /usr/local/cvsrep/hunchentoot/port-lw.lisp,v 1.14 2008/04/08 14:39:18 edi Exp $
   3
   4 ;;; Copyright (c) 2004-2008, Dr. Edmund Weitz. All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot)
  31
  32 (eval-when (:compile-toplevel :load-toplevel :execute)
  33   ;; make sure socket code is loaded
  34   (require "comm"))
  35
  36 (defun get-env-variable-as-directory (name)
  37   "Retrieves the environment variable named NAME and interprets it as
  38 the pathname of a directory which is returned."
  39   (lw:when-let (string (lw:environment-variable name))
  40     (when (plusp (length string))
  41       (cond ((find (char string (1- (length string))) "\\/" :test #'char=) string)
  42             (t (lw:string-append string "/"))))))
  43
  44 (defmacro with-rebinding (bindings &body body)
  45   "Renaming LW:REBINDING for better indentation."
  46   `(lw:rebinding ,bindings ,@body))
  47
  48 #+(and :lispworks4.4 (or :win32 :linux))
  49 (let ((id :system-cons-free-chain))
  50   (unless (scm::patch-id-loaded-p id)
  51     (error "You need a patch to improve the performance of this code. Request patch ~S for ~A for ~A from lisp-support@lispworks.com using the Report Bug command."
  52           id (lisp-implementation-type)
  53           #+:win32 "Windows"
  54           #+:linux "Linux")))
  55
  56 (defvar *cleanup-interval* 100
  57   "Should be NIL or a positive integer.  The system calls
  58 *CLEANUP-FUNCTION* whenever *CLEANUP-INTERVAL* new worker threads have
  59 been created unless the value is NIL.")
  60
  61 (defvar *cleanup-function* 'cleanup-function
  62   "The function which is called if *CLEANUP-INTERVAL* is not NIL.")
  63
  64 (defvar *worker-counter* 0
  65   "Internal counter used to generate meaningful names for worker
  66 threads.")
  67
  68 (defun cleanup-function ()
  69   "The default for *CLEANUP-FUNCTION*.  Invokes a GC on 32-bit
  70 LispWorks."
  71   #-:lispworks-64bit
  72   (hcl:mark-and-sweep 2))
  73
  74 (defun get-peer-address-and-port (socket)
  75   "Returns the peer address and port of the socket SOCKET as two
  76 values.  The address is returned as a string in dotted IP address
  77 notation."
  78   (multiple-value-bind (peer-addr peer-port)
  79       (comm:get-socket-peer-address socket)
  80     (values (ignore-errors (comm:ip-address-string peer-addr)) peer-port)))
  81
  82 (defun make-socket-stream (socket server)
  83   "Returns a stream for the socket SOCKET.  The SERVER argument is
  84 used to set the timeouts."
  85   #-:lispworks5
  86   (when (server-write-timeout server)
  87     (parameter-error "You need LispWorks 5 or higher for write timeouts."))
  88   (make-instance 'comm:socket-stream
  89                  :socket socket
  90                  :direction :io
  91                  :read-timeout (server-read-timeout server)
  92                  #+:lispworks5 #+:lispworks5
  93                  :write-timeout (server-write-timeout server)
  94                  :element-type 'octet))
  95
  96 (defun make-lock (name)
  97   "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
  98   (mp:make-lock :name name))
  99
 100 (defun make-recursive-lock (name)
 101   "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
 102   (mp:make-lock :name name))
 103
 104 (defmacro with-recursive-lock-held ((lock) &body body)
 105   "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
 106   `(mp:with-lock (,lock) ,@body))
 107
 108 (defmacro with-lock-held ((lock) &body body)
 109   "Simple wrapper to allow LispWorks and Bordeaux Threads to coexist."
 110   `(mp:with-lock (,lock) ,@body))
 111
 112 ;; some help for the IDE
 113 (dspec:define-dspec-alias defvar-unbound (name)
 114   `(defparameter ,name))
 115
 116 (dspec:define-dspec-alias def-http-return-code (name)
 117   `(defconstant ,name))
 118
 119 (editor:setup-indent "defvar-unbound" 1 2 4)
 120
 121 (editor:setup-indent "def-http-return-code" 1 2 4)
 122