+(defmethod specializer-accepts-p ((specializer accept-specializer) obj)
+ nil)
+(defmethod specializer-accepts-p ((specializer accept-specializer) (obj tbnl:request))
+ (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
+ ((string= (media-type s1) (media-type s2)) '=)
+ (t (let ((q1 (q (media-type s1) (tree generalizer)))
+ (q2 (q (media-type s2) (tree generalizer))))
+ (cond
+ ((= q1 q2) '=)
+ ((< q1 q2) '>)
+ (t '<))))))
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 class) generalizer)
+ '<)
+(defmethod specializer< ((gf accept-generic-function) (s1 accept-specializer) (s2 sb-mop:eql-specializer) generalizer)
+ '>)
+(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 accept-specializer) generalizer)
+ (ecase (specializer< gf s2 s1 generalizer)
+ ((>) '<)
+ ((<) '>)))
+(defmethod specializer< ((gf accept-generic-function) (s1 sb-mop:specializer) (s2 sb-mop:specializer) (g accept-generalizer))
+ (specializer< gf s1 s2 (next g)))
+\f
+(defvar *actual-content-type*)
+(defgeneric handle-content-type (x))
+(define-method-combination content-negotiation ()
+ ((around (:around))
+ (before (:before))
+ (primary () :required t)
+ (after (:after)))
+ (:arguments request)
+ (labels ((call-methods (methods)
+ (mapcar #'(lambda (method)
+ `(call-method ,method))
+ methods))
+ (transform (primaries)
+ (let ((method (car primaries))
+ (nexts (cdr primaries)))
+ `(make-method
+ (progn
+ (let ((request-specializer (car (sb-mop:method-specializers ,method))))
+ (when (typep request-specializer 'accept-specializer)
+ (setf *actual-content-type* (media-type request-specializer))))
+ (throw 'content-negotiation (call-method ,method ,@(and nexts `((,(transform nexts))))))))))
+ (wrap (form)
+ `(let ((*actual-content-type*))
+ (multiple-value-prog1
+ ,form
+ (handle-content-type ,request)))))
+ (let ((form (if (or before after (rest primary))
+ `(multiple-value-prog1
+ (progn ,@(call-methods before)
+ (catch 'content-negotiation (call-method ,(transform primary))))
+ ,@(call-methods (reverse after)))
+ `(catch 'content-negotiation (call-method ,(transform primary))))))
+ (if around
+ (wrap `(call-method ,(first around)
+ (,@(rest around) (make-method ,form))))
+ (wrap form)))))
+(define-method-combination content-negotiation/or ()
+ ((around (:around))
+ (primary () :required t))
+ (:arguments request)
+ (labels ((transform/1 (method)
+ `(make-method
+ (progn
+ (let ((s (car (sb-mop:method-specializers ,method))))
+ (when (typep s 'accept-specializer)
+ (setf *actual-content-type* (media-type s))))
+ (call-method ,method))))
+ (transform (primaries)
+ (mapcar #'(lambda (x) `(call-method ,(transform/1 x)))
+ primaries))
+ (wrap (form)
+ `(let ((*actual-content-type*))
+ (multiple-value-prog1
+ ,form
+ (handle-content-type ,request)))))
+ (let ((form (if (rest primary)
+ `(or ,@(transform primary))
+ `(call-method ,(transform/1 (car primary))))))
+ (if around
+ (wrap `(call-method ,(first around)
+ (,@(rest around) (make-method ,form))))
+ (wrap form)))))
+
+(defmethod generalizer-of-using-class ((gf accept-generic-function) (s string))
+ (make-instance 'accept-generalizer
+ :header s
+ :next (call-next-method)))
+(defmethod specializer-accepts-p ((s accept-specializer) (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 handle-content-type ((x string))
+ (format t "~&Content-Type: ~A" *actual-content-type*))