/[de-setf-amqp]/rabbitmq/utilities.lisp
ViewVC logotype

Contents of /rabbitmq/utilities.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (show annotations)
Tue Feb 23 09:05:39 2010 UTC (4 years, 1 month ago) by janderson
File size: 4070 byte(s)
Merge commit 'remotes/github/master' into remotes/git-svn
1 ;;;-* Package: rabbitmq; -*-
2
3 (in-package :rabbitmq)
4
5 ;; UTILITIES.LISP
6 ;; Nick Levine, Ravenbrook Limited, 2007-09-21
7 ;; James Anderson, setf.de, 2010-02-04
8
9 ;; 1. INTRODUCTION
10 ;;
11 ;; This document collects utilities for the RabbitMQ interface.
12 ;;
13 ;; See Appendix C below for copyright and license.
14
15 (defun whitespace-char-p (char)
16 (find char #(#\space #\tab #\return #\linefeed)))
17
18 (defun simple-word-wrap (text &optional (start 0))
19 (let* ((ideal 72)
20 (where (+ start ideal))
21 (length (length text)))
22 (when (>= where length)
23 (return-from simple-word-wrap
24 text))
25 (loop (when (whitespace-char-p (schar text where))
26 (setf (schar text where) #\Newline)
27 (return-from simple-word-wrap
28 (simple-word-wrap text (1+ where))))
29 (when (= (decf where) start)
30 (return)))
31 (setf where (+ start ideal 1))
32 (loop (when (whitespace-char-p (schar text where))
33 (setf (schar text where) #\Newline)
34 (return
35 (simple-word-wrap text (1+ where))))
36 (when (= (incf where) length)
37 (return text)))))
38
39
40 #+(or ) ;; by-hand
41 (defmacro rebinding (variables . body)
42 (let ((rebindings (mapcar #'(lambda (v) (list (gensym (string v)) v)) variables)))
43 `(list 'let (list ,@(mapcar #'(lambda (b) `(list (quote ,(first b)) ,(second b))) rebindings))
44 ,@(mapcar #'(lambda (form)
45 `(let ((form ,form))
46 (loop for (new old) in (list ,@(mapcar #'(lambda (b) `(list (quote ,(first b)) ,(second b))) rebindings))
47 do (setf form (subst new old form))
48 return form)))
49 body))))
50
51 (defmacro rebinding (variables . body)
52 (let ((rebindings (mapcar #'(lambda (v) (list (gensym (string v)) v)) variables)))
53 `(list 'let (list ,@(mapcar #'(lambda (b) `(list (quote ,(first b)) ,(second b))) rebindings))
54 (list 'symbol-macrolet ',(mapcar #'reverse rebindings)
55 ,@body))))
56
57 #+mcl
58 (defmacro defadvice ((function tag when) arglist . body)
59 `(ccl:advise ,function (apply #'(lambda ,arglist ,@body) arglist) :when ,when :name ,tag))
60
61
62 (defgeneric interpose-superclass (add-class amqp-class)
63 (:method ((add-class symbol) (amqp-class t))
64 (interpose-superclass (find-class add-class) amqp-class))
65 (:method ((add-class t) (amqp-class symbol))
66 (assert (eq (symbol-package amqp-class) (find-package :amqp)) ()
67 "Permitted for protocol classes only.")
68 (interpose-superclass add-class (find-class amqp-class)))
69 (:method ((add-class class) (amqp-class class))
70 (let ((existing-supers (c2mop:class-direct-superclasses amqp-class)))
71 (unless (find add-class existing-supers)
72 (reinitialize-instance amqp-class
73 :direct-superclasses (cons add-class existing-supers))))
74 amqp-class))
75
76
77 ;; A. REFERENCES
78 ;;
79 ;;
80 ;; B. HISTORY
81 ;;
82 ;; 2007-09-21 NDL Created.
83 ;; 2010-02-04 james.anderson@setf.de portability
84 ;;
85 ;;
86 ;; C. COPYRIGHT
87 ;;
88 ;; Copyright (c) 2007 Wiinz Limited.
89 ;;
90 ;; See `rabbitmq.asd` for the license terms for the original org.levine.rabbitmq package.
91
92 ;;; This file is part of the `de.setf.amqp.rabbitmq` library module.
93 ;;; (c) 2010 [james anderson](mailto:james.anderson@setf.de)
94 ;;;
95 ;;; `de.setf.amqp.rabbitmq` is free software: you can redistribute it and/or modify
96 ;;; it under the terms of the GNU General Public License as published by
97 ;;; the Free Software Foundation as version 3 of the License.
98 ;;;
99 ;;; `de.setf.amqp.rabbitmq` is distributed in the hope that it will be useful,
100 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
101 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
102 ;;; GNU General Public License for more details.
103 ;;;
104 ;;; You should have received a copy of the GNU General Public License
105 ;;; along with `de.setf.amqp.rabbitmq`. If not, see the GNU [site](http://www.gnu.org/licenses/).

  ViewVC Help
Powered by ViewVC 1.1.5