/[de-setf-amqp]/data-wire-coding.lisp
ViewVC logotype

Contents of /data-wire-coding.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: 71073 byte(s)
Merge commit 'remotes/github/master' into remotes/git-svn
1 ;;; -*- Package: de.setf.amqp.implementation; -*-
2
3 (in-package :de.setf.amqp.implementation)
4
5
6 (document :file
7 (description "This file defines buffer accessors for AMQP data as part of the 'de.setf.amqp' library.")
8 (copyright
9 "Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved"
10 "'de.setf.amqp' is free software: you can redistribute it and/or modify it under the terms of version 3
11 of the GNU Affero General Public License as published by the Free Software Foundation.
12
13 'setf.amqp' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
14 implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
15 See the Affero General Public License for more details.
16
17 A copy of the GNU Affero General Public License should be included with 'de.setf.amqp' as `AMQP:agpl.txt`.
18 If not, see the GNU [site](http://www.gnu.org/licenses/).")
19
20 (long-description "This file defines the general data buffer accessors for AMQP.[1]
21 These encode/decode data between Lisp values and byte sequence buffers. All types required by the AMQP
22 versions 0.8 through 0.10 are supported. Where the AMQP type corresponds directly to a designatable Lisp
23 type, the general accessors reflect that name. Each type corresponds to an operator reader/writer pair of
24 the form
25
26 BUFFER-_type_ (buffer position)
27 (SETF BUFFER-_type_) (value buffer position)
28 Both expect a `(SIMPLE-ARRAY (UNSIGNED-BYTE 8))` typed buffer and an integer position within the buffer.
29 Many of the AMQP typed operators map directly to atomic buffer operators with self-evident names.
30 Sequence types require sized iterative coding. In some such cases, the AMQP type designation's size
31 does not agree with the lisp type (eg str8 from 0.10 indicates the the length itself is an
32 `(unsigned-byte 8)` value. In these cases an intermediate type serves to mediate terms.
33
34 The self-describing encodings present a special case for each version, as the encoding structure and the
35 type codes vary. As a consequence, those are not defined here. Instead a macro is defined to generate them
36 for each version given the respective type codes.
37
38 Each protocol specification includes a type table. The respective `data-encoding.lisp` file includes a
39 transliterated version of this table to specify implementations for version-specific operators in terms of
40 the general, and to inform the generation of the codecs for self-defining encodings.
41
42
43 ----
44 [1]: 'Advanced Message Queueing Protocol', amqp0-9-1.pdf, Section 4"))
45
46
47
48 (defvar *wire-level-type-map* ()
49 "A bi-directional map between a primary lisp type and the types for a
50 given protocol version. Each type map entry indicates a relation between a wire-level data type
51 and a lisp data type, which can be used to generate the proper accessors for the wire-level
52 type. Each protocol version recognizes different types and uses different indicators to mark
53 them in-frame. In order to suport this, the accessor implementation for each version uses
54 version-specific names for its operators and delegates them to general operators based on the
55 entries in this table. One attribute, in particular, is whether a field type specializes `bit`,
56 as they require special codec processing.
57
58 NB. This is generated as a side-effect of translating the protocol specification, but is not
59 used afterwards, as the equivalent relations are hard-wired into the generated definitions.")
60
61 (defun amqp:wire-level-type (type &optional (map *wire-level-type-map*))
62 (gethash type map))
63
64 (defun (setf amqp:wire-level-type) (other-type key-type &optional (map *wire-level-type-map*))
65 (when (and (symbolp key-type) (eq other-type 'amqp:bit))
66 (setf (get key-type 'amqp:bit) t))
67 (setf (gethash key-type map) other-type))
68
69
70
71
72
73 (document (with-argument-decoders with-property-decoders)
74 "The wire-level representation presents three patterns:
75
76 - a fixed record structure for fields universally present - eg, frame type, channel, and size
77 in this case the record fields are en/decoded with operations which reflect a fixed position/size/type
78 map between lisp objects and the buffered data.
79
80 - a fixed sequence of variable length fields for method arguments
81 in this case macros are provided to en/decode a fixed sequence of values between lisp and buffered
82 representations. varying sized data (eg sized strings) and self describing composite types are
83 supported. As fields which are always present in the same order in the buffer the process is statically
84 expressed in the source. The only variation is that of the length of sized elements. the macros establish
85 an environment with a buffer and a position indicator which is maintained through interaction with the
86 primitive codecs for each field.
87
88 - a fixed sequence of optional, variable length fields for class content header properties
89 the encoded representation of a porperty set includes prefix flags to specify which fields are present.
90 these are consulted/computed by macros to decode to a property list and encode from variables.
91 the former mode is required in roder to construct keyword arguments based on presence. the latter
92 relies on a null/not-null distinction, which will need to be revisited should bit property fields appear.
93 The Property buffer codecs operate on a sequence of fields under control of an, initial bit flag
94 sequence. Where the flag indicates presence value is decoded. otherwise, the field is skipped. The encoding
95 performs the opposite projection, and skips null values. The property order and types are fixed, so use of
96 the respective buffer accessors can be expressed in static code in sequence to step through the fields.
97
98
99 The macro operators are paired for decode/encode and argument/property functions:
100 with-argument-decoders ((buffer &key (start 0)) &body body &environment env)
101 with-argument-encoders ((buffer &key (start 0)) &body body &environment env)
102 with-property-decoders ((buffer &key (start 0)) &body body &environment env)
103 with-property-encoders ((buffer &key (start 0)) &body body &environment env)")
104
105
106 (defmacro with-argument-decoders ((buffer &key (start 0)) &body body &environment env)
107 "Set up an argument decoding environment for the specified BUFFER. This includes a position indicator,
108 which is initialized from the specified START value. Within the environment two operators
109 are available
110 field (type) : decodes a field of the specified type, updates the position based on its
111 length and returns the value
112 bit (bit-position &optional update-position) : decodes a single bit as a boolean value
113 from the specified position in a bit field. if update-position is true, the position
114 indicator is modified to reflect all immediately preceeding bits.
115 VALUE : the length of the encoded data"
116
117 (let* ((buffer-var (if (and (symbolp buffer) (eq (macroexpand-1 buffer env) buffer))
118 buffer (gensym (string :buffer-))))
119 (position-var (gensym (string :position-))))
120 `(macrolet ((amqp:field (type)
121 (list 'multiple-value-bind
122 '(value new-position)
123 (list (cons-symbol (symbol-package type) :buffer- type)
124 ',buffer-var
125 ',position-var)
126 (list 'setf ',position-var 'new-position)
127 'value))
128 (amqp:bit (bit-position &optional (advance-position nil))
129 (let ((form (list 'buffer-bit ',buffer-var
130 (list '+ ',position-var (floor bit-position 8))
131 (mod bit-position 8))))
132 (if advance-position
133 (list 'prog1 form (list 'incf ',position-var (ceiling (1+ bit-position) 8)))
134 form))))
135 (let ((,position-var ,start)
136 ,@(unless (eq buffer buffer-var) `((,buffer-var ,buffer))))
137 ,@body
138 ,position-var))))
139
140
141 (defmacro with-argument-encoders ((buffer &key (start 0)) &body body &environment env)
142 "Set up an argument encoding environment for the specified BUFFER. This includes a position indicator,
143 which is initialized from the specified START value. Within the environment two operators
144 are available:
145 field (value type) : encodes the given value into a field of the specified type at the current
146 position. Updates the position based on the value and returns the value
147 bit (variable bit-position &optional update-position) : encodes a boolean as a single bit to the specified
148 position in a bit field. if update-position is true, the position indicator is modified to reflect
149 all immediately preceeding bits.
150 VALUE : the length of the encoded data"
151
152 (let* ((buffer-var (if (and (symbolp buffer) (eq (macroexpand-1 buffer env) buffer))
153 buffer (gensym (string :buffer-))))
154 (position-var (gensym (string :position-))))
155 `(macrolet ((amqp:field (value type)
156 (list 'multiple-value-bind
157 '(value new-position)
158 (list 'setf (list (cons-symbol (symbol-package type) :buffer- type)
159 ',buffer-var
160 ',position-var)
161 value)
162 (list 'setf ',position-var 'new-position)
163 'value))
164 (amqp:bit (variable bit-position &optional (advance-position nil))
165 (let ((form (list 'setf (list 'buffer-bit ',buffer-var
166 (list '+ ',position-var (floor bit-position 8))
167 (mod bit-position 8))
168 variable)))
169 (when (zerop (mod bit-position 8))
170 ;; first bit in an actet clears it
171 (setf form (list 'progn (list 'setf (list 'buffer-unsigned-byte-8 ',buffer-var
172 (list '+ ',position-var (floor bit-position 8)))
173 0)
174 form)))
175 (when advance-position
176 (setf form (list 'prog1 form (list 'incf ',position-var (ceiling (1+ bit-position) 8)))))
177 form)))
178 (let ((,position-var ,start)
179 ,@(unless (eq buffer buffer-var) `((,buffer-var ,buffer))))
180 ,@(unless (eq buffer buffer-var) `((declare (ignorable ,buffer-var))))
181 ,@body
182 ,position-var))))
183
184
185
186 (defmacro with-property-decoders ((buffer &key (start 0)) &body body &environment env)
187 "Set up a property decoding environment for the specified BUFFER. This includes a position indicator,
188 which is initialized from the specified START value, and initial logic to extract a variable-length
189 flag field. Within the environment a decoding operator is available which decodes the value:
190 field (type &optional place keyword) : if the respective flag indicates presence, decodes a value of the
191 given type, update the position, and returns the value. In addition, if a place and keyword are
192 provided, the value is updated in the property list.
193 VALUE : the length of the decoded data"
194
195 (let* ((buffer-var (if (and (symbolp buffer) (eq (macroexpand-1 buffer env) buffer))
196 buffer (gensym (string :buffer-))))
197 (position-var (gensym (string :position-)))
198 (flag-var (gensym (string :flags-)))
199 (bit-count-var (gensym (string :bit-))))
200 `(macrolet ((amqp:field (type &optional place keyword)
201 (list* (if place 'if 'when)
202 (list 'logbitp (list 'decf ',bit-count-var) ',flag-var)
203 (list* 'multiple-value-bind
204 '(value new-position)
205 (list (cons-symbol (symbol-package type) :buffer- type)
206 ',buffer-var
207 ',position-var)
208 (list 'setf ',position-var 'new-position)
209 ;; even if a reserved value is present, ignore it
210 (if place
211 (list (list 'setf (list 'getf place keyword) 'value))
212 (list 'value)))
213 (when place (list (list 'remf place keyword))))))
214 (let (,@(unless (eq buffer buffer-var) `((,buffer-var ,buffer)))
215 (,bit-count-var 0))
216 (declare (ignorable ,bit-count-var))
217 (multiple-value-bind (,flag-var ,position-var) (buffer-property-flags-16 ,buffer-var ,start)
218 (declare (ignorable ,flag-var))
219 (setf ,bit-count-var (* (/ (- ,position-var ,start) 2) 15))
220 ,@body
221 ,position-var)))))
222
223
224 (defmacro with-property-encoders ((buffer &key (start 0)) &body body &environment env)
225 "Set up a property decoding environment for the specified BUFFER. This includes a position indicator,
226 which is initialized from the specified START value, and initial logic to encode a variable-length
227 flag field based on the count of field operators in the body. Within the environment an operator is
228 available which encodes values:
229 field (value type) : if the value is not null, encodes in at the present position and updates same
230 based on the value's encoded length. the presences is recored in the bit flags, which are set
231 retrospectivelt at the conclusion.
232 VALUE : the length of the encoded data"
233
234 (let* ((buffer-var (if (and (symbolp buffer) (eq (macroexpand-1 buffer env) buffer))
235 buffer (gensym (string :buffer-))))
236 (position-var (gensym (string :position-)))
237 (flag-var (gensym (string :flags-)))
238 (value-var (gensym (string :value-)))
239 (bit-count-var (gensym (string :bit-)))
240 (start-var (gensym (string :start-)))
241 (field-count 0)
242 (bit-count 0)
243 (short-count 0)
244 (byte-count 0))
245 (labels ((count-fields (x)
246 (typecase x
247 (symbol (when (eq x 'amqp:field) (incf field-count)))
248 (cons (mapcar #'count-fields x))
249 (t ))))
250 (count-fields body))
251 (setf short-count (ceiling field-count 15)
252 byte-count (* short-count 2)
253 bit-count (* 15 short-count))
254 `(macrolet ((amqp:field (value type)
255 (list 'let (list (list ',value-var value))
256 (list 'setf (list 'ldb (list 'byte 1 (list 'decf ',bit-count-var)) ',flag-var)
257 (list 'if ',value-var 1 0))
258 (list 'when ',value-var
259 (list 'setf ',position-var
260 (list 'nth-value 1
261 (list 'setf (list (cons-symbol (symbol-package type) :buffer- type)
262 ',buffer-var
263 ',position-var)
264 ',value-var)))))))
265 (let* (,@(unless (eq buffer buffer-var) `((,buffer-var ,buffer)))
266 (,start-var ,start)
267 (,position-var (+ ,start-var ,byte-count))
268 (,flag-var 0)
269 (,bit-count-var ,bit-count))
270 (declare (ignorable ,bit-count-var))
271 ,@body
272 (setf (buffer-property-flags-16 ,buffer-var ,start-var ,short-count) ,flag-var)
273 ,position-var))))
274
275
276
277
278 (document "The individual AMQP field types all resolve to common lisp types. Some directly, but most in
279 terms of custom type definitions. This applies, for example, to types where the AMQP size specifies the bit
280 count of the respective size field rather than the length of the data. For example, string-8. These type
281 definitions for these base types follow below. All names are in the :amqp package.
282
283 Given these, the operator def-encodings (see below) defines version specific type predicates, elementary
284 buffer accessors and composite codecs.")
285
286 #-sbcl
287 (deftype amqp:frame-buffer (&optional length)
288 (if length
289 `(simple-array (unsigned-byte 8) (*))
290 `(simple-array (unsigned-byte 8) (,length))))
291
292 #+sbcl ;; don't tell it more than it needs to know, otherwise shorter vectors conflict with declarations
293 (deftype amqp:frame-buffer (&optional length)
294 (declare (ignore length))
295 `(simple-array (unsigned-byte 8) (*)))
296
297 (defun make-frame-buffer (&optional (length *frame-size*))
298 (make-array length :element-type '(unsigned-byte 8)))
299
300 (defun amqp:frame-buffer (length &key initial-contents)
301 (let ((buffer (make-frame-buffer length)))
302 (etypecase initial-contents
303 (null buffer)
304 (cons (map-into buffer (etypecase (first initial-contents)
305 (character #'char-code)
306 ((unsigned-byte 8) #'identity))
307 initial-contents))
308 (string (map-into buffer #'char-code initial-contents))
309 (vector (replace buffer initial-contents)))))
310
311
312 (deftype amqp:bit ()
313 "The bit type is a common lisp boolean which is coded to a bit array"
314 'boolean)
315
316
317 (deftype amqp:iso-8859-character ()
318 "names the subset of characters within the ISO-8859 domain."
319 `(satisfies amqp:iso-8859-character-p))
320
321 (defun amqp:iso-8859-character-p (x)
322 (and (characterp x)
323 (<= 0 (char-code x) 255)))
324
325
326 (deftype amqp:utf32-character ()
327 "names the subset of characters within the UTF-32 domain."
328 `(satisfies utf32-character-p))
329
330 (defun amqp:utf32-character-p (x)
331 (and (characterp x)
332 (<= 0 (char-code x) #.(1- (expt 2 32)))))
333
334
335 (deftype amqp:string (length-integer-length)
336 "the AMQP string type designators are in terms of the size
337 of the byte count, not the size of the string itself."
338 (ecase length-integer-length
339 (8 '(satisfies amqp:string-8-p))
340 (16 '(satisfies amqp:string-16-p))
341 (32 '(satisfies amqp:string-32-p))))
342
343 (macrolet ((def-string-predicate (length-integer-length)
344 ;; define also the symbol form of type specifier
345 (let* ((type-name (cons-symbol :amqp :string- (prin1-to-string length-integer-length)))
346 (predicate-name (cons-symbol :amqp type-name :-p))
347 (base (format nil "STRING with length less than ~s" length-integer-length))
348 (predicate-doc-string (format nil "Return true iff the argument is of type ~a." base))
349 (type-doc-string (format nil "The class of data of type ~a." base)))
350 `(progn (eval-when (:compile-toplevel :load-toplevel :execute)
351 (export ',predicate-name :amqp)
352 (import ',predicate-name *package*)
353 (export ',type-name :amqp)
354 (import ',type-name *package*))
355 (deftype ,type-name () ,type-doc-string '(satisfies ,predicate-name))
356 (defun ,predicate-name (x)
357 ,predicate-doc-string
358 (and (stringp x)
359 (< (length x) ,(expt 2 length-integer-length))))))))
360 (def-string-predicate 8)
361 (def-string-predicate 16)
362 (def-string-predicate 32))
363
364
365 (deftype amqp:binary (length-in-bits)
366 "the AMQP vector type designators are in terms of bit count."
367 (ecase length-in-bits
368 (8 '(satisfies amqp:binary-8))
369 (16 '(satisfies amqp:binary-16))
370 (32 '(satisfies amqp:binary-32))
371 (40 '(satisfies amqp:binary-40))
372 (48 '(satisfies amqp:binary-48))
373 (64 '(satisfies amqp:binary-64))
374 (72 '(satisfies amqp:binary-72))
375 (128 '(satisfies amqp:binary-128))
376 (256 '(satisfies amqp:binary-256))
377 (512 '(satisfies amqp:binary-512))
378 (1024 '(satisfies amqp:binary-1024))))
379
380 (macrolet ((def-binary-predicate (length-in-bits)
381 ;; define also the symbol form of type specifier
382 (let* ((type-name (cons-symbol :amqp :binary- (prin1-to-string length-in-bits)))
383 (predicate-name (cons-symbol :amqp type-name :-p))
384 (base (format nil "(vector (unsigned-byte 8)) with length less than ~s" (floor length-in-bits 8)))
385 (predicate-doc-string (format nil "Return true iff the argument is of type ~a." base))
386 (type-doc-string (format nil "The class of data of type ~a." base)))
387 `(progn (eval-when (:compile-toplevel :load-toplevel :execute)
388 (export ',predicate-name :amqp)
389 (import ',predicate-name *package*)
390 (export ',type-name :amqp)
391 (import ',type-name *package*))
392 (deftype ,type-name () ,type-doc-string '(satisfies ,predicate-name))
393 (defun ,predicate-name (x)
394 ,predicate-doc-string
395 (and (typep x '(vector (unsigned-byte 8)))
396 (<= (length x) ,(floor length-in-bits 8))))))))
397 (def-binary-predicate 8)
398 (def-binary-predicate 16)
399 (def-binary-predicate 32)
400 (def-binary-predicate 40)
401 (def-binary-predicate 48)
402 (def-binary-predicate 64)
403 (def-binary-predicate 128)
404 (def-binary-predicate 256)
405 (def-binary-predicate 512)
406 (def-binary-predicate 1024))
407
408
409 (deftype amqp:table () `(satisfies amqp:table-p))
410
411 (defun amqp:table-p (x)
412 (or (null x)
413 (and (consp x)
414 (keywordp (pop x))
415 (consp x)
416 (amqp:table-p (rest x)))))
417
418
419 (deftype amqp:array () 'vector)
420
421 (defun amqp:array-p (x) (typep x 'vector))
422
423
424 (deftype amqp:list () 'list)
425
426 (defun amqp:list-p (x) (typep x 'list))
427
428
429 (deftype amqp:decimal (&optional length)
430 (declare (ignore length))
431 '(and number (not complex)))
432
433 (defun amqp:decimal-p (x) (and (numberp x) (not (complexp x))))
434
435
436
437
438
439
440
441 (document (compute-type-initform field-type-initform)
442 "Where class slots definitions and codec keyword arguments require default values, these
443 are imputed from the respective field type. This occurs as the specifications are translated into
444 class and method definitions, at which point any version specific types are generalized and yield
445 initial values, as below.")
446
447
448 (defun coerce-line-code (line-code)
449 "Coerce a 'line code' into an integer.
450 This allows for the variety of the code indicators which are carried over from the various xml
451 specifications to the def-encodings elements."
452 (etypecase line-code
453 ((unsigned-byte 8) line-code)
454 (character (char-code line-code))))
455
456
457 (eval-when (:compile-toplevel :load-toplevel :execute)
458 ;; define macro and expansion operators to map respective standard's types to
459 ;; initform values. these implement the generic types. each version's encoding
460 ;; definition generates methods for its own types.
461 (defgeneric compute-type-initform (type)
462 (:documentation "Given a type, return an appropriate initform value.")
463
464 (:method ((type cons))
465 (compute-type-initform (first type)))
466
467 (:method ((type null)) nil)
468 (:method ((type (eql 'amqp:array))) #())
469 (:method ((type (eql 'amqp:bit))) nil)
470 (:method ((type (eql 'amqp:binary))) #())
471 (:method ((type (eql 'amqp:decimal))) 0)
472 (:method ((type (eql 'amqp:iso-8859-character))) #\null)
473 (:method ((type (eql 'amqp:list))) ())
474 (:method ((type (eql 'amqp:string))) "")
475 (:method ((type (eql 'amqp:struct))) ())
476 (:method ((type (eql 'amqp:table))) ())
477 (:method ((type (eql 'boolean))) nil)
478 (:method ((type (eql 'double-float))) 0.0d0)
479 (:method ((type (eql 'short-float))) 0.0s0)
480 (:method ((type (eql 'signed-byte))) 0)
481 (:method ((type (eql 'unsigned-byte))) 0)
482 (:method ((type (eql 'amqp:utf32-character))) #\null)
483 (:method ((type (eql 'amqp:vbinary))) #())
484 (:method ((type t))
485 (error "No default known for type: ~s." type)))
486
487
488 (defgeneric compute-field-type-initform (name type)
489 (:documentation "return a value form to produce the initial value for
490 the named (slot x type) combination.
491 NB. the present version return NIL for ever field.")
492
493 (:method ((name symbol) (type t))
494 "The default version ignores the field."
495 (compute-type-initform type))))
496
497
498 (defmacro field-type-initform (field type)
499 (compute-field-type-initform field type))
500
501
502 (document (def-encodings def-byte-accessors def-string-accessors)
503 "The codecs implement transformations between lisp objects and byte sequences. The buffer type,
504 frame-buffer, is defined as (vector (unsigned-byte 8) (*)). It serves as a declaration and an argument
505 constraint. Each version's codecs are are expressed in terms of that version's types and its operators.
506 Each version-specific field type resolves to a lisp type, and the version-specific buffer accessors
507 are implemented, in turn, in terms of the lisp-type frame-buffer accessors. This permits
508 type names in one fersion to designate a different base implementation type than some other version.
509
510 The lisp-type accessors are defined in the def-byte-accessors, def-string-accessors, etc.
511
512 Each version includes a `data-wire-coding` file, in which a `def-encodings` form declares the type relation.
513 That declaration compiles into the several things for each entry:
514
515 - a type definition
516 - a method to compute an initform
517 - protocol-specific buffer-accessors; for which, if a line code is included, they are intended to be used
518 in self-describing data (tables)
519
520 In addition compound buffer accessors are defined for the types
521
522 - list
523 - array
524 - table")
525
526
527
528 (defmacro def-encodings ((protocol-version) &rest type-specifications
529 &aux void-line-code)
530
531 "Compile a protocol type specification into buffer codec operators for
532 the respectively defined types and type codes. Also generate a map
533 specific to that protocol version between lisp type specifiers and the
534 protocol's. The operators include respective reader and writers for:
535 - atomic data
536 - name-value pair data
537 - table/map data
538 - list
539 - array (with mixed and uniform types)
540 - structure (NYI)"
541
542 (flet ((protocol-buffer-op (type)
543 (cons-symbol protocol-version :buffer- type))
544 (lisp-buffer-op (type)
545 (cons-symbol *package* :buffer (format nil "~{-~a~}" (if (consp type) type (list type)))))
546 (array-type-spec ()
547 (find 'amqp:array type-specifications :key #'second))
548 (list-type-spec ()
549 (find 'amqp:list type-specifications :key #'second))
550 (table-type-spec ()
551 (find 'amqp:table type-specifications :key #'second))
552 )
553
554 (when (setf void-line-code
555 (getf (find nil type-specifications :key #'first) :line-code))
556 (setf type-specifications (remove nil type-specifications :key #'first))
557 (setf void-line-code (coerce-line-code void-line-code)))
558
559 (let ((wire-level-type-map (intern (string :*wire-level-type-map*) protocol-version)))
560
561 `(progn
562 (defparameter ,wire-level-type-map (make-hash-table :test 'equal))
563 (macrolet ((optionally-set-type (line-code)
564 `(when type-code-p
565 (setf (aref buffer position) ,(coerce-line-code line-code))
566 (incf position))))
567
568 ;; generate the field and table encoders such that they reference each other
569 ,@(let ((buffer-table-op (protocol-buffer-op 'table-codec))
570 (buffer-array-op (protocol-buffer-op 'array-codec))
571 (buffer-list-op (protocol-buffer-op 'list-codec))
572 (buffer-field-value-op (protocol-buffer-op 'field-value))
573 (buffer-field-value-pair-op (protocol-buffer-op 'field-value-pair))
574 (buffer-setf-field-value-pair-op (protocol-buffer-op 'setf-field-value-pair))
575 (type-code-of-op (intern (string :type-code-of) protocol-version)))
576 `((defun ,type-code-of-op (datum)
577 (etypecase datum
578 ,@(remove nil
579 (mapcar #'(lambda (spec)
580 (destructuring-bind (amqp-type lisp-type &key line-code &allow-other-keys)
581 spec
582 (declare (ignore amqp-type))
583 (when line-code
584 `(,lisp-type
585 ,(coerce-line-code line-code)))))
586 type-specifications))))
587
588 (defun ,buffer-field-value-op (buffer position &optional line-code)
589 (ecase (or line-code (aref buffer (shiftf position (1+ position))))
590 (,void-line-code nil)
591 ,@(remove nil
592 (mapcar #'(lambda (spec)
593 (destructuring-bind (amqp-type lisp-type
594 &key line-code
595 (codec (lisp-buffer-op lisp-type)))
596 spec
597 (declare (ignore amqp-type))
598 (when line-code
599 `(,(coerce-line-code line-code)
600 (,codec buffer position)))))
601 type-specifications))))
602 (defun (setf ,buffer-field-value-op) (value buffer position &optional (type-code-p nil))
603 (etypecase value
604 ,@(remove nil
605 (remove-duplicates
606 (mapcar #'(lambda (spec)
607 (destructuring-bind (amqp-type lisp-type &key (codec (protocol-buffer-op amqp-type))
608 (line-code nil)
609 &allow-other-keys)
610 spec
611 (when line-code
612 `(,lisp-type
613 (setf position
614 (nth-value 1 (setf (,codec buffer position
615 ,@(when line-code '(type-code-p)))
616 value)))))))
617 type-specifications)
618 :key #'first :from-end t :test #'equalp)))
619 (values value position))
620
621
622 (defun ,buffer-field-value-pair-op (buffer position)
623 (let ((namestring (buffer-string-8 buffer position)))
624 (incf position (1+ (length namestring)))
625 (multiple-value-bind (value position)
626 (,buffer-field-value-op buffer position)
627 (values (list (intern namestring :keyword) value)
628 position))))
629
630 (defun ,buffer-setf-field-value-pair-op (name value buffer position &optional type-code-p)
631 (setf position (nth-value 1 (setf (buffer-string-8 buffer position) (string name))))
632 (setf position (nth-value 1 (setf (,buffer-field-value-op buffer position type-code-p) value)))
633 (values value position))
634
635 (defsetf ,buffer-field-value-pair-op (buffer position &optional type-code-p) (name value)
636 (list ',buffer-setf-field-value-pair-op name value buffer position type-code-p))
637
638
639 ,@(let ((type-spec (table-type-spec)))
640 (when type-spec
641 `((defun ,buffer-table-op (buffer position)
642 (let* ((length (buffer-unsigned-byte-32 buffer position))
643 (result ())
644 (end (+ position 4 length)))
645 (incf position 4)
646 (loop (when (>= position end)
647 (return))
648 (multiple-value-bind (pair new-position)
649 (,buffer-field-value-pair-op buffer position)
650 (push pair result)
651 (setf position new-position)))
652 (values (reduce 'nconc (nreverse result)) end)))
653 (defmethod (setf ,buffer-table-op) ((table list) buffer position &optional type-code-p)
654 (optionally-set-type ,(getf type-spec :line-code))
655 (let ((base position))
656 (incf position 4)
657 (loop for (field-name field-value) on table by #'cddr
658 do (setf position
659 (nth-value 1
660 #+ignore (setf (,buffer-field-value-pair-op buffer position t)
661 (values field-name field-value))
662 (,buffer-setf-field-value-pair-op field-name field-value buffer position t))))
663 (setf (buffer-unsigned-byte-32 buffer base) (- (- position base) 4))
664 (values table position))))))
665
666 ,@(let ((type-spec (list-type-spec)))
667 (when type-spec
668 `((defun ,buffer-list-op (buffer position)
669 (let* ((length (buffer-unsigned-byte-32 buffer position))
670 (result ())
671 (end (+ position 4 length)))
672 (incf position 4)
673 (loop (when (>= position end)
674 (return))
675 (multiple-value-bind (value new-position)
676 (,buffer-field-value-op buffer position)
677 (push value result)
678 (setf position new-position)))
679 (values (nreverse result) end)))
680 (defmethod (setf ,buffer-list-op) ((list list) buffer position &optional (type-code-p nil))
681 (optionally-set-type ,(getf type-spec :line-code))
682 (let ((base position))
683 (incf position 4)
684 (dolist (value list)
685 (setf position
686 (nth-value 1 (setf (,buffer-field-value-op buffer position t) value))))
687 (setf (buffer-unsigned-byte-32 buffer base) (- (- position base) 4))
688 (values list position))))))
689
690 ;;; !!! needs to take account of the 0.10 change to include a count filed after
691 ;;; the length and type
692 ,@(let ((type-spec (array-type-spec)))
693 (when type-spec
694 `((defun ,buffer-array-op (buffer position)
695 (let* ((length (buffer-unsigned-byte-32 buffer position))
696 (result (make-array 8 :adjustable t :fill-pointer 0))
697 (end (+ position 4 length))
698 (count 0)
699 (type-code (buffer-unsigned-byte-8 buffer (+ 4 position))))
700 (incf position 5)
701 (loop (when (>= position end)
702 (return))
703 (multiple-value-bind (value new-position)
704 (,buffer-field-value-op buffer position type-code)
705 (vector-push-extend value result)
706 (setf position new-position)))
707 (values result end)))
708 (defmethod (setf ,buffer-array-op) ((array vector) buffer position &optional (type-code-p nil))
709 (optionally-set-type ,(getf type-spec :line-code))
710 (let ((base position)
711 (code (if (> (length array) 0)
712 (,type-code-of-op (elt array 0))
713 ,void-line-code)))
714 (incf position 4)
715 (setf (buffer-unsigned-byte-8 buffer position) code)
716 (incf position)
717 (loop for value across array
718 do (setf position
719 (nth-value 1
720 (setf (,buffer-field-value-op buffer position nil)
721 value))))
722 (setf (buffer-unsigned-byte-32 buffer base) (- (- position base) 4))
723 (values array position))))))))
724
725
726 ;; generate the atomic encoders
727 ,@(mapcar #'(lambda (spec)
728 (destructuring-bind (amqp-type lisp-type
729 &key line-code
730 (codec (lisp-buffer-op lisp-type)))
731 spec
732 (setf amqp-type (cons-symbol protocol-version amqp-type))
733 (let ((p-op (protocol-buffer-op amqp-type))
734 (l-op codec))
735 `(progn
736 (export ',amqp-type ,protocol-version)
737 (deftype ,amqp-type () ',lisp-type)
738 ,@(unless (equalp amqp-type lisp-type)
739 `((eval-when (:compile-toplevel :load-toplevel :execute)
740 (defmethod compute-type-initform ((type (eql ',amqp-type)))
741 (compute-type-initform ',lisp-type)))))
742 (setf (amqp:wire-level-type ',amqp-type ,wire-level-type-map) ',lisp-type)
743 (unless (amqp:wire-level-type ',lisp-type ,wire-level-type-map)
744 (setf (amqp:wire-level-type ',lisp-type ,wire-level-type-map) ',amqp-type))
745 (defun ,p-op (buffer position)
746 (,l-op buffer position ,@(when (eq l-op 'buffer-bit) '(0))))
747 ;; if the line code is specified, the protocol-specific encoder
748 ;; should add it if necessary and then call the primtiive.
749 ;; method arguments have no line-code and are never encoded
750 ;; in a context which needs one.
751 ,@(unless (eq p-op l-op)
752 (if line-code
753 `((defun (setf ,p-op) (value buffer position &optional type-code-p)
754 (optionally-set-type ,line-code)
755 (setf (,l-op buffer position ,@(when (eq l-op 'buffer-bit) '(0))) value)))
756 `((defun (setf ,p-op) (value buffer position)
757 (setf (,l-op buffer position ,@(when (eq l-op 'buffer-bit) '(0))) value)))))))))
758 type-specifications))))))
759
760
761
762 (document (encode-ieee-754-32 encode-ieee-754-64)
763 " codec operators
764
765 The protocol data domain names vary from version to version, but they
766 resolve to a limited number of lisp types, mostly
767
768 string
769 (unsigned-byte 8, 16, 32, 64)
770
771 for each an encoding and a decoding operator is defined to pack/unpack the
772 value from a byte buffer. The operators are not generic as the entity codecs
773 all operate on data which fits in a single frame buffer - and (at least
774 through 0.10) operations were defined to be communicated in single frame.
775
776 Each buffered type requires two operators, one to encode and one to decode.
777 they are paired as a reader operator and the respective setf. In the latter
778 case the operator accepts an addition optional argument to specify the
779 type code. Each protocol version reuqires its own frame codecs as the type
780 codes vary.")
781
782
783 ;;;
784 ;;; floating point is brute force.
785
786 (defun encode-ieee-754-32 (integer)
787 (let* ((negative-p (logbitp 31 integer))
788 (sign (if negative-p -1 +1))
789 (exponent (- (ash (logand #x7f800000 integer) -23) 127))
790 (fraction (logand #x007fffff integer)))
791 (cond ((zerop exponent)
792 (if (zerop fraction)
793 (float 0 single-float-epsilon)
794 (float (* sign (* fraction #.(expt 2 -23)) (expt 2 exponent)) single-float-epsilon)))
795 ((= exponent #.(1- (expt 2 8)))
796 (if (zerop fraction)
797 (if negative-p single-float-negative-infinity single-float-positive-infinity)
798 single-float-nan))
799 (t
800 (float (* sign (1+ (* fraction #.(expt 2 -23))) (expt 2 exponent))
801 single-float-epsilon)))))
802
803 (defun encode-ieee-754-64 (integer)
804 (let* ((negative-p (logbitp 63 integer))
805 (sign (if negative-p -1 +1))
806 (exponent (- (ash (logand #x7ff0000000000000 integer) -52) 2043))
807 (fraction (logand #x000fffffffffffff integer)))
808 (cond ((zerop exponent)
809 (if (zerop fraction)
810 (float 0 single-float-epsilon)
811 (float (* sign (* fraction #.(expt 2 -52)) (expt 2 exponent)) double-float-epsilon)))
812 ((= exponent #.(1- (expt 2 11)))
813 (if (zerop fraction)
814 (if negative-p double-float-negative-infinity double-float-positive-infinity)
815 double-float-nan))
816 (t
817 (float (* sign (1+ (* fraction #.(expt 2 -52))) (expt 2 (- exponent 127)))
818 double-float-epsilon)))))
819
820 ;; (eql (encode-ieee-754-32 #b00111110001000000000000000000000) 0.15625)
821 ;; (eql (encode-ieee-754-32 #b11000010111011010100000000000000) -118.625)
822
823
824
825
826 #+ignore ; not used as the logic is protocol-specific
827 (defgeneric amqp:type-code (type)
828 (:method ((value string))
829 (let ((length (length string)))
830 (if (<= length 255) (gethash 'string-8 *type-codes*)
831 (if (<= length 65535) (gethash 'string-16 *type-codes*)
832 (gethash 'string-32 *type-codes*)))))
833 (:method ((value double-float))
834 (gethash 'double-float *type-codes*))
835 (:method ((value short-float))
836 (gethash 'short-float *type-codes*))
837 (:method ((value integer))
838 (if (minusp value)
839 (cond ((typep value '(signed-byte 8))
840 (gethash 'signed-byte-8 *type-codes*))
841 ((typep value '(signed-byte 16))
842 (gethash 'signed-byte-16 *type-codes*))
843 ((typep value '(signed-byte 32))
844 (gethash 'signed-byte-32 *type-codes*))
845 (t
846 (gethash 'signed-byte-64 *type-codes*)))
847 (cond ((typep value '(unsigned-byte 8))
848 (gethash 'unsigned-byte-8 *type-codes*))
849 ((typep value '(unsigned-byte 16))
850 (gethash 'unsigned-byte-16 *type-codes*))
851 ((typep value '(unsigned-byte 32))
852 (gethash 'unsigned-byte-32 *type-codes*))
853 (t
854 (gethash 'unsigned-byte-64 *type-codes*))))))
855
856
857 (defun buffer-character (buffer position)
858 (values (code-char (aref buffer position))
859 (1+ position)))
860
861 (defun (setf buffer-character) (value buffer position)
862 (setf (aref buffer position)
863 (char-code value))
864 (values value (1+ position)))
865
866
867 (defun buffer-iso-8859-character (buffer position)
868 (values (code-char (aref buffer position))
869 (1+ position)))
870
871 (defun (setf buffer-iso-8859-character) (value buffer position)
872 (setf (aref buffer position)
873 (char-code value))
874 (values value (1+ position)))
875
876
877 (defun buffer-utf32-character (buffer position)
878 (buffer-integer buffer position 4))
879
880 (defun (setf buffer-utf32-character) (value buffer position)
881 (setf (buffer-integer buffer position 4) value))
882
883
884 (defun buffer-boolean (buffer position)
885 (values (not (zerop (aref buffer position))) (1+ position)))
886
887 (defun (setf buffer-boolean) (value buffer position)
888 (setf (aref buffer position)
889 (if value 1 0))
890 (values value (1+ position)))
891
892
893 (defun buffer-property-flags-16 (buffer position)
894 (let ((result 0))
895 (loop
896 (multiple-value-bind (segment new-position)
897 (buffer-unsigned-byte-16 buffer position)
898 (setf result (logior (ash result 15) (ash segment -1)))
899 (if (logbitp 0 segment)
900 (setf position new-position)
901 (return (values result new-position)))))))
902
903 (defun (setf buffer-property-flags-16) (flags buffer position count)
904 (dotimes (i count)
905 (let ((segment (ldb (byte 15 (* 15 (1- (- count i)))) flags)))
906 (setf segment (ash segment 1))
907 (when (< i (1- count))
908 (setf segment (logior segment 1)))
909 (setf position (nth-value 1 (setf (buffer-unsigned-byte-16 buffer position) segment)))))
910 (values flags position))
911
912
913
914 (defun buffer-decimal (buffer position)
915 (let ((scale (aref buffer position))
916 (value (buffer-integer buffer (1+ position) 4)))
917 (values (if (plusp scale)
918 (/ value (expt 10 scale))
919 value)
920 (+ position 5))))
921
922
923 (defun (setf buffer-decimal) (value buffer position)
924 (let ((scaled (floor (* value *decimal-scale-factor*))))
925 (setf (aref buffer position) *decimal-scale*)
926 (setf (buffer-unsigned-byte-32 buffer (1+ position)) scaled)
927 (values value (+ position 5))))
928
929
930 (defun buffer-short-float (buffer position)
931 (values (encode-ieee-754-32 (buffer-integer buffer position 4))
932 (+ position 4)))
933
934 (defun (setf buffer-short-float) (value buffer position)
935 (declare (ignore value buffer position))
936 (error "NYI: (setf buffer-short-float)"))
937
938
939 (defun buffer-double-float (buffer position)
940 (values (encode-ieee-754-64 (buffer-integer buffer position 8))
941 (+ position 8)))
942
943 (defun (setf buffer-double-float) (value buffer position)
944 (declare (ignore value buffer position))
945 (error "NYI: (setf buffer-double-float)"))
946
947
948 #+(or )
949 (defun buffer-bit (buffer position bit-position)
950 (let ((byte (buffer-unsigned-byte-8 buffer position)))
951 (values (plusp (logand byte (ash 1 bit-position)))
952 (+ position 1))))
953
954 (defun buffer-bit (buffer position bit-position)
955 (values (ldb-test (byte 1 bit-position) (buffer-unsigned-byte-8 buffer position))
956 (+ position 1)))
957
958 (defun (setf buffer-bit) (value buffer position bit-position)
959 (let ((byte (buffer-unsigned-byte-8 buffer position)))
960 (setf byte (dpb (if value 1 0) (byte 1 bit-position) byte))
961 (setf (buffer-unsigned-byte-8 buffer position) byte)
962 ;; advance the position by 1/8. in fact, this never advances the position for
963 ;; known protocols, as they never have more than 8 bits. the caller must +1
964 ;; ths total for a bit string
965 (values value (+ position (ash bit-position -1)))))
966
967
968 (macrolet ((signed-byte (datum length)
969 `(if (>= ,datum ,(1- (expt 2 (1- length)))) ; convert
970 (- (logxor ,(1- (expt 2 length)) (1- ,datum)))
971 ,datum)))
972
973 (defun signed-byte-8 (byte) (signed-byte byte 8))
974 (defun signed-byte-16 (byte) (signed-byte byte 16))
975 (defun signed-byte-32 (byte) (signed-byte byte 32))
976 (defun signed-byte-64 (byte) (signed-byte byte 64))
977 )
978
979
980 (macrolet ((def-byte-accessors (length)
981 (let ((buffer-signed-name (intern (format nil "~a~d" :buffer-signed-byte- length)
982 :de.setf.amqp.implementation))
983 (signed-name (intern (format nil "~a~d" :signed-byte- length)
984 :de.setf.amqp.implementation))
985 (buffer-unsigned-name (intern (format nil "~a~d" :buffer-unsigned-byte- length)
986 :de.setf.amqp.implementation))
987 (bytes (floor length 8)))
988 `(progn (defun ,buffer-unsigned-name (buffer position &optional (assert-conditions t))
989 #-sbcl (declare (type (frame-buffer ,*frame-size*) buffer))
990 #+sbcl (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
991 (declare (type fixnum position))
992 (when assert-conditions
993 (assert-argument-type ,buffer-unsigned-name buffer frame-buffer)
994 (assert-condition (and (typep position 'fixnum) (<= (+ position ,bytes) (length buffer)))
995 buffer-unsigned-name "value overflows buffer: (~s + ~s), ~s"
996 position ,bytes (length buffer)))
997 (let ((value 0))
998 (declare (type ,(if (<= (expt 2 length) most-positive-fixnum) 'fixnum 'integer) value))
999 ,@(loop for i from 1 to bytes
1000 append `((setf value ,(if (= i 1)
1001 '(aref buffer position)
1002 '(+ (ash value 8) (aref buffer position))))
1003 (incf position)))
1004 (values value position)))
1005
1006 (defun (setf ,buffer-unsigned-name) (value buffer position &optional (assert-conditions t))
1007 #-sbcl (declare (type (frame-buffer ,*frame-size*) buffer))
1008 #+sbcl (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
1009 (declare (type fixnum position)
1010 (type ,(if (<= (expt 2 length) most-positive-fixnum) 'fixnum 'integer) value))
1011 (assert-condition (and (integerp value) (>= value 0) (< value ,(expt 2 length)))
1012 (setf ,buffer-unsigned-name) "Invalid byte value, exceeds domain: ~s."
1013 value)
1014 (when assert-conditions
1015 (assert-argument-type (setf ,buffer-unsigned-name) buffer frame-buffer)
1016 (assert-condition (and (typep position 'fixnum) (<= (+ position ,bytes) (length buffer)))
1017 (setf ,buffer-unsigned-name) "value overflows buffer: (~s + ~s), ~s"
1018 position ,bytes (length buffer)))
1019 (values value
1020 (progn ,@(loop for i from (1- bytes) downto 0
1021 append `((setf (aref buffer (+ position ,i)) (logand #xff value))
1022 (setf value (ash value -8))))
1023 (+ position ,bytes))))
1024
1025 (defun ,buffer-signed-name (buffer position &optional (assert-conditions t))
1026 (values (,signed-name (,buffer-unsigned-name buffer position assert-conditions))
1027 (+ position ,bytes)))
1028
1029 (defun (setf ,buffer-signed-name) (value buffer position &optional (assert-conditions t))
1030 (setf (,buffer-unsigned-name buffer position assert-conditions) value))))))
1031
1032 (def-byte-accessors 8)
1033 (def-byte-accessors 16)
1034 (def-byte-accessors 32)
1035 (def-byte-accessors 64))
1036
1037
1038 ;;; the variable integer operator packs/unpacks an integer value of a given
1039 ;;; integer length.
1040 ;;; NB. this is not used as the protocols all specify constant length fields
1041
1042 (defun buffer-integer (buffer &optional (position 0) (length 4))
1043 (ecase length
1044 (8 (buffer-unsigned-byte-8 buffer position))
1045 (16 (buffer-unsigned-byte-16 buffer position))
1046 (32 (buffer-unsigned-byte-32 buffer position))
1047 (64 (buffer-unsigned-byte-64 buffer position))))
1048
1049
1050 (defun (setf buffer-integer) (value buffer &optional (position 0) (length 4))
1051 (ecase length
1052 (8 (setf (buffer-unsigned-byte-8 buffer position) value))
1053 (16 (setf (buffer-unsigned-byte-16 buffer position) value))
1054 (32 (setf (buffer-unsigned-byte-32 buffer position) value))
1055 (64 (setf (buffer-unsigned-byte-64 buffer position) value))))
1056
1057
1058 (document (buffer-timestamp (setf buffer-stimestamp))
1059 "Timestamps are '64-bit POSIX time_t format with an accuracy of one second[1].
1060 The UNIX epoch is 1970-01-01T00:00:00Z. This is specified by the amqp:*timestamp-epoch*,
1061 which the buffer accessors use to shift to/from universal time.
1062 ---
1063 [1] amqp0-9-1.pdf, 4.2.5.4
1064 [2] http://en.wikipedia.org/wiki/Unix_time")
1065
1066 (defun buffer-timestamp (buffer position)
1067 (+ amqp:*timestamp-epoch*
1068 (buffer-unsigned-byte-64 buffer position)))
1069
1070 (defun (setf buffer-timestamp) (value buffer position)
1071 (setf (buffer-unsigned-byte-64 buffer position) (- value amqp:*timestamp-epoch*)))
1072
1073 (defun buffer-offset (buffer position)
1074 (buffer-unsigned-byte-64 buffer position))
1075
1076 (defun (setf buffer-offset) (value buffer position)
1077 (setf (buffer-unsigned-byte-64 buffer position) value))
1078
1079
1080 (macrolet ((def-string-accessors (length-bits)
1081 ;; for a given bit size fo the length field,
1082 ;; generate iso8859, utf8, utf16, and utf32 buffer operators
1083
1084 (let* ((buffer-iso-name (intern (format nil "~a-~d" :buffer-string length-bits)
1085 :de.setf.amqp.implementation))
1086 (buffer-utf8-name (intern (format nil "~a-~d-~a" :buffer-string length-bits :utf8)
1087 :de.setf.amqp.implementation))
1088 (buffer-utf16-name (intern (format nil "~a-~d-~a" :buffer-string length-bits :utf16)
1089 :de.setf.amqp.implementation))
1090 (buffer-utf32-name (intern (format nil "~a-~d-~a" :buffer-string length-bits :utf32)
1091 :de.setf.amqp.implementation))
1092 (buffer-unsigned-name (intern (format nil "~a-~d" :buffer-unsigned-byte length-bits)
1093 :de.setf.amqp.implementation))
1094 (length-bytes (floor length-bits 8)))
1095 (declare (ignore buffer-utf16-name buffer-utf32-name))
1096 `(progn (defun ,buffer-iso-name (buffer position)
1097 #-sbcl (declare (type (simple-array (unsigned-byte 8) (,*frame-size*)) buffer))
1098 #+sbcl (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
1099 (declare (type fixnum position))
1100 (assert-argument-type ,buffer-iso-name buffer frame-buffer)
1101 (assert-condition (and (typep position 'fixnum) (<= (+ position ,length-bytes) (length buffer)))
1102 ,buffer-iso-name "size field overflows buffer: (~s + ~s), ~s"
1103 position ,length-bytes (length buffer))
1104 (let* ((length (,buffer-unsigned-name buffer position nil)))
1105 (declare (type fixnum length))
1106 (incf position ,length-bytes)
1107 (if (plusp length)
1108 (let ((result (make-array length :element-type +string-element-type+)))
1109 #-sbcl (declare (type (simple-array character (,*frame-size*)) result))
1110 #+sbcl (declare (type (simple-array character (*)) result))
1111 (assert-condition (<= (+ position length) (length buffer))
1112 ,buffer-iso-name "string overflows buffer: (~s + ~s), ~s"
1113 position length (length buffer))
1114 (dotimes (i length)
1115 (setf (aref result i)
1116 (code-char (aref buffer position)))
1117 (incf position))
1118 (values result position))
1119 (values "" position))))
1120 (defun (setf ,buffer-iso-name) (value buffer position)
1121 #-sbcl (declare (type (simple-array (unsigned-byte 8) (,*frame-size*)) buffer))
1122 #+sbcl (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
1123 (declare (type fixnum position)
1124 (type string value))
1125 (assert-argument-type ,buffer-iso-name buffer frame-buffer)
1126 (assert-argument-type ,buffer-iso-name value string) ; no remorse
1127 (let* ((length (length value)))
1128 (assert-condition (< length ,(expt 2 length-bits))
1129 (setf ,buffer-iso-name) "String overflows the size constraint")
1130 (assert-condition (and (typep position 'fixnum) (<= (+ position length ,length-bytes) (length buffer)))
1131 (setf ,buffer-iso-name) "value overflows buffer: (~s + ~s), ~s"
1132 position (+ length ,length-bytes) (length buffer))
1133 (setf (,buffer-unsigned-name buffer position nil) length)
1134 (incf position ,length-bytes)
1135 (dotimes (i length)
1136 (setf (aref buffer position) (char-code (aref value i)))
1137 (incf position))
1138 (values value position buffer)))
1139
1140 (defun ,buffer-utf8-name (buffer position)
1141 #-sbcl (declare (type (simple-array (unsigned-byte 8) (,*frame-size*)) buffer))
1142 #+sbcl (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
1143 (declare (type fixnum position))
1144 (assert-argument-type ,buffer-iso-name buffer frame-buffer)
1145 (assert-condition (and (typep position 'fixnum) (<= (+ position ,length-bytes) (length buffer)))
1146 ,buffer-iso-name "size field overflows buffer: (~s + ~s), ~s"
1147 position ,length-bytes (length buffer))
1148 (let* ((length (,buffer-unsigned-name buffer position nil))
1149 (end (+ position ,length-bytes))
1150 (decoder (load-time-value (content-encoding-byte-decoder (content-encoding :utf-8)))))
1151 (declare (type fixnum length))
1152 (incf position ,length-bytes)
1153 (if (plusp length)
1154 (let ((result (make-array length :element-type +string-element-type+)))
1155 (declare (type (simple-array character (,*frame-size*)) result))
1156 (assert-condition (<= (setf end (+ position length)) (length buffer))
1157 ,buffer-iso-name "string size overflows buffer: (~s + ~s), ~s"
1158 position length (length buffer))
1159 (flet ((buffer-extract-byte (buffer)
1160 (declare (type (simple-array (unsigned-byte 8) (,*frame-size*)) buffer))
1161 (assert-condition (< position end)
1162 ,buffer-iso-name "string overflows own size: ~s, ~s"
1163 position end)
1164 (prog1 (aref buffer position)
1165 (incf position))))
1166 (declare (dynamic-extent #'buffer-extract-byte)) ; just in case
1167 (dotimes (i length)
1168 (setf (aref result i) (funcall decoder #'buffer-extract-byte buffer))))
1169 (values result end))
1170 (values "" end))))
1171 (defun (setf ,buffer-utf8-name) (value buffer position)
1172 #-sbcl (declare (type (simple-array (unsigned-byte 8) (,*frame-size*)) buffer))
1173 #+sbcl (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
1174 (declare (type fixnum position)
1175 (type string value))
1176 (assert-argument-type (setf ,buffer-utf8-name) buffer frame-buffer)
1177 (assert-argument-type ,buffer-iso-name value string)
1178 (let* ((length (length value))
1179 (max-position 0)
1180 (start position)
1181 (encoder (load-time-value (content-encoding-byte-encoder (content-encoding :utf-8)))))
1182 ;; can't check bounds here as the object length does not signify
1183 (incf position ,length-bytes)
1184 (setf max-position (+ position ,(expt 2 length-bits)))
1185 (assert-condition (< length ,(expt 2 length-bits))
1186 (setf ,buffer-utf8-name) "String overflows the size constraint")
1187 (flet ((buffer-insert-byte (buffer byte)
1188 #-sbcl (declare (type (simple-array (unsigned-byte 8) (,*frame-size*)) buffer))
1189 #+sbcl (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
1190 (declare (type (unsigned-byte 8) byte))
1191 ;; check bounds here as it's finally the encoded positioning
1192 (assert-condition (< position max-position)
1193 (setf ,buffer-utf8-name) "String overflows size constraint: ~s, ~s"
1194 ',buffer-utf8-name position max-position)
1195 (setf (aref buffer position) byte)
1196 (incf position)))
1197 (declare (dynamic-extent #'buffer-insert-byte)) ; just in case
1198 (dotimes (i length) ; can't check bounds here either
1199 (funcall encoder (char value i) #'buffer-insert-byte buffer))
1200 ;; update the length prefix after the fact
1201 (setf (,buffer-unsigned-name buffer start nil) (- position (+ start ,length-bytes)))
1202 (values value position buffer))))))))
1203
1204 (def-string-accessors 8)
1205 (def-string-accessors 16)
1206 (def-string-accessors 32))
1207 ;;; (buffer-string-8-utf8 (nth-value 2 (setf (buffer-string-8-utf8 (frame-buffer 32) 0) "testing")) 0)
1208
1209 (macrolet ((def-binary-accessors (length-bits)
1210 ;; for a given data bit count generate binary vector codecs
1211
1212 (let ((buffer-binary-name (intern (format nil "~a-~d" :buffer-binary length-bits)
1213 :de.setf.amqp.implementation))
1214 (length-bytes (floor length-bits 8)))
1215 `(progn (defun ,buffer-binary-name (buffer position)
1216 (let* ((result (make-array ,length-bytes :element-type '(unsigned-byte 8)))
1217 (end (+ position ,length-bytes))
1218 (length (length buffer)))
1219 (assert (<= end length) ()
1220 "~s: size exceeds buffer: (~s + ~s), ~s"
1221 ',buffer-binary-name position ,length-bytes length)
1222 (replace result buffer :start2 position :end2 end)
1223 (values result end)))
1224 (defun (setf ,buffer-binary-name) (value buffer position)
1225 (let* ((length (length value))
1226 (end (+ position ,length-bytes))
1227 (value-end (+ position length)))
1228 (assert (<= length ,length-bytes) ()
1229 "~s: Binary value length exceeds the size constraint: ~s"
1230 '(setf ,buffer-binary-name) length)
1231 (assert (< end (length buffer)) ()
1232 "~s: value overflows buffer: (~s + ~s), ~s"
1233 '(setf ,buffer-binary-name) position ,length-bytes (length buffer))
1234 (replace buffer value :start1 position :end1 value-end)
1235 (when (< value-end end)
1236 (fill buffer 0 :start value-end :end end))
1237 (values value (+ position end))))))))
1238
1239 (def-binary-accessors 8)
1240 (def-binary-accessors 16)
1241 (def-binary-accessors 32)
1242 (def-binary-accessors 40)
1243 (def-binary-accessors 48)
1244 (def-binary-accessors 64)
1245 (def-binary-accessors 72)
1246 (def-binary-accessors 128)
1247 (def-binary-accessors 256)
1248 (def-binary-accessors 512)
1249 (def-binary-accessors 1024))
1250
1251
1252 (macrolet ((def-vbinary-accessors (length-bits)
1253 ;; for a given bit size of the length field generate binary vector codecs
1254
1255 (let ((buffer-binary-name (intern (format nil "~a-~d" :buffer-vbinary length-bits)
1256 :de.setf.amqp.implementation))
1257 (buffer-unsigned-name (intern (format nil "~a-~d" :buffer-unsigned-byte length-bits)
1258 :de.setf.amqp.implementation))
1259 (length-bytes (floor length-bits 8)))
1260 `(progn (defun ,buffer-binary-name (buffer position)
1261 (let* ((length (,buffer-unsigned-name buffer position))
1262 (result (make-array length :element-type '(unsigned-byte 8)))
1263 (end (+ position length)))
1264 (incf position ,length-bytes)
1265 (replace result buffer :start2 position :end2 end)
1266 (values result end)))
1267 (defun (setf ,buffer-binary-name) (value buffer position)
1268 (let* ((length (length value))
1269 (end (+ position length)))
1270 (assert (< length ,(expt 2 length-bits)) ()
1271 "Binary overflows the size constraint")
1272 (assert (< end (length buffer)) ()
1273 "Binary overflows buffer")
1274 (setf (buffer-integer buffer position ,length-bytes) length)
1275 (incf position ,length-bytes)
1276 (replace buffer value :start1 position :end1 end)
1277 (values value end)))))))
1278
1279 (def-vbinary-accessors 8)
1280 (def-vbinary-accessors 16)
1281 (def-vbinary-accessors 32))
1282
1283 ;;; these two manifest an unrealistic structural relation between the version elements and
1284 ;;; the protocol headers. in fact, the relation is conventional and is recorded in
1285 ;;; amqp.u:*version-headers* by each version as it loads.
1286
1287 #(or )
1288 (progn
1289 (defgeneric buffer-protocol-header (buffer)
1290 (:documentation "Extract a protocol header from a buffer.
1291 Return it as as keyword. (see make-version-keyword)")
1292
1293 (:method ((buffer vector))
1294 (make-version-keyword :name (map-into (make-string 4) #'code-char buffer)
1295 :class (aref buffer 4)
1296 :instance (aref buffer 5)
1297 :major (aref buffer 6)
1298 :minor (aref buffer 7))))
1299 (defgeneric (setf buffer-protocol-header) (header buffer)
1300 (:documentation "Store a protocol header into a buffer.")
1301
1302 (:method ((header symbol) (buffer t))
1303 (setf (buffer-protocol-header buffer) (string header)))
1304 (:method ((header string) (buffer t))
1305 (setf (buffer-protocol-header buffer) (parse-version-keyword header)))
1306 (:method ((header cons) (buffer vector))
1307 "Store the header cookie and the version numbers in the first eight bytes of the buffer"
1308 (map-into buffer #'char-code (string (first header)))
1309 (replace buffer (rest header) :start1 4 :end2 4)
1310 header))
1311 )
1312
1313
1314 (defun (setf buffer-protocol-header-version) (version buffer)
1315 "Store a protocol header into a buffer.
1316 Accept a version keyword and set the version header as registered in the list of supported versions."
1317
1318 (replace buffer (or (version-protocol-header version) (error "Invalid version : ~s." version)) :start1 0 :end1 8)
1319 version)
1320
1321
1322 (defun buffer-protocol-header-version (buffer &optional (error-p t))
1323 "Extract a protocol header from a buffer.
1324 Return the respective version keyword as registered in the list of supported versions."
1325
1326 (cond ((protocol-header-version (if (= (length buffer) 8) buffer (setf buffer (subseq buffer 0 8)))))
1327 (error-p
1328 (error "Invalid version : ~s." buffer))
1329 (t
1330 nil)))

  ViewVC Help
Powered by ViewVC 1.1.5