X-Git-Url: http://christophe.rhodes.io/gitweb/?a=blobdiff_plain;f=accept-specializer.lisp;h=c08f5373a18d19b49ec1c8db18bfe9eb04c89978;hb=d55ebbbcbd77023c799d8d95dce5d3772aec5841;hp=a72b1595918ca6b30b7a065e508ad62e5eafdfc5;hpb=206c80bb505fa274ef0ff9e22b1ffd4a93720dd3;p=specializable.git

diff --git a/accept-specializer.lisp b/accept-specializer.lisp
index a72b159..c08f537 100644
--- a/accept-specializer.lisp
+++ b/accept-specializer.lisp
@@ -117,7 +117,7 @@
 (defmethod generalizer-of-using-class ((gf accept-generic-function) (arg tbnl:request))
   (make-instance 'accept-generalizer
                  :header (tbnl:header-in :accept arg)
-                 :next (class-of arg)))
+                 :next (call-next-method)))
 (defmethod generalizer-equal-hash-key
     ((gf accept-generic-function) (g accept-generalizer))
   `(accept-generalizer ,(header g)))
@@ -189,11 +189,37 @@
           (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 (class-of s)))
+                 :next (call-next-method)))
 (defmethod specializer-accepts-p ((s accept-specializer) (string string))
   (q-ok (media-type s) (parse-accept-string string)))
 
@@ -228,3 +254,15 @@
   'mp3)
 (defmethod cn-test :after (request)
   (print 'after))
+
+(defgeneric cn/or-test (request)
+  (:generic-function-class accept-generic-function)
+  (:method-combination content-negotiation/or))
+
+(defmethod cn/or-test or ((request (accept "audio/mp3")))
+  'mp3)
+(defmethod cn/or-test or ((request (accept "image/webp")))
+  'webp)
+(defmethod cn/or-test :around ((request t))
+  (print :around)
+  (call-next-method))