4358148e |
1 | (in-package :lisp-on-lines-ucw) |
2 | |
3 | ;;; * Lisp on Lines YACLML tags. |
4 | |
5 | ;;; * Utilities |
6 | |
7 | (defun gen-id (string) |
8 | `(js:gen-js-name-string :prefix ,string)) |
9 | |
10 | ;;; ** ACTION tags |
11 | |
12 | ;;; These tags take UCW "actions" and create the appropriate HTML |
13 | ;;; tag to signal their execution. |
14 | |
15 | (defmacro %with-action-unique-names (&body body) |
16 | "These magic macros." |
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") |
20 | (rebinding (id) |
21 | `(let* ((,current-frame (context.current-frame *context*)) |
22 | (,action-object ,(or action* |
23 | `(lol-ucw:make-action |
24 | ,(or function |
25 | `(lambda () |
26 | (with-call/cc ,action)))))) |
27 | (,action-id (register-action-in-frame |
28 | ,current-frame |
29 | ,action-object)) |
30 | |
31 | |
32 | (,url (compute-url ,action-object *current-component*))) |
33 | (declare (ignorable ,action-id ,url)) |
34 | ,,@body)))) |
35 | |
36 | |
37 | (deftag-macro <lol:a (&attribute (id (gen-id "lol-action")) |
38 | action action* function |
39 | &allow-other-attributes others |
40 | &body body) |
41 | "A Simple <:A which does not require javascript." |
42 | (%with-action-unique-names |
43 | `(<:a :href (print-uri-to-string ,url) |
44 | :id ,id |
45 | ,@others |
46 | ,@body))) |
47 | |
48 | (deftag-macro <lol:form (&attribute (id (gen-id "lol-form")) |
49 | action action* function |
50 | &allow-other-attributes others |
51 | &body body) |
52 | "A Simple form which does not require javascript. " |
53 | (%with-action-unique-names |
54 | `(<:form :action (print-uri-to-string-sans-query ,url) |
55 | :id ,id |
56 | ,@others |
57 | (dolist (query (uri.query ,url)) |
58 | (if (string= ,+action-parameter-name+ (car query)) |
59 | (<:input :type "hidden" :name ,+action-parameter-name+ |
60 | :value (cdr query) |
61 | :id ,action-id) |
62 | (<:input :type "hidden" :name (car query) :value (cdr query)))) |
63 | ,@body))) |
64 | |
65 | (deftag-macro <lol:submit (&attribute (id (gen-id "lol-submit")) |
66 | action action* function value |
67 | &allow-other-attributes others |
68 | &body body) |
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+ |
75 | ,action-id)))) |
76 | |
77 | ;;; * CALLBACK tags |
78 | |
79 | ;;; All these tags take some kind of input, and execute a UCW callback. |
80 | |
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))))) |
87 | |
88 | `(<:input :value ,reader |
89 | :name (register-callback ,writer) |
90 | ,@others))) |
91 | |
92 | |
93 | |
94 | |
95 | |
96 | |
97 | |
98 | |
99 | |