(and type-node (accept-node-q type-node))
(accept-node-q accept-tree))))
+(defun q-ok (media-type accept-tree)
+ (let ((q (q media-type accept-tree)))
+ (and q (> q 0) q)))
+
(defun insert (range q tree)
(labels ((ensure-node (range tree)
(cond
(result (make-accept-node :name nil)))
(cl-ppcre:do-register-groups (type subtype qp q)
;; not desperately error-proof
- ("([a-z]*|\\*)/([a-z]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
+ ("([a-z]*|\\*)/([a-z0-9]*|\\*)(;q=([01]\\.[0-9]*))?(,|$)" string result)
(if qp
(setf q (float (+ (digit-char-p (char q 0))
(/ (parse-integer q :start 2)
((gf accept-generic-function) (g accept-generalizer))
`(accept-generalizer ,(header g)))
(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) (generalizer accept-generalizer))
- (values (q (media-type s) (tree generalizer)) t))
+ (values (q-ok (media-type s) (tree generalizer)) t))
(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s accept-specializer) generalizer)
(values nil t))
(defmethod specializer-accepts-generalizer-p ((gf accept-generic-function) (s sb-mop:specializer) (generalizer accept-generalizer))
(defmethod specializer-accepts-p ((specializer accept-specializer) obj)
nil)
(defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
- (q (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
+ (q-ok (media-type specializer) (parse-accept-string (tbnl:header-in :accept obj))))
(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 accept-specializer) generalizer)
(cond
(let ((request-specializer (car (sb-mop:method-specializers ,method))))
(when (typep request-specializer 'accept-specializer)
(setf *actual-content-type* (media-type request-specializer))))
- (call-method ,method ,@(and nexts `((,(transform nexts)))))))))
+ (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
(wrap (form)
`(let ((*actual-content-type*))
(multiple-value-prog1
(let ((form (if (or before after (rest primary))
`(multiple-value-prog1
(progn ,@(call-methods before)
- (call-method ,(transform primary)))
+ (catch 'content-negotiation (call-method ,(transform primary))))
,@(call-methods (reverse after)))
- `(call-method ,(transform primary)))))
+ `(catch 'content-negotiation (call-method ,(transform primary))))))
(if around
(wrap `(call-method ,(first around)
(,@(rest around) (make-method ,form))))
:header s
:next (class-of s)))
(defmethod specializer-accepts-p ((s accept-specializer) (string string))
- (q (media-type s) (parse-accept-string string)))
+ (q-ok (media-type s) (parse-accept-string string)))
(defmethod handle-content-type ((x tbnl:request))
(setf (tbnl:content-type*) *actual-content-type*))
(defmethod respond list ((s (accept "audio/mp3")))
"audio/mp3")
+(defgeneric cn-test (request)
+ (:generic-function-class accept-generic-function)
+ (:method-combination content-negotiation))
+(defmethod cn-test ((request (accept "text/html")))
+ 'html)
+(defmethod cn-test ((request (accept "text/plain")))
+ 'plain)
+(defmethod cn-test ((request (accept "image/webp")))
+ 'webp)
+(defmethod cn-test ((request (accept "audio/mp3")))
+ (call-next-method)
+ 'mp3)
+(defmethod cn-test :after (request)
+ (print 'after))