Permalink
Browse files

lw additions; record delivery tag in basic for later use to ack message

  • Loading branch information...
1 parent 6dea972 commit f5a85606a8f7322fc85f033555a50630287ff531 @lisp committed Apr 20, 2011
@@ -16,10 +16,10 @@
A copy of the GNU Affero General Public License should be included with 'de.setf.amqp' as `AMQP:agpl.txt`.
If not, see the GNU [site](http://www.gnu.org/licenses/)."))
-
-(defvar amqp-1-1-0-8-0::+protocol-version+
- ':amqp-1-1-0-8-0
- "Specifies the protocol header for the highest supported version.")
+(eval-when (:compile-toplevel :load-toplevel :execute) ; lw wants this for the shared slot
+ (defvar amqp-1-1-0-8-0::+protocol-version+
+ ':amqp-1-1-0-8-0
+ "Specifies the protocol header for the highest supported version."))
(setf (version-protocol-header amqp-1-1-0-8-0::+protocol-version+) #(65 77 81 80 1 1 8 0))
@@ -27,8 +27,8 @@
:version 20100111.1
:depends-on (:de.setf.amqp)
:components ((:file "package")
- (:file "data-wire-coding")
(:file "abstract-classes")
+ (:file "data-wire-coding")
(:file "classes")
(:file "device-level"))
:description
@@ -18,9 +18,10 @@
If not, see the GNU [site](http://www.gnu.org/licenses/)."))
-(defvar amqp-1-1-0-9-0::+protocol-version+
- :amqp-1-1-0-9-0
- "Specifies the protocol header for the highest supported version.")
+(eval-when (:compile-toplevel :load-toplevel :execute) ; lw wants this for the shared slot
+ (defvar amqp-1-1-0-9-0::+protocol-version+
+ :amqp-1-1-0-9-0
+ "Specifies the protocol header for the highest supported version."))
(setf (version-protocol-header amqp-1-1-0-9-0::+protocol-version+) #(65 77 81 80 1 1 0 9))
@@ -27,8 +27,8 @@
:version 20100111.1
:depends-on (:de.setf.amqp)
:components ((:file "package")
- (:file "data-wire-coding")
(:file "abstract-classes")
+ (:file "data-wire-coding")
(:file "classes")
(:file "device-level"))
:description
@@ -17,9 +17,10 @@
If not, see the GNU [site](http://www.gnu.org/licenses/)."))
-(defvar amqp-1-1-0-9-1::+protocol-version+
- :amqp-1-1-0-9-1
- "Specifies the protocol header for the highest supported version.")
+(eval-when (:compile-toplevel :load-toplevel :execute) ; lw wants this for the shared slot
+ (defvar amqp-1-1-0-9-1::+protocol-version+
+ :amqp-1-1-0-9-1
+ "Specifies the protocol header for the highest supported version."))
(setf (version-protocol-header amqp-1-1-0-9-1::+protocol-version+) #(65 77 81 80 0 0 9 1))
@@ -30,8 +30,8 @@
;; conformant
;; (:file "data-wire-coding")
;; rabbitmq-like
- (:file "data-wire-coding-rmq")
(:file "abstract-classes")
+ (:file "data-wire-coding-rmq")
(:file "classes")
(:file "device-level"))
:description
View
@@ -96,6 +96,18 @@
"Do nothing more than log the message."
class)))
+;; 20110402 lw required the -ok be defined before the typecase refrence
+(def-amqp-command amqp:bind-ok (class &key)
+ (:documentation "C<--S : Confirm bind successful.
+ This command appears as eventual response to a Bind, and should be processed
+ synchronously by a request-bind. If one appears independently, log it.
+ and continue.")
+
+ (:response
+ (:method ((queue amqp:queue) &key)
+ "Simply log and continue."
+ queue)))
+
(def-amqp-command amqp:bind (class &key ticket queue exchange routing-key no-wait arguments)
(:documentation "C-->S: Bind queue to an exchange")
@@ -128,16 +140,18 @@
queue-class)))
-(def-amqp-command amqp:bind-ok (class &key)
- (:documentation "C<--S : Confirm bind successful.
- This command appears as eventual response to a Bind, and should be processed
- synchronously by a request-bind. If one appears independently, log it.
+;; 20110402 lw required the -ok be defined before the typecase refrence
+(def-amqp-command amqp:cancel-ok (class &key consumer-tag)
+ (:documentation "C<--S : confirm a canceled consumer.
+ This command appears as eventual response to Cancel and should be processed
+ synchronously by a request-cancel. If one appears independently, log it.
and continue.")
-
+
(:response
- (:method ((queue amqp:queue) &key)
+ (:method ((basic amqp::basic) &key consumer-tag)
+ (declare (ignore consumer-tag))
"Simply log and continue."
- queue)))
+ basic)))
(def-amqp-command amqp:cancel (class &rest args &key consumer-tag no-wait)
@@ -165,17 +179,27 @@ messages in between sending the cancel method and receiving the cancel-ok reply.
(amqp:body (frame) t)))))
-(def-amqp-command amqp:cancel-ok (class &key consumer-tag)
- (:documentation "C<--S : confirm a canceled consumer.
- This command appears as eventual response to Cancel and should be processed
- synchronously by a request-cancel. If one appears independently, log it.
- and continue.")
+;; 20110402 lw required the -ok be defined before the typecase refrence
+(def-amqp-command amqp:close-ok (class &key)
+ (:documentation "C<->S : confirm a channel or connection close close : Sync response to Close.
+ This command appears as the eventual response to Cancel and should be processes
+ synchronously together with that. I one appears independently, ignore it.")
+
+ (:request
+ (:method ((class amqp:connection) &key)
+ (amqp::send-close-ok class)
+ class)
+
+ (:method ((class amqp:channel) &key)
+ (amqp::send-close-ok class)
+ class))
(:response
- (:method ((basic amqp::basic) &key consumer-tag)
- (declare (ignore consumer-tag))
- "Simply log and continue."
- basic)))
+ (:method ((class amqp:connection) &key)
+ class)
+
+ (:method ((class amqp:channel) &key)
+ class)))
(def-amqp-command amqp:close (class &key reply-code reply-text class-id method-id)
@@ -270,28 +294,6 @@ messages in between sending the cancel method and receiving the cancel-ok reply.
connection)))
-(def-amqp-command amqp:close-ok (class &key)
- (:documentation "C<->S : confirm a channel or connection close close : Sync response to Close.
- This command appears as the eventual response to Cancel and should be processes
- synchronously together with that. I one appears independently, ignore it.")
-
- (:request
- (:method ((class amqp:connection) &key)
- (amqp::send-close-ok class)
- class)
-
- (:method ((class amqp:channel) &key)
- (amqp::send-close-ok class)
- class))
-
- (:response
- (:method ((class amqp:connection) &key)
- class)
-
- (:method ((class amqp:channel) &key)
- class)))
-
-
(def-amqp-command amqp:commit (class &key)
(:documentation "C-->S : Commit the current transaction.")
@@ -442,11 +444,17 @@ messages in between sending the cancel method and receiving the cancel-ok reply.
(:method ((basic amqp:basic) &rest args &key delivery-tag &allow-other-keys)
(declare (dynamic-extent args))
(let ((channel (object-channel basic)))
+ (when (channel-acknowledge-messages channel)
+ (setf (amqp:basic-delivery-tag basic) delivery-tag))
(prog1 (apply #'device-read-content channel args)
- (when (channel-acknowledge-messages channel)
+ (when (and (channel-acknowledge-messages channel)
+ ;; in case the ack was managed elsewhere, set the tag to zero
+ (eql (amqp:basic-delivery-tag basic) delivery-tag))
+ (setf (amqp:basic-delivery-tag basic) 0)
(amqp::send-ack basic :delivery-tag delivery-tag)))))))
+
(def-amqp-command amqp:Flow (class &key active)
(:documentation "C<->S : enable/disable flow from peer : Sync request ")
View
@@ -298,7 +298,7 @@
`(simple-array (unsigned-byte 8) (*))
`(simple-array (unsigned-byte 8) (,length))))
-#+(or clozure sbcl)
+#+(or clozure sbcl lispworks)
;; don't tell it more than it needs to know, otherwise shorter vectors conflict with declarations
(deftype amqp:frame-buffer (&optional length)
(declare (ignore length))
View
@@ -147,3 +147,14 @@
(eval '(+ single-float-positive-infinity single-float-negative-infinity)))
(defconstant double-float-nan
(eval '(+ double-float-positive-infinity double-float-negative-infinity)))))
+
+#+lispworks
+(progn
+ (defconstant double-float-positive-infinity system::*plus-infinity-double*)
+ (defconstant double-float-negative-infinity system::*minus-infinity-double*)
+ (defconstant single-float-positive-infinity (coerce system::*plus-infinity-double* 'single-float))
+ (defconstant single-float-negative-infinity (coerce system::*minus-infinity-double* 'single-float))
+
+ (defconstant single-float-nan (+ single-float-positive-infinity single-float-negative-infinity))
+ (defconstant double-float-nan (+ double-float-positive-infinity double-float-negative-infinity))
+ )

0 comments on commit f5a8560

Please sign in to comment.