1 (in-package :lisp-on-lines-ucw
)
3 ;;; * Lisp on Lines YACLML tags.
8 `(js:gen-js-name-string
:prefix
,string
))
12 ;;; These tags take UCW "actions" and create the appropriate HTML
13 ;;; tag to signal their execution.
15 (defmacro %with-action-unique-names
(&body body
)
17 `(with-unique-names (url action-object action-id current-frame
)
18 (assert (xor action action
* function
) nil
19 "Must supply only one of ACTION, ACTION* or FUNCTION")
21 `(let* ((,current-frame
(context.current-frame
*context
*))
22 (,action-object
,(or action
*
26 (with-call/cc
,action
))))))
27 (,action-id
(register-action-in-frame
32 (,url
(compute-url ,action-object
*current-component
*)))
33 (declare (ignorable ,action-id
,url
))
37 (deftag-macro <lol
:a
(&attribute
(id (gen-id "lol-action"))
38 action action
* function
39 &allow-other-attributes others
41 "A Simple <:A which does not require javascript."
42 (%with-action-unique-names
43 `(<:a
:href
(print-uri-to-string ,url
)
48 (deftag-macro <lol
:form
(&attribute
(id (gen-id "lol-form"))
49 action action
* function
50 &allow-other-attributes others
52 "A Simple form which does not require javascript. "
53 (%with-action-unique-names
54 `(<:form
:action
(print-uri-to-string-sans-query ,url
)
57 (dolist (query (uri.query
,url
))
58 (if (string= ,+action-parameter-name
+ (car query
))
59 (<:input
:type
"hidden" :name
,+action-parameter-name
+
62 (<:input
:type
"hidden" :name
(car query
) :value
(cdr query
))))
65 (deftag-macro <lol
:submit
(&attribute
(id (gen-id "lol-submit"))
66 action action
* function value
67 &allow-other-attributes others
69 (%with-action-unique-names
70 `(<:input
:type
"submit"
71 :value
(or ,value
,@body
)
72 :name
(format nil
"~A~A~A"
73 ,+action-parameter-name
+
74 ,+action-compound-name-delimiter
+
79 ;;; All these tags take some kind of input, and execute a UCW callback.
81 (deftag-macro <lol
:input
(&attribute accessor reader writer
82 (id (gen-id "lol-input"))
83 &allow-other-attributes others
)
84 (let ((reader (or reader accessor
))
85 (writer (or writer
`(lambda (v)
86 (setf ,accessor v
)))))
88 `(<:input
:value
,reader
89 :name
(register-callback ,writer
)
93 (deftag-macro <lol
::%select
(&attribute writer accessor
96 name
(id (js:gen-js-name-string
:prefix
"sel"))
97 &allow-other-attributes others
99 "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
100 "You need to supply either an accessor or a writer to <ucw:select"
101 (with-unique-names (id-value v val values
)
102 (let ((writer (or writer
`(lambda (,v
) (setf ,accessor
,v
)))))
103 `(let ((%current-select-value
,accessor
)
104 (%current-select-test
,test
)
105 (%current-select-key
,key
)
108 (declare (ignorable %current-select-value %current-select-test %current-select-key
110 (<:select
:name
(register-callback
111 (flet ((get-associated-value (v)
112 (let ((v (assoc v %select-table
:test
#'string
=)))
115 (error "Unknown option value: ~S." v
)))))
116 (lambda (,v
) (funcall ,writer
(get-associated-value ,v
))))
122 (deftag-macro <lol
::%select-action
(&attribute writer accessor
125 name
(id (js:gen-js-name-string
:prefix
"sel"))
126 &allow-other-attributes others
128 "The implementation of <ucw:select and tal tags with a ucw:accessor (or ucw:writer) attribute."
129 "You need to supply either an accessor or a writer to <ucw:select"
130 (with-unique-names (id-value v val values
)
131 (let ((writer (or writer
`(lambda (,v
) (setf ,accessor
,v
)))))
132 `(let ((%current-select-value
,accessor
)
133 (%current-select-test
,test
)
134 (%current-select-key
,key
)
137 (declare (ignorable %current-select-value %current-select-test %current-select-key
139 (<:select
:name
(register-callback
140 (flet ((get-associated-value (v)
141 (let ((v (assoc v %select-table
:test
#'string
=)))
144 (error "Unknown option value: ~S." v
)))))
145 (lambda (,v
) (funcall ,writer
(get-associated-value ,v
))))
151 (deftag-macro <lol
:select
(&allow-other-attributes others
153 `(<lol
::%select
,@others
,@body
))
155 (deftag-macro <lol
::%option
(&attribute value
&allow-other-attributes others
&body body
)
156 (with-unique-names (value-id)
158 `(let ((,value-id
(random-string 10)))
159 (push (cons ,value-id
,value
) %select-table
)
160 (<:option
:value
,value-id
161 ;;NB: we are applying key to both the option value being rendered,
162 ;; as well as the selected value(s).
163 ;;That was how the code worked previously, I don't know if it is desirable.
164 ;;I think the alternative would be to apply the key to ",value" that is
165 ;; the option being rendered, and remove the :key argument from find.
167 ;;The logical operation we are trying to accomplish is
168 ;;(mapcar #'add-selected-attribute
169 ;; (find-all %current-select-value(s)
170 ;; (list-of-collected-<lol::%option-calls)
171 ;; :key %current-select-key))
172 :selected
(when (find
173 (funcall %current-select-key
,value
) ;key applied to an option
175 %current-select-value
176 (list %current-select-value
))
177 :test %current-select-test
178 :key %current-select-key
)
182 (deftag-macro <lol
:option
(&allow-other-attributes others
&body body
)
183 "Replacement for the standard OPTION tag, must be used with
184 <LOL:SELECT tag. Unlike \"regular\" OPTION tags the :value
185 attribute can be any lisp object (printable or not)."
186 `(<lol
::%option
,@others
,@body
))