| 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 | |