diff --git a/doc/clog-manual.html b/doc/clog-manual.html index 2da243c..c8c1f48 100644 --- a/doc/clog-manual.html +++ b/doc/clog-manual.html @@ -717,6 +717,25 @@ an application share per connection the same queue of serialized events.

Returns true if connection is valid on this CLOG-OBJ.

+

+

+ + + +

+

+ + +

CLOG-Obj - Internals for Extensions and Plugins

@@ -8151,10 +8170,11 @@ result or DEFAULT-ANSWER on time out.

diff --git a/source/clog-base.lisp b/source/clog-base.lisp index 3666702..0983d15 100644 --- a/source/clog-base.lisp +++ b/source/clog-base.lisp @@ -14,7 +14,16 @@ ;;; methods to retrieve connection-data (data that is associated with the ;;; current page regardless of object or thread of execution is lisp). -(push :clog *features*) +(pushnew :clog *features*) + +(defvar *connection-cache* nil + "Dynamic variable containing optional cache. Every thread has its +own context and therefore its own copy of this variable when +dynamically bound. As a result no thread protection is needed to +access. To use dynamically bind the *connection-cache* and set it +to (list :cache) turn on caching. By default this is off its main use +is in initial setup complex pages. (private) +See macro with-connection-cache.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Implementation - clog-obj @@ -84,9 +93,34 @@ during attachment. (Private)")) dicarded, return CLOG-OBJ. (Internal)")) (defmethod js-execute ((obj clog-obj) script) - (clog-connection:execute (connection-id obj) script) + (if *connection-cache* + (push script *connection-cache*) + (clog-connection:execute (connection-id obj) script)) obj) +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; with-connection-cache ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmacro with-connection-cache ((clog-obj) &body body) + "Caches writes to the connection-id of CLOG-OBJ until +flushed with FLUSH-CONNECTION-CACHE or a query is made." + `(let ((*connection-cache* (list :cache))) + ,@body + (clog:flush-connection-cache ,clog-obj))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; flush-connection-cache ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun flush-connection-cache (clog-obj) + "Flush connection cache if on." + (when *connection-cache* + (dolist (script (reverse *connection-cache*)) + (unless (eq script :cache) + (clog-connection:execute (connection-id clog-obj) script))) + (setf *connection-cache* (list :cache)))) + ;;;;;;;;;;;;;; ;; js-query ;; ;;;;;;;;;;;;;; @@ -95,6 +129,7 @@ dicarded, return CLOG-OBJ. (Internal)")) (:documentation "Execure SCRIPT on browser and return result. (Internal)")) (defmethod js-query ((obj clog-obj) script &key (default-answer nil)) + (flush-connection-cache obj) (clog-connection:query (connection-id obj) script :default-answer default-answer)) ;;;;;;;;;;;;; diff --git a/source/clog.lisp b/source/clog.lisp index d9fe3b3..7a52c49 100644 --- a/source/clog.lisp +++ b/source/clog.lisp @@ -113,6 +113,8 @@ embedded in a native template application.)" (with-sync-event macro) (remove-connection-data-item generic-function) (validp generic-function) + (with-connection-cache macro) + (flush-connection-cache function) "CLOG-Obj - Internals for Extensions and Plugins" (html-id generic-function) diff --git a/tutorial/09-tutorial.lisp b/tutorial/09-tutorial.lisp index 684602b..7436189 100644 --- a/tutorial/09-tutorial.lisp +++ b/tutorial/09-tutorial.lisp @@ -6,154 +6,157 @@ (defun on-new-window (body) (setf (title (html-document body)) "Tutorial 9") - (let* (last-tab - ;; Note: Since the there is no need to use the tmp objects - ;; we reuse the same symbol name (tmp) even though the - ;; compiler can mark those for garbage collection early - ;; this not an issue as the element is created already - ;; in the browser window. This is probably not the best - ;; option for a production app though regardless. - ;; - ;; Create tabs and panels - (t1 (create-button body :content "Tab1")) - (t2 (create-button body :content "Tab2")) - (t3 (create-button body :content "Tab3")) - (tmp (create-br body)) - (p1 (create-div body)) - (p2 (create-div body)) - (p3 (create-div body :content "Panel3 - Type here")) - ;; Create form for panel 1 - (f1 (create-form p1)) - (fe1 (create-form-element f1 :text - :label (create-label f1 :content "Fill in blank:"))) - (tmp (create-br f1)) - (fe2 (create-form-element f1 :color :value "#ffffff" - :label (create-label f1 :content "Pick a color:"))) - (tmp (create-br f1)) - (tmp (create-form-element f1 :submit :value "OK")) - (tmp (create-form-element f1 :reset :value "Start Again")) - ;; Create for for panel 2 - (f2 (create-form p2)) - (fs2 (create-fieldset f2 :legend "Stuff")) - (tmp (create-label fs2 :content "Please type here:")) - (ta1 (create-text-area fs2 :columns 60 :rows 8 :label tmp)) - (tmp (create-br fs2)) - (rd1 (create-form-element fs2 :radio :name "rd")) - (tmp (create-label fs2 :content "To Be" :label-for rd1)) - (rd2 (create-form-element fs2 :radio :name "rd")) - (tmp (create-label fs2 :content "No to Be" :label-for rd2)) - (tmp (create-br fs2)) - (ck1 (create-form-element fs2 :checkbox :name "ck")) - (tmp (create-label fs2 :content "Here" :label-for ck1)) - (ck2 (create-form-element fs2 :checkbox :name "ck")) - (tmp (create-label fs2 :content "There" :label-for ck2)) - (tmp (create-br fs2)) - (sl1 (create-select fs2 :label (create-label fs2 :content "Pick one:"))) - (sl2 (create-select fs2 :label (create-label fs2 :content "Pick one:"))) - (sl3 (create-select fs2 :multiple t - :label (create-label fs2 :content "Pick some:"))) - (o1 (create-option sl3 :content "one")) - (o2 (create-option sl3 :content "two")) - (o3 (create-option sl3 :content "three")) - (og1 (create-optgroup sl3 :content "These are a group")) - (o4 (create-option og1 :content "four")) - (o5 (create-option og1 :content "five")) - (tmp (create-form-element f2 :submit :value "OK")) - (tmp (create-form-element f2 :reset :value "Start Again"))) - (declare (ignore tmp)) + ;; When doing extensive setup of a page using connection cache + ;; reduces rountrip traffic and speeds setup considerably. + (with-connection-cache (body) + (let* (last-tab + ;; Note: Since the there is no need to use the tmp objects + ;; we reuse the same symbol name (tmp) even though the + ;; compiler can mark those for garbage collection early + ;; this not an issue as the element is created already + ;; in the browser window. This is probably not the best + ;; option for a production app though regardless. + ;; + ;; Create tabs and panels + (t1 (create-button body :content "Tab1")) + (t2 (create-button body :content "Tab2")) + (t3 (create-button body :content "Tab3")) + (tmp (create-br body)) + (p1 (create-div body)) + (p2 (create-div body)) + (p3 (create-div body :content "Panel3 - Type here")) + ;; Create form for panel 1 + (f1 (create-form p1)) + (fe1 (create-form-element f1 :text + :label (create-label f1 :content "Fill in blank:"))) + (tmp (create-br f1)) + (fe2 (create-form-element f1 :color :value "#ffffff" + :label (create-label f1 :content "Pick a color:"))) + (tmp (create-br f1)) + (tmp (create-form-element f1 :submit :value "OK")) + (tmp (create-form-element f1 :reset :value "Start Again")) + ;; Create for for panel 2 + (f2 (create-form p2)) + (fs2 (create-fieldset f2 :legend "Stuff")) + (tmp (create-label fs2 :content "Please type here:")) + (ta1 (create-text-area fs2 :columns 60 :rows 8 :label tmp)) + (tmp (create-br fs2)) + (rd1 (create-form-element fs2 :radio :name "rd")) + (tmp (create-label fs2 :content "To Be" :label-for rd1)) + (rd2 (create-form-element fs2 :radio :name "rd")) + (tmp (create-label fs2 :content "No to Be" :label-for rd2)) + (tmp (create-br fs2)) + (ck1 (create-form-element fs2 :checkbox :name "ck")) + (tmp (create-label fs2 :content "Here" :label-for ck1)) + (ck2 (create-form-element fs2 :checkbox :name "ck")) + (tmp (create-label fs2 :content "There" :label-for ck2)) + (tmp (create-br fs2)) + (sl1 (create-select fs2 :label (create-label fs2 :content "Pick one:"))) + (sl2 (create-select fs2 :label (create-label fs2 :content "Pick one:"))) + (sl3 (create-select fs2 :multiple t + :label (create-label fs2 :content "Pick some:"))) + (o1 (create-option sl3 :content "one")) + (o2 (create-option sl3 :content "two")) + (o3 (create-option sl3 :content "three")) + (og1 (create-optgroup sl3 :content "These are a group")) + (o4 (create-option og1 :content "four")) + (o5 (create-option og1 :content "five")) + (tmp (create-form-element f2 :submit :value "OK")) + (tmp (create-form-element f2 :reset :value "Start Again"))) + (declare (ignore tmp)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Panel 1 contents - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (setf (place-holder fe1) "type here..") - (setf (requiredp fe1) t) - (setf (size fe1) 60) - (make-data-list fe1 '("Cool Title" - "Not So Cool Title" - "Why Not, Another Title")) - (make-data-list fe2 '("#ffffff" - "#ff0000" - "#00ff00" - "#0000ff" - "#ff00ff")) - (set-on-submit f1 - (lambda (obj) - (declare (ignore obj)) - (setf (title (html-document body)) (value fe1)) - (setf (background-color p1) (value fe2)) - (setf (hiddenp f1) t) - (create-span p1 :content - "
Your form has been submitted"))) - (setf (width p1) "100%") - (setf (width p2) "100%") - (setf (width p3) "100%") - (setf (height p1) 400) - (setf (height p2) 400) - (setf (height p3) 400) - (set-border p1 :thin :solid :black) - (set-border p2 :thin :solid :black) - (set-border p3 :thin :solid :black) + ;; Panel 1 contents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Panel 2 contents + (setf (place-holder fe1) "type here..") + (setf (requiredp fe1) t) + (setf (size fe1) 60) + (make-data-list fe1 '("Cool Title" + "Not So Cool Title" + "Why Not, Another Title")) + (make-data-list fe2 '("#ffffff" + "#ff0000" + "#00ff00" + "#0000ff" + "#ff00ff")) + (set-on-submit f1 + (lambda (obj) + (declare (ignore obj)) + (setf (title (html-document body)) (value fe1)) + (setf (background-color p1) (value fe2)) + (setf (hiddenp f1) t) + (create-span p1 :content + "
Your form has been submitted"))) + (setf (width p1) "100%") + (setf (width p2) "100%") + (setf (width p3) "100%") + (setf (height p1) 400) + (setf (height p2) 400) + (setf (height p3) 400) + (set-border p1 :thin :solid :black) + (set-border p2 :thin :solid :black) + (set-border p3 :thin :solid :black) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (setf (vertical-align ta1) :top) - (disable-resize ta1) - (setf (vertical-align sl1) :top) - (setf (vertical-align sl2) :top) - (setf (vertical-align sl3) :top) - (setf (size sl1) 3) - (add-select-options sl1 '("one" - "two" - "three" - "four" - "five")) - (add-select-options sl2 '("one" - "two" - "three" - "four" - "five")) - (set-on-change sl3 (lambda (obj) - (declare (ignore obj)) - (when (selectedp o5) - (alert (window body) "Selected 5")))) - (set-on-submit f2 - (lambda (obj) - (declare (ignore obj)) - (setf (hiddenp f2) t) - (create-span p2 :content - (format nil "
Your form has been submitted: + ;; Panel 2 contents + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (setf (vertical-align ta1) :top) + (disable-resize ta1) + (setf (vertical-align sl1) :top) + (setf (vertical-align sl2) :top) + (setf (vertical-align sl3) :top) + (setf (size sl1) 3) + (add-select-options sl1 '("one" + "two" + "three" + "four" + "five")) + (add-select-options sl2 '("one" + "two" + "three" + "four" + "five")) + (set-on-change sl3 (lambda (obj) + (declare (ignore obj)) + (when (selectedp o5) + (alert (window body) "Selected 5")))) + (set-on-submit f2 + (lambda (obj) + (declare (ignore obj)) + (setf (hiddenp f2) t) + (create-span p2 :content + (format nil "
Your form has been submitted:
~A

1 - ~A
2 - ~A
3 - ~A" - (value ta1) - (value sl1) - (value sl2) - (selectedp o2))))) + (value ta1) + (value sl1) + (value sl2) + (selectedp o2))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Panel 3 contents + ;; Panel 3 contents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (setf (editablep p3) t) + (setf (editablep p3) t) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Tab functionality + ;; Tab functionality ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (flet ((select-tab (obj) - (setf (hiddenp p1) t) - (setf (hiddenp p2) t) - (setf (hiddenp p3) t) - (setf (background-color t1) :lightgrey) - (setf (background-color t2) :lightgrey) - (setf (background-color t3) :lightgrey) - (setf (background-color last-tab) :lightblue) - (setf (hiddenp obj) nil) - (focus obj))) - (setf last-tab t1) - (select-tab p1) - (set-on-click t1 (lambda (obj) - (setf last-tab obj) - (select-tab p1))) - (set-on-click t2 (lambda (obj) - (setf last-tab obj) - (select-tab p2))) - (set-on-click t3 (lambda (obj) - (setf last-tab obj) - (select-tab p3)))))) + (flet ((select-tab (obj) + (setf (hiddenp p1) t) + (setf (hiddenp p2) t) + (setf (hiddenp p3) t) + (setf (background-color t1) :lightgrey) + (setf (background-color t2) :lightgrey) + (setf (background-color t3) :lightgrey) + (setf (background-color last-tab) :lightblue) + (setf (hiddenp obj) nil) + (focus obj))) + (setf last-tab t1) + (select-tab p1) + (set-on-click t1 (lambda (obj) + (setf last-tab obj) + (select-tab p1))) + (set-on-click t2 (lambda (obj) + (setf last-tab obj) + (select-tab p2))) + (set-on-click t3 (lambda (obj) + (setf last-tab obj) + (select-tab p3))))))) (defun start-tutorial () "Start turtorial."