Commit 423dbd69 authored by hayeah via gmail com's avatar hayeah via gmail com

Added nested url mapping.

Nothing's as easy as it should be.
This got to be pretty hairy.

darcs-hash:706e351b9a977df4b46c7d7b5c29fdd640bc79be
parent 6950bd3c
(in-package :wisp-mvc)
(define-condition werror (error)
())
(define-condition wisp-no-object-with-id (werror)
((class :initarg :class)
(id :initarg :id))
(:report (lambda (c s)
(with-slots (class id) c
(fmt :> s
"No object of class " class " stored by ID " id " is found.")))))
(define-condition wisp-undefined-view (werror)
((view-name :initarg :view-name))
(:report (lambda (c s)
(with-slots (view-name) c
(fmt :> s
"Unable to render the undefined view " view-name)))))
(define-condition wisp-no-dispatch-for-url (werror)
((url :initarg :url))
(:report (lambda (c s)
(with-slots (url) c
(fmt :> s
"No dispatch is associated with " url)))))
(define-condition wisp-undefined-nested-urlmap (werror)
((nested-map :initarg :nested-map)
(root-map :initarg :root-map))
(:report (lambda (c s)
(with-slots (nested-map root-map) c
(fmt :> s
"Undefined nested-urlmap " nested-map
" in root map " root-map)))))
(define-condition wisp-circular-nested-urlmap (werror)
((circular-map :initarg :circular-map)
(parent-map :initarg :parent-map)
(root-map :initarg :root-map))
(:report (lambda (c s)
(with-slots (circular-map parent-map root-map) c
(fmt :> s
"Circular nested-urlmap " circular-map
" detected under parent map " parent-map
" in root map " root-map)))))
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
......@@ -27,32 +76,3 @@
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :wisp-mvc)
(define-condition werror (error)
())
(define-condition wisp-no-object-with-id (werror)
((class :initarg :class)
(id :initarg :id))
(:report (lambda (c s)
(with-slots (class id) c
(fmt :> s
"No object of class " class " stored by ID " id " is found.")))))
(define-condition wisp-undefined-view (werror)
((view-name :initarg :view-name))
(:report (lambda (c s)
(with-slots (view-name) c
(fmt :> s
"Unable to render the undefined view " view-name)))))
(define-condition wisp-no-dispatch-for-url (werror)
((url :initarg :url))
(:report (lambda (c s)
(with-slots (url) c
(fmt :> s
"No dispatch is associated with " url)))))
\ No newline at end of file
......@@ -2,71 +2,99 @@
;;;; urlmap.lisp
(scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_bar")
NIL
(scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_mo_bar")
NIL
(scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_o/momo_bar")
"abc_o/momo_bar"
#("o" "bar")
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21_fe/llaf2213")
NIL
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf_2213")
NIL
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213/")
NIL
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213")
"21fe/llaf2213"
#("21fe" "llaf2213")
(def-suite urlmap)
(in-suite urlmap)
(test make-url-handler-regex
(is (eql (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_bar")
nil))
(is (eql (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_mo_bar")
nil))
(is (equal
(^string (multiple-value-list (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_o/momo_bar")))
(^string '("abc_o/momo_bar" #("o" "bar")))))
(is (eql (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21_fe/llaf2213")
nil))
(is (eql (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf_2213")
nil))
(is (eql
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213/")
nil))
(is (equal
(^string (multiple-value-list (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213")))
(^string '("21fe/llaf2213" #("21fe" "llaf2213")))))
)
(test extract-url-fnlist
(is (equal
(^string (extract-url-fnlist "/abc__:d_ef/efg_:h") )
(^string '(("abc_" "d_ef") ("efg" "h")))))
(is (equal
(^string (extract-url-fnlist "/:a/:b"))
(^string '(("" "a") ("" "b")))))
)
(scan-to-strings (make-handler-url-regex "abc_:fo_o/momo_:bar") "abc_21fe/momo_llaf2213/boo")
"abc_21fe/momo_llaf2213"
#("21fe" "llaf2213")
(extract-url-fnlist "/abc__:d_ef/efg_:h")
(("abc_" "d_ef") ("efg" "h"))
(test normalize-url-spec
(is (equal
(^string (normalize-url-spec '("show/class1" :handler (fn () (show (find-class 'class1) (find-class 'class2))))))
(^string '((list "show/class1" :handler
#'(lambda nil
(show (find-class 'class1) (find-class 'class2))))))
))
(is (equal
(^string (normalize-url-spec '("show/:class1/:class2" :handler (fn (a b) (show (find-class a) (find-class b))))))
(^string '((list "show/:class1/:class2" :handler
#'(lambda (a b) (show (find-class a) (find-class b))))))
))
(is (equal
(^string (normalize-url-spec '("" :wethod foo
(t t)
(class1 t)
(t class2)
(class1 class2))))
(^string '((list ":arg1/:arg2" :wethod (symbol-function 'foo))
(list "class1_:arg1/:arg2" :wethod (symbol-function 'foo))
(list ":arg1/class2_:arg2" :wethod (symbol-function 'foo))
(list "class1_:arg1/class2_:arg2" :wethod (symbol-function 'foo))))
))
(is (equal
(^string (normalize-url-spec '("" :class-wethod show
(class1 class2)
(class3 class4))))
(^string '((list "class1/class2" :class-wethod (symbol-function 'show))
(list "class3/class4" :class-wethod (symbol-function 'show))))
))
(is (equal
(^string (normalize-url-spec '("some" :map silly-map)))
(^string '((list "some" :map 'silly-map)))
))
)
(extract-url-fnlist "/:a/:b")
(("" "a") ("" "b"))
(defurlmap foo
("" :map bar))
(defurlmap bar
("" :map qux))
(defurlmap qux
("" :map foo))
(defurlmap foo2
("" :map foo3))
(test attach-urlmap
(signals wisp-circular-nested-urlmap
(attach-urlmap "/" 'foo))
(signals wisp-undefined-nested-urlmap
(attach-urlmap "/" 'foo2)))
(defurlmap wisp
("" :class-wethod show
(class1 class2)
(class3 class4))
("" :wethod show
(t t)
(class1 t)
(t class2)
(class1 class2))
;; ("a" :instance-wethod show (t t))
("show/class1" :handler (fn () (show (find-class 'class1) (find-class 'class2))))
("show/:class1/:class2" :handler (fn (a b) (show (find-class a) (find-class b))))
)
;; error, because undefined classes are used in wethod signatures.
(defclass class1 () ((a :initform 0)
(b :initform 1)))
(defclass class1 () ((a :initform 1)
(b :initform 2)))
(defclass class2 () ((c :initform 3)
(d :initform 4)))
......@@ -83,9 +111,16 @@ NIL
(defmethod foo ((arg1 class1) arg2)
(list 'foo
(with-slots (a b) arg1
(list arg1 a b))
(list (class-name (class-of arg1)) a b))
arg2))
(defmethod foo ((arg1 class1) (arg2 class2))
(list 'foo
(with-slots (a b) arg1
(list (class-name (class-of arg1)) a b))
(with-slots (c d) arg2
(list (class-name (class-of arg2)) c d))))
(defmethod ^wisp-arg ((type (eql (find-class 'class1))) arg)
(make-instance 'class1))
......@@ -93,41 +128,79 @@ NIL
(defmethod ^wisp-arg ((type (eql (find-class 'class2))) arg)
(make-instance 'class2))
(defmethod ^wisp-arg ((type (eql (find-class 'class3))) arg)
(make-instance 'class3))
(defmethod ^wisp-arg ((type (eql (find-class 'class4))) arg)
(make-instance 'class4))
(defurlmap wisp
("" :class-wethod foo
(class1 class2)
(class3 class4))
(class1 class2))
("" :wethod foo
(t t)
(class1 t)
(t class2)
(class1 class2))
(class1 class2)
(class3 class4))
("wisp2" :map wisp2)
;; ("a" :instance-wethod show (t t))
("foo/class1" :handler (fn () (foo (find-class 'class1) (find-class 'class2))))
("foo/:class1/:class2" :handler (fn (a b) (foo (find-class a) (find-class b))))
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp a b)))
)
(attach-urlmap "/wisp" 'wisp)
(match-url-dispatch "abc_21fe/momo_llaf2213/boo" (get-urlmap 'wisp))
(defurlmap wisp2
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp2 a b)))
)
(match-url-dispatch "abc21fe/momollaf2213" (get-urlmap 'wisp))
(attach-urlmap "/wisp" 'wisp)
(match-url-dispatch "class1_abc21fe/momollaf2213" (get-urlmap 'wisp))
;; (get-effective-urls 'wisp)
(test match-url-dispatch-for-url
(signals wisp-no-dispatch-for-url
(match-url-dispatch "abc_21fe/momo_llaf2213/boo" (get-urlmap 'wisp)))
(is (equal
(^string (match-url-dispatch "abc21fe/momollaf2213" (get-urlmap 'wisp)))
(^string '(foo "abc21fe" "momollaf2213"))
))
(is (equal
(^string (match-url-dispatch "class1_abc21fe/momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class1 1 2) "momollaf2213"))
))
(is (equal
(^string (match-url-dispatch "class1_abc21fe/class2_momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class1 1 2) (class2 3 4)))
))
(is (equal
(^string (match-url-dispatch "class3_abc21fe/class4_momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class3 30 2) (class4 3 4)))
))
(is (equal
(^string (match-url-dispatch "foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp "abc" "def"))
))
(is (equal
(^string (match-url-dispatch "wisp2/foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp2 "abc" "def"))
))
)
(match-url-dispatch "class1_abc21fe/class2_momollaf2213" (get-urlmap 'wisp))
(run! 'urlmap)
(defmethod foo (a b)
(render-html (:html (:print (list 'foo a b)))))
;; (defmethod foo (a b)
;; (render-html (:html (:print (list 'foo a b)))))
(defmethod foo ((arg1 class1) arg2)
(render-html (:html (:print
(list 'foo
(with-slots (a b) arg1
(list arg1 a b))
arg2)))))
;; (defmethod foo ((arg1 class1) arg2)
;; (render-html (:html (:print
;; (list 'foo
;; (with-slots (a b) arg1
;; (list arg1 a b))
;; arg2)))))
......@@ -64,7 +64,14 @@
(defpackage :wisp-mvc
(:use :wisp-util :cl :com.gigamonkeys.foo :elephant :net.aserve :kmrcl :mop :cl-ppcre)
(:use :cl :wisp-util
:com.gigamonkeys.foo
:elephant
:net.aserve
:kmrcl
:mop
:cl-ppcre
:it.bese.fiveam)
(:export :find-instances
:find-instances*
......
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment