/[cl-ipc]/cl-ipc/cl-ipc.lisp
ViewVC logotype

Contents of /cl-ipc/cl-ipc.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Mon Sep 19 08:48:24 2005 UTC (8 years, 7 months ago) by skamphausen
Branch: MAIN
CVS Tags: release-1-0, HEAD
Changes since 1.3: +3 -3 lines
fixed typo (*err-no-message* instead of +err-no-message+)
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
2
3 ;;; $Header: /tiger/var/lib/cvsroots/cl-ipc/cl-ipc/cl-ipc.lisp,v 1.4 2005/09/19 08:48:24 skamphausen Exp $
4 ;;; $Id: cl-ipc.lisp,v 1.4 2005/09/19 08:48:24 skamphausen Exp $
5
6 ;;; Copyright (C) 2005 by
7 ;;; Dr. Edmund Weitz http://weitz.de
8 ;;; and
9 ;;; Stefan Kamphausen http://www.skamphausen.de
10 ;;; All rights reserved.
11
12 ;;; Redistribution and use in source and binary forms, with or without
13 ;;; modification, are permitted provided that the following conditions
14 ;;; are met:
15
16 ;;; * Redistributions of source code must retain the above copyright
17 ;;; notice, this list of conditions and the following disclaimer.
18
19 ;;; * Redistributions in binary form must reproduce the above
20 ;;; copyright notice, this list of conditions and the following
21 ;;; disclaimer in the documentation and/or other materials
22 ;;; provided with the distribution.
23
24 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
25 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
26 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
27 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
28 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
29 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
30 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
31 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
32 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
33 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
34 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35
36 (in-package :cl-ipc)
37
38 (defmacro do-msg-queue ((var key &key nowait) &body body)
39 "Loop forever over an IPC queue which will be opened using the
40 number provided in KEY. Within the body the passed variable VAR
41 contains the current message from the client.
42
43 You can use EXIT-IPC-LOOP in the body to exit the loop.
44
45 A simple example:
46
47 \(do-msg-queue (msg 2223 :nowait nil)
48 (format t \"received ~A~%\" msg)
49 (force-output)
50 (when (string= msg \"quit\")
51 (exit-ipc-loop \"optional argument\")))
52
53 If you set NOWAIT to t the body will be executed immediately and the
54 variable holding the message will be set to NIL. In this case it is
55 up to you to wait or consume all CPU cycles. The default is to only
56 execute the body when a message was received.
57 "
58 (with-rebinding (key nowait)
59 (with-unique-names (id ipc-loop ipc-result msg-buf msg-flag)
60 `(let ((,id)
61 (,msg-flag (if ,nowait +ipc-no-wait-flag+ 0)))
62 (unwind-protect
63 (progn
64 (setf ,id (msg-get ,key
65 (logior +ipc-create-flag+
66 +ipc-exclusive-flag+
67 #o0666)))
68 (unless (plusp ,id)
69 (error "IPC GET ERROR (~a)" (get-unix-errno)))
70 (block ,ipc-loop
71 (flet ((exit-ipc-loop (&optional ,ipc-result)
72 (return-from ,ipc-loop ,ipc-result)))
73 (with-foreign-object (,msg-buf 'msg-struct)
74 (loop
75 (let ((,var))
76 (if (minusp (msg-receive ,id ,msg-buf
77 #.+message-length+
78 1 ,msg-flag))
79 (if (and ,nowait (= (get-unix-errno) *err-no-message*))
80 (setf ,var nil)
81 (error "IPC RCV ERROR (~a)" (get-unix-errno)))
82 (setf ,var (convert-from-foreign-string
83 (get-slot-value ,msg-buf 'msg-struct 'text))))
84 ,@body))))))
85 (when (and ,id (plusp ,id))
86 (msg-close ,id)))))))

  ViewVC Help
Powered by ViewVC 1.1.5