mirrors/clog
1
Fork 0
mirror of https://github.com/rabbibotton/clog.git synced 2025-12-24 11:00:41 -08:00
Code Issues Projects Releases Wiki Activity

remove tabs and trailing white spaces

Browse source
This commit is contained in:
David Botton 2022-06-09 19:17:58 -04:00
parent bb7b532ea7
commit ce339a4f56
30 changed files with 4062 additions and 4071 deletions
Download patch file Download diff file Expand all files Collapse all files

14
source/clog-auth.lisp
View file

@ -48,7 +48,7 @@ for CLOG")
(setf token nil))
(unless token
(when auth-path
(url-assign (window body) auth-path)))
(url-assign (window body) auth-path)))
token))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -74,10 +74,10 @@ for CLOG")
(defun set-on-authentication-change (body handler)
(check-type body clog-body)
(set-on-storage (window body) (lambda (obj data)
(set-on-storage (window body) nil)
(when (equalp (getf data :key)
"clog-auth-token")
(funcall handler body)))))
(set-on-storage (window body) nil)
(when (equalp (getf data :key)
"clog-auth-token")
(funcall handler body)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-auth - Authorization
@ -105,6 +105,6 @@ for CLOG")
"Given ROLE-LIST is action authorized. If action is nil returns t."
(if action
(dolist (role role-list nil)
(when (member action (gethash role *authorization-hash*))
(return t)))
(when (member action (gethash role *authorization-hash*))
(return t)))
t))

380
source/clog-base.lisp
View file

@ -118,7 +118,7 @@ flushed with FLUSH-CONNECTION-CACHE or a query is made."
(when *connection-cache*
(dolist (script (reverse *connection-cache*))
(unless (eq script :cache)
(clog-connection:execute (connection-id clog-obj) script)))
(clog-connection:execute (connection-id clog-obj) script)))
(setf *connection-cache* (list :cache))))
;;;;;;;;;;;;;;
@ -153,7 +153,7 @@ result or if time out DEFAULT-ANSWER. see JQUERY-QUERY (Internal)"))
(defmethod query ((obj clog-obj) method &key (default-answer nil))
(js-query obj (format nil "~A.~A" (script-id obj) method)
:default-answer default-answer))
:default-answer default-answer))
;;;;;;;;;;;;;;;;;;;;;;;
;; bind-event-script ;;
@ -165,7 +165,7 @@ result or if time out DEFAULT-ANSWER. see JQUERY-QUERY (Internal)"))
(defmethod bind-event-script ((obj clog-obj) event call-back)
(jquery-execute obj (format nil "on('~A',function (e, data){~A})"
event call-back)))
event call-back)))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; unbind-event-script ;;
@ -300,8 +300,8 @@ result or if time out DEFAULT-ANSWER. see JQUERY-QUERY (Internal)"))
:shift-key (js-true-p (nth 4 f))
:meta-key (js-true-p (nth 5 f))
:key (if (equal (nth 6 f) "colon")
":"
(nth 6 f)))))
":"
(nth 6 f)))))
;;;;;;;;;;;;;;;;;;;;;;
;; parse-drop-event ;;
@ -332,39 +332,39 @@ result or if time out DEFAULT-ANSWER. see JQUERY-QUERY (Internal)"))
;;;;;;;;;;;;;;;
(defgeneric set-event (clog-obj event handler
&key call-back-script
eval-script
post-eval
cancel-event
one-time)
&key call-back-script
eval-script
post-eval
cancel-event
one-time)
(:documentation "Create the hook for incoming events. (Private)"))
(defmethod set-event ((obj clog-obj) event handler
&key (call-back-script "")
(eval-script "")
(post-eval "")
(cancel-event nil)
(one-time nil))
&key (call-back-script "")
(eval-script "")
(post-eval "")
(cancel-event nil)
(one-time nil))
(let ((hook (format nil "~A:~A" (html-id obj) event)))
(cond (handler
(bind-event-script
obj event (format nil "~Aws.send('E:~A '~A)~A~A~A"
eval-script
hook
call-back-script
post-eval
(if one-time
(format nil "; ~A.off('~A')"
(jquery obj)
event)
"")
(if cancel-event
"; return false"
"")))
(setf (gethash hook (connection-data obj)) handler))
(t
(unbind-event-script obj event)
(remhash hook (connection-data obj))))))
(bind-event-script
obj event (format nil "~Aws.send('E:~A '~A)~A~A~A"
eval-script
hook
call-back-script
post-eval
(if one-time
(format nil "; ~A.off('~A')"
(jquery obj)
event)
"")
(if cancel-event
"; return false"
"")))
(setf (gethash hook (connection-data obj)) handler))
(t
(unbind-event-script obj event)
(remhash hook (connection-data obj))))))
;;;;;;;;;;;;;;
;; property ;;
@ -375,7 +375,7 @@ result or if time out DEFAULT-ANSWER. see JQUERY-QUERY (Internal)"))
(defmethod property ((obj clog-obj) property-name &key (default-answer nil))
(jquery-query obj (format nil "prop('~A')" property-name)
:default-answer default-answer))
:default-answer default-answer))
(defgeneric set-property (clog-obj property-name value)
(:documentation "Set html property."))
@ -533,10 +533,10 @@ nil unbind all event handlers. (Internal)"))
(defmethod set-on-event ((obj clog-obj) event-name handler)
(set-event obj event-name
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;
@ -589,21 +589,21 @@ is nil unbind the event."))
;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-drag-start (clog-obj on-drag-start-handler
&key drag-data drag-type)
&key drag-data drag-type)
(:documentation "Set the ON-DRAG-START-HANDLER for CLOG-OBJ.
If ON-DRAG-START-HANDLER is nil unbind the event."))
(defmethod set-on-drag-start ((obj clog-obj) handler
&key (drag-data "") (drag-type "text/plain"))
&key (drag-data "") (drag-type "text/plain"))
(set-event obj "dragstart"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:eval-script (format nil
"e.originalEvent.dataTransfer.setData('~A','~A'); "
drag-type
drag-data)))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:eval-script (format nil
"e.originalEvent.dataTransfer.setData('~A','~A'); "
drag-type
drag-data)))
;;;;;;;;;;;;;;;;;
;; set-on-drag ;;
@ -660,12 +660,12 @@ is nil unbind the event."))
(defmethod set-on-drag-over ((obj clog-obj) handler)
(set-event obj "dragover"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:cancel-event t
:eval-script "e.preventDefault(); "))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:cancel-event t
:eval-script "e.preventDefault(); "))
;;;;;;;;;;;;;;;;;
;; set-on-drop ;;
@ -677,12 +677,12 @@ is nil unbind the event."))
(defmethod set-on-drop ((obj clog-obj) handler &key (drag-type "text/plain"))
(set-event obj "drop"
(when handler
(lambda (data)
(funcall handler obj (parse-drop-event data))))
:call-back-script (format nil drop-event-script drag-type)
:eval-script "e.preventDefault(); "
:cancel-event t))
(when handler
(lambda (data)
(funcall handler obj (parse-drop-event data))))
:call-back-script (format nil drop-event-script drag-type)
:eval-script "e.preventDefault(); "
:cancel-event t))
;;;;;;;;;;;;;;;;;;;;;
;; set-on-focus-in ;;
@ -717,11 +717,11 @@ this event is bound, you must call the form reset manually."))
(defmethod set-on-reset ((obj clog-obj) handler)
(set-event obj "reset"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:cancel-event t))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:cancel-event t))
;;;;;;;;;;;;;;;;;;;
;; set-on-search ;;
@ -757,18 +757,18 @@ form action to be run. See CLOG-Form SUBMIT for more details."))
(defmethod set-on-submit ((obj clog-obj) handler)
(set-event obj "submit"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:cancel-event t))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:cancel-event t))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-context-menu ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-context-menu (clog-obj on-context-menu-handler
&key one-time)
&key one-time)
(:documentation "Set the ON-CONTEXT-MENU-HANDLER for CLOG-OBJ. If
ON-CONTEXT-MENU-HANDLER is nil unbind the event. Setting
on-mouse-right-click will replace this handler. If :ONE-TIME unbind
@ -776,12 +776,12 @@ event on right click."))
(defmethod set-on-context-menu ((obj clog-obj) handler &key (one-time nil))
(set-event obj "contextmenu"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:one-time one-time
:cancel-event t))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:one-time one-time
:cancel-event t))
;;;;;;;;;;;;;;;;;;
;; set-on-click ;;
@ -794,29 +794,29 @@ set. If :ONE-TIME unbind event on click."))
(defmethod set-on-click ((obj clog-obj) handler &key (one-time nil))
(set-event obj "click"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:one-time one-time))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:one-time one-time))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-double-click ;;
;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-double-click (clog-obj on-double-click-handler
&key one-time)
&key one-time)
(:documentation "Set the ON-DOUBLE-CLICK-HANDLER for CLOG-OBJ. If
ON-DOUBLE-CLICK-HANDLER is nil unbind the event. Setting the
on-mouse-double-click event will replace this handler."))
(defmethod set-on-double-click ((obj clog-obj) handler &key (one-time nil))
(set-event obj "dblclick"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:one-time one-time))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))
:one-time one-time))
;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-mouse-click ;;
@ -829,49 +829,49 @@ on an on-click event."))
(defmethod set-on-mouse-click ((obj clog-obj) handler &key (one-time nil))
(set-event obj "click"
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:call-back-script mouse-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:call-back-script mouse-event-script))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-mouse-double-click ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-mouse-double-click (clog-obj on-mouse-double-click-handler
&key one-time)
&key one-time)
(:documentation "Set the ON-MOUSE-DOUBLE-CLICK-HANDLER for CLOG-OBJ. If
ON-MOUSE-DOUBLE-CLICK-HANDLER is nil unbind the event. Setting this event will
replace on an on-double-click event."))
(defmethod set-on-mouse-double-click ((obj clog-obj) handler &key (one-time nil))
(set-event obj "dblclick"
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:call-back-script mouse-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:call-back-script mouse-event-script))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-mouse-right-click ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-mouse-right-click (clog-obj on-mouse-right-click-handler
&key one-time)
&key one-time)
(:documentation "Set the ON-MOUSE-RIGHT-CLICK-HANDLER for CLOG-OBJ. If
ON-MOUSE-RIGHT-CLICK-HANDLER is nil unbind the event. Setting this event will
replace on an on-context-menu event."))
(defmethod set-on-mouse-right-click ((obj clog-obj) handler
&key (one-time nil))
&key (one-time nil))
(set-event obj "contextmenu"
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:call-back-script mouse-event-script
:cancel-event t))
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:call-back-script mouse-event-script
:cancel-event t))
;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-mouse-enter ;;
@ -928,12 +928,12 @@ does not bubble."))
(defmethod set-on-mouse-down ((obj clog-obj) handler &key (one-time nil) (cancel-event nil))
(set-event obj "mousedown"
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:cancel-event cancel-event
:call-back-script mouse-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:one-time one-time
:cancel-event cancel-event
:call-back-script mouse-event-script))
;;;;;;;;;;;;;;;;;;;;;
;; set-on-mouse-up ;;
@ -945,10 +945,10 @@ ON-MOUSE-UP-HANDLER is nil unbind the event."))
(defmethod set-on-mouse-up ((obj clog-obj) handler)
(set-event obj "mouseup"
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:call-back-script mouse-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:call-back-script mouse-event-script))
;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-mouse-move ;;
@ -960,10 +960,10 @@ ON-MOUSE-MOVE-HANDLER is nil unbind the event."))
(defmethod set-on-mouse-move ((obj clog-obj) handler)
(set-event obj "mousemove"
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:call-back-script mouse-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-mouse-event data))))
:call-back-script mouse-event-script))
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-pointer-enter ;;
@ -1014,24 +1014,24 @@ is nil unbind the event."))
;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-pointer-down (clog-obj on-pointer-down-handler
&key capture-pointer one-time cancel-event)
&key capture-pointer one-time cancel-event)
(:documentation "Set the ON-POINTER-DOWN-HANDLER for CLOG-OBJ. If
ON-POINTER-DOWN-HANDLER is nil unbind the event. If cancel event is t the
even does not bubble."))
(defmethod set-on-pointer-down ((obj clog-obj) handler
&key (capture-pointer nil) (one-time nil) (cancel-event nil))
&key (capture-pointer nil) (one-time nil) (cancel-event nil))
(set-event obj "pointerdown"
(when handler
(lambda (data)
(funcall handler obj (parse-pointer-event data))))
:post-eval (if capture-pointer
(format nil "; ~A.setPointerCapture(e.pointerId)"
(script-id obj))
"")
:one-time one-time
:cancel-event cancel-event
:call-back-script pointer-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-pointer-event data))))
:post-eval (if capture-pointer
(format nil "; ~A.setPointerCapture(e.pointerId)"
(script-id obj))
"")
:one-time one-time
:cancel-event cancel-event
:call-back-script pointer-event-script))
;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-pointer-up ;;
@ -1043,12 +1043,12 @@ ON-POINTER-UP-HANDLER is nil unbind the event."))
(defmethod set-on-pointer-up ((obj clog-obj) handler)
(set-event obj "pointerup"
(when handler
(lambda (data)
(funcall handler obj (parse-pointer-event data))))
:post-eval (format nil "; ~A.releasePointerCapture(e.pointerId)"
(script-id obj))
:call-back-script pointer-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-pointer-event data))))
:post-eval (format nil "; ~A.releasePointerCapture(e.pointerId)"
(script-id obj))
:call-back-script pointer-event-script))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-pointer-move ;;
@ -1060,10 +1060,10 @@ ON-POINTER-MOVE-HANDLER is nil unbind the event."))
(defmethod set-on-pointer-move ((obj clog-obj) handler)
(set-event obj "pointermove"
(when handler
(lambda (data)
(funcall handler obj (parse-pointer-event data))))
:call-back-script pointer-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-pointer-event data))))
:call-back-script pointer-event-script))
;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-touch-start ;;
@ -1075,11 +1075,11 @@ ON-TOUCH-START-HANDLER is nil unbind the event."))
(defmethod set-on-touch-start ((obj clog-obj) handler &key (one-time nil))
(set-event obj "touchstart"
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:one-time one-time
:call-back-script touch-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:one-time one-time
:call-back-script touch-event-script))
;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-touch-move ;;
@ -1091,10 +1091,10 @@ ON-TOUCH-MOVE-HANDLER is nil unbind the event."))
(defmethod set-on-touch-move ((obj clog-obj) handler)
(set-event obj "touchmove"
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:call-back-script touch-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:call-back-script touch-event-script))
;;;;;;;;;;;;;;;;;;;;;;
;; set-on-touch-end ;;
@ -1106,10 +1106,10 @@ ON-TOUCH-END-HANDLER is nil unbind the event."))
(defmethod set-on-touch-end ((obj clog-obj) handler)
(set-event obj "touchend"
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:call-back-script touch-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:call-back-script touch-event-script))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-touch-cancel ;;
@ -1121,52 +1121,52 @@ ON-TOUCH-CANCEL-HANDLER is nil unbind the event."))
(defmethod set-on-touch-cancel ((obj clog-obj) handler)
(set-event obj "touchcancel"
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:call-back-script touch-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-touch-event data))))
:call-back-script touch-event-script))
;;;;;;;;;;;;;;;;;;;;;;
;; set-on-character ;;
;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-character (clog-obj on-character-handler
&key one-time disable-default)
&key one-time disable-default)
(:documentation "Set the ON-CHARACTER-HANDLER for CLOG-OBJ. If
ON-CHARACTER-HANDLER is nil unbind the event. If disable-default is t
default key bindings in browser will not occur. Setting this event to
nil will unbind on-key-press also."))
(defmethod set-on-character ((obj clog-obj) handler
&key (one-time nil) (disable-default nil))
&key (one-time nil) (disable-default nil))
(set-event obj "keypress"
(when handler
(lambda (data)
(let ((f (parse-keyboard-event data)))
(funcall handler obj (code-char (getf f :char-code))))))
:one-time one-time
:cancel-event disable-default
:call-back-script keyboard-event-script))
(when handler
(lambda (data)
(let ((f (parse-keyboard-event data)))
(funcall handler obj (code-char (getf f :char-code))))))
:one-time one-time
:cancel-event disable-default
:call-back-script keyboard-event-script))
;;;;;;;;;;;;;;;;;;;;;
;; set-on-key-down ;;
;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-key-down (clog-obj on-key-down-handler
&key one-time disable-default)
&key one-time disable-default)
(:documentation "Set the ON-KEY-DOWN-HANDLER for CLOG-OBJ. If
disable-default is t default key bindings in browser will not occur.
If ON-KEY-DOWN-HANDLER is nil unbind the event."))
(defmethod set-on-key-down ((obj clog-obj) handler
&key (one-time nil) (disable-default nil))
&key (one-time nil) (disable-default nil))
(set-event obj "keydown"
(when handler
(lambda (data)
(funcall handler obj (parse-keyboard-event data))))
:one-time one-time
:cancel-event disable-default
:call-back-script keyboard-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-keyboard-event data))))
:one-time one-time
:cancel-event disable-default
:call-back-script keyboard-event-script))
;;;;;;;;;;;;;;;;;;;
;; set-on-key-up ;;
@ -1178,30 +1178,30 @@ ON-KEY-UP-HANDLER is nil unbind the event."))
(defmethod set-on-key-up ((obj clog-obj) handler &key (one-time nil))
(set-event obj "keyup"
(when handler
(lambda (data)
(funcall handler obj (parse-keyboard-event data))))
:one-time one-time
:call-back-script keyboard-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-keyboard-event data))))
:one-time one-time
:call-back-script keyboard-event-script))
;;;;;;;;;;;;;;;;;;;;;;
;; set-on-key-press ;;
;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-key-press (clog-obj on-key-press-handler
&key one-time disable-default)
&key one-time disable-default)
(:documentation "Set the ON-KEY-PRESS-HANDLER for CLOG-OBJ. If
ON-KEY-PRESS-HANDLER is nil unbind the event."))
(defmethod set-on-key-press ((obj clog-obj) handler
&key (one-time nil) (disable-default nil))
&key (one-time nil) (disable-default nil))
(set-event obj "keypress"
(when handler
(lambda (data)
(funcall handler obj (parse-keyboard-event data))))
:one-time one-time
:cancel-event disable-default
:call-back-script keyboard-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-keyboard-event data))))
:one-time one-time
:cancel-event disable-default
:call-back-script keyboard-event-script))
;;;;;;;;;;;;;;;;;
;; set-on-copy ;;

19
source/clog-body.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-window.lisp ;;;;
@ -34,12 +34,12 @@
(defun make-clog-body (connection-id)
"Construct a new clog-body object."
(let ((body (make-instance
'clog-body
:connection-id connection-id :html-id 0
:window (make-clog-window connection-id)
:html-document (make-clog-document connection-id)
:location (make-clog-location connection-id)
:navigator (make-clog-navigator connection-id))))
'clog-body
:connection-id connection-id :html-id 0
:window (make-clog-window connection-id)
:html-document (make-clog-document connection-id)
:location (make-clog-location connection-id)
:navigator (make-clog-navigator connection-id))))
(set-body (html-document body) body)))
;;;;;;;;;
@ -52,8 +52,8 @@ user close of connection / browser."))
(defmethod run ((obj clog-body))
(loop
(if (validp obj)
(sleep 10)
(return))))
(sleep 10)
(return))))
;;;;;;;;;;;;;;;;;;;;;;;
;; set-html-on-close ;;
@ -93,4 +93,3 @@ with HTML."))
(defgeneric navigator (clog-body)
(:documentation "Reader for CLOG-Navigator object"))

96
source/clog-canvas.lisp
View file

@ -20,26 +20,26 @@
;;;;;;;;;;;;;;;;;;;
(defgeneric create-canvas (clog-obj &key width height
class hidden html-id auto-place)
class hidden html-id auto-place)
(:documentation "Create a new CLOG-Canvas as child of CLOG-OBJ if
:AUTO-PLACE (default t) place-inside-bottom-of CLOG-OBJ."))
(defmethod create-canvas ((obj clog-obj)
&key (width 300) (height 150)
(class nil) (hidden nil)
(html-id nil) (auto-place t))
&key (width 300) (height 150)
(class nil) (hidden nil)
(html-id nil) (auto-place t))
(create-child obj (format nil "<canvas~A~A width=~A height=~A/>"
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if hidden
" style='visibility:hidden;'"
"")
width height)
:clog-type 'clog-canvas
:html-id html-id
:auto-place auto-place))
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if hidden
" style='visibility:hidden;'"
"")
width height)
:clog-type 'clog-canvas
:html-id html-id
:auto-place auto-place))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-context2d
@ -58,13 +58,13 @@
(defmethod create-context2d ((obj clog-canvas))
(let ((web-id (clog-connection:generate-id)))
(clog-connection:execute (connection-id obj)
(format nil "clog['~A']=clog['~A'].getContext('2d')"
web-id
(html-id obj)))
(format nil "clog['~A']=clog['~A'].getContext('2d')"
web-id
(html-id obj)))
(make-instance 'clog-context2d
:connection-id (connection-id obj)
:html-id web-id)))
:connection-id (connection-id obj)
:html-id web-id)))
;;;;;;;;;;;;;;;;
;; clear-rect ;;
@ -75,7 +75,7 @@
(defmethod clear-rect ((obj clog-context2d) x y width height)
(execute obj (format nil "clearRect(~A,~A,~A,~A)"
x y width height)))
x y width height)))
;;;;;;;;;;;;;;;
;; fill-rect ;;
@ -86,7 +86,7 @@
(defmethod fill-rect ((obj clog-context2d) x y width height)
(execute obj (format nil "fillRect(~A,~A,~A,~A)"
x y width height)))
x y width height)))
;;;;;;;;;;;;;;;;;
;; stroke-rect ;;
@ -97,7 +97,7 @@
(defmethod stroke-rect ((obj clog-context2d) x y width height)
(execute obj (format nil "strokeRect(~A,~A,~A,~A)"
x y width height)))
x y width height)))
;;;;;;;;;;;;;;;
;; fill-text ;;
@ -108,11 +108,11 @@
(defmethod fill-text ((obj clog-context2d) text x y &key (max-width nil))
(execute obj (format nil "fillText('~A',~A,~A~A)"
(escape-string text)
x y
(if max-width
(format nil ",~A" max-width)
""))))
(escape-string text)
x y
(if max-width
(format nil ",~A" max-width)
""))))
;;;;;;;;;;;;;;;;;
;; stroke-text ;;
;;;;;;;;;;;;;;;;;
@ -122,11 +122,11 @@
(defmethod stroke-text ((obj clog-context2d) text x y &key (max-width nil))
(execute obj (format nil "strokeText('~A',~A,~A~A)"
(escape-string text)
x y
(if max-width
(format nil ",~A" max-width)
""))))
(escape-string text)
x y
(if max-width
(format nil ",~A" max-width)
""))))
;;;;;;;;;;;;;;;;;;
;; measure-text ;;
;;;;;;;;;;;;;;;;;;
@ -373,7 +373,7 @@
(defmethod bezier-curve-to ((obj clog-context2d) cp1x cp1y cp2x cp2y x y)
(execute obj (format nil "bezierCurveTo(~A,~A,~A,~A,~A,~A)"
cp1x cp1y cp2x cp2y x y)))
cp1x cp1y cp2x cp2y x y)))
;;;;;;;;;;;;;;;;;;;;;;;;
;; quadratic-curve-to ;;
@ -390,16 +390,16 @@
;;;;;;;;;
(Defgeneric arc (clog-context2d x y radius start-angle end-angle
&key anticlockwise)
&key anticlockwise)
(:documentation "Adds a circular arc to the current path."))
(defmethod arc ((obj clog-context2d) x y radius start-angle end-angle
&key (anticlockwise nil))
&key (anticlockwise nil))
(execute obj (format nil "arc(~A,~A,~A,~A,~A~A)"
x y radius start-angle end-angle
(if anticlockwise
(format nil ",~A" anticlockwise)
""))))
x y radius start-angle end-angle
(if anticlockwise
(format nil ",~A" anticlockwise)
""))))
;;;;;;;;;;;;
;; arc-to ;;
@ -416,18 +416,18 @@
;;;;;;;;;;;;;
(defgeneric ellipse (clog-context2d x y radius-x radius-y rotation
start-angle end-angle
&key anticlockwise)
start-angle end-angle
&key anticlockwise)
(:documentation "Adds an elliptical arc to the current path."))
(defmethod ellipse ((obj clog-context2d) x y radius-x radius-y rotation
start-angle end-angle
&key (anticlockwise nil))
start-angle end-angle
&key (anticlockwise nil))
(execute obj (format nil "ellipse(~A,~A,~A,~A,~A,~A,~A~A)"
x y radius-x radius-y rotation start-angle end-angle
(if anticlockwise
(format nil ",~A" anticlockwise)
""))))
x y radius-x radius-y rotation start-angle end-angle
(if anticlockwise
(format nil ",~A" anticlockwise)
""))))
;;;;;;;;;;
;; rect ;;

508
source/clog-connection.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-connection.lisp ;;;;
@ -156,11 +156,11 @@ with DEFAULT-ANSWER in case of a time out. (Private)"
the default answer. (Private)"
(handler-case
(progn
(bordeaux-threads:wait-on-semaphore (gethash id *queries-sems*) :timeout timeout)
(let ((answer (gethash id *queries*)))
(remhash id *queries*)
(remhash id *queries-sems*)
answer))
(bordeaux-threads:wait-on-semaphore (gethash id *queries-sems*) :timeout timeout)
(let ((answer (gethash id *queries*)))
(remhash id *queries*)
(remhash id *queries-sems*)
answer))
(t (c)
(format t "Condition caught in wait-for-answer - ~A.~&" c)
(values 0 c))))
@ -173,27 +173,27 @@ the default answer. (Private)"
"Handle new incoming websocket CONNECTIONS with ID from boot page. (Private)"
(handler-case
(cond (id
(format t "Reconnection id - ~A to ~A~%" id connection)
(setf (gethash id *connection-ids*) connection)
(setf (gethash connection *connections*) id))
(t
(setf id (generate-id))
(setf (gethash connection *connections*) id)
(setf (gethash id *connection-ids*) connection)
(setf (gethash id *connection-data*) (make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(format t "New connection id - ~A - ~A~%" id connection)
(websocket-driver:send connection
(format nil "clog['connection_id']=~A" id))
(bordeaux-threads:make-thread
(lambda ()
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c)))))
(format t "Reconnection id - ~A to ~A~%" id connection)
(setf (gethash id *connection-ids*) connection)
(setf (gethash connection *connections*) id))
(t
(setf id (generate-id))
(setf (gethash connection *connections*) id)
(setf (gethash id *connection-ids*) connection)
(setf (gethash id *connection-data*) (make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(format t "New connection id - ~A - ~A~%" id connection)
(websocket-driver:send connection
(format nil "clog['connection_id']=~A" id))
(bordeaux-threads:make-thread
(lambda ()
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c)))))
:name (format nil "CLOG connection ~A"
id))))
(t (c)
@ -208,42 +208,42 @@ the default answer. (Private)"
"Handle incoming websocket MESSAGE on CONNECTION. (Private)"
(handler-case
(let ((id (gethash connection *connections*))
(ml (ppcre:split ":" message :limit 2)))
(cond ((equal (first ml) "0")
(when *verbose-output*
(format t "~A Ping~%" id)))
((equal (first ml) "E")
(let* ((em (ppcre:split " " (second ml) :limit 2))
(ml (ppcre:split ":" message :limit 2)))
(cond ((equal (first ml) "0")
(when *verbose-output*
(format t "~A Ping~%" id)))
((equal (first ml) "E")
(let* ((em (ppcre:split " " (second ml) :limit 2))
(event-id (first em))
(data (second em)))
(when *verbose-output*
(format t "Channel ~A Hook ~A Data ~A~%"
id event-id data))
(bordeaux-threads:make-thread
(lambda ()
(if *break-on-error*
(let* ((event-hash (get-connection-data id))
(event (when event-hash
(gethash event-id event-hash))))
(when event
(funcall event data)))
(handler-case
(let* ((event-hash (get-connection-data id))
(event (when event-hash
(gethash event-id event-hash))))
(when event
(funcall event data)))
(t (c)
(format t "Condition caught in handle-message for event - ~A.~&" c)
(values 0 c)))))
:name (format nil "CLOG event handler ~A"
event-id))))
(t
(when *verbose-output*
(format t "~A ~A = ~A~%" id (first ml) (second ml)))
(setf (gethash (parse-integer (first ml)) *queries*) (second ml))
(bordeaux-threads:signal-semaphore
(gethash (parse-integer (first ml)) *queries-sems*)))))
(when *verbose-output*
(format t "Channel ~A Hook ~A Data ~A~%"
id event-id data))
(bordeaux-threads:make-thread
(lambda ()
(if *break-on-error*
(let* ((event-hash (get-connection-data id))
(event (when event-hash
(gethash event-id event-hash))))
(when event
(funcall event data)))
(handler-case
(let* ((event-hash (get-connection-data id))
(event (when event-hash
(gethash event-id event-hash))))
(when event
(funcall event data)))
(t (c)
(format t "Condition caught in handle-message for event - ~A.~&" c)
(values 0 c)))))
:name (format nil "CLOG event handler ~A"
event-id))))
(t
(when *verbose-output*
(format t "~A ~A = ~A~%" id (first ml) (second ml)))
(setf (gethash (parse-integer (first ml)) *queries*) (second ml))
(bordeaux-threads:signal-semaphore
(gethash (parse-integer (first ml)) *queries-sems*)))))
(t (c)
(format t "Condition caught in handle-message - ~A.~&" c)
(values 0 c))))
@ -256,12 +256,12 @@ the default answer. (Private)"
"Close websocket CONNECTION. (Private)"
(handler-case
(let ((id (gethash connection *connections*)))
(when id
(when *verbose-output*
(format t "Connection id ~A has closed. ~A~%" id connection))
(remhash id *connection-data*)
(remhash id *connection-ids*)
(remhash connection *connections*)))
(when id
(when *verbose-output*
(format t "Connection id ~A has closed. ~A~%" id connection))
(remhash id *connection-data*)
(remhash id *connection-ids*)
(remhash connection *connections*)))
(t (c)
(format t "Condition caught in handle-message - ~A.~&" c)
(values 0 c))))
@ -274,40 +274,40 @@ the default answer. (Private)"
"Setup websocket server on ENV. (Private)"
(handler-case
(let ((ws (websocket-driver:make-server env)))
(websocket-driver:on :open ws
(websocket-driver:on :open ws
(lambda ()
(handler-case
(let* ((query (getf env :query-string))
(items (when query
(quri:url-decode-params query)))
(id (when items
(cdr (assoc "r" items
:test #'equalp)))))
(when (typep id 'string)
(setf id (parse-integer id :junk-allowed t)))
(handle-new-connection ws id))
(t (c)
(print env)
(format t "Condition caught in clog-server :open - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :message ws
(handler-case
(let* ((query (getf env :query-string))
(items (when query
(quri:url-decode-params query)))
(id (when items
(cdr (assoc "r" items
:test #'equalp)))))
(when (typep id 'string)
(setf id (parse-integer id :junk-allowed t)))
(handle-new-connection ws id))
(t (c)
(print env)
(format t "Condition caught in clog-server :open - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :message ws
(lambda (msg)
(handler-case
(handle-message ws msg)
(t (c)
(format t "Condition caught in clog-server :message - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :close ws
(handler-case
(handle-message ws msg)
(t (c)
(format t "Condition caught in clog-server :message - ~A.~&" c)
(values 0 c)))))
(websocket-driver:on :close ws
(lambda (&key code reason)
(declare (ignore code reason))
(handler-case
(handle-close-connection ws)
(t (c)
(format t "Condition caught in clog-server :message - ~A.~&" c)
(values 0 c)))))
(lambda (responder)
(declare (ignore responder))
(websocket-driver:start-connection ws)))
(handler-case
(handle-close-connection ws)
(t (c)
(format t "Condition caught in clog-server :message - ~A.~&" c)
(values 0 c)))))
(lambda (responder)
(declare (ignore responder))
(websocket-driver:start-connection ws)))
(t (c)
(format t "Condition caught in clog-server start-up - ~A.~&" c)
(values 0 c))))
@ -317,17 +317,17 @@ the default answer. (Private)"
;;;;;;;;;;;;;;;;
(defun initialize (on-connect-handler
&key
(host "0.0.0.0")
(port 8080)
(server :hunchentoot)
(extended-routing nil)
(long-poll-first nil)
(boot-file "/boot.html")
(boot-function nil)
(static-boot-html nil)
(static-boot-js nil)
(static-root #P"./static-files/"))
&key
(host "0.0.0.0")
(port 8080)
(server :hunchentoot)
(extended-routing nil)
(long-poll-first nil)
(boot-file "/boot.html")
(boot-function nil)
(static-boot-html nil)
(static-boot-js nil)
(static-root #P"./static-files/"))
"Initialize CLOG on a socket using HOST and PORT to serve BOOT-FILE
as the default route for '/' to establish web-socket connections and
static files located at STATIC-ROOT. The webserver used with CLACK can
@ -348,126 +348,126 @@ brower."
(when boot-file
(set-clog-path "/" boot-file))
(setf *app*
(lack:builder
(lambda (app)
(lambda (env)
;; if not static-boot-js use internal compiled boot.js
(if (and (eq static-boot-js nil)
(equalp (getf env :path-info) "/js/boot.js"))
`(200 (:content-type "text/javascript")
(,(compiled-boot-js)))
(funcall app env))))
(lambda (app)
(lambda (env)
;; Special handling of "clog paths"
(let* ((url-path (getf env :path-info))
(clog-path (gethash url-path *url-to-boot-file*)))
(unless clog-path
(when extended-routing
(maphash (lambda (k v)
(unless (equal k "/")
(when (ppcre:scan (format nil "^~A/" k)
url-path)
(setf clog-path v))))
*url-to-boot-file*)))
(cond (clog-path
(let ((file (uiop:subpathname static-root clog-path)))
(with-open-file (stream file :direction :input
:if-does-not-exist nil)
(let ((page-data (if stream
(make-string (file-length stream))
(if static-boot-html
""
(compiled-boot-html nil nil))))
(post-data nil))
(when stream
(read-sequence page-data stream))
(when boot-function
(setf page-data (funcall boot-function
url-path
page-data)))
(when (search "multipart/form-data;"
(getf env :content-type))
(let ((id (get-universal-time))
(req (lack.request:make-request env)))
(setf (gethash id *connection-data*)
(lack.request:request-body-parameters req))
(setf post-data id)))
(when (equal (getf env :content-type)
"application/x-www-form-urlencoded")
(setf post-data (make-string (getf env :content-length)))
(read-sequence post-data (getf env :raw-body)))
(cond (long-poll-first
(let ((id (generate-id)))
(setf (gethash id *connection-data*) (make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(format t "New html connection id - ~A~%" id)
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer))
(*long-poll-url* url-path)
(*long-poll-first* stream))
(write-sequence page-data stream)
(write-sequence
(format nil "<script>clog['connection_id']=~A;Open_ws();</script>" id)
stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c))))
(when *long-poll-first*
(setf *long-poll-first* nil)
(handler-case
(finish-output stream)
(t (c)
(format t "Condition caught finish-output ~A - ~A.~&" id c)
(values 0 c))))
(format t "HTML connection closed - ~A~%" id)))))
(t
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer)))
(write-sequence page-data stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(finish-output stream)))))))))
;; Pass the handling on to next rule
(t (funcall app env))))))
(:static :path (lambda (path)
;; Request is static path if not the websocket connection.
;; Websocket url is /clog
(cond ((ppcre:scan "^(?:/clog$)" path) nil)
(t path)))
:root static-root)
;; Handle Websocket connection
(lambda (env)
(clog-server env))))
(lack:builder
(lambda (app)
(lambda (env)
;; if not static-boot-js use internal compiled boot.js
(if (and (eq static-boot-js nil)
(equalp (getf env :path-info) "/js/boot.js"))
`(200 (:content-type "text/javascript")
(,(compiled-boot-js)))
(funcall app env))))
(lambda (app)
(lambda (env)
;; Special handling of "clog paths"
(let* ((url-path (getf env :path-info))
(clog-path (gethash url-path *url-to-boot-file*)))
(unless clog-path
(when extended-routing
(maphash (lambda (k v)
(unless (equal k "/")
(when (ppcre:scan (format nil "^~A/" k)
url-path)
(setf clog-path v))))
*url-to-boot-file*)))
(cond (clog-path
(let ((file (uiop:subpathname static-root clog-path)))
(with-open-file (stream file :direction :input
:if-does-not-exist nil)
(let ((page-data (if stream
(make-string (file-length stream))
(if static-boot-html
""
(compiled-boot-html nil nil))))
(post-data nil))
(when stream
(read-sequence page-data stream))
(when boot-function
(setf page-data (funcall boot-function
url-path
page-data)))
(when (search "multipart/form-data;"
(getf env :content-type))
(let ((id (get-universal-time))
(req (lack.request:make-request env)))
(setf (gethash id *connection-data*)
(lack.request:request-body-parameters req))
(setf post-data id)))
(when (equal (getf env :content-type)
"application/x-www-form-urlencoded")
(setf post-data (make-string (getf env :content-length)))
(read-sequence post-data (getf env :raw-body)))
(cond (long-poll-first
(let ((id (generate-id)))
(setf (gethash id *connection-data*) (make-hash-table* :test #'equal))
(setf (gethash "connection-id" (get-connection-data id)) id)
(format t "New html connection id - ~A~%" id)
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer))
(*long-poll-url* url-path)
(*long-poll-first* stream))
(write-sequence page-data stream)
(write-sequence
(format nil "<script>clog['connection_id']=~A;Open_ws();</script>" id)
stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(if *break-on-error*
(funcall *on-connect-handler* id)
(handler-case
(funcall *on-connect-handler* id)
(t (c)
(format t "Condition caught connection ~A - ~A.~&" id c)
(values 0 c))))
(when *long-poll-first*
(setf *long-poll-first* nil)
(handler-case
(finish-output stream)
(t (c)
(format t "Condition caught finish-output ~A - ~A.~&" id c)
(values 0 c))))
(format t "HTML connection closed - ~A~%" id)))))
(t
(lambda (responder)
(let* ((writer (funcall responder '(200 (:content-type "text/html"))))
(stream (lack.util.writer-stream:make-writer-stream writer)))
(write-sequence page-data stream)
(when post-data
(write-sequence
(format nil "<script>clog['post-data']='~A'</script>"
post-data)
stream))
(finish-output stream)))))))))
;; Pass the handling on to next rule
(t (funcall app env))))))
(:static :path (lambda (path)
;; Request is static path if not the websocket connection.
;; Websocket url is /clog
(cond ((ppcre:scan "^(?:/clog$)" path) nil)
(t path)))
:root static-root)
;; Handle Websocket connection
(lambda (env)
(clog-server env))))
(setf *client-handler* (clack:clackup *app* :server server :address host :port port))
(format t "HTTP listening on : ~A:~A~%" host port)
(format t "HTML root : ~A~%" static-root)
(format t "Long poll first : ~A~%" (if long-poll-first
"yes"
"no"))
"yes"
"no"))
(format t "Boot function added : ~A~%" (if boot-function
"yes"
"no"))
"yes"
"no"))
(format t "Boot html source use : ~A~%" (if static-boot-html
"static file"
"compiled version, when no file"))
"static file"
"compiled version, when no file"))
(format t "Boot js source use : ~A~%" (if static-boot-js
"static file"
"compiled version"))
"static file"
"compiled version"))
(format t "Boot file for path / : ~A~%" boot-file)
*client-handler*)
@ -501,11 +501,11 @@ brower."
"Associate URL path to BOOT-FILE"
(if boot-file
(setf (gethash path *url-to-boot-file*)
;; Make clog-path into a relative path of
;; of site-root.
(if (eql (char boot-file 0) #\/)
(concatenate 'string "." boot-file)
boot-file))
;; Make clog-path into a relative path of
;; of site-root.
(if (eql (char boot-file 0) #\/)
(concatenate 'string "." boot-file)
boot-file))
(remhash path *url-to-boot-file*)))
;;;;;;;;;;;;;;;;;;;
@ -529,10 +529,10 @@ brower."
"Execute SCRIPT on CONNECTION-ID, disregard return value."
(if *long-poll-first*
(write-sequence (format nil "<script>~A</script>~%" message)
*long-poll-first*)
*long-poll-first*)
(let ((con (get-connection connection-id)))
(when con
(websocket-driver:send con message)))))
(when con
(websocket-driver:send con message)))))
;;;;;;;;;;;
;; query ;;
@ -547,16 +547,16 @@ DEFAULT-ANSWER."
(finish-output *long-poll-first*)
(loop
for n from 1 to 10 do
(let ((con (get-connection connection-id)))
(when con
(return))
(sleep .1))))
(let ((con (get-connection connection-id)))
(when con
(return))
(sleep .1))))
(let ((uid (generate-id)))
(prep-query uid (when default-answer (format nil "~A" default-answer)))
(execute connection-id
(format nil "ws.send (\"~A:\"+eval(\"~A\"));"
uid
(escape-string script)))
(format nil "ws.send (\"~A:\"+eval(\"~A\"));"
uid
(escape-string script)))
(wait-for-answer uid)))
;;;;;;;;;;;;
@ -594,7 +594,7 @@ reistablish connectivity."
(defun put (connection-id text)
"Write TEXT to document object of CONNECTION-ID with out new line."
(execute connection-id
(format nil "document.write('~A');" (escape-string text))))
(format nil "document.write('~A');" (escape-string text))))
;;;;;;;;;;;;;;
;; put-line ;;
@ -604,7 +604,7 @@ reistablish connectivity."
"Write TEXT to document object of CONNECTION-ID with new line and
HTML <br />."
(execute connection-id
(format nil "document.writeln('~A<br />');" (escape-string text))))
(format nil "document.writeln('~A<br />');" (escape-string text))))
;;;;;;;;;;;;;;
;; new-line ;;
@ -638,7 +638,7 @@ HTML <br />."
"Set the client side variable clog['html_on_close'] to replace
the browser contents in case of connection loss."
(execute connection-id (format nil "clog['html_on_close']='~A'"
(escape-string html))))
(escape-string html))))
;;;;;;;;;;;;;;;;;;;;;;;;
;; compiled-boot-html ;;
@ -700,10 +700,10 @@ function Ping_ws() {
function Shutdown_ws(event) {
if (ws != null) {
ws.onerror = null;
ws.onclose = null;
ws.close ();
ws = null;
ws.onerror = null;
ws.onclose = null;
ws.close ();
ws = null;
}
clearInterval (pingerid);
if (clog['html_on_close'] != '') {
@ -715,7 +715,7 @@ function Setup_ws() {
ws.onmessage = function (event) {
try {
if (clog_debug == true) {
console.log ('eval data = ' + event.data);
console.log ('eval data = ' + event.data);
}
eval (event.data);
} catch (e) {
@ -754,9 +754,9 @@ function Setup_ws() {
function Open_ws() {
if (location.protocol == 'https:') {
adr = 'wss://' + location.hostname;
adr = 'wss://' + location.hostname;
} else {
adr = 'ws://' + location.hostname;
adr = 'ws://' + location.hostname;
}
if (location.port != '') { adr = adr + ':' + location.port; }
@ -767,21 +767,21 @@ function Open_ws() {
} else { adrc = adr }
try {
console.log ('connecting to ' + adrc);
ws = new WebSocket (adrc);
console.log ('connecting to ' + adrc);
ws = new WebSocket (adrc);
} catch (e) {
console.log ('trying again, connecting to ' + adrc);
ws = new WebSocket (adrc);
console.log ('trying again, connecting to ' + adrc);
ws = new WebSocket (adrc);
}
if (ws != null) {
ws.onopen = function (event) {
ws.onopen = function (event) {
console.log ('connection successful');
Setup_ws();
}
pingerid = setInterval (function () {Ping_ws ();}, 10000);
}
pingerid = setInterval (function () {Ping_ws ();}, 10000);
} else {
document.writeln ('If you are seeing this your browser or your connection to the internet is blocking websockets.');
document.writeln ('If you are seeing this your browser or your connection to the internet is blocking websockets.');
}
}

204
source/clog-data.lisp
View file

@ -27,24 +27,24 @@ upper cased before attempting to match it to a slot if :UPCASE-KEY t
(default). If :ROW-ID-NAME is set returns that fields value."
(let ((result))
(loop for (key value) on plist by #'cddr while value
do
(when (consp key)
(setf key (second key)))
(let* ((slot-str (format nil "~A" key))
(slot-name (if upcase-key
(string-upcase slot-str)
slot-str))
(slot-sym (find slot-name (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=)))
(when (equalp row-id-name slot-name)
(setf result value))
(when slot-sym
(setf slot-sym (closer-mop:slot-definition-name slot-sym))
(if (and (slot-boundp obj slot-sym)
(typep (slot-value obj slot-sym) 'clog:clog-element))
(setf (text-value (slot-value obj slot-sym)) value)
(setf (slot-value obj slot-sym) value)))))
do
(when (consp key)
(setf key (second key)))
(let* ((slot-str (format nil "~A" key))
(slot-name (if upcase-key
(string-upcase slot-str)
slot-str))
(slot-sym (find slot-name (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=)))
(when (equalp row-id-name slot-name)
(setf result value))
(when slot-sym
(setf slot-sym (closer-mop:slot-definition-name slot-sym))
(if (and (slot-boundp obj slot-sym)
(typep (slot-value obj slot-sym) 'clog:clog-element))
(setf (text-value (slot-value obj slot-sym)) value)
(setf (slot-value obj slot-sym) value)))))
result))
;;;;;;;;;;;;;;;;;;;;;;
@ -60,20 +60,20 @@ must be bound."
(let ((result))
(dolist (slot (reverse slot-name-list))
(when (consp slot)
(setf slot (second slot)))
(setf slot (second slot)))
(when (keywordp slot)
(setf slot (format nil "~A" slot)))
(setf slot (format nil "~A" slot)))
(unless (symbolp slot)
(when upcase-key
(setf slot (string-upcase slot))))
(when upcase-key
(setf slot (string-upcase slot))))
(setf slot (closer-mop:slot-definition-name
(find slot (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=)))
(find slot (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=)))
(if (and (slot-boundp obj slot)
(typep (slot-value obj slot) 'clog:clog-element))
(push (text-value (slot-value obj slot)) result)
(push (slot-value obj slot) result)))
(typep (slot-value obj slot) 'clog:clog-element))
(push (text-value (slot-value obj slot)) result)
(push (slot-value obj slot) result)))
result))
;;;;;;;;;;;;;;;;;;;;;;;
@ -81,7 +81,7 @@ must be bound."
;;;;;;;;;;;;;;;;;;;;;;;
(defun data-write-plist (obj slot-name-list &key (upcase-key t)
(keys-as-keywords t))
(keys-as-keywords t))
"Returns a plist, one member for each slot name in SLOT-NAME-LIST,
the key is the slot name. If a slot contains a CLOG-ELEMENT then
TEXT-VALUE is used to retrieve the value otherwise it is the
@ -93,31 +93,31 @@ slot-name does not exist it is left out of returned plist. If
:KEYS-AS-KEYWORDS t (default) then the keys will be symbols in the
keyword package."
(let (result
pname)
pname)
(dolist (slot (reverse slot-name-list))
(cond ((consp slot)
(setf pname (first slot))
(setf slot (second slot)))
(t
(setf pname slot)))
(setf pname (first slot))
(setf slot (second slot)))
(t
(setf pname slot)))
(when (keywordp slot)
(setf slot (format nil "~A" slot)))
(setf slot (format nil "~A" slot)))
(unless (symbolp slot)
(when upcase-key
(setf pname (string-upcase pname))
(setf slot (string-upcase slot))))
(when upcase-key
(setf pname (string-upcase pname))
(setf slot (string-upcase slot))))
(setf slot (find slot (closer-mop:compute-slots (class-of obj))
:key #'closer-mop:slot-definition-name
:test #'string=))
:key #'closer-mop:slot-definition-name
:test #'string=))
(when slot
(setf slot (closer-mop:slot-definition-name slot))
(if (and (slot-boundp obj slot)
(typep (slot-value obj slot) 'clog:clog-element))
(push (text-value (slot-value obj slot)) result)
(push (slot-value obj slot) result))
(if keys-as-keywords
(push (intern (format nil "~A" pname) 'keyword) result)
(push pname result))))
(setf slot (closer-mop:slot-definition-name slot))
(if (and (slot-boundp obj slot)
(typep (slot-value obj slot) 'clog:clog-element))
(push (text-value (slot-value obj slot)) result)
(push (slot-value obj slot) result))
(if keys-as-keywords
(push (intern (format nil "~A" pname) 'keyword) result)
(push pname result))))
result))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -143,20 +143,20 @@ stringified first. If :QUOTE-ALL t then all fields are in quotes."
(let ((result))
(dolist (field (reverse field-list))
(if (and for-insert
(consp field))
(setf field (car field)))
(consp field))
(setf field (car field)))
(if (consp field)
(setf field (format nil "~A as '~A'~A"
(if quote-all
(format nil "'~A'" (first field))
(format nil "~A" (first field)))
(second field)
(if result ", " "")))
(setf field (format nil "~A~A"
(if quote-all
(format nil "'~A'" field)
(format nil "~A" field))
(if result ", " ""))))
(setf field (format nil "~A as '~A'~A"
(if quote-all
(format nil "'~A'" (first field))
(format nil "~A" (first field)))
(second field)
(if result ", " "")))
(setf field (format nil "~A~A"
(if quote-all
(format nil "'~A'" field)
(format nil "~A" field))
(if result ", " ""))))
(push field result))
(format nil "~{~A~}" result)))
@ -169,13 +169,13 @@ stringified first. If :QUOTE-ALL t then all fields are in quotes."
unless is the single character '?'. If value is a list the car is returned
unquoted"
(cond ((and (stringp value)
(not (equal value "?")))
(format nil "'~A'"
(ppcre:regex-replace-all "'" value "''")))
((consp value)
(car value))
(t
value)))
(not (equal value "?")))
(format nil "'~A'"
(ppcre:regex-replace-all "'" value "''")))
((consp value)
(car value))
(t
value)))
;;;;;;;;;;;;;;;;;;;;
;; sql-value-list ;;
@ -187,8 +187,8 @@ use in a SQL insert value list."
(let ((result))
(dolist (value (reverse value-list))
(setf value (format nil "~A~A"
(sql-quote value)
(if result ", " "")))
(sql-quote value)
(if result ", " "")))
(push value result))
(format nil "~{~A~}" result)))
@ -202,14 +202,14 @@ returns a string for use in a SQL update. if the 'key' is a cons the
first 'key' used."
(let ((result))
(loop for (key value) on plist by #'cddr while value
do
(push (format nil "~A = ~A~A"
(if (consp key)
(car key)
key)
(sql-quote value)
(if result ", " ""))
result))
do
(push (format nil "~A = ~A~A"
(if (consp key)
(car key)
key)
(sql-quote value)
(if result ", " ""))
result))
(format nil "~{~A~}" result)))
;;;;;;;;;;;;;;;;
@ -219,21 +219,21 @@ first 'key' used."
(defun sql-select (table field-list &key where order-by limit)
"Build basic sql select statement"
(format nil "select ~A from ~A~A~A~A"
(if (consp field-list)
(sql-field-list field-list)
field-list)
(if (consp table)
(sql-field-list table)
table)
(if (and where (not (equal where "")))
(format nil " where ~A" where)
"")
(if (and order-by (not (equal order-by "")))
(format nil " order by ~A" order-by)
"")
(if (and limit (not (equal limit "")))
(format nil " limit ~A" limit)
"")))
(if (consp field-list)
(sql-field-list field-list)
field-list)
(if (consp table)
(sql-field-list table)
table)
(if (and where (not (equal where "")))
(format nil " where ~A" where)
"")
(if (and order-by (not (equal order-by "")))
(format nil " order by ~A" order-by)
"")
(if (and limit (not (equal limit "")))
(format nil " limit ~A" limit)
"")))
;;;;;;;;;;;;;;;;
;; sql-insert ;;
@ -242,9 +242,9 @@ first 'key' used."
(defun sql-insert (table field-list value-list)
"Build basic sql insert statement"
(format nil "insert into ~A (~A) values (~A)"
table
(sql-field-list field-list :for-insert t)
(sql-value-list value-list)))
table
(sql-field-list field-list :for-insert t)
(sql-value-list value-list)))
;;;;;;;;;;;;;;;;;
;; sql-insert* ;;
@ -253,9 +253,9 @@ first 'key' used."
(defun sql-insert* (table plist)
"Build basic sql insert statement using a plist"
(loop for (key value) on plist by #'cddr while value
collect key into fields
collect value into values
finally (return (sql-insert table fields values))))
collect key into fields
collect value into values
finally (return (sql-insert table fields values))))
;;;;;;;;;;;;;;;;
;; sql-update ;;
@ -264,6 +264,6 @@ first 'key' used."
(defun sql-update (table plist where)
"Build basic sql update statement"
(format nil "update ~A set ~A where ~A"
table
(sql-update-list plist)
where))
table
(sql-update-list plist)
where))

216
source/clog-dbi.lisp
View file

@ -28,22 +28,22 @@
;;;;;;;;;;;;;;;;;;;;;
(defgeneric create-database (clog-obj
&key hidden class html-id auto-place)
&key hidden class html-id auto-place)
(:documentation "Create a new CLOG-Database element, for use in
CLOG-Builder. If not using builder use to connect:
(dbi:connect (database-connection clog-obj) ...) or if a
connection exists assign it to the database-connecton."))
(defmethod create-database ((obj clog-obj)
&key (hidden nil)
(class nil)
(html-id nil) (auto-place t))
&key (hidden nil)
(class nil)
(html-id nil) (auto-place t))
(let ((new-obj (change-class (create-div obj :content ""
:hidden hidden
:class class
:html-id html-id
:auto-place auto-place)
'clog-database)))
:hidden hidden
:class class
:html-id html-id
:auto-place auto-place)
'clog-database)))
new-obj))
(defgeneric clog-database (clog-obj)
@ -126,24 +126,24 @@ connection exists assign it to the database-connecton."))
;;;;;;;;;;;;;;;;;;;;
(defgeneric create-one-row (clog-obj &key clog-database
hidden class html-id auto-place)
hidden class html-id auto-place)
(:documentation "Create a new CLOG-One-Row element. If CLOG-OBJ is
of type-of CLOG-DATABASE it is used as database source unless
:CLOG-DATABASE is set."))
(defmethod create-one-row ((obj clog-obj) &key (clog-database nil)
(hidden nil)
(class nil)
(html-id nil) (auto-place t))
(hidden nil)
(class nil)
(html-id nil) (auto-place t))
(let ((new-obj (change-class (create-div obj :content ""
:hidden hidden
:class class
:html-id html-id
:auto-place auto-place)
'clog-one-row)))
:hidden hidden
:class class
:html-id html-id
:auto-place auto-place)
'clog-one-row)))
(if (and (typep obj 'clog-database) (not clog-database))
(setf (clog-database new-obj) obj)
(setf (clog-database new-obj) clog-database))
(setf (clog-database new-obj) obj)
(setf (clog-database new-obj) clog-database))
new-obj))
(defgeneric query-row (clog-one-row panel sql)
@ -153,9 +153,9 @@ slots on panel will be set using DATA-LOAD-PLIST."))
(defmethod query-row ((obj clog-one-row) panel sql)
(setf (last-sql obj) sql)
(setf (queryid obj) (dbi:execute
(dbi:prepare
(database-connection (clog-database obj))
sql)))
(dbi:prepare
(database-connection (clog-database obj))
sql)))
(next-row obj panel))
(defgeneric get-row (clog-one-row panel)
@ -167,24 +167,24 @@ be set using DATA-LOAD-PLIST."))
(let ((where (where-clause obj)))
(when (slave-to-slot obj)
(let ((field (slave-to-slot obj))
(data (car (data-write-list panel (list (slave-to-slot obj))))))
(when (consp (slave-to-slot obj))
(setf field (car field)))
(setf where (format nil "~A='~A'~A"
field
data
(if (equal where "")
""
(format nil " and ~A" where))))))
(data (car (data-write-list panel (list (slave-to-slot obj))))))
(when (consp (slave-to-slot obj))
(setf field (car field)))
(setf where (format nil "~A='~A'~A"
field
data
(if (equal where "")
""
(format nil " and ~A" where))))))
(setf (last-sql obj) (sql-select (table-name obj)
(table-columns obj)
:where where
:order-by (order-by obj)
:limit (limit obj)))
(table-columns obj)
:where where
:order-by (order-by obj)
:limit (limit obj)))
(setf (queryid obj) (dbi:execute
(dbi:prepare
(database-connection (clog-database obj))
(last-sql obj)))))
(dbi:prepare
(database-connection (clog-database obj))
(last-sql obj)))))
(next-row obj panel))
(defgeneric next-row (clog-one-row panel)
@ -198,13 +198,13 @@ using DATA-LOAD-PLIST."))
(when (on-fetch obj)
(funcall (on-fetch obj) obj))
(setf (rowid obj) (data-load-plist panel
(last-fetch obj)
:row-id-name (row-id-name obj)))
(last-fetch obj)
:row-id-name (row-id-name obj)))
(if (rowid obj)
(dolist (slave (slaves obj))
(get-row slave panel))
(get-row slave panel))
(unless (slave-to-slot obj)
(clear-row obj panel)))
(clear-row obj panel)))
(rowid obj))
(defgeneric insert-row (clog-one-row panel)
@ -214,7 +214,7 @@ used to extract data from PANEL items and custom slots."))
(defmethod insert-row ((obj clog-one-row) panel)
(dbi:do-sql (database-connection (clog-database obj))
(sql-insert* (table-name obj)
(data-write-plist panel (table-columns obj)))))
(data-write-plist panel (table-columns obj)))))
(defgeneric update-row (clog-one-row panel)
(:documentation "Update row in database table based on
@ -224,8 +224,8 @@ on panel will be retrieved from PANEL using DATA-WRITE-PLIST."))
(defmethod update-row ((obj clog-one-row) panel)
(dbi:do-sql (database-connection (clog-database obj))
(sql-update (table-name obj)
(data-write-plist panel (table-columns obj))
(format nil "~A=~A" (row-id-name obj) (rowid obj)))))
(data-write-plist panel (table-columns obj))
(format nil "~A=~A" (row-id-name obj) (rowid obj)))))
(defgeneric delete-row (clog-one-row panel)
(:documentation "Delete a row from a database table based on
@ -233,9 +233,9 @@ current rowid and then call CLEAR-ROW"))
(defmethod delete-row ((obj clog-one-row) panel)
(dbi:do-sql (database-connection (clog-database obj))
(format nil "delete from ~A where ~A=~A"
(table-name obj)
(row-id-name obj)
(rowid obj)))
(table-name obj)
(row-id-name obj)
(rowid obj)))
(clear-row obj panel))
(defgeneric clear-row (clog-one-row panel)
@ -293,30 +293,30 @@ new-row will block until on-fetch returns."))
(:documentation "Create a new clog-lookup as child of CLOG-OBJ."))
(defmethod create-lookup ((obj clog-obj)
&key (clog-database nil)
(name nil)
(multiple nil)
(label nil)
(class nil)
(html-id nil))
&key (clog-database nil)
(name nil)
(multiple nil)
(label nil)
(class nil)
(html-id nil))
(let ((element (create-child
obj (format nil "<select~A~A~A/>"
(if multiple
" multiple"
"")
(if name
(format nil " name='~A'" name)
"")
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-lookup :html-id html-id :auto-place t)))
obj (format nil "<select~A~A~A/>"
(if multiple
" multiple"
"")
(if name
(format nil " name='~A'" name)
"")
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-lookup :html-id html-id :auto-place t)))
(when label
(label-for label element))
(if (and (typep obj 'clog-database) (not clog-database))
(setf (clog-database element) obj)
(setf (clog-database element) clog-database))
(setf (clog-database element) obj)
(setf (clog-database element) clog-database))
element))
(defmethod next-row ((obj clog-lookup) panel)
@ -332,20 +332,20 @@ the displayed option."
(setf (inner-html obj) "")
(loop
(let ((selected nil)
(row (dbi:fetch (queryid obj))))
(unless row
(return))
(when (on-fetch obj)
(funcall (on-fetch obj) obj))
(when (equal select-value (getf row (value-field obj)))
(setf selected t)
(setf (rowid obj) (data-load-plist panel
(last-fetch obj)
:row-id-name (row-id-name obj))))
(add-select-option obj
(getf row (value-field obj))
(getf row (option-field obj))
:selected selected))))
(row (dbi:fetch (queryid obj))))
(unless row
(return))
(when (on-fetch obj)
(funcall (on-fetch obj) obj))
(when (equal select-value (getf row (value-field obj)))
(setf selected t)
(setf (rowid obj) (data-load-plist panel
(last-fetch obj)
:row-id-name (row-id-name obj))))
(add-select-option obj
(getf row (value-field obj))
(getf row (option-field obj))
:selected selected))))
(dolist (slave (slaves obj))
(get-row slave panel))
(rowid obj))
@ -384,27 +384,27 @@ the displayed option."
;;;;;;;;;;;;;;;;;;;;;
(defgeneric create-db-table (clog-obj &key clog-database
hidden class html-id auto-place)
hidden class html-id auto-place)
(:documentation "Create a new clog-db-table as child of CLOG-OBJ."))
(defmethod create-db-table ((obj clog-obj)
&key (clog-database nil)
(hidden nil)
(class nil) (html-id nil) (auto-place t))
&key (clog-database nil)
(hidden nil)
(class nil) (html-id nil) (auto-place t))
(let ((element (create-child obj (format nil "<table~A~A/>"
(if hidden
" style='visibility:hidden;'"
"")
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-db-table
:html-id html-id
:auto-place auto-place)))
(if hidden
" style='visibility:hidden;'"
"")
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-db-table
:html-id html-id
:auto-place auto-place)))
(if (and (typep obj 'clog-database) (not clog-database))
(setf (clog-database element) obj)
(setf (clog-database element) clog-database))
(setf (clog-database element) obj)
(setf (clog-database element) clog-database))
element))
(defmethod next-row ((obj clog-db-table) panel)
@ -419,17 +419,17 @@ the displayed option."
(loop
(let ((row (dbi:fetch (queryid obj))))
(unless row
(return))
(return))
(when (on-fetch obj)
(funcall (on-fetch obj) obj))
(funcall (on-fetch obj) obj))
(let ((tr (create-table-row obj)))
(when (on-row obj)
(funcall (on-row obj) obj tr))
(loop for (key value) on row by #'cddr while value
do
(let ((td (create-table-column obj :content value)))
(when (on-column obj)
(funcall (on-column obj) obj key td)))))))
(when (on-row obj)
(funcall (on-row obj) obj tr))
(loop for (key value) on row by #'cddr while value
do
(let ((td (create-table-column obj :content value)))
(when (on-column obj)
(funcall (on-column obj) obj key td)))))))
(when (on-footer obj)
(funcall (on-footer obj) obj))
(dolist (slave (slaves obj))

10
source/clog-docs.lisp
View file

@ -25,7 +25,7 @@
(load "source/clog-style.lisp")
(load "source/clog-canvas.lisp")
(load "source/clog-form.lisp")
(load "source/clog-multimedia.lisp")
(load "source/clog-multimedia.lisp")
(load "source/clog-window.lisp")
(load "source/clog-document.lisp")
(load "source/clog-location.lisp")
@ -34,7 +34,7 @@
(load "source/clog-system.lisp")
(load "source/clog-panel.lisp")
(load "source/clog-gui.lisp")
(load "source/clog-web.lisp")
(load "source/clog-web.lisp")
(load "source/clog-docs.lisp")
(load "source/clog-helpers.lisp")
(load "source/clog-panel.lisp")
@ -86,7 +86,7 @@ frameworks and website frameworks. The CLOG package starts up the
connectivity to the browser or other websocket client (often a browser
embedded in a native template application.)
STATUS: CLOG is complete and all work is on higher order additions,
STATUS: CLOG is complete and all work is on higher order additions,
such as full desktop over the web, database tools,etc. See below for
some enhacements being worked on. CLOG is actually based on GNOGA, a
framework I wrote for Ada in 2013 and used in commercial production
@ -295,7 +295,7 @@ change the even hander, set-on-* function will need to be called.")
(defsection @clog-event-data (:title "CLOG Event Data")
"
Some events in CLOG return in addition to the target event, event data.
The data is passed in the second argument to the event handler as a
The data is passed in the second argument to the event handler as a
property list. To retrieve the data use (getf data :property) the available
properties (to use for :property) are based on the event type.
@ -410,7 +410,7 @@ keyboard-event-script:
(when handler
(lambda (data)
(funcall handler obj (parse-keyboard-event data))))
:call-back-script keyboard-event-script))
:call-back-script keyboard-event-script))
```
* The script

28
source/clog-document.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-document.lisp ;;;;
@ -31,12 +31,12 @@
"Construct a new clog-document. (Private)"
(make-instance
'clog-document :connection-id connection-id :html-id "document"
:document-element (make-instance 'clog-element
:connection-id connection-id
:html-id "documentElement")
:head-element (make-instance 'clog-element
:connection-id connection-id
:html-id "head")))
:document-element (make-instance 'clog-element
:connection-id connection-id
:html-id "documentElement")
:head-element (make-instance 'clog-element
:connection-id connection-id
:html-id "head")))
;;;;;;;;;;;;;;;;;;;;;;
;; document-element ;;
;;;;;;;;;;;;;;;;;;;;;;
@ -120,10 +120,10 @@ clog-document object. (Private)"))
(query obj "title"))
(defgeneric set-title (clog-document value))
(defmethod set-title ((obj clog-document) value)
(execute obj
(format nil "title='~A'" (clog-connection:escape-string value)))
(format nil "title='~A'" (clog-connection:escape-string value)))
value)
(defsetf title set-title)
@ -156,8 +156,8 @@ clog-document object. (Private)"))
(defmethod load-css ((obj clog-document) css-url)
(jquery-execute (head-element obj)
(format nil "append('<link rel=\"stylesheet\" href=\"~A\" type=\"text/css\">')"
(escape-string css-url))))
(format nil "append('<link rel=\"stylesheet\" href=\"~A\" type=\"text/css\">')"
(escape-string css-url))))
;;;;;;;;;;;;;;;;;
;; load-script ;;
@ -168,8 +168,8 @@ clog-document object. (Private)"))
(defmethod load-script ((obj clog-document) script-url)
(jquery-execute (head-element obj)
(format nil "append('<script src=\"~A\">')"
(escape-string script-url))))
(format nil "append('<script src=\"~A\">')"
(escape-string script-url))))
;;;;;;;;;
;; put ;;
@ -216,7 +216,7 @@ clog-document object. (Private)"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-full-screen-change (clog-document
on-full-screen-change-handler)
on-full-screen-change-handler)
(:documentation "Set the ON-FULL-SCREEN-CHANGE-HANDLER for CLOG-OBJ.
If ON-FULL-SCREEN-CHANGE-HANDLER is nil unbind the event."))

1004
source/clog-element-common.lisp
View file

File diff suppressed because it is too large Load diff

140
source/clog-element.lisp
View file

@ -31,7 +31,7 @@ element objects."))
;;;;;;;;;;;;;;;;;;;;;;
(defun create-with-html (connection-id html
&key (clog-type 'clog-element) (html-id nil))
&key (clog-type 'clog-element) (html-id nil))
"Create a new clog-element and attach it to HTML on
CONNECTION-ID. There must be a single outer block that will be set to
an internal id. The returned CLOG-Element requires placement or will
@ -39,13 +39,13 @@ not be visible, ie. place-after, etc. as it exists in the javascript
clog[] but is not in the DOM. If HTML-ID is nil one is generated.
(private)"
(let ((web-id (if html-id
html-id
(format nil "CLOG~A" (clog-connection:generate-id)))))
html-id
(format nil "CLOG~A" (clog-connection:generate-id)))))
(clog-connection:execute
connection-id
(format nil
"clog['~A']=$(\"~A\").get(0); $(clog['~A']).first().prop('id','~A')"
web-id html web-id web-id))
"clog['~A']=$(\"~A\").get(0); $(clog['~A']).first().prop('id','~A')"
web-id html web-id web-id))
(make-clog-element connection-id web-id :clog-type clog-type)))
;;;;;;;;;;;;
@ -56,7 +56,7 @@ clog[] but is not in the DOM. If HTML-ID is nil one is generated.
"Create a new clog-obj and attach an existing element with HTML-ID on
CONNECTION-ID to it and then return it. The HTML-ID must be unique. (private)"
(clog-connection:execute connection-id
(format nil "clog['~A']=$('#~A').get(0)" html-id html-id))
(format nil "clog['~A']=$('#~A').get(0)" html-id html-id))
(make-clog-element connection-id html-id))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -73,14 +73,14 @@ as child of CLOG-OBJ and if :AUTO-PLACE (default t) place-inside-bottom-of
CLOG-OBJ. If HTML-ID is nil one will be generated."))
(defmethod create-child ((obj clog-obj) html &key (html-id nil)
(auto-place t)
(clog-type 'clog-element))
(auto-place t)
(clog-type 'clog-element))
(let ((child (create-with-html (connection-id obj) (escape-string html)
:clog-type clog-type
:html-id html-id)))
:clog-type clog-type
:html-id html-id)))
(if auto-place
(place-inside-bottom-of obj child)
child)))
(place-inside-bottom-of obj child)
child)))
;;;;;;;;;;;;;;;;;;;;;
;; attach-as-child ;;
@ -93,17 +93,17 @@ must be in DOM, ie placed or auto-placed. If new-id is true the HTML-ID
after attachment is changed to one unique to this session."))
(defmethod attach-as-child ((obj clog-obj) html-id
&key (clog-type 'clog-element)
(new-id nil))
&key (clog-type 'clog-element)
(new-id nil))
(if new-id
(let ((id (format nil "CLOG~A" (clog-connection:generate-id))))
(clog-connection:execute (connection-id obj)
(format nil "$('#~A').attr('id','~A');clog['~A']=$('#~A').get(0)"
html-id id id id))
(setf html-id id))
(clog-connection:execute (connection-id obj)
(format nil "$('#~A').attr('id','~A');clog['~A']=$('#~A').get(0)"
html-id id id id))
(setf html-id id))
(clog-connection:execute (connection-id obj)
(format nil "clog['~A']=$('#~A').get(0)"
html-id html-id)))
(format nil "clog['~A']=$('#~A').get(0)"
html-id html-id)))
(make-clog-element (connection-id obj) html-id :clog-type clog-type))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -118,16 +118,16 @@ after attachment is changed to one unique to this session."))
(:documentation "Get/Setf css style."))
(defmethod style ((obj clog-element) style-name
&key (default-answer nil))
&key (default-answer nil))
(jquery-query obj (format nil "css('~A')" style-name)
:default-answer default-answer))
:default-answer default-answer))
(defgeneric set-style (clog-element style-name value)
(:documentation "Set css style."))
(defmethod set-style ((obj clog-element) style-name value)
(jquery-execute obj (format nil "css('~A','~A')"
style-name (escape-string value)))
style-name (escape-string value)))
value)
(defsetf style set-style)
@ -136,13 +136,13 @@ after attachment is changed to one unique to this session."))
(defmethod set-styles ((obj clog-element) style-list)
(jquery-execute obj (format nil "css({~{~A~^,~}})"
(remove nil (mapcar
(lambda (n)
(when n
(format nil "'~A':'~A'"
(first n)
(second n))))
style-list)))))
(remove nil (mapcar
(lambda (n)
(when n
(format nil "'~A':'~A'"
(first n)
(second n))))
style-list)))))
;;;;;;;;;;;;;;;
;; attribute ;;
@ -152,9 +152,9 @@ after attachment is changed to one unique to this session."))
(:documentation "Get/Setf html tag attribute. (eg. src on img tag)"))
(defmethod attribute ((obj clog-element) attribute-name
&key (default-answer nil))
&key (default-answer nil))
(jquery-query obj (format nil "attr('~A')" attribute-name)
:default-answer default-answer))
:default-answer default-answer))
(defgeneric remove-attribute (clog-element attribute-name)
(:documentation "Remove html tag attribute. (eg. src on img tag)"))
@ -168,7 +168,7 @@ after attachment is changed to one unique to this session."))
(defmethod set-attribute ((obj clog-element) attribute-name value)
(jquery-execute obj (format nil "attr('~A','~A')"
attribute-name (escape-string value)))
attribute-name (escape-string value)))
value)
(defsetf attribute set-attribute)
@ -233,7 +233,7 @@ after attachment is changed to one unique to this session."))
[special key] + Access_Key
The [special key] per browser and platform is:
Browser Windows Linux Mac
----------------- ------- ----- ---
Internet Explorer [Alt] N/A N/A
@ -488,7 +488,7 @@ Additionally for forms get/setf the value."))
(defmethod set-text-value ((obj clog-element) value)
(jquery-execute obj (format nil "contents().not(~A.children()).get(0).nodeValue='~A'"
(jquery obj) value)))
(jquery obj) value)))
(defsetf text-value set-text)
@ -780,27 +780,27 @@ elements wrap around it."))
;;;;;;;;;;;;;
(deftype display-type () '(member :none :block :inline :inline-block :flex
:grid :inline-grid))
:grid :inline-grid))
(defgeneric display (clog-element)
(:documentation "Get/Setf display. Display sets the CSS Display property that
handles how elements are treated by the browser layout engine.
Common Values:
none - Remove Element from layout but remain in the DOM this is
similar to hiddenp, but not like visiblep that makes the
element not visible but still take up space in layout.
block - Displays an element starting on a new line and stretches
out to the left and right as far as it can. e.g. <div> by
default
inline - Wraps with text in a paragraph. e.g. <span> by default
inline-block - Flows with paragraph but will always fill from left to
right.
flex - Turn this item in to a flexbox container. The flexbox
properties for container to adjust are:
@ -894,7 +894,7 @@ and basis"))
flex-basis (default :auto = use width or height) for CLOG-ELEMENT"))
(defmethod set-flex ((obj clog-element)
&key (grow 0) (shrink 1) (flex-basis :auto))
&key (grow 0) (shrink 1) (flex-basis :auto))
(setf (style obj "flex") (format nil "~A ~A ~A" grow shrink flex-basis)))
@ -1453,24 +1453,24 @@ in UNITS (default :px)"))
(defmethod set-geometry ((obj clog-element) &key left top right bottom width height (units :px))
(jquery-execute obj (format nil "css({~A~A~A~A~A~A})"
(if left
(format nil "'left':'~A~A'," left units)
"")
(if top
(format nil "'top':'~A~A'," top units)
"")
(if right
(format nil "'right':'~A~A'," right units)
"")
(if bottom
(format nil "'bottom':'~A~A'," bottom units)
"")
(if width
(format nil "'width':'~A~A'," width units)
"")
(if height
(format nil "'height':'~A~A'," height units)
""))))
(if left
(format nil "'left':'~A~A'," left units)
"")
(if top
(format nil "'top':'~A~A'," top units)
"")
(if right
(format nil "'right':'~A~A'," right units)
"")
(if bottom
(format nil "'bottom':'~A~A'," bottom units)
"")
(if width
(format nil "'width':'~A~A'," width units)
"")
(if height
(format nil "'height':'~A~A'," height units)
""))))
;;;;;;;;;;
;; left ;;
@ -1901,7 +1901,7 @@ is relative to origin of: padding-box|border-box|content-box"))
(deftype background-clip-type ()
'(member :border-box :padding-box :content-box :text))
(defgeneric background-clip (clog-element)
(:documentation "Get/Setf background-clip. If an element's background extends
underneath its border box, padding box, or content box."))
@ -1958,7 +1958,7 @@ line-width - size or medium|thin|thick|length|initial|inherit"))
(defmethod set-border ((obj clog-element) line-width border-style line-color)
(setf (style obj "border") (format nil "~A ~A ~A"
line-width border-style line-color)))
line-width border-style line-color)))
;;;;;;;;;;;;;;;;;;;
;; border-radius ;;
@ -2019,7 +2019,7 @@ line-width - size or medium|thin|thick|length|initial|inherit"))
'(member :none :hidden :dotted :dashed :solid :double
:groove :ridge :inset :outset))
(defgeneric outline (clog-element)
(defgeneric outline (clog-element)
(:documentation "Get outline. <line-color> <outline-style> <line-width>"))
(defmethod outline ((obj clog-element))
@ -2035,7 +2035,7 @@ line-width - size or medium|thin|thick|length|initial|inherit"))
(defmethod set-outline ((obj clog-element) line-color outline-style line-width)
(setf (style obj "outline") (format nil "~A ~A ~A"
line-color outline-style line-width)))
line-color outline-style line-width)))
;;;;;;;;;;;;
;; margin ;;
@ -2084,7 +2084,7 @@ VALUE can be - <length>|auto|initial|inherit"))
(defmethod set-padding ((obj clog-element) top right bottom left)
(setf (style obj "padding") (format nil "~A ~A ~A ~A"
top right bottom left)))
top right bottom left)))
(defsetf padding set-padding)
;;;;;;;;;;;;;;;;;;;;;;
@ -2144,8 +2144,8 @@ A list of standard cursor types can be found at:
((obj clog-element)
font-style font-variant font-weight font-height font-family)
(setf (style obj "font")
(format nil "~A ~A ~A ~A ~A"
font-style font-variant font-weight font-height font-family)))
(format nil "~A ~A ~A ~A ~A"
font-style font-variant font-weight font-height font-family)))
(defgeneric set-font-css (clog-element value)
(:documentation "Set font VALUE for CLOG-ELEMENT"))
@ -2208,7 +2208,7 @@ is set to :table-cell or for labels on form elements."))
(defmethod add-class ((obj clog-element) css-class-name)
(jquery-execute obj (format nil "addClass('~A')"
(escape-string css-class-name))))
(escape-string css-class-name))))
;;;;;;;;;;;;;;;;;;
;; remove-class ;;
@ -2219,7 +2219,7 @@ is set to :table-cell or for labels on form elements."))
(defmethod remove-class ((obj clog-element) css-class-name)
(jquery-execute obj (format nil "removeClass('~A')"
(escape-string css-class-name))))
(escape-string css-class-name))))
;;;;;;;;;;;;;;;;;;
;; toggle-class ;;
@ -2230,7 +2230,7 @@ is set to :table-cell or for labels on form elements."))
(defmethod toggle-class ((obj clog-element) css-class-name)
(jquery-execute obj (format nil "toggleClass('~A')"
(escape-string css-class-name))))
(escape-string css-class-name))))
;;;;;;;;;;;;;;;;;;;;;
;; remove-from-dom ;;

334
source/clog-form.lisp
View file

@ -61,8 +61,8 @@ never be GC'd. File upload items will be a four part list
(deftype form-method-type () '(members :get :post :none))
(defgeneric create-form (clog-obj
&key action method target encoding
class html-id auto-place)
&key action method target encoding
class html-id auto-place)
(:documentation "Create a new CLOG-Form as child of CLOG-OBJ that organizes
a collection of form elements in to a single form if :AUTO-PLACE (default t)
place-inside-bottom-of CLOG-OBJ. In CLOG a form's on-submit handler should be
@ -74,26 +74,26 @@ action. The default :ENCODING is application/x-www-form-urlencoded if
doing file upload use multipart/form-data"))
(defmethod create-form ((obj clog-obj)
&key (action "#")
(method :none)
(target "_self")
(encoding "application/x-www-form-urlencoded")
(class nil)
(html-id nil)
(auto-place t))
&key (action "#")
(method :none)
(target "_self")
(encoding "application/x-www-form-urlencoded")
(class nil)
(html-id nil)
(auto-place t))
(create-child obj
(format nil "<form action='~A' ~A enctype='~A' target='~A'~A/>"
action
(if (eq method :none)
"onSubmit='return false;'"
(format nil "method='~A'" method))
encoding
target
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-form :html-id html-id :auto-place auto-place))
(format nil "<form action='~A' ~A enctype='~A' target='~A'~A/>"
action
(if (eq method :none)
"onSubmit='return false;'"
(format nil "method='~A'" method))
encoding
target
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-form :html-id html-id :auto-place auto-place))
;;;;;;;;;;;;;;;;;;;;;;;;
;; form-element-count ;;
@ -201,38 +201,38 @@ elements."))
:reset :search :submit :tel :text :time :url :week))
(defgeneric create-form-element (clog-obj element-type
&key name value label class
hidden html-id)
&key name value label class
hidden html-id)
(:documentation "Create a new clog-form-element as child of CLOG-OBJ.
It is importamt that clog-form-elements are a child or descendant of a
clog-form in the DOM. The radio ELEMENT-TYPE groups by NAME."))
(defmethod create-form-element ((obj clog-obj) element-type
&key (name nil)
(value nil)
(label nil)
(class nil)
(hidden nil)
(html-id nil))
&key (name nil)
(value nil)
(label nil)
(class nil)
(hidden nil)
(html-id nil))
(let ((element (create-child
obj (format nil "<input type='~A'~A~A~A~A/>"
(escape-string element-type)
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if hidden
" style='visibility:hidden;'"
"")
(if value
(format nil " value='~A'" value)
"")
(if name
(format nil " name='~A'" name)
""))
:clog-type 'clog-form-element
:html-id html-id
:auto-place t)))
obj (format nil "<input type='~A'~A~A~A~A/>"
(escape-string element-type)
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if hidden
" style='visibility:hidden;'"
"")
(if value
(format nil " value='~A'" value)
"")
(if name
(format nil " name='~A'" name)
""))
:clog-type 'clog-form-element
:html-id html-id
:auto-place t)))
(when label
(label-for label element))
element))
@ -447,8 +447,8 @@ group called NAME."))
(defmethod radio-value ((obj clog-obj) name)
(clog-connection:query (connection-id obj)
(format nil "$('input:radio[name=~A]:checked').val()"
name)))
(format nil "$('input:radio[name=~A]:checked').val()"
name)))
;;;;;;;;;;;;;;;;;;;;
;; checkbox-value ;;
@ -459,8 +459,8 @@ group called NAME."))
(defmethod checkbox-value ((obj clog-obj) name)
(js-on-p (clog-connection:query (connection-id obj)
(format nil "$('input:checkbox[name=~A]:checked').val()"
name))))
(format nil "$('input:checkbox[name=~A]:checked').val()"
name))))
;;;;;;;;;;;;;;;;;;
;; select-value ;;
@ -472,7 +472,7 @@ be unique name on entire document."))
(defmethod select-value ((obj clog-obj) name)
(clog-connection:query (connection-id obj)
(format nil "$('select[name=~A] option:selected').val()" name)))
(format nil "$('select[name=~A] option:selected').val()" name)))
;;;;;;;;;;;;;;;;
;; name-value ;;
@ -484,7 +484,7 @@ be unique name on entire document."))
(defmethod name-value ((obj clog-obj) name)
(clog-connection:query (connection-id obj)
(format nil "$('input[name=~A]').val()" name)))
(format nil "$('input[name=~A]').val()" name)))
;;;;;;;;;;;;;
;; pattern ;;
@ -750,19 +750,19 @@ virtual keyboards."))
(:documentation "Create a new clog-label as child of CLOG-OBJ."))
(defmethod create-label ((obj clog-obj) &key (content "")
(label-for nil)
(class nil)
(html-id nil))
(label-for nil)
(class nil)
(html-id nil))
(create-child obj (format nil "<label for='~A'~A>~A</label>"
(if label-for
(html-id label-for)
"")
(if class
(format nil " class='~A'"
(escape-string class))
"")
(escape-string content))
:clog-type 'clog-label :html-id html-id :auto-place t))
(if label-for
(html-id label-for)
"")
(if class
(format nil " class='~A'"
(escape-string class))
"")
(escape-string content))
:clog-type 'clog-label :html-id html-id :auto-place t))
;;;;;;;;;;;;;;;
;; label-for ;;
@ -789,17 +789,17 @@ virtual keyboards."))
(:documentation "Create a new clog-fieldset as child of CLOG-OBJ."))
(defmethod create-fieldset ((obj clog-obj) &key (legend nil)
(class nil)
(html-id nil))
(class nil)
(html-id nil))
(create-child obj (format nil "<fieldset~A>~A</fieldset>"
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if legend
(format nil "<legend>~A</legend>" legend)
""))
:clog-type 'clog-fieldset :html-id html-id :auto-place t))
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if legend
(format nil "<legend>~A</legend>" legend)
""))
:clog-type 'clog-fieldset :html-id html-id :auto-place t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-text-area
@ -813,27 +813,27 @@ virtual keyboards."))
;;;;;;;;;;;;;;;;;;;;;;
(defgeneric create-text-area (clog-obj
&key columns rows name value label class html-id)
&key columns rows name value label class html-id)
(:documentation "Create a new clog-text-area as child of CLOG-OBJ."))
(defmethod create-text-area ((obj clog-obj)
&key (columns 20)
(rows 2)
(name "")
(value "")
(label nil)
(class nil)
(html-id nil))
&key (columns 20)
(rows 2)
(name "")
(value "")
(label nil)
(class nil)
(html-id nil))
(let ((element
(create-child obj
(format nil "<textarea name='~A' cols='~A' rows='~A'~A>~A</textarea>"
name columns rows
(if class
(format nil " class='~A'"
(escape-string class))
"")
(escape-string value))
:clog-type 'clog-text-area :html-id html-id :auto-place t)))
(create-child obj
(format nil "<textarea name='~A' cols='~A' rows='~A'~A>~A</textarea>"
name columns rows
(if class
(format nil " class='~A'"
(escape-string class))
"")
(escape-string value))
:clog-type 'clog-text-area :html-id html-id :auto-place t)))
(when label
(label-for label element))
@ -932,15 +932,15 @@ virtual keyboards."))
(:documentation "Create a new clog-legend as child of CLOG-OBJ."))
(defmethod create-legend ((obj clog-obj) &key (content "")
(class nil)
(html-id nil))
(class nil)
(html-id nil))
(create-child obj (format nil "<legend~A>~A</legend>"
(if class
(format nil " class='~A'"
(escape-string class))
"")
content)
:clog-type 'clog-legend :html-id html-id :auto-place t))
(if class
(format nil " class='~A'"
(escape-string class))
"")
content)
:clog-type 'clog-legend :html-id html-id :auto-place t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-data-list
@ -959,9 +959,9 @@ optionally fill in with contents of data-list."))
(defmethod create-data-list ((obj clog-obj) &key (data-list nil) (html-id nil))
(let ((element (create-child obj "<datalist />"
:clog-type 'clog-data-list
:html-id html-id
:auto-place t)))
:clog-type 'clog-data-list
:html-id html-id
:auto-place t)))
(when data-list
(add-options element data-list))
element))
@ -975,7 +975,7 @@ optionally fill in with contents of data-list."))
(defmethod add-option ((obj clog-data-list) value)
(create-child obj (format nil "<option value='~A'>" (escape-string value))
:clog-type 'clog-element :auto-place t))
:clog-type 'clog-element :auto-place t))
;;;;;;;;;;;;;;;;;
;; add-options ;;
@ -1003,24 +1003,24 @@ optionally fill in with contents of data-list."))
(:documentation "Create a new clog-select as child of CLOG-OBJ."))
(defmethod create-select ((obj clog-obj)
&key (name nil)
(multiple nil)
(label nil)
(class nil)
(html-id nil))
&key (name nil)
(multiple nil)
(label nil)
(class nil)
(html-id nil))
(let ((element (create-child
obj (format nil "<select~A~A~A/>"
(if multiple
" multiple"
"")
(if name
(format nil " name='~A'" name)
"")
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-select :html-id html-id :auto-place t)))
obj (format nil "<select~A~A~A/>"
(if multiple
" multiple"
"")
(if name
(format nil " name='~A'" name)
"")
(if class
(format nil " class='~A'"
(escape-string class))
""))
:clog-type 'clog-select :html-id html-id :auto-place t)))
(when label
(label-for label element))
element))
@ -1034,15 +1034,15 @@ optionally fill in with contents of data-list."))
(defmethod add-select-option ((obj clog-select) value content &key selected disabled)
(create-child obj (format nil "<option~A~A value='~A'>~A</option>"
(if selected
" selected"
"")
(if disabled
" disabled"
"")
(escape-string value)
(escape-string content))
:clog-type 'clog-element :auto-place t))
(if selected
" selected"
"")
(if disabled
" disabled"
"")
(escape-string value)
(escape-string content))
:clog-type 'clog-element :auto-place t))
;;;;;;;;;;;;;;;;;;;;;;;;
;; add-select-options ;;
@ -1064,8 +1064,8 @@ optionally fill in with contents of data-list."))
(defmethod add-select-optgroup ((obj clog-select) content)
(create-child obj (format nil "<optgroup label='~A'/>"
(escape-string content))
:clog-type 'clog-element :auto-place t))
(escape-string content))
:clog-type 'clog-element :auto-place t))
;;;;;;;;;;;;;;;;;
;; select-text ;;
@ -1076,7 +1076,7 @@ optionally fill in with contents of data-list."))
(defmethod select-text ((obj clog-obj))
(clog-connection:query (connection-id obj)
(format nil "$('#~A option:selected').text()" (html-id obj))))
(format nil "$('#~A option:selected').text()" (html-id obj))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-option
@ -1091,32 +1091,32 @@ or CLOG Data-List objects."));
;;;;;;;;;;;;;;;;;;;
(defgeneric create-option (clog-obj
&key content value selected disabled class html-id)
&key content value selected disabled class html-id)
(:documentation "Create a new clog-option as child of CLOG-OBJ."))
(defmethod create-option ((obj clog-obj) &key
(content "")
(value nil)
(selected nil)
(disabled nil)
(class nil)
(html-id nil))
(content "")
(value nil)
(selected nil)
(disabled nil)
(class nil)
(html-id nil))
(create-child obj (format nil "<option~A~A~A~A>~A</option>"
(if selected
" selected"
"")
(if disabled
" disabled"
"")
(if value
(format nil " value='~A'" value)
"")
(if class
(format nil " class='~A'"
(escape-string class))
"")
content)
:clog-type 'clog-option :html-id html-id :auto-place t))
(if selected
" selected"
"")
(if disabled
" disabled"
"")
(if value
(format nil " value='~A'" value)
"")
(if class
(format nil " class='~A'"
(escape-string class))
"")
content)
:clog-type 'clog-option :html-id html-id :auto-place t))
;;;;;;;;;;;;;;;
;; selectedp ;;
@ -1150,16 +1150,16 @@ or CLOG Data-List objects."));
(:documentation "Create a new clog-optgroup as child of CLOG-OBJ."))
(defmethod create-optgroup ((obj clog-obj) &key (content "")
(disabled nil)
(class nil)
(html-id nil))
(disabled nil)
(class nil)
(html-id nil))
(create-child obj (format nil "<optgroup label='~A'~A~A/>"
content
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if disabled
" disabled"
""))
:clog-type 'clog-optgroup :html-id html-id :auto-place t))
content
(if class
(format nil " class='~A'"
(escape-string class))
"")
(if disabled
" disabled"
""))
:clog-type 'clog-optgroup :html-id html-id :auto-place t))

1106
source/clog-gui.lisp
View file

File diff suppressed because it is too large Load diff

50
source/clog-helpers.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-helpers.lisp ;;;;
@ -38,9 +38,9 @@
(defun open-manual ()
"Launches a browser with CLOG manual."
(open-browser :url (format nil "~A"
(merge-pathnames "./doc/clog-manual.html"
(asdf:system-source-directory :clog)))))
(merge-pathnames "./doc/clog-manual.html"
(asdf:system-source-directory :clog)))))
;;;;;;;;;;;;;;;;;;
;; run-tutorial ;;
;;;;;;;;;;;;;;;;;;
@ -49,8 +49,8 @@
"Run tutorial NUM"
(load-tutorial num)
(funcall (symbol-function (find-symbol
"START-TUTORIAL"
(format nil "CLOG-TUT-~A" num)))))
"START-TUTORIAL"
(format nil "CLOG-TUT-~A" num)))))
;;;;;;;;;;;;;;;;;;;
;; load-tutorial ;;
@ -59,7 +59,7 @@
(defun load-tutorial (num)
"Load tutorial NUM - use (clog-user:start-tutorial)"
(let ((p (merge-pathnames (format nil "./tutorial/~2,'0d-tutorial.lisp" num)
(asdf:system-source-directory :clog))))
(asdf:system-source-directory :clog))))
(load p)
(format t "~%~% ---- The tutorial src is located at: ~A~%" p)))
@ -71,8 +71,8 @@
"Run demo NUM"
(load-demo num)
(funcall (symbol-function (find-symbol
"START-DEMO"
(format nil "CLOG-DEMO-~A" num)))))
"START-DEMO"
(format nil "CLOG-DEMO-~A" num)))))
;;;;;;;;;;;;;;;
;; load-demo ;;
@ -81,7 +81,7 @@
(defun load-demo (num)
"Load demo NUM - use (clog-user:start-demo)"
(let ((p (merge-pathnames (format nil "./demos/~2,'0d-demo.lisp" num)
(asdf:system-source-directory :clog))))
(asdf:system-source-directory :clog))))
(load p)
(format t "~%~% ---- The demo src is located at: ~A~%" p)))
@ -96,13 +96,13 @@ set (logging to browser console), "
(unless *clog-running*
(initialize nil :boot-file "/debug.html"))
(set-on-new-window (lambda (body)
(clog-connection:debug-mode (connection-id body))
(when clog-web-initialize
(clog-web:clog-web-initialize body))
(when clog-gui-initialize
(clog-gui:clog-gui-initialize body))
(setf clog-user::*body* body))
:path "/repl")
(clog-connection:debug-mode (connection-id body))
(when clog-web-initialize
(clog-web:clog-web-initialize body))
(when clog-gui-initialize
(clog-gui:clog-gui-initialize body))
(setf clog-user::*body* body))
:path "/repl")
(open-browser :url "http://127.0.0.1:8080/repl")
(format t "Use clog-user:*body* to access the clog-repl window."))
@ -111,14 +111,14 @@ set (logging to browser console), "
;;;;;;;;;;;;;;;;;;;;;;;
(defun save-body-to-file (file-name &key (body clog-user::*body*)
(if-exists :error)
if-does-not-exist
external-format)
(if-exists :error)
if-does-not-exist
external-format)
"Save the current html of BODY in the current state to FILE-NAME"
(when (alexandria:write-string-into-file
(outer-html (document-element (html-document body)))
file-name
:if-exists if-exists
:if-does-not-exist if-does-not-exist
:external-format external-format)
(outer-html (document-element (html-document body)))
file-name
:if-exists if-exists
:if-does-not-exist if-does-not-exist
:external-format external-format)
t))

9
source/clog-jquery.lisp
View file

@ -3,7 +3,7 @@
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-jquery.lisp ;;;;
;;;; clog-jquery.lisp ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cl:in-package :clog)
@ -36,8 +36,8 @@ Some sample jquery selectors:
(clog-connection:execute
(connection-id obj)
(format nil
"clog['~A']=$(\"~A\")"
html-id jquery))
"clog['~A']=$(\"~A\")"
html-id jquery))
(make-clog-element (connection-id obj) html-id :clog-type 'clog-jquery)))
;;;;;;;;;;;;
@ -71,5 +71,4 @@ result or DEFAULT-ANSWER on time out."))
(defmethod jquery-query ((obj clog-obj) method &key (default-answer nil))
(js-query obj (format nil "~A.~A" (jquery obj) method)
:default-answer default-answer))
:default-answer default-answer))

2
source/clog-location.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-location.lisp ;;;;

346
source/clog-multimedia.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-mulitmedia.lisp ;;;;
@ -8,7 +8,6 @@
(cl:in-package :clog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-multimedia
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -226,7 +225,7 @@ media type.
audio/ogg
audio/mp4
audio/mp3
Common values, including codecs:
video/ogg; codecs=\"theora, vorbis\"
video/mp4; codecs=\"avc1.4D401E, mp4a.40.2\"
@ -252,10 +251,10 @@ is nil unbind the event."))
(defmethod set-on-media-abort ((obj clog-multimedia) handler)
(set-event obj "abort"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-media-error ;;
@ -267,10 +266,10 @@ is nil unbind the event."))
(defmethod set-on-media-error ((obj clog-multimedia) handler)
(set-event obj "error"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;
;; set-on-can-play ;;
@ -282,10 +281,10 @@ is nil unbind the event."))
(defmethod set-on-can-play ((obj clog-multimedia) handler)
(set-event obj "canplay"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-can-play-through ;;
@ -297,10 +296,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-can-play-through ((obj clog-multimedia) handler)
(set-event obj "canplaythrough"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-duration-change ;;
@ -312,10 +311,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-duration-change ((obj clog-multimedia) handler)
(set-event obj "durationchange"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;
;; set-on-emptied ;;
@ -327,10 +326,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-emptied ((obj clog-multimedia) handler)
(set-event obj "emptied"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;
;; set-on-ended ;;
@ -342,10 +341,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-ended ((obj clog-multimedia) handler)
(set-event obj "ended"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-loaded-data ;;
@ -357,10 +356,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-loaded-data ((obj clog-multimedia) handler)
(set-event obj "loadeddata"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-loaded-meta-data ;;
@ -372,10 +371,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-loaded-meta-data ((obj clog-multimedia) handler)
(set-event obj "loadedmetadata"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-load-start ;;
@ -387,10 +386,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-load-start ((obj clog-multimedia) handler)
(set-event obj "loadstart"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;
;; set-on-play ;;
@ -402,10 +401,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-play ((obj clog-multimedia) handler)
(set-event obj "play"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;
;; set-on-pause ;;
@ -417,10 +416,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-pause ((obj clog-multimedia) handler)
(set-event obj "pause"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;
;; set-on-playing ;;
@ -432,10 +431,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-playing ((obj clog-multimedia) handler)
(set-event obj "playing"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;
;; set-on-progress ;;
@ -447,10 +446,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-progress ((obj clog-multimedia) handler)
(set-event obj "progress"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-rate-change ;;
@ -462,10 +461,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-rate-change ((obj clog-multimedia) handler)
(set-event obj "ratechange"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;
;; set-on-seeked ;;
@ -477,10 +476,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-seeked ((obj clog-multimedia) handler)
(set-event obj "seeked"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;
;; set-on-seeking ;;
@ -492,10 +491,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-seeking ((obj clog-multimedia) handler)
(set-event obj "seeking"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;
;; set-on-stalled ;;
@ -507,10 +506,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-stalled ((obj clog-multimedia) handler)
(set-event obj "stalled"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;
;; set-on-suspend ;;
@ -522,10 +521,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-suspend ((obj clog-multimedia) handler)
(set-event obj "suspend"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-time-update ;;
@ -537,10 +536,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-time-update ((obj clog-multimedia) handler)
(set-event obj "timeupdate"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-volume-change ;;
@ -552,10 +551,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-volume-change ((obj clog-multimedia) handler)
(set-event obj "volumechange"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;
;; set-on-waiting ;;
@ -567,10 +566,10 @@ HANDLER is nil unbind the event."))
(defmethod set-on-waiting ((obj clog-multimedia) handler)
(set-event obj "waiting"
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
(when handler
(lambda (data)
(declare (ignore data))
(funcall handler obj)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-audio
@ -584,48 +583,48 @@ HANDLER is nil unbind the event."))
;;;;;;;;;;;;;;;;;;
(defgeneric create-audio (clog-obj &key
source
controls
preload
autoplay
autoloop
muted
html-id
auto-place)
source
controls
preload
autoplay
autoloop
muted
html-id
auto-place)
(:documentation "Create a CLOG Audio control"))
(defmethod create-audio ((obj clog-obj)
&key (source "")
(controls t)
(preload nil)
(autoplay nil)
(autoloop nil)
(muted nil)
(html-id nil)
(auto-place t))
&key (source "")
(controls t)
(preload nil)
(autoplay nil)
(autoloop nil)
(muted nil)
(html-id nil)
(auto-place t))
(create-child obj (format nil "<audio~A~A~A~A~A~A/>"
(if (equal source "")
""
(format nil " src='~A'"
(escape-string source)))
(if controls
" controls"
"")
(if preload
" preload='auto'"
"")
(if autoplay
" autoplay"
"")
(if autoloop
" loop"
"")
(if muted
" muted"
""))
:clog-type 'clog-audio
:html-id html-id
:auto-place auto-place))
(if (equal source "")
""
(format nil " src='~A'"
(escape-string source)))
(if controls
" controls"
"")
(if preload
" preload='auto'"
"")
(if autoplay
" autoplay"
"")
(if autoloop
" loop"
"")
(if muted
" muted"
""))
:clog-type 'clog-audio
:html-id html-id
:auto-place auto-place))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -636,52 +635,51 @@ HANDLER is nil unbind the event."))
(:documentation "CLOG Video class."))
(defgeneric create-video (clog-obj &key
source
controls
preload
poster
autoplay
autoloop
muted
html-id
auto-place)
source
controls
preload
poster
autoplay
autoloop
muted
html-id
auto-place)
(:documentation "Create a CLOG video control"))
(defmethod create-video ((obj clog-obj)
&key (source "")
(controls t)
(preload nil)
(poster "")
(autoplay nil)
(autoloop nil)
(muted nil)
(html-id nil)
(auto-place t))
&key (source "")
(controls t)
(preload nil)
(poster "")
(autoplay nil)
(autoloop nil)
(muted nil)
(html-id nil)
(auto-place t))
(create-child obj (format nil "<video~A~A~A~A~A~A~A/>"
(if (equal source "")
""
(format nil " src='~A'"
(escape-string source)))
(if controls
" controls"
"")
(if preload
" preload='auto'"
"")
(if (equal poster "")
""
(format nil " poster='~A'"
(escape-string poster)))
(if autoplay
" autoplay"
"")
(if autoloop
" loop"
"")
(if muted
" muted"
""))
:clog-type 'clog-video
:html-id html-id
:auto-place auto-place))
(if (equal source "")
""
(format nil " src='~A'"
(escape-string source)))
(if controls
" controls"
"")
(if preload
" preload='auto'"
"")
(if (equal poster "")
""
(format nil " poster='~A'"
(escape-string poster)))
(if autoplay
" autoplay"
"")
(if autoloop
" loop"
"")
(if muted
" muted"
""))
:clog-type 'clog-video
:html-id html-id
:auto-place auto-place))

3
source/clog-navigator.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-navigator.lisp ;;;;
@ -8,7 +8,6 @@
(cl:in-package :clog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-navigator
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

290
source/clog-panel.lisp
View file

@ -23,13 +23,13 @@
;;;;;;;;;;;;;;;;;;
(defgeneric create-panel (clog-obj &key left top right bottom
width height units
margin-left margin-top
margin-right margin-bottom
border-style border-width border-color
background-color
positioning overflow resizable content
style hidden class html-id auto-place)
width height units
margin-left margin-top
margin-right margin-bottom
border-style border-width border-color
background-color
positioning overflow resizable content
style hidden class html-id auto-place)
(:documentation "Create a new CLOG-Panel as child of
CLOG-OBJ. Optionally you can set the :X, :Y, :WIDTH and :HEIGHT (in
:UNITS defulting to :px, if set to nil unit type must be provided for
@ -43,98 +43,98 @@ place-inside-bottom-of CLOG-OBJ. If hidden is true visiblep is set to
nil. Resizable only works if overflow is set to :SCROLL"))
(defmethod create-panel ((obj clog-obj) &key
(left nil)
(top nil)
(right nil)
(bottom nil)
(width nil)
(height nil)
(units :px)
(margin-left nil)
(margin-top nil)
(margin-right nil)
(margin-bottom nil)
(border-style nil)
(border-width nil)
(border-color nil)
(background-color nil)
(positioning :absolute)
(overflow :clip)
(display nil)
(resizable nil)
(content "")
(style "")
(hidden nil)
(class nil)
(html-id nil)
(auto-place t))
(left nil)
(top nil)
(right nil)
(bottom nil)
(width nil)
(height nil)
(units :px)
(margin-left nil)
(margin-top nil)
(margin-right nil)
(margin-bottom nil)
(border-style nil)
(border-width nil)
(border-color nil)
(background-color nil)
(positioning :absolute)
(overflow :clip)
(display nil)
(resizable nil)
(content "")
(style "")
(hidden nil)
(class nil)
(html-id nil)
(auto-place t))
(create-child obj
(format nil "<div~A style='~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A~A'>~A</div>"
(if class
(format nil " class='~A'" (escape-string class))
"")
(if style
(format nil "~A;" (escape-string style))
"")
(if left
(format nil "left:~A~A;" left units)
"")
(if top
(format nil "top:~A~A;" top units)
"")
(if right
(format nil "right:~A~A;" right units)
"")
(if bottom
(format nil "bottom:~A~A;" bottom units)
"")
(if margin-left
(format nil "margin-left:~A~A;" margin-left units)
"")
(if margin-top
(format nil "margin-top:~A~A;" margin-top units)
"")
(if margin-right
(format nil "margin-right:~A~A;" margin-right units)
"")
(if margin-bottom
(format nil "margin-bottom:~A~A;" margin-bottom units)
"")
(if width
(format nil "width:~A~A;" width units)
"")
(if height
(format nil "height:~A~A;" height units)
"")
(if border-style
(format nil "border-style:~A;" border-style)
"")
(if border-width
(format nil "border-width:~A;" border-width)
"")
(if border-color
(format nil "border-color:~A;" border-color)
"")
(if background-color
(format nil "background-color:~A;" background-color)
"")
(if overflow
(format nil "overflow:~A;" overflow)
"")
(if display
(format nil "display:~A;" display)
"")
(if resizable
(format nil "resize:~A;" resizable)
"")
(if positioning
(format nil "position:~A;"
(escape-string positioning))
"")
(if hidden
"visibility:hidden;"
"")
(escape-string content))
(if class
(format nil " class='~A'" (escape-string class))
"")
(if style
(format nil "~A;" (escape-string style))
"")
(if left
(format nil "left:~A~A;" left units)
"")
(if top
(format nil "top:~A~A;" top units)
"")
(if right
(format nil "right:~A~A;" right units)
"")
(if bottom
(format nil "bottom:~A~A;" bottom units)
"")
(if margin-left
(format nil "margin-left:~A~A;" margin-left units)
"")
(if margin-top
(format nil "margin-top:~A~A;" margin-top units)
"")
(if margin-right
(format nil "margin-right:~A~A;" margin-right units)
"")
(if margin-bottom
(format nil "margin-bottom:~A~A;" margin-bottom units)
"")
(if width
(format nil "width:~A~A;" width units)
"")
(if height
(format nil "height:~A~A;" height units)
"")
(if border-style
(format nil "border-style:~A;" border-style)
"")
(if border-width
(format nil "border-width:~A;" border-width)
"")
(if border-color
(format nil "border-color:~A;" border-color)
"")
(if background-color
(format nil "background-color:~A;" background-color)
"")
(if overflow
(format nil "overflow:~A;" overflow)
"")
(if display
(format nil "display:~A;" display)
"")
(if resizable
(format nil "resize:~A;" resizable)
"")
(if positioning
(format nil "position:~A;"
(escape-string positioning))
"")
(if hidden
"visibility:hidden;"
"")
(escape-string content))
:clog-type 'clog-panel
:html-id html-id
:auto-place auto-place))
@ -156,8 +156,8 @@ panel will happen."))
(defmethod center-children ((obj clog-element) &key (vertical t) (horizontal t))
(set-styles obj `(("display" "flex")
,(when vertical '("align-items" "center"))
,(when horizontal '("justify-content" "center")))))
,(when vertical '("align-items" "center"))
,(when horizontal '("justify-content" "center")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-panel-box-layout
@ -221,9 +221,9 @@ panel will happen."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun create-panel-box-layout (clog-obj &key (top-height 50) (left-width 50)
(bottom-height 50) (right-width 50)
(units "px")
(html-id nil))
(bottom-height 50) (right-width 50)
(units "px")
(html-id nil))
"Create a five panel app layout that fills entire contents of CLOG-OBJ.
HTML-ID if set is the base and top,left,right,center, bottom are added e.g.
if :HTML-ID \"myid\" then the HTML-ID for center will be: myid-center"
@ -231,34 +231,34 @@ if :HTML-ID \"myid\" then the HTML-ID for center will be: myid-center"
(unless html-id
(setf html-id (clog-connection:generate-id)))
(setf (top-panel panel-box)
(create-panel clog-obj :left 0 :top 0 :right 0 :height top-height
:units units
:html-id (format nil "~A-top" html-id)))
(create-panel clog-obj :left 0 :top 0 :right 0 :height top-height
:units units
:html-id (format nil "~A-top" html-id)))
(setf (left-panel panel-box)
(create-panel clog-obj :left 0 :top 0 :bottom 0 :width left-width
:margin-top top-height
:margin-bottom bottom-height
:units units
:html-id (format nil "~A-left" html-id)))
(create-panel clog-obj :left 0 :top 0 :bottom 0 :width left-width
:margin-top top-height
:margin-bottom bottom-height
:units units
:html-id (format nil "~A-left" html-id)))
(setf (right-panel panel-box)
(create-panel clog-obj :right 0 :top 0 :bottom 0 :width right-width
:margin-top top-height
:margin-bottom bottom-height
:units units
:html-id (format nil "~A-right" html-id)))
(create-panel clog-obj :right 0 :top 0 :bottom 0 :width right-width
:margin-top top-height
:margin-bottom bottom-height
:units units
:html-id (format nil "~A-right" html-id)))
(setf (center-panel panel-box)
(create-panel clog-obj :left 0 :top 0 :right 0 :bottom 0
:margin-left left-width
:margin-top top-height
:margin-right right-width
:margin-bottom bottom-height
:units units
:html-id (format nil "~A-center" html-id)))
(create-panel clog-obj :left 0 :top 0 :right 0 :bottom 0
:margin-left left-width
:margin-top top-height
:margin-right right-width
:margin-bottom bottom-height
:units units
:html-id (format nil "~A-center" html-id)))
(setf (bottom-panel panel-box)
(create-panel clog-obj :left 0 :bottom 0 :right 0
:height bottom-height
:units units
:html-id (format nil "~A-bottom" html-id)))
(create-panel clog-obj :left 0 :bottom 0 :right 0
:height bottom-height
:units units
:html-id (format nil "~A-bottom" html-id)))
panel-box))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -282,26 +282,26 @@ CLOG-PANEL-BOX-LAYOUT as child of CLOG-OBJ with and if :AUTO-PLACE
is set to nil."))
(defmethod create-panel-box ((obj clog-obj) &key (width "100%") (height "100%")
(hidden nil)
(class nil)
(html-id nil)
(auto-place t))
(hidden nil)
(class nil)
(html-id nil)
(auto-place t))
(let ((parent (create-child obj (format nil "<div~A~A~A~A/>"
(if class
(format nil " class='~A'" (escape-string class))
"")
(if width
(format nil " width='~A'" width)
"")
(if height
(format nil " height='~A'" height)
"")
(if hidden
" style='visibility:hidden;'"
""))
:clog-type 'clog-panel-box
:html-id html-id
:auto-place auto-place)))
(if class
(format nil " class='~A'" (escape-string class))
"")
(if width
(format nil " width='~A'" width)
"")
(if height
(format nil " height='~A'" height)
"")
(if hidden
" style='visibility:hidden;'"
""))
:clog-type 'clog-panel-box
:html-id html-id
:auto-place auto-place)))
(setf (panel-box parent) (create-panel-box-layout parent :html-id (html-id parent)))
parent))

60
source/clog-presentations.lisp
View file

@ -19,75 +19,75 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro link-slot-and-form-element (object accessor clog-obj
&key (set-event #'set-on-change)
transform-to-lisp
transform-to-element)
&key (set-event #'set-on-change)
transform-to-lisp
transform-to-element)
"Biderectional link slot (ACCESSOR OBJECT) <> clog-form-element (CLOG-OBJ)"
`(progn
(link-form-element-to-slot ,clog-obj ,object ,accessor
:set-event ,set-event
:transform ,transform-to-lisp)
:set-event ,set-event
:transform ,transform-to-lisp)
(link-slot-to-form-element ,object ,accessor ,clog-obj
:transform ,transform-to-element)))
:transform ,transform-to-element)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; link-slot-and-element ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro link-slot-and-element (object accessor clog-obj
&key (set-event #'set-on-change)
transform-to-lisp
transform-to-element)
&key (set-event #'set-on-change)
transform-to-lisp
transform-to-element)
"Biderectional link slot (ACCESSOR OBJECT) <> clog-element (CLOG-OBJ)"
`(progn
(link-element-to-slot ,clog-obj ,object ,accessor
:set-event ,set-event
:transform ,transform-to-lisp)
:set-event ,set-event
:transform ,transform-to-lisp)
(link-slot-to-element ,object ,accessor ,clog-obj
:transform ,transform-to-element)))
:transform ,transform-to-element)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; link-form-element-to-slot ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro link-form-element-to-slot (clog-obj object accessor
&key (set-event #'set-on-change)
transform)
&key (set-event #'set-on-change)
transform)
"Link changes to (value CLOG-OBJ) to (ACESSOR OBJECT)
on SET-EVENT with TRANSFORM"
`(link-element-to-place ,clog-obj value (,accessor ,object)
:set-event ,set-event
:transform ,transform))
:set-event ,set-event
:transform ,transform))
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; link-element-to-slot ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro link-element-to-slot (clog-obj object accessor
&key (set-event #'set-on-change)
transform)
&key (set-event #'set-on-change)
transform)
"Link changes to (text CLOG-OBJ) to (ACESSOR OBJECT)
on SET-EVENT with TRANSFORM"
`(link-element-to-place ,clog-obj text (,accessor ,object)
:set-event ,set-event
:transform ,transform))
:set-event ,set-event
:transform ,transform))
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; link-element-to-place ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro link-element-to-place (clog-obj property place
&key (set-event #'set-on-change)
transform)
&key (set-event #'set-on-change)
transform)
"Link changes to (PROPERTY CLOG-OBJ) to any lisp PLACE
on SET-EVENT with TRANSFORM"
`(funcall ,set-event ,clog-obj
(lambda (obj)
(declare (ignore obj))
(let ((v (if ,transform
(funcall ,transform (,property ,clog-obj))
(,property ,clog-obj))))
(setf ,place v)))))
(lambda (obj)
(declare (ignore obj))
(let ((v (if ,transform
(funcall ,transform (,property ,clog-obj))
(,property ,clog-obj))))
(setf ,place v)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; link-slot-to-form-element ;;
@ -116,5 +116,5 @@ element can be bound at a time to a lisp object."
PLACE can be bound at a time to a lisp object."
`(defmethod (setf ,accessor) :after (new-value (obj (eql ,object)))
(setf ,place (if ,transform
(funcall ,transform new-value)
new-value))))
(funcall ,transform new-value)
new-value))))

52
source/clog-style.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-style.lisp ;;;;
@ -8,7 +8,6 @@
(cl:in-package :clog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-style-block
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -21,25 +20,25 @@
;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric create-style-block (clog-obj
&key content media html-id auto-place)
&key content media html-id auto-place)
(:documentation "Ideally style blocks should be created in the (head body)
clog-element but can be placed anywhere on a document and are applied as found
in the document. Although they are not 'scoped'. Media is a css media query
defaulting to all. To load CSS style sheets from files see LOAD-CSS in
clog-document. The add-style method can be used or can directly use the
clog-document. The add-style method can be used or can directly use the
TEXT method to access blocks content."))
(defmethod create-style-block ((obj clog-obj)
&key
(content "")
(media "all")
(html-id nil) (auto-place t))
&key
(content "")
(media "all")
(html-id nil) (auto-place t))
(create-child obj (format nil "<style media='~A'>~A</style>"
(escape-string media)
(escape-string content))
:clog-type 'clog-style-block
:html-id html-id
:auto-place auto-place))
(escape-string media)
(escape-string content))
:clog-type 'clog-style-block
:html-id html-id
:auto-place auto-place))
;;;;;;;;;;;;;;;
;; add-style ;;
@ -55,17 +54,16 @@ selector. For example:
(defmethod add-style ((obj clog-style-block) selector-type selector style-alist)
(let ((old-text (text obj)))
(setf (text obj) (format nil "~A ~A~A\{~{~A~}\}"
(if old-text
old-text
"")
(cond ((eq selector-type :id) "#")
((eq selector-type :element) "")
((eq selector-type :class) ".")
(t ""))
selector
(mapcar (lambda (s)
(format nil "~A:~A;"
(car s)
(cadr s)))
style-alist)))))
(if old-text
old-text
"")
(cond ((eq selector-type :id) "#")
((eq selector-type :element) "")
((eq selector-type :class) ".")
(t ""))
selector
(mapcar (lambda (s)
(format nil "~A:~A;"
(car s)
(cadr s)))
style-alist)))))

65
source/clog-system.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-system.lisp ;;;;
@ -8,7 +8,6 @@
(cl:in-package :clog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - CLOG System
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -38,26 +37,26 @@ the same as the clog directy this overides the relative paths used in them.")
(format t "Start new window handler on connection-id - ~A" connection-id))
(let ((body (make-clog-body connection-id)))
(let* ((path (if clog-connection::*long-poll-url*
clog-connection::*long-poll-url*
(path-name (location body))))
(on-new-window (gethash path *url-to-on-new-window*)))
clog-connection::*long-poll-url*
(path-name (location body))))
(on-new-window (gethash path *url-to-on-new-window*)))
(unless on-new-window
(when *extended-routing*
(maphash (lambda (k v)
(unless (equal k "/")
(when (ppcre:scan (format nil "^~A/" k) path)
(setf on-new-window v))))
*url-to-on-new-window*)))
(when *extended-routing*
(maphash (lambda (k v)
(unless (equal k "/")
(when (ppcre:scan (format nil "^~A/" k) path)
(setf on-new-window v))))
*url-to-on-new-window*)))
(unless on-new-window
(setf on-new-window (or (gethash :default *url-to-on-new-window*)
(gethash "/" *url-to-on-new-window*))))
(setf on-new-window (or (gethash :default *url-to-on-new-window*)
(gethash "/" *url-to-on-new-window*))))
(if on-new-window
(progn
(setf (connection-data-item body "clog-path") path)
(setf (connection-data-item body "clog-body") body)
(setf (connection-data-item body "clog-sync") (bordeaux-threads:make-lock))
(funcall on-new-window body))
(put-br (html-document body) "No route to on-new-window")))))
(progn
(setf (connection-data-item body "clog-path") path)
(setf (connection-data-item body "clog-body") body)
(setf (connection-data-item body "clog-sync") (bordeaux-threads:make-lock))
(funcall on-new-window body))
(put-br (html-document body) "No route to on-new-window")))))
(defun initialize
(on-new-window-handler
@ -72,7 +71,7 @@ the same as the clog directy this overides the relative paths used in them.")
(static-boot-html nil)
(static-boot-js nil)
(static-root (merge-pathnames "./static-files/"
(asdf:system-source-directory :clog))))
(asdf:system-source-directory :clog))))
"Inititalize CLOG on a socket using HOST and PORT to serve BOOT-FILE
as the default route to establish web-socket connections and static
files located at STATIC-ROOT. The webserver used with CLACK can be
@ -100,26 +99,26 @@ optimization, see tutorial 12 for an example."
(unless *clog-running*
(setf *clog-running* t)
(setf *static-root* (if *overide-static-root*
*overide-static-root*
static-root))
*overide-static-root*
static-root))
(clog-connection:initialize #'on-connect
:host host
:port port
:server server
:long-poll-first long-poll-first
:extended-routing extended-routing
:boot-file boot-file
:boot-function boot-function
:static-boot-html static-boot-html
:static-boot-js static-boot-js
:static-root *static-root*)))
:host host
:port port
:server server
:long-poll-first long-poll-first
:extended-routing extended-routing
:boot-file boot-file
:boot-function boot-function
:static-boot-html static-boot-html
:static-boot-js static-boot-js
:static-root *static-root*)))
;;;;;;;;;;;;;;;;;;;;;;;
;; set-on-new-window ;;
;;;;;;;;;;;;;;;;;;;;;;;
(defun set-on-new-window (on-new-window-handler
&key (path "/") (boot-file "/boot.html"))
&key (path "/") (boot-file "/boot.html"))
"Set or change the ON-NEW-WINDOW-HANDLER for PATH using
BOOT_FILE. Paths should always begin with a forward slash '/'. If PATH
is set to :default any path without another route and there is no

108
source/clog-utilities.lisp
View file

@ -32,37 +32,37 @@ levels of decleraton are used as the parent clog-obj. To bind a
variable to any created clog object using :bind var. See tutorial 33
and 22 for examples."
(flet ((extract-bind (args)
(when args
(let ((fargs ())
bind)
(do* ((i 0)
(x (nth i args) (nth i args)))
((>= i (length args)))
(if (eql x :bind)
(progn
(setf bind (nth (1+ i) args))
(incf i 2))
(progn
(push x fargs)
(incf i))))
(values (reverse fargs) bind)))))
(when args
(let ((fargs ())
bind)
(do* ((i 0)
(x (nth i args) (nth i args)))
((>= i (length args)))
(if (eql x :bind)
(progn
(setf bind (nth (1+ i) args))
(incf i 2))
(progn
(push x fargs)
(incf i))))
(values (reverse fargs) bind)))))
(let ((let-bindings ())
(used-bindings ()))
(used-bindings ()))
(labels ((create-from-spec (spec parent-binding)
(destructuring-bind (gui-func-name args &body children)
spec
(multiple-value-bind (gui-func-args bind) (extract-bind args)
(let* ((binding (or bind (gensym)))
(create-func-name (intern (concatenate 'string "CREATE-" (symbol-name gui-func-name)))))
(push `(,binding (,create-func-name ,parent-binding ,@gui-func-args)) let-bindings)
(when (or bind children)
(push binding used-bindings))
(dolist (child-spec children)
(create-from-spec child-spec binding)))))))
(create-from-spec spec obj)
`(let* ,(reverse let-bindings)
(declare (ignore ,@(set-difference (mapcar #'first let-bindings) used-bindings)))
,@body)))))
(destructuring-bind (gui-func-name args &body children)
spec
(multiple-value-bind (gui-func-args bind) (extract-bind args)
(let* ((binding (or bind (gensym)))
(create-func-name (intern (concatenate 'string "CREATE-" (symbol-name gui-func-name)))))
(push `(,binding (,create-func-name ,parent-binding ,@gui-func-args)) let-bindings)
(when (or bind children)
(push binding used-bindings))
(dolist (child-spec children)
(create-from-spec child-spec binding)))))))
(create-from-spec spec obj)
`(let* ,(reverse let-bindings)
(declare (ignore ,@(set-difference (mapcar #'first let-bindings) used-bindings)))
,@body)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-group
@ -84,8 +84,8 @@ CLOG-OBJ unless :NAME is set and is used instead."))
(defmethod add ((group clog-group) clog-obj &key (name nil))
(let ((id (if name
name
(html-id clog-obj))))
name
(html-id clog-obj))))
(setf (gethash id (controls group)) clog-obj)))
(defgeneric obj (clog-group name)
@ -144,12 +144,12 @@ if str is NIL returns empty string otherwise returns nil."
(if (and (not str) (not no-nil))
nil
(let ((res))
(setf res (format nil "~@[~A~]" str))
(setf res (ppcre:regex-replace-all "\\x22" res "\\x22"))
(setf res (ppcre:regex-replace-all "\\x27" res "\\x27"))
(setf res (ppcre:regex-replace-all "\\x0A" res "\\x0A"))
(setf res (ppcre:regex-replace-all "\\x0D" res "\\x0D"))
res)))
(setf res (format nil "~@[~A~]" str))
(setf res (ppcre:regex-replace-all "\\x22" res "\\x22"))
(setf res (ppcre:regex-replace-all "\\x27" res "\\x27"))
(setf res (ppcre:regex-replace-all "\\x0A" res "\\x0A"))
(setf res (ppcre:regex-replace-all "\\x0D" res "\\x0D"))
res)))
;;;;;;;;;;;;;;
;; lf-to-br ;;
@ -204,31 +204,31 @@ alpha 0.0 - 1.0"
;; unit ;;
;;;;;;;;;;
;; cm centimeters
;; mm millimeters
;; in inches (1in = 96px = 2.54cm
;; px pixels (1px = 1/96th of 1in)
;; pt points (1pt = 1/72 of 1in)
;; pc picas (1pc = 12 pt)
;; em Relative to the font-size of the element (2em means 2 times the size of the current font)
;; ex Relative to the x-height of the current font (rarely used)
;; ch Relative to the width of the "0" (zero)
;; rem Relative to font-size of the root element
;; vw Relative to 1% of the width of the viewport*
;; vh Relative to 1% of the height of the viewport*
;; vmin Relative to 1% of viewport's* smaller dimension
;; vmax Relative to 1% of viewport's* larger dimension
;; % Relative to the parent element
;; cm centimeters
;; mm millimeters
;; in inches (1in = 96px = 2.54cm
;; px pixels (1px = 1/96th of 1in)
;; pt points (1pt = 1/72 of 1in)
;; pc picas (1pc = 12 pt)
;; em Relative to the font-size of the element (2em means 2 times the size of the current font)
;; ex Relative to the x-height of the current font (rarely used)
;; ch Relative to the width of the "0" (zero)
;; rem Relative to font-size of the root element
;; vw Relative to 1% of the width of the viewport*
;; vh Relative to 1% of the height of the viewport*
;; vmin Relative to 1% of viewport's* smaller dimension
;; vmax Relative to 1% of viewport's* larger dimension
;; % Relative to the parent element
;;
;; * Viewport = the browser window size. If the viewport is 50cm wide, 1vw = 0.5cm.
(deftype unit-type () '(member :cm :mm :in :px :pt :pc :em :ex :ch :rem :vw
:vh :vmin :vmax :%))
:vh :vmin :vmax :%))
(defun unit (unit-type value)
"produce a string from numeric value with UNIT-TYPE appended."
(format nil "~A~A" value unit-type))
;; https://www.w3schools.com/colors/colors_names.asp
;;
;; From - https://www.w3schools.com/

468
source/clog-web-dbi.lisp
View file

@ -34,16 +34,16 @@
"Retrieve profile based on current authentication token. If there is
no token or fails to match as user returns nil"
(let* ((body (connection-body obj))
(token (clog-auth:get-authentication-token body)))
(token (clog-auth:get-authentication-token body)))
(when token
(let ((contents (dbi:fetch-all
(dbi:execute
(dbi:prepare
sql-connection
"select * from users where token=?")
(list token)))))
(when contents
(car contents))))))
(dbi:execute
(dbi:prepare
sql-connection
"select * from users where token=?")
(list token)))))
(when contents
(car contents))))))
;;;;;;;;;;;
;; login ;;
@ -54,11 +54,11 @@ no token or fails to match as user returns nil"
if one is present and login fails."
(check-type body clog-body)
(let ((contents (dbi:fetch-all
(dbi:execute
(dbi:prepare
sql-connection
"select * from users where username=?")
(list username)))))
(dbi:execute
(dbi:prepare
sql-connection
"select * from users where username=?")
(list username)))))
(when (and contents
(cl-pass:check-password password (getf (car contents) :|password|)))
(store-authentication-token body (getf (car contents) :|token|)))))
@ -77,7 +77,7 @@ if one is present and login fails."
;;;;;;;;;;;;;
(defun sign-up (body sql-connection &key (title "Sign Up")
(next-step "/login"))
(next-step "/login"))
"Setup a sign-up form and process a new sign-up"
(check-type body clog-body)
(clog-web-form
@ -87,50 +87,50 @@ if one is present and login fails."
("Retype Password" "repass" :password))
(lambda (result)
(cond ((not
(equal (form-result result "password")
(form-result result "repass")))
(clog-web-alert body "Mismatch"
"The passwords do match."
:time-out 3
:place-top t))
((< (length (form-result result "password")) 4)
(clog-web-alert body "Missize"
"The passwords must at least 4 characters."
:time-out 3
:place-top t))
((< (length (form-result result "username")) 4)
(clog-web-alert body "Missize"
"The username must be at least 4 characters."
:time-out 3
:place-top t))
(t
(let ((contents (dbi:fetch-all
(dbi:execute
(dbi:prepare
sql-connection
"select username from users where username=?")
(list (form-result result "username"))))))
(cond (contents
(clog-web-alert body "Exists"
"The username is not available."
:time-out 3
:place-top t))
(t
(dbi:do-sql
sql-connection
(sql-insert*
"users"
`(:username ,(form-result result "username")
:password ,(cl-pass:hash (form-result result "password"))
:token ,(make-token))))
(url-replace (location body) next-step)))))))))
(equal (form-result result "password")
(form-result result "repass")))
(clog-web-alert body "Mismatch"
"The passwords do match."
:time-out 3
:place-top t))
((< (length (form-result result "password")) 4)
(clog-web-alert body "Missize"
"The passwords must at least 4 characters."
:time-out 3
:place-top t))
((< (length (form-result result "username")) 4)
(clog-web-alert body "Missize"
"The username must be at least 4 characters."
:time-out 3
:place-top t))
(t
(let ((contents (dbi:fetch-all
(dbi:execute
(dbi:prepare
sql-connection
"select username from users where username=?")
(list (form-result result "username"))))))
(cond (contents
(clog-web-alert body "Exists"
"The username is not available."
:time-out 3
:place-top t))
(t
(dbi:do-sql
sql-connection
(sql-insert*
"users"
`(:username ,(form-result result "username")
:password ,(cl-pass:hash (form-result result "password"))
:token ,(make-token))))
(url-replace (location body) next-step)))))))))
;;;;;;;;;;;;;;;;;;;;;
;; change-password ;;
;;;;;;;;;;;;;;;;;;;;;
(defun change-password (body sql-connection &key (title "Change Password")
(next-step "/"))
(next-step "/"))
"Setup a change password form and handle change of password"
(check-type body clog-body)
(clog-web-form
@ -140,40 +140,40 @@ if one is present and login fails."
("Retype Password" "repass" :password))
(lambda (result)
(cond ((not
(equal (form-result result "password")
(form-result result "repass")))
(clog-web-alert body "Password Mismatch"
"The new passwords do match."
:time-out 3
:place-top t))
((< (length (form-result result "password")) 4)
(clog-web-alert body "Password Missize"
"The new passwords must at least 4 characters."
:time-out 3
:place-top t))
(t
(let ((contents (dbi:fetch-all
(dbi:execute
(dbi:prepare
sql-connection
"select username, password from users where username=?")
(list (getf (profile (get-web-site body)) :|username|))))))
(cond ((and contents
(equal (form-result result "password")
(form-result result "repass")))
(clog-web-alert body "Password Mismatch"
"The new passwords do match."
:time-out 3
:place-top t))
((< (length (form-result result "password")) 4)
(clog-web-alert body "Password Missize"
"The new passwords must at least 4 characters."
:time-out 3
:place-top t))
(t
(let ((contents (dbi:fetch-all
(dbi:execute
(dbi:prepare
sql-connection
"select username, password from users where username=?")
(list (getf (profile (get-web-site body)) :|username|))))))
(cond ((and contents
(cl-pass:check-password (form-result result "oldpass")
(getf (car contents) :|password|)))
(dbi:do-sql
sql-connection
(sql-update
"users"
`(:password ,(cl-pass:hash (form-result result "password")))
"username=?")
(list (getf (profile (get-web-site body)) :|username|)))
(url-replace (location body) next-step))
(t
(clog-web-alert body "Old Password"
"Old password is incorrect."
:time-out 3
:place-top t)))))))))
(dbi:do-sql
sql-connection
(sql-update
"users"
`(:password ,(cl-pass:hash (form-result result "password")))
"username=?")
(list (getf (profile (get-web-site body)) :|username|)))
(url-replace (location body) next-step))
(t
(clog-web-alert body "Old Password"
"Old password is incorrect."
:time-out 3
:place-top t)))))))))
;;;;;;;;;;;;;;;;;;;;
;; reset-password ;;
@ -222,38 +222,38 @@ if one is present and login fails."
(dbi:do-sql
sql-connection
(sql-insert* "content" `(:key "main"
:title "Welcome to CLOG"
:value "Sample data"
:createdate (,sql-timestamp-func))))
:title "Welcome to CLOG"
:value "Sample data"
:createdate (,sql-timestamp-func))))
(dbi:do-sql
sql-connection
(sql-insert* "users" `(:username "admin"
:password ,(cl-pass:hash "admin")
:token ,(make-token)))))
:password ,(cl-pass:hash "admin")
:token ,(make-token)))))
;;;;;;;;;;;;;;;;;;
;; load-content ;;
;;;;;;;;;;;;;;;;;;
(defun load-content (sql-connection table key-value &key
(key-col "key")
where
order-by)
(key-col "key")
where
order-by)
"Returns list of records found in TABLE where KEY-COL = KEY-VALUE and
optional WHERE and ORDER-BY sql."
(let ((contents (dbi:fetch-all
(dbi:execute
(dbi:prepare
sql-connection
(format nil "select * from ~A where ~A=? ~A ~A"
table key-col
(if where
(format nil "and ~A" where)
"")
(if order-by
(format nil "order by ~A" order-by)
"")))
(list key-value)))))
(dbi:execute
(dbi:prepare
sql-connection
(format nil "select * from ~A where ~A=? ~A ~A"
table key-col
(if where
(format nil "and ~A" where)
"")
(if order-by
(format nil "order by ~A" order-by)
"")))
(list key-value)))))
contents))
;;;;;;;;;;;;;;;;;;;;;;
@ -261,24 +261,24 @@ optional WHERE and ORDER-BY sql."
;;;;;;;;;;;;;;;;;;;;;;
(defun clog-web-content (sql-connection
&key
(page "main")
(table "content")
(base-url "/content")
(follow-url-page t)
comment-table
on-content
on-comment
on-new
on-edit
on-delete
(can-admin :content-admin)
(can-comment :content-comment)
(can-show-comments :content-show-comments)
(can-edit :content-edit)
(content-order-by "createdate")
(comment-order-by "createdate desc")
(sql-timestamp-func *sqlite-timestamp*))
&key
(page "main")
(table "content")
(base-url "/content")
(follow-url-page t)
comment-table
on-content
on-comment
on-new
on-edit
on-delete
(can-admin :content-admin)
(can-comment :content-comment)
(can-show-comments :content-show-comments)
(can-edit :content-edit)
(content-order-by "createdate")
(comment-order-by "createdate desc")
(sql-timestamp-func *sqlite-timestamp*))
"This is used to create PAGE based content. If more than one entry in
TABLE is keyed for same PAGE, if theme is configured for it, displays
a table of contents, followed by each content record, followed by
@ -305,121 +305,121 @@ authorize on action set by CAN-COMMENT, CAN-ADMIN, CAN-SHOW-COMMENTS
and if CAN-EDIT unless they are set to nil."
(lambda (obj)
(let* ((body (connection-body obj))
(theme (theme (get-web-site body)))
(prof (profile (get-web-site body)))
(roles (roles (get-web-site body)))
(url (base-url-split base-url (path-name (location body)))))
(theme (theme (get-web-site body)))
(prof (profile (get-web-site body)))
(roles (roles (get-web-site body)))
(url (base-url-split base-url (path-name (location body)))))
;; set page to show content
(when follow-url-page
(when (second url)
(setf page (second url))))
(when (second url)
(setf page (second url))))
;; page content display
(let ((pages (load-content sql-connection table page
:order-by content-order-by)))
;; ask theme for table of contents or to allow add
(funcall theme obj :content-contents
(list :content pages
:do-add (when (clog-auth:is-authorized-p roles can-edit)
(lambda (content)
(push (list sql-timestamp-func) content)
(push :createdate content)
(push page content)
(push :key content)
(push page content)
(push :username content)
(when on-new
(setf content (funcall on-new content)))
(when content
(dbi:do-sql
sql-connection
(sql-insert* table content)))))))
(dolist (content pages)
(when content
(when on-content
(setf content (funcall on-content obj content)))
(funcall theme obj :content-body
(list :content content
:save-edit (when (clog-auth:is-authorized-p roles can-edit)
(lambda (new-content)
(when on-edit
(setf new-content (funcall on-edit new-content)))
(when new-content
(dbi:do-sql
sql-connection
(sql-update table
new-content
"key=? and createdate=?")
(list page (getf content :|createdate|)))
(print (getf content :|createdate|)))))
:do-delete (when (clog-auth:is-authorized-p roles can-edit)
(lambda ()
(if on-delete
(setf on-delete (setf on-delete (funcall on-delete obj page nil)))
(setf on-delete t))
(when on-delete
(dbi:do-sql
sql-connection
(format nil "delete from ~A where key=? and createdate=?" table)
(list page (getf content :|createdate|))))))
:new-comment (when (clog-auth:is-authorized-p
roles can-comment)
(lambda (content)
(push (list sql-timestamp-func) content)
(push :|createdate| content)
(push (list sql-timestamp-func) content)
(push :|key| content)
(push page content)
(push :|parent| content)
(push (getf prof :|username|) content)
(push :|username| content)
(when on-new
(setf content (funcall on-new content)))
(when content
(dbi:do-sql
sql-connection
(sql-insert* comment-table content))))))))))
:order-by content-order-by)))
;; ask theme for table of contents or to allow add
(funcall theme obj :content-contents
(list :content pages
:do-add (when (clog-auth:is-authorized-p roles can-edit)
(lambda (content)
(push (list sql-timestamp-func) content)
(push :createdate content)
(push page content)
(push :key content)
(push page content)
(push :username content)
(when on-new
(setf content (funcall on-new content)))
(when content
(dbi:do-sql
sql-connection
(sql-insert* table content)))))))
(dolist (content pages)
(when content
(when on-content
(setf content (funcall on-content obj content)))
(funcall theme obj :content-body
(list :content content
:save-edit (when (clog-auth:is-authorized-p roles can-edit)
(lambda (new-content)
(when on-edit
(setf new-content (funcall on-edit new-content)))
(when new-content
(dbi:do-sql
sql-connection
(sql-update table
new-content
"key=? and createdate=?")
(list page (getf content :|createdate|)))
(print (getf content :|createdate|)))))
:do-delete (when (clog-auth:is-authorized-p roles can-edit)
(lambda ()
(if on-delete
(setf on-delete (setf on-delete (funcall on-delete obj page nil)))
(setf on-delete t))
(when on-delete
(dbi:do-sql
sql-connection
(format nil "delete from ~A where key=? and createdate=?" table)
(list page (getf content :|createdate|))))))
:new-comment (when (clog-auth:is-authorized-p
roles can-comment)
(lambda (content)
(push (list sql-timestamp-func) content)
(push :|createdate| content)
(push (list sql-timestamp-func) content)
(push :|key| content)
(push page content)
(push :|parent| content)
(push (getf prof :|username|) content)
(push :|username| content)
(when on-new
(setf content (funcall on-new content)))
(when content
(dbi:do-sql
sql-connection
(sql-insert* comment-table content))))))))))
;; comments display
(when (and (clog-auth:is-authorized-p roles can-show-comments)
comment-table)
(let ((comments (load-content sql-connection comment-table page
:key-col "parent"
:order-by comment-order-by)))
(dolist (comment comments)
(when on-comment
(setf comment (funcall on-comment obj comment)))
(funcall theme obj :content-comment
(list :content comment
:do-delete (when (or (clog-auth:is-authorized-p roles can-admin)
(and (getf prof :|username|)
(equalp (getf comment :|username|)
(getf prof :|username|))))
(lambda ()
(if on-delete
(setf on-delete (funcall on-delete obj page (getf comment :|key|)))
(setf on-delete t))
(when on-delete
(if (clog-auth:is-authorized-p roles can-admin)
(dbi:do-sql
sql-connection
(format nil "delete from ~A where key=? and parent=?"
comment-table)
(list (getf comment :|key|) page))
(dbi:do-sql
sql-connection
(format nil "delete from ~A where key=? and username=? and parent=?"
comment-table)
(list (getf comment :|key|) (getf prof :|username|) page))))))
:save-edit (when (or (clog-auth:is-authorized-p roles can-admin)
(and (getf prof :|username|)
(equalp (getf comment :|username|)
(getf prof :|username|))))
(lambda (content)
(when on-edit
(setf content (funcall on-edit content)))
(when content
(dbi:do-sql
sql-connection
(sql-update comment-table
content
"key=?")
(list (getf comment :|key|))))))))))))))
comment-table)
(let ((comments (load-content sql-connection comment-table page
:key-col "parent"
:order-by comment-order-by)))
(dolist (comment comments)
(when on-comment
(setf comment (funcall on-comment obj comment)))
(funcall theme obj :content-comment
(list :content comment
:do-delete (when (or (clog-auth:is-authorized-p roles can-admin)
(and (getf prof :|username|)
(equalp (getf comment :|username|)
(getf prof :|username|))))
(lambda ()
(if on-delete
(setf on-delete (funcall on-delete obj page (getf comment :|key|)))
(setf on-delete t))
(when on-delete
(if (clog-auth:is-authorized-p roles can-admin)
(dbi:do-sql
sql-connection
(format nil "delete from ~A where key=? and parent=?"
comment-table)
(list (getf comment :|key|) page))
(dbi:do-sql
sql-connection
(format nil "delete from ~A where key=? and username=? and parent=?"
comment-table)
(list (getf comment :|key|) (getf prof :|username|) page))))))
:save-edit (when (or (clog-auth:is-authorized-p roles can-admin)
(and (getf prof :|username|)
(equalp (getf comment :|username|)
(getf prof :|username|))))
(lambda (content)
(when on-edit
(setf content (funcall on-edit content)))
(when content
(dbi:do-sql
sql-connection
(sql-update comment-table
content
"key=?")
(list (getf comment :|key|))))))))))))))

496
source/clog-web-themes.lisp
View file

@ -54,255 +54,255 @@ Page properties:
:content - (def: \"\")"
;; Settings and Properties with default values
(let* ((website (get-web-site body))
(color-class (get-setting website :color-class "w3-black"))
(border-class (get-setting website :border-class ""))
(button-class (get-setting website :button-class
"w3-button w3-round-xlarge
(color-class (get-setting website :color-class "w3-black"))
(border-class (get-setting website :border-class ""))
(button-class (get-setting website :button-class
"w3-button w3-round-xlarge
w3-tiny w3-border w3-padding-small"))
(text-class (get-setting website :text-class ""))
(login-link (get-setting website :login-link "/login"))
(signup-link (get-setting website :signup-link "/signup"))
(username-link (get-setting website :username-link "/logout"))
(menu-property (get-property properties :menu "w3-black"))
(content (get-property properties :content "")))
(text-class (get-setting website :text-class ""))
(login-link (get-setting website :login-link "/login"))
(signup-link (get-setting website :signup-link "/signup"))
(username-link (get-setting website :username-link "/logout"))
(menu-property (get-property properties :menu "w3-black"))
(content (get-property properties :content "")))
(cond ;; Sub-section: Table of Contents
((or (eq page :content-contents) ; data based contents layout
(eq page :blog-contents)) ; blog based contents layout
(let ((contents (get-property properties :content nil))
(do-add (get-property properties :do-add nil)))
(when do-add
(set-on-click (create-a body :class button-class
:content "add contents")
(lambda (obj)
(set-on-click obj nil)
(let* ((opanel (create-div obj :auto-place nil))
(etitle (create-section opanel :h3 :content "New Title"))
(ebody (create-div opanel :content "New Body")))
(place-after obj opanel)
(setf (editablep etitle) t)
(setf (editablep ebody) t)
(set-border opanel :medium :dotted :red)
(setf (text obj) "Save")
(set-on-click obj
(lambda (obj)
(funcall do-add (list
:|title| (text etitle)
:|value| (text ebody)))
(reload (location (connection-body obj))))))))
(create-br body))
(when contents
(let ((ul (create-ordered-list body :auto-place nil))
(count 0))
(dolist (content contents)
(incf count)
(create-list-item (create-a ul :link (format nil "#~A" (getf content :|createdate|)))
:content (getf content :|title|)))
(when (> count 1)
(place-inside-bottom-of body ul))))))
;; Sub-Section: Content
((or (eq page :content-body) ; data based content layout
(eq page :blog-body)) ; blog based content layout
(let ((anchor (create-child body
(format nil "<a id=~A></a>"
(getf content :|createdate|))))
(etitle (create-section body :h3
:content (getf content :|title|)))
(ebody (create-div body :content (getf content :|value|)))
(panel (create-div body))
(new-comment (get-property properties :new-comment nil))
(save-edit (get-property properties :save-edit nil))
(do-delete (get-property properties :do-delete nil)))
(when new-comment
(labels ((start-add (obj)
(create-br obj)
(let* ((opanel (create-div panel :auto-place nil))
(ipanel (create-span opanel :content
(format nil "~A: " (getf (profile website) :|username|))))
(npanel (create-span opanel :content "")))
(declare (ignore ipanel))
(set-border opanel :medium :dotted :red)
(place-after panel opanel)
(setf (editablep npanel) t)
(focus npanel)
(set-on-click obj nil)
(setf (text obj) "save")
(set-on-click obj
(lambda (obj)
(let ((tcomment (text npanel)))
(set-on-click obj nil)
(setf (editablep npanel) nil)
(setf (inner-html npanel) tcomment)
(funcall new-comment (list :|value| tcomment))
(set-border opanel :thin :dotted :black)
(setf (text obj) "comment")
(set-on-click obj #'start-add)
(reload (location (connection-body obj)))))))))
(set-on-click (create-a panel :class button-class
:content "comment")
#'start-add)))
(when save-edit
(labels ((start-edit (obj)
(setf (editablep etitle) t)
(setf (text etitle) (inner-html etitle))
(setf (editablep ebody) t)
(setf (text ebody) (inner-html ebody))
(focus etitle)
(setf (text obj) "save")
(set-border etitle :medium :solid :red)
(set-border ebody :medium :solid :red)
(set-on-click obj nil)
(set-on-click obj
(lambda (obj)
(let ((ttitle (text etitle))
(tbody (text ebody)))
(set-on-click obj nil)
(setf (editablep etitle) nil)
(setf (inner-html etitle) ttitle)
(setf (editablep ebody) nil)
(setf (inner-html ebody) tbody)
(funcall save-edit
(list :|title| ttitle
:|value| tbody))
(set-border etitle :none "" "")
(set-border ebody :none "" "")
(setf (text obj) "edit")
(set-on-click obj #'start-edit))))))
(set-on-click (create-a panel :class button-class
:content "edit")
#'start-edit)))
(when do-delete
(set-on-click (create-a panel :class button-class
:content "delete")
(lambda (obj)
(funcall do-delete)
(reload (location (connection-body obj)))))))
(create-br body))
;; Sub-Section: Comments
((or (eq page :content-comment) ; data comment layout
(eq page :blog-comment)) ; blog comment layout
(let* ((opanel (create-div body))
(ipanel (create-span opanel :content (format nil "~A: " (getf content :|username|))))
(comment (create-span opanel :content (getf content :|value|))))
(declare (ignore ipanel))
(set-border opanel :thin :dotted :black)
(let ((panel (create-span opanel :content "&nbsp;&nbsp;"))
(save-edit (get-property properties :save-edit nil))
(do-delete (get-property properties :do-delete nil)))
(when save-edit
(labels ((start-edit (obj)
(setf (editablep comment) t)
(setf (text comment) (inner-html comment))
(focus comment)
(setf (text obj) "save")
(set-border opanel :medium :solid :red)
(set-on-click obj nil)
(set-on-click obj
(lambda (obj)
(let ((tcomment (text comment)))
(set-on-click obj nil)
(setf (editablep comment) nil)
(setf (inner-html comment) tcomment)
(funcall save-edit (list :|value| tcomment))
(set-border opanel :thin :dotted :black)
(setf (text obj) "edit")
(set-on-click obj #'start-edit))))))
(set-on-click (create-a panel :class button-class
:content "edit")
#'start-edit)))
(when do-delete
(set-on-click (create-a panel :class button-class
:content "delete")
(lambda (obj)
(funcall do-delete)
(reload (location (connection-body obj)))))))))
;; Full page layout ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(t
;; Setup CSS style changes
(let ((sb (create-style-block body)))
(add-style sb :element "a.clog-theme" '(("text-decoration" "none"))))
;;
;; Page layout
;;
;; SECTION: Above of menu bar
(let* ((row (create-web-auto-row body))
(left (create-web-auto-column row))
(right (create-web-auto-column row :vertical-align :middle)))
(when (logo website)
(set-geometry (create-img (create-a left
:link (url website))
:url-src (logo website))
:height 75))
(create-span (create-a right
:class "clog-theme"
:link (url website))
:content (title website)
:class "w3-xlarge w3-sans-serif"))
;; SECTION: Menu bar
(let ((menu (create-web-menu-bar body :class "w3-card-4 w3-margin-top")))
(add-class menu color-class)
(dolist (drop-down menu-property)
(let ((drop (create-web-menu-drop-down menu
:content (first drop-down)
:class "w3-border"))
(count 0))
(dolist (item (second drop-down))
(when (or (and (fourth item)
(clog-auth:is-authorized-p (roles website)
(fourth item)))
(eq (fourth item) nil))
(incf count)
(create-web-menu-item drop
:class "clog-theme"
:content (first item)
:link (second item))))
(when (eql count 0)
(destroy (parent-element drop)))))
(if (getf (profile website) :|username|)
(create-web-menu-item menu :class "w3-right"
:content (getf (profile website) :|username|)
:link username-link)
(when login-link
(create-web-menu-item menu :class "w3-right"
:content "login"
:link login-link))))
;; SECTION: Content area
(create-br body)
(when content
(typecase content
(string
(create-div body :content content))
(function
(funcall content body))
(t
(create-div body :content (format nil "~A" content)))))
;; SECTION: Special pages - Login
(when (eq page :login)
(let* ((outter (create-web-container body))
(form (create-form outter))
(p1 (create-p form))
(l1 (create-label p1 :content "User Name"
:class text-class))
(user (create-form-element p1 :text
:name "username"
:class (format nil "w3-input ~A" border-class)))
(p2 (create-p form))
(l2 (create-label p2 :content "Password"
:class text-class))
(pass (create-form-element p2 :password
:name "password"
:class (format nil "w3-input ~A" border-class)))
(p3 (create-p form)))
(declare (ignore l1 l2 p3))
(setf (maximum-width outter) (unit :px 500))
(setf (requiredp user) t)
(setf (requiredp pass) t)
(create-form-element form :submit :value "Submit"
:class (format nil "~A ~A" "w3-button" color-class))
(set-on-submit form (getf properties :on-submit))
(when signup-link
(create-a form :class "w3-right" :content "sign up" :link signup-link))))
;; SECTION: Footer
(create-br body)
(create-br body)
(create-div body :content (format nil "~A" (footer website)))))))
(eq page :blog-contents)) ; blog based contents layout
(let ((contents (get-property properties :content nil))
(do-add (get-property properties :do-add nil)))
(when do-add
(set-on-click (create-a body :class button-class
:content "add contents")
(lambda (obj)
(set-on-click obj nil)
(let* ((opanel (create-div obj :auto-place nil))
(etitle (create-section opanel :h3 :content "New Title"))
(ebody (create-div opanel :content "New Body")))
(place-after obj opanel)
(setf (editablep etitle) t)
(setf (editablep ebody) t)
(set-border opanel :medium :dotted :red)
(setf (text obj) "Save")
(set-on-click obj
(lambda (obj)
(funcall do-add (list
:|title| (text etitle)
:|value| (text ebody)))
(reload (location (connection-body obj))))))))
(create-br body))
(when contents
(let ((ul (create-ordered-list body :auto-place nil))
(count 0))
(dolist (content contents)
(incf count)
(create-list-item (create-a ul :link (format nil "#~A" (getf content :|createdate|)))
:content (getf content :|title|)))
(when (> count 1)
(place-inside-bottom-of body ul))))))
;; Sub-Section: Content
((or (eq page :content-body) ; data based content layout
(eq page :blog-body)) ; blog based content layout
(let ((anchor (create-child body
(format nil "<a id=~A></a>"
(getf content :|createdate|))))
(etitle (create-section body :h3
:content (getf content :|title|)))
(ebody (create-div body :content (getf content :|value|)))
(panel (create-div body))
(new-comment (get-property properties :new-comment nil))
(save-edit (get-property properties :save-edit nil))
(do-delete (get-property properties :do-delete nil)))
(when new-comment
(labels ((start-add (obj)
(create-br obj)
(let* ((opanel (create-div panel :auto-place nil))
(ipanel (create-span opanel :content
(format nil "~A: " (getf (profile website) :|username|))))
(npanel (create-span opanel :content "")))
(declare (ignore ipanel))
(set-border opanel :medium :dotted :red)
(place-after panel opanel)
(setf (editablep npanel) t)
(focus npanel)
(set-on-click obj nil)
(setf (text obj) "save")
(set-on-click obj
(lambda (obj)
(let ((tcomment (text npanel)))
(set-on-click obj nil)
(setf (editablep npanel) nil)
(setf (inner-html npanel) tcomment)
(funcall new-comment (list :|value| tcomment))
(set-border opanel :thin :dotted :black)
(setf (text obj) "comment")
(set-on-click obj #'start-add)
(reload (location (connection-body obj)))))))))
(set-on-click (create-a panel :class button-class
:content "comment")
#'start-add)))
(when save-edit
(labels ((start-edit (obj)
(setf (editablep etitle) t)
(setf (text etitle) (inner-html etitle))
(setf (editablep ebody) t)
(setf (text ebody) (inner-html ebody))
(focus etitle)
(setf (text obj) "save")
(set-border etitle :medium :solid :red)
(set-border ebody :medium :solid :red)
(set-on-click obj nil)
(set-on-click obj
(lambda (obj)
(let ((ttitle (text etitle))
(tbody (text ebody)))
(set-on-click obj nil)
(setf (editablep etitle) nil)
(setf (inner-html etitle) ttitle)
(setf (editablep ebody) nil)
(setf (inner-html ebody) tbody)
(funcall save-edit
(list :|title| ttitle
:|value| tbody))
(set-border etitle :none "" "")
(set-border ebody :none "" "")
(setf (text obj) "edit")
(set-on-click obj #'start-edit))))))
(set-on-click (create-a panel :class button-class
:content "edit")
#'start-edit)))
(when do-delete
(set-on-click (create-a panel :class button-class
:content "delete")
(lambda (obj)
(funcall do-delete)
(reload (location (connection-body obj)))))))
(create-br body))
;; Sub-Section: Comments
((or (eq page :content-comment) ; data comment layout
(eq page :blog-comment)) ; blog comment layout
(let* ((opanel (create-div body))
(ipanel (create-span opanel :content (format nil "~A: " (getf content :|username|))))
(comment (create-span opanel :content (getf content :|value|))))
(declare (ignore ipanel))
(set-border opanel :thin :dotted :black)
(let ((panel (create-span opanel :content "&nbsp;&nbsp;"))
(save-edit (get-property properties :save-edit nil))
(do-delete (get-property properties :do-delete nil)))
(when save-edit
(labels ((start-edit (obj)
(setf (editablep comment) t)
(setf (text comment) (inner-html comment))
(focus comment)
(setf (text obj) "save")
(set-border opanel :medium :solid :red)
(set-on-click obj nil)
(set-on-click obj
(lambda (obj)
(let ((tcomment (text comment)))
(set-on-click obj nil)
(setf (editablep comment) nil)
(setf (inner-html comment) tcomment)
(funcall save-edit (list :|value| tcomment))
(set-border opanel :thin :dotted :black)
(setf (text obj) "edit")
(set-on-click obj #'start-edit))))))
(set-on-click (create-a panel :class button-class
:content "edit")
#'start-edit)))
(when do-delete
(set-on-click (create-a panel :class button-class
:content "delete")
(lambda (obj)
(funcall do-delete)
(reload (location (connection-body obj)))))))))
;; Full page layout ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(t
;; Setup CSS style changes
(let ((sb (create-style-block body)))
(add-style sb :element "a.clog-theme" '(("text-decoration" "none"))))
;;
;; Page layout
;;
;; SECTION: Above of menu bar
(let* ((row (create-web-auto-row body))
(left (create-web-auto-column row))
(right (create-web-auto-column row :vertical-align :middle)))
(when (logo website)
(set-geometry (create-img (create-a left
:link (url website))
:url-src (logo website))
:height 75))
(create-span (create-a right
:class "clog-theme"
:link (url website))
:content (title website)
:class "w3-xlarge w3-sans-serif"))
;; SECTION: Menu bar
(let ((menu (create-web-menu-bar body :class "w3-card-4 w3-margin-top")))
(add-class menu color-class)
(dolist (drop-down menu-property)
(let ((drop (create-web-menu-drop-down menu
:content (first drop-down)
:class "w3-border"))
(count 0))
(dolist (item (second drop-down))
(when (or (and (fourth item)
(clog-auth:is-authorized-p (roles website)
(fourth item)))
(eq (fourth item) nil))
(incf count)
(create-web-menu-item drop
:class "clog-theme"
:content (first item)
:link (second item))))
(when (eql count 0)
(destroy (parent-element drop)))))
(if (getf (profile website) :|username|)
(create-web-menu-item menu :class "w3-right"
:content (getf (profile website) :|username|)
:link username-link)
(when login-link
(create-web-menu-item menu :class "w3-right"
:content "login"
:link login-link))))
;; SECTION: Content area
(create-br body)
(when content
(typecase content
(string
(create-div body :content content))
(function
(funcall content body))
(t
(create-div body :content (format nil "~A" content)))))
;; SECTION: Special pages - Login
(when (eq page :login)
(let* ((outter (create-web-container body))
(form (create-form outter))
(p1 (create-p form))
(l1 (create-label p1 :content "User Name"
:class text-class))
(user (create-form-element p1 :text
:name "username"
:class (format nil "w3-input ~A" border-class)))
(p2 (create-p form))
(l2 (create-label p2 :content "Password"
:class text-class))
(pass (create-form-element p2 :password
:name "password"
:class (format nil "w3-input ~A" border-class)))
(p3 (create-p form)))
(declare (ignore l1 l2 p3))
(setf (maximum-width outter) (unit :px 500))
(setf (requiredp user) t)
(setf (requiredp pass) t)
(create-form-element form :submit :value "Submit"
:class (format nil "~A ~A" "w3-button" color-class))
(set-on-submit form (getf properties :on-submit))
(when signup-link
(create-a form :class "w3-right" :content "sign up" :link signup-link))))
;; SECTION: Footer
(create-br body)
(create-br body)
(create-div body :content (format nil "~A" (footer website)))))))

590
source/clog-web.lisp
View file

@ -190,8 +190,8 @@ create-web-menu-bar."))
(defmethod web-menu-bar-height ((obj clog-obj))
(let ((app (connection-data-item obj "clog-web")))
(if (web-menu app)
(height (web-menu app))
0)))
(height (web-menu app))
0)))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; create-web-menu-bar ;;
@ -205,11 +205,11 @@ create-web-menu-bar."))
clog-body."))
(defmethod create-web-menu-bar ((obj clog-obj)
&key (class nil)
(html-id nil))
&key (class nil)
(html-id nil))
(let* ((div (create-div obj :class class :html-id html-id))
(tmp (create-span div)) ; corrects css issue with w3.css
(app (connection-data-item obj "clog-web")))
(tmp (create-span div)) ; corrects css issue with w3.css
(app (connection-data-item obj "clog-web")))
(declare (ignore tmp))
(add-class div "w3-bar")
(change-class div 'clog-web-menu-bar)
@ -224,16 +224,16 @@ clog-body."))
(:documentation "Drop down menu"))
(defgeneric create-web-menu-drop-down (clog-web-menu-bar
&key content class html-id)
&key content class html-id)
(:documentation "Attached a menu bar drop-down to a CLOG-WEB-MENU-BAR"))
(defmethod create-web-menu-drop-down ((obj clog-web-menu-bar)
&key (content "")
(class nil)
(html-id nil))
&key (content "")
(class nil)
(html-id nil))
(let* ((hover (create-div obj :class "w3-dropdown-hover"))
(button (create-button hover :class "w3-button" :content content))
(div (create-div hover :class class :html-id html-id)))
(button (create-button hover :class "w3-button" :content content))
(div (create-div hover :class class :html-id html-id)))
(declare (ignore button))
(add-class div "w3-dropdown-content")
(add-class div "w3-bar-block")
@ -247,27 +247,27 @@ clog-body."))
(:documentation "Menu item"))
(defgeneric create-web-menu-item (clog-web-menu-drop-down
&key content
link
on-click
class
html-id)
&key content
link
on-click
class
html-id)
(:documentation "Attached a menu item to a CLOG-WEB-MENU-DROP-DOWN.
Use to set a link or on-click to set an on-click handler"))
(defmethod create-web-menu-item ((obj clog-obj)
&key (content "")
(link nil)
(on-click nil)
(class nil)
(html-id nil))
&key (content "")
(link nil)
(on-click nil)
(class nil)
(html-id nil))
(let ((span
(create-span (if link
(create-a obj :class class :link link)
obj)
:content content
:class (unless link class)
:html-id html-id)))
(create-span (if link
(create-a obj :class class :link link)
obj)
:content content
:class (unless link class)
:html-id html-id)))
(add-class span "w3-bar-item")
(add-class span "w3-button")
(set-on-click span on-click)
@ -282,38 +282,38 @@ Use to set a link or on-click to set an on-click handler"))
icon ⤢ and full screen mode."))
(defmethod create-web-menu-full-screen ((obj clog-web-menu-bar)
&key (html-id nil))
&key (html-id nil))
(create-child obj
" <span class='w3-bar-item w3-right' style='user-select:none;'
onClick='if (document.fullscreenElement==null) {
" <span class='w3-bar-item w3-right' style='user-select:none;'
onClick='if (document.fullscreenElement==null) {
documentElement.requestFullscreen()
} else {document.exitFullscreen();}'>⤢</span>"
:html-id html-id
:clog-type 'clog-web-menu-item))
:html-id html-id
:clog-type 'clog-web-menu-item))
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; create-web-menu-icon ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric create-web-menu-icon (clog-web-menu-bar &key image-url
on-click
class
html-id)
on-click
class
html-id)
(:documentation "Add icon as menu bar item."))
(defmethod create-web-menu-icon ((obj clog-web-menu-bar)
&key (image-url "/img/clogicon.png")
(on-click nil)
(class "w3-button w3-bar-item")
(html-id nil))
&key (image-url "/img/clogicon.png")
(on-click nil)
(class "w3-button w3-bar-item")
(html-id nil))
(set-on-click
(create-child obj
(format nil "<button class='~A'>~
(format nil "<button class='~A'>~
<img height=22 src='~A'></button>"
class
image-url)
:html-id html-id
:clog-type 'clog-web-menu-item)
class
image-url)
:html-id html-id
:clog-type 'clog-web-menu-item)
on-click))
@ -413,11 +413,11 @@ and right padding and 16x top and bottom margin. If hidden is t then then the
visiblep propetery will be set to nil on creation."))
(defmethod create-web-panel ((obj clog-obj) &key (content "")
(hidden nil)
(class nil)
(html-id nil))
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class div "w3-panel")
(unless hidden
(setf (visiblep div) t))
@ -431,18 +431,18 @@ visiblep propetery will be set to nil on creation."))
(:documentation "Content for web content"))
(defgeneric create-web-content (clog-obj &key content maximum-width
hidden class html-id)
hidden class html-id)
(:documentation "Create a clog-web-content. General container with 16px left
and right padding. If hidden is t then then the visiblep propetery will be set
to nil on creation."))
(defmethod create-web-content ((obj clog-obj) &key (content "")
(maximum-width nil)
(hidden nil)
(class nil)
(html-id nil))
(maximum-width nil)
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class div "w3-content")
(when maximum-width
(setf (maximum-width div) (unit "px" maximum-width)))
@ -464,11 +464,11 @@ composit-location is called on the object of that content. If hidden is t then
then the visiblep propetery will be set to nil on creation."))
(defmethod create-web-compositor ((obj clog-obj) &key (content "")
(hidden nil)
(class nil)
(html-id nil))
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class div "w3-display-container")
(unless hidden
(setf (visiblep div) t))
@ -480,7 +480,7 @@ then the visiblep propetery will be set to nil on creation."))
(deftype web-padding-class-type ()
'(member :padding-small :padding :padding-large :padding-16 :padding-24
:padding-32 :padding-48 :padding-64 :padding-top-64 :padding-top-48
:padding-32 :padding-48 :padding-64 :padding-top-64 :padding-top-48
:padding-top-48 :padding-top-32))
(defgeneric composite-on-hover (clog-element)
@ -493,14 +493,14 @@ then the visiblep propetery will be set to nil on creation."))
(:documentation "Composite CLOG-ELEMENT to coordinate top left."))
(defmethod composite-position ((obj clog-element)
&key
(top 0) (left 0)
(padding-class nil))
&key
(top 0) (left 0)
(padding-class nil))
(add-class obj
(format nil "w3-display-position~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
"")))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
"")))
(setf (top obj) (unit :px top))
(setf (left obj) (unit :px left)))
@ -508,100 +508,100 @@ then the visiblep propetery will be set to nil on creation."))
(:documentation "Composite CLOG-ELEMENT on top-middle."))
(defmethod composite-top-middle ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-topmiddle~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-bottom-middle (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on bottom-middle."))
(defmethod composite-bottom-middle ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-bottommiddle~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-bottom-right (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on bottom-right."))
(defmethod composite-bottom-right ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-bottomright~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-bottom-left (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on bottom-left."))
(defmethod composite-bottom-left ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-bottomleft~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-top-right (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on top-right."))
(defmethod composite-top-right ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-topright~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-top-left (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on top-left."))
(defmethod composite-top-left ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-topleft~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-left (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on left."))
(defmethod composite-left ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-left~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-middle (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on middle."))
(defmethod composite-middle ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-middle~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(defgeneric composite-right (clog-element &key padding-class)
(:documentation "Composite CLOG-ELEMENT on right."))
(defmethod composite-right ((obj clog-element)
&key (padding-class nil))
&key (padding-class nil))
(add-class obj
(format nil "w3-display-right~A"
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
(if padding-class
(format nil " w3-~A" (string-downcase padding-class))
""))))
;;;;;;;;;;;;;;;;;;;;;
;; create-web-code ;;
@ -611,17 +611,17 @@ then the visiblep propetery will be set to nil on creation."))
(:documentation "Code for web code"))
(defgeneric create-web-code (clog-obj &key content
hidden class html-id)
hidden class html-id)
(:documentation "Create a clog-web-code. Code content container.
If hidden is t then then the visiblep propetery will be set
to nil on creation."))
(defmethod create-web-code ((obj clog-obj) &key (content "")
(hidden nil)
(class nil)
(html-id nil))
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class div "w3-code")
(unless hidden
(setf (visiblep div) t))
@ -641,11 +641,11 @@ technique. If hidden is t then then the visiblep propetery will be set
to nil on creation."))
(defmethod create-web-main ((obj clog-obj) &key (content "")
(hidden nil)
(class nil)
(html-id nil))
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class div "w3-main")
(unless hidden
(setf (visiblep div) t))
@ -668,11 +668,11 @@ to set the sidebar's size and set a margin equal to the size on the main
container."))
(defmethod create-web-sidebar ((obj clog-obj) &key (content "")
(hidden nil)
(class nil)
(html-id nil))
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(setf (display div) :none)
(setf (visiblep div) t)
(add-class div "w3-sidebar w3-bar-block")
@ -693,11 +693,11 @@ If hidden is t then then the visiblep propetery will be set to nil on
creation."))
(defmethod create-web-sidebar-item ((obj clog-obj) &key (content "")
(hidden nil)
(class nil)
(html-id nil))
(hidden nil)
(class nil)
(html-id nil))
(let ((item (create-button obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class item "w3-bar-item w3-button")
(unless hidden
(setf (visiblep item) t))
@ -726,8 +726,8 @@ If hidden is t then then the visiblep propetery will be set to nil on
creation."))
(defmethod create-web-auto-row ((obj clog-obj) &key (hidden nil)
(class nil)
(html-id nil))
(class nil)
(html-id nil))
(let ((div (create-div obj :hidden t :class class :html-id html-id)))
(add-class div "w3-cell-row")
(unless hidden
@ -744,22 +744,22 @@ creation."))
(:documentation "Content for web content"))
(defgeneric create-web-auto-column (clog-obj &key content vertical-align
hidden class html-id)
hidden class html-id)
(:documentation "Create a clog-web-auto-column. Container for auto-columns
If hidden is t then then the visiblep propetery will be set to nil on
creation."))
(defmethod create-web-auto-column ((obj clog-obj) &key (content "")
(vertical-align nil)
(hidden nil)
(class nil)
(html-id nil))
(vertical-align nil)
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class div "w3-cell")
(when vertical-align
(add-class div (format nil "w3-cell-~A"
(string-downcase vertical-align))))
(string-downcase vertical-align))))
(unless hidden
(setf (visiblep div) t))
(change-class div 'clog-web-auto-column)))
@ -786,13 +786,13 @@ right padding is addded. If hidden is t then then the visiblep propetery will
be set to nil on creation."))
(defmethod create-web-row ((obj clog-obj) &key (padding nil)
(hidden nil)
(class nil)
(html-id nil))
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :hidden t :class class :html-id html-id)))
(if padding
(add-class div "w3-row-padding")
(add-class div "w3-row"))
(add-class div "w3-row-padding")
(add-class div "w3-row"))
(unless hidden
(setf (visiblep div) t))
(change-class div 'clog-web-row)))
@ -802,14 +802,14 @@ be set to nil on creation."))
;;;;;;;;;;;;;;;;;;;;;;;;;;
(deftype web-container-size-type () '(member :half :third :twothird :quarter
:threequarter :rest :col))
:threequarter :rest :col))
(defclass clog-web-container (clog-div)()
(:documentation "Container cells for web content in 12 column grid"))
(defgeneric create-web-container (clog-obj &key content
column-size
hidden class html-id)
column-size
hidden class html-id)
(:documentation "Create a clog-web-container. COLUMN-SIZE can be of type
container-size-type when to set size displayed on medium and large screens
or can use a string of \"s1-12 m1-12 l1-12\" s m or l followed by how many
@ -819,12 +819,12 @@ be of type :w3-rest to fill space. If hidden is t then then the visiblep
propetery will be set to nil on creation."))
(defmethod create-web-container ((obj clog-obj) &key (content "")
(column-size nil)
(hidden nil)
(class nil)
(html-id nil))
(column-size nil)
(hidden nil)
(class nil)
(html-id nil))
(let ((div (create-div obj :content content
:hidden t :class class :html-id html-id)))
:hidden t :class class :html-id html-id)))
(add-class div "w3-container")
(when column-size
(add-class div (format nil "w3-~A" (string-downcase column-size))))
@ -837,30 +837,30 @@ propetery will be set to nil on creation."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun clog-web-alert (obj title content &key
(color-class "w3-red")
(time-out nil)
(place-top nil)
(html-id nil))
(color-class "w3-red")
(time-out nil)
(place-top nil)
(html-id nil))
"Create an alert toast with option :TIME-OUT. If place-top is t then alert
is placed in DOM at top of OBJ instead of bottom of OBJ."
(unless html-id
(setf html-id (clog-connection:generate-id)))
(let* ((panel (create-child obj
(format nil
(format nil
" <div class='w3-panel ~A w3-animate-right w3-display-container'>~
<span id='~A-closer' class='w3-button w3-large w3-display-topright'>&times;</span>~
<h3>~A</h3>~
<p>~A</p>~
</div>"
color-class
html-id
title
content)
:html-id html-id
:auto-place nil)))
html-id
title
content)
:html-id html-id
:auto-place nil)))
(if place-top
(place-inside-top-of obj panel)
(place-inside-bottom-of obj panel))
(place-inside-top-of obj panel)
(place-inside-bottom-of obj panel))
(set-on-click
(attach-as-child obj (format nil "~A-closer" html-id))
(lambda (obj)
@ -875,12 +875,12 @@ is placed in DOM at top of OBJ instead of bottom of OBJ."
(second (assoc key result :test #'equal)))
(defun clog-web-form (obj content fields on-input &key (modal nil)
(ok-text "OK")
(cancel-text "Cancel")
(border-class "w3-border")
(text-class "w3-text-black")
(color-class "w3-black")
(html-id nil))
(ok-text "OK")
(cancel-text "Cancel")
(border-class "w3-border")
(text-class "w3-text-black")
(color-class "w3-black")
(html-id nil))
"Create a form with CONTENT followed by FIELDS.
FIELDS is a list of lists each list has:
@ -906,87 +906,87 @@ if confirmed or nil if canceled. CANCEL-TEXT is only displayed if modal is t
If clog-web-site is being used the class class setting will be replaced with
the value if set in the theme settings."
(let* ((app (connection-data-item obj "clog-web"))
(website (web-site app)))
(website (web-site app)))
(when website
(when (getf (settings website) :text-class)
(setf text-class (getf (settings website) :text-class)))
(setf text-class (getf (settings website) :text-class)))
(when (getf (settings website) :border-class)
(setf border-class (getf (settings website) :border-class)))
(setf border-class (getf (settings website) :border-class)))
(when (getf (settings website) :color-class)
(setf color-class (getf (settings website) :color-class)))))
(setf color-class (getf (settings website) :color-class)))))
(unless html-id
(setf html-id (clog-connection:generate-id)))
(let* ((fls (format nil "~{~A~}"
(mapcar (lambda (l)
(cond
((eq (third l) :select)
(format nil
"<p><label class='~A'>~A</label>~
<select class='w3-select ~A' name='~A-~A'>~A</select></p>"
text-class (first l)
border-class html-id (second l)
(format nil "~{~A~}"
(mapcar (lambda (s)
(format nil
"<option value='~A' ~A>~A</option>"
(second s)
(if (third s)
(third s)
"")
(first s)))
(fourth l)))))
((eq (third l) :radio)
(format nil
"<p><label class='~A'>~A</label>~A</p>"
text-class (first l)
(format nil "~{~A~}"
(mapcar (lambda (s)
(format nil
"<p><input type=radio class='w3-radio' name='~A-~A'~
(mapcar (lambda (l)
(cond
((eq (third l) :select)
(format nil
"<p><label class='~A'>~A</label>~
<select class='w3-select ~A' name='~A-~A'>~A</select></p>"
text-class (first l)
border-class html-id (second l)
(format nil "~{~A~}"
(mapcar (lambda (s)
(format nil
"<option value='~A' ~A>~A</option>"
(second s)
(if (third s)
(third s)
"")
(first s)))
(fourth l)))))
((eq (third l) :radio)
(format nil
"<p><label class='~A'>~A</label>~A</p>"
text-class (first l)
(format nil "~{~A~}"
(mapcar (lambda (s)
(format nil
"<p><input type=radio class='w3-radio' name='~A-~A'~
id='~A-~A-~A' value='~A' ~A> ~
<label for='~A-~A-~A'>~A</label></p>"
html-id (second l)
html-id (second l) (second s)
(second s)
(if (third s)
(third s)
"")
html-id (second l) (second s)
(first s)))
(fourth l)))))
((eq (third l) :checkbox)
(format nil
"<p><input class='w3-check' type='checkbox' ~
html-id (second l)
html-id (second l) (second s)
(second s)
(if (third s)
(third s)
"")
html-id (second l) (second s)
(first s)))
(fourth l)))))
((eq (third l) :checkbox)
(format nil
"<p><input class='w3-check' type='checkbox' ~
name='~A-~A' id='~A-~A' ~A> ~
<label class='~A' for='~A-~A'>~
~A</label>~
</p>"
html-id (second l) html-id (second l)
(if (fourth l)
"checked"
"")
text-class html-id (second l)
(first l)))
((third l)
(format nil
"<p><label class='~A'>~A</label>~
html-id (second l) html-id (second l)
(if (fourth l)
"checked"
"")
text-class html-id (second l)
(first l)))
((third l)
(format nil
"<p><label class='~A'>~A</label>~
<input class='w3-input ~A' type='~A'~
name='~A-~A' id='~A-~A' value='~A'></p>"
text-class (first l)
border-class (third l)
html-id (second l) html-id (second l)
(if (fourth l)
(fourth l)
"")))
(t
(format nil
"<p><label class='~A'>~A</label>~
text-class (first l)
border-class (third l)
html-id (second l) html-id (second l)
(if (fourth l)
(fourth l)
"")))
(t
(format nil
"<p><label class='~A'>~A</label>~
<input class='w3-input ~A' type='text' name='~A-~A' id='~A-~A'></p>"
text-class (first l)
border-class html-id (second l) html-id (second l)))))
fields)))
(win (create-web-content obj
:content (format nil
border-class html-id (second l) html-id (second l)))))
fields)))
(win (create-web-content obj
:content (format nil
"<div class='w3-panel'>
~A
<form class='w3-container' onSubmit='return false;'>
@ -996,43 +996,43 @@ the value if set in the theme settings."
</center>
</form>
</div>" (if content
(format nil "<center>~A</center><br>" content)
"")
(format nil "<center>~A</center><br>" content)
"")
fls
color-class html-id ok-text ; ok
(if modal
(format nil "&nbsp;<button class='w3-button ~A' style='width:7em' id='~A-cancel'>~A</button>"
color-class html-id cancel-text)
""))
:hidden t
:html-id html-id))
(ok (attach-as-child win (format nil "~A-ok" html-id)))
(cancel (if modal
(attach-as-child win (format nil "~A-cancel" html-id))
nil)))
color-class html-id ok-text ; ok
(if modal
(format nil "&nbsp;<button class='w3-button ~A' style='width:7em' id='~A-cancel'>~A</button>"
color-class html-id cancel-text)
""))
:hidden t
:html-id html-id))
(ok (attach-as-child win (format nil "~A-ok" html-id)))
(cancel (if modal
(attach-as-child win (format nil "~A-cancel" html-id))
nil)))
(declare (ignore cancel))
(setf (visiblep win) t)
(when modal
(js-execute obj (format nil "$('[name=~A-~A]').focus()"
html-id
(cadar fields))))
html-id
(cadar fields))))
(set-on-click ok (lambda (obj)
(declare (ignore obj))
(let ((result (mapcar
(lambda (l)
`(,(second l)
,(let ((name (format nil "~A-~A" html-id (second l))))
(cond ((eq (third l) :select)
(select-value win name))
((eq (third l) :radio)
(radio-value win name))
((eq (third l) :checkbox)
(checkbox-value win name))
(t
(name-value win name))))))
fields)))
(funcall on-input result)))
:one-time nil)))
(declare (ignore obj))
(let ((result (mapcar
(lambda (l)
`(,(second l)
,(let ((name (format nil "~A-~A" html-id (second l))))
(cond ((eq (third l) :select)
(select-value win name))
((eq (third l) :radio)
(radio-value win name))
((eq (third l) :checkbox)
(checkbox-value win name))
(t
(name-value win name))))))
fields)))
(funcall on-input result)))
:one-time nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-web Websites
@ -1044,21 +1044,21 @@ the value if set in the theme settings."
(defclass clog-web-site ()
((theme :initarg :theme
:accessor theme)
:accessor theme)
(profile :initarg :profile
:accessor profile)
:accessor profile)
(roles :initarg :roles
:accessor roles)
:accessor roles)
(settings :initarg :settings
:reader settings)
(url :initarg :url
:reader url)
(title :initarg :title
:reader title)
:reader title)
(footer :initarg :footer
:reader footer)
:reader footer)
(logo :initarg :logo
:reader logo))
:reader logo))
(:documentation "Website information"))
;;;;;;;;;;;;;;;;;;;;;
@ -1066,36 +1066,36 @@ the value if set in the theme settings."
;;;;;;;;;;;;;;;;;;;;;
(defgeneric create-web-site (clog-obj &key
settings
profile
roles
theme
url
title
footer
logo)
settings
profile
roles
theme
url
title
footer
logo)
(:documentation "Attach a clog-web-site to a CLOG-OBJ generally a
clog-body."))
(defmethod create-web-site ((obj clog-obj) &key
settings
(profile nil)
(roles nil)
(theme 'default-theme)
(url "/")
(title "")
(footer "")
(logo ""))
settings
(profile nil)
(roles nil)
(theme 'default-theme)
(url "/")
(title "")
(footer "")
(logo ""))
(let ((website (make-instance 'clog-web-site
:settings settings
:profile profile
:roles roles
:theme theme
:url url
:title title
:footer footer
:logo logo))
(app (connection-data-item obj "clog-web")))
:settings settings
:profile profile
:roles roles
:theme theme
:url url
:title title
:footer footer
:logo logo))
(app (connection-data-item obj "clog-web")))
(setf (web-site app) website)
website))
@ -1109,7 +1109,7 @@ connection"))
(defmethod get-web-site ((obj clog-obj))
(let* ((app (connection-data-item obj "clog-web"))
(website (web-site app)))
(website (web-site app)))
website))
;;;;;;;;;;;;;;;;;;;;;
@ -1126,10 +1126,10 @@ permission to PAGE"))
(defmethod create-web-page ((obj clog-obj) page properties &key authorize)
(if (or (and authorize
(clog-auth:is-authorized-p (roles (get-web-site obj)) page))
(not authorize))
(clog-auth:is-authorized-p (roles (get-web-site obj)) page))
(not authorize))
(funcall (theme (get-web-site obj))
obj page properties)
obj page properties)
(create-div obj :content "Authorization failure")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1146,9 +1146,9 @@ and no-script body information for search engines with DESCRIPTION."
(lambda (path content)
(declare (ignore path))
(funcall (cl-template:compile-template content)
(list :meta (format nil "<meta name='description' content='~A'>"
description)
:body description))))
(list :meta (format nil "<meta name='description' content='~A'>"
description)
:body description))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; clog-web-routes-from-menu ;;
@ -1160,7 +1160,7 @@ element."
(dolist (drop-down menu)
(dolist (item (second drop-down))
(when (third item)
(set-on-new-window (third item) :path (second item))))))
(set-on-new-window (third item) :path (second item))))))
;;;;;;;;;;;;;;;;
;; base-url-p ;;
@ -1188,5 +1188,5 @@ element."
"Split path by / adjusting for base-url"
(let ((s (ppcre:split "/" (adjust-for-base-url base-url url-path))))
(if (equal (car s) "")
(cdr s)
s)))
(cdr s)
s)))

53
source/clog-window.lisp
View file

@ -1,6 +1,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; CLOG - The Common Lisp Omnificent GUI ;;;;
;;;; (c) 2020-2021 David Botton ;;;;
;;;; (c) 2020-2022 David Botton ;;;;
;;;; License BSD 3 Clause ;;;;
;;;; ;;;;
;;;; clog-window.lisp ;;;;
@ -8,7 +8,6 @@
(cl:in-package :clog)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation - clog-window
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -36,7 +35,7 @@ window."))
(query obj "name"))
(defgeneric set-window-name (clog-window value))
(defmethod set-window-name ((obj clog-window) value)
(execute obj (format nil "name='~A'" (escape-string value)))
value)
@ -53,7 +52,7 @@ window."))
(query obj "status"))
(defgeneric set-status-bar (clog-window value))
(defmethod set-status-bar ((obj clog-window) value)
(execute obj (format nil "status='~A'" (escape-string value)))
value)
@ -70,7 +69,7 @@ window."))
(parse-integer (query obj "innerHeight") :junk-allowed t))
(defgeneric set-inner-height (clog-window value))
(defmethod set-inner-height ((obj clog-window) value)
(execute obj (format nil "innerHeight='~A'" (escape-string value)))
value)
@ -87,7 +86,7 @@ window."))
(parse-integer (query obj "innerWidth") :junk-allowed t))
(defgeneric set-inner-width (clog-window value))
(defmethod set-inner-width ((obj clog-window) value)
(execute obj (format nil "innerWidth='~A'" (escape-string value)))
value)
@ -104,7 +103,7 @@ window."))
(parse-integer (query obj "outerHeight") :junk-allowed t))
(defgeneric set-outer-height (clog-window value))
(defmethod set-outer-height ((obj clog-window) value)
(execute obj (format nil "outerHeight='~A'" (escape-string value)))
value)
@ -121,7 +120,7 @@ window."))
(parse-integer (query obj "outerWidth") :junk-allowed t))
(defgeneric set-outer-width (clog-window value))
(defmethod set-outer-width ((obj clog-window) value)
(execute obj (format nil "outerWidth='~A'" (escape-string value)))
value)
@ -138,7 +137,7 @@ window."))
(parse-integer (query obj "pageXOffset") :junk-allowed t))
(defgeneric set-x-offset (clog-window value))
(defmethod set-x-offset ((obj clog-window) value)
(execute obj (format nil "pageXOffset='~A'" (escape-string value)))
value)
@ -155,7 +154,7 @@ window."))
(parse-integer (query obj "pageYOffset") :junk-allowed t))
(defgeneric set-y-offset (clog-window value))
(defmethod set-y-offset ((obj clog-window) value)
(execute obj (format nil "pageYOffset='~A'" (escape-string value)))
value)
@ -172,7 +171,7 @@ window."))
(parse-integer (query obj "screenY") :junk-allowed t))
(defgeneric set-top (clog-window value))
(defmethod set-top ((obj clog-window) value)
(execute obj (format nil "screenY='~A'" (escape-string value)))
value)
@ -189,7 +188,7 @@ window."))
(parse-integer (query obj "screenX") :junk-allowed t))
(defgeneric set-left (clog-window value))
(defmethod set-left ((obj clog-window) value)
(execute obj (format nil "screenX='~A'" (escape-string value)))
value)
@ -295,7 +294,7 @@ events and messages may not be trasmitted on most browsers."))
(defmethod log-console ((obj clog-window) message)
(execute obj (format nil "console.log('~A')"
(escape-string message))))
(escape-string message))))
;;;;;;;;;;;;;;;
;; log-error ;;
@ -306,7 +305,7 @@ events and messages may not be trasmitted on most browsers."))
(defmethod log-error ((obj clog-window) message)
(execute obj (format nil "console.error('~A')"
(escape-string message))))
(escape-string message))))
;;;;;;;;;;;;;;;;;;
;; print-window ;;
@ -388,9 +387,9 @@ CLOG-WINDOW is displayed (remote or local). In modern browsers it is
very limitted to just open a new tab with url unless is a localhost url."))
(defmethod open-window ((obj clog-window) url &key
(name "_blank")
(specs "")
(replace "false"))
(name "_blank")
(specs "")
(replace "false"))
(execute obj (format nil "open('~A','~A','~A',~A)" url name specs replace)))
;;;;;;;;;;;;;;;;;;
@ -463,7 +462,7 @@ ON-HASH-CHANGE-HANDLER is nil unbind the event."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric set-on-orientation-change (clog-window
on-orientation-change-handler)
on-orientation-change-handler)
(:documentation "Set the ON-ORIENTATION-CHANGE-HANDLER for CLOG-OBJ.
If ON-ORIENTATION-CHANGE-HANDLER is nil unbind the event."))
@ -493,10 +492,10 @@ on-storage event is fired for changes to :local storage keys."))
(defmethod set-on-storage ((obj clog-window) handler)
(set-event obj "storage"
(when handler
(lambda (data)
(funcall handler obj (parse-storage-event data))))
:call-back-script storage-event-script))
(when handler
(lambda (data)
(funcall handler obj (parse-storage-event data))))
:call-back-script storage-event-script))
;;;;;;;;;;;;;;;;;;;;
;; storage-length ;;
@ -542,16 +541,16 @@ STORAGE-TYPE. (local = persistant or session)"))
(defmethod storage-element ((obj clog-window) storage-type key-name)
(query obj (format nil "~(~a~)Storage.getItem('~A')"
storage-type
(escape-string key-name))))
storage-type
(escape-string key-name))))
(defgeneric set-storage-element (clog-window storage-type key-name value)
(:documentation "Set storage-element."))
(defmethod set-storage-element ((obj clog-window) storage-type key-name value)
(execute obj (format nil "~(~a~)Storage.setItem('~A','~A')"
storage-type
(escape-string key-name)
(escape-string value)))
storage-type
(escape-string key-name)
(escape-string value)))
value)
(defsetf storage-element set-storage-element)

1284
tools/clog-builder-settings.lisp
View file

File diff suppressed because it is too large Load diff

188
tools/clog-db-admin.lisp
View file

@ -27,25 +27,25 @@
(defun on-db-open (obj)
(let* ((app (connection-data-item obj "app-data")))
(form-dialog obj nil
'(("Database Type" :db-type :select (("SQLite3" :sqlite3)))
("Database Name" :db-name :filename "./"))
(lambda (results)
(when results
(setf (db-type app) (cadr (assoc :db-type results)))
(setf (db-connection app)
(sqlite:connect (cadr (assoc :db-name results))))
(remove-class (body app) "w3-blue-grey")
(add-class (body app) "w3-teal")
(setf (indicator app)
(create-child (body app)
"<div style='position:fixed;z-index:-9999;
'(("Database Type" :db-type :select (("SQLite3" :sqlite3)))
("Database Name" :db-name :filename "./"))
(lambda (results)
(when results
(setf (db-type app) (cadr (assoc :db-type results)))
(setf (db-connection app)
(sqlite:connect (cadr (assoc :db-name results))))
(remove-class (body app) "w3-blue-grey")
(add-class (body app) "w3-teal")
(setf (indicator app)
(create-child (body app)
"<div style='position:fixed;z-index:-9999;
bottom:0px;right:0px'><div>"))
(setf (inner-html (indicator app))
(cadr (assoc :db-name results)))
(setf (title (html-document (body app)))
(format nil "CLOG DB Admin - ~A" (cadr (assoc :db-name results))))))
:title "Open Database" :height 250)))
(setf (inner-html (indicator app))
(cadr (assoc :db-name results)))
(setf (title (html-document (body app)))
(format nil "CLOG DB Admin - ~A" (cadr (assoc :db-name results))))))
:title "Open Database" :height 250)))
(defun on-db-close (obj)
(let ((app (connection-data-item obj "app-data")))
(when (db-connection app)
@ -61,111 +61,111 @@
(unless title
(setf title sql))
(let* ((prep (sqlite:prepare-statement (db-connection app) sql))
(st (sqlite:execute-to-list (db-connection app) sql))
(win (create-gui-window (body app)
:width 500
:height 400
:title title))
(body (window-content win))
(rt (create-table body :class "w3-table-all w3-hover"))
(th (create-table-head rt :class "w3-green"))
(names (sqlite:statement-column-names prep))
(cr))
(st (sqlite:execute-to-list (db-connection app) sql))
(win (create-gui-window (body app)
:width 500
:height 400
:title title))
(body (window-content win))
(rt (create-table body :class "w3-table-all w3-hover"))
(th (create-table-head rt :class "w3-green"))
(names (sqlite:statement-column-names prep))
(cr))
(dolist (name names)
(create-table-heading th :content name))
(dolist (row st)
(setf cr (create-table-row rt))
(when on-click-row
(set-on-click cr (lambda (obj)
(funcall on-click-row obj names row))))
(set-on-click cr (lambda (obj)
(funcall on-click-row obj names row))))
(dolist (value row)
(create-table-column cr :content value)))))
(create-table-column cr :content value)))))
(defun on-query-results (obj)
(let ((app (connection-data-item obj "app-data")))
(when (db-connection app)
(form-dialog obj nil
'(("Query" :db-query))
(lambda (results)
(when results
(handler-case
(results-window app (cadr (assoc :db-query results)))
(error (c)
(alert-dialog obj c :title "Error")))))
:title "Run Database Query" :height 200))))
'(("Query" :db-query))
(lambda (results)
(when results
(handler-case
(results-window app (cadr (assoc :db-query results)))
(error (c)
(alert-dialog obj c :title "Error")))))
:title "Run Database Query" :height 200))))
(defun on-query-non (obj)
(let ((app (connection-data-item obj "app-data")))
(when (db-connection app)
(form-dialog obj nil
'(("Non-Query" :db-query))
(lambda (results)
(when results
(handler-case
(progn
(sqlite:execute-non-query (db-connection app)
(cadr (assoc :db-query results)))
(results-window app "select changes()" :title (cadr (assoc :db-query results))))
(error (c)
(alert-dialog obj c :title "Error")))))
:title "Run Database Non-Query" :height 200))))
'(("Non-Query" :db-query))
(lambda (results)
(when results
(handler-case
(progn
(sqlite:execute-non-query (db-connection app)
(cadr (assoc :db-query results)))
(results-window app "select changes()" :title (cadr (assoc :db-query results))))
(error (c)
(alert-dialog obj c :title "Error")))))
:title "Run Database Non-Query" :height 200))))
(defun edit-record (obj app table names data)
(form-dialog obj "Edit Record"
(loop for x in names for z in data append (list (list x x :text z)))
(lambda (data)
(when data
(flet ((trim-last (s)
(subseq s 0 (- (length s) 1))))
(loop for x in names for z in data append (list (list x x :text z)))
(lambda (data)
(when data
(flet ((trim-last (s)
(subseq s 0 (- (length s) 1))))
(apply
#'sqlite:execute-non-query
(db-connection app)
(format nil
"update ~A set ~A where rowid=~A"
table
(trim-last (format nil "~{~A~}"
(mapcar (lambda (l)
(if (equalp "rowid"
(first l))
""
(format nil "~A=?,"
(first l))))
data)))
(cadar data))
(db-connection app)
(format nil
"update ~A set ~A where rowid=~A"
table
(trim-last (format nil "~{~A~}"
(mapcar (lambda (l)
(if (equalp "rowid"
(first l))
""
(format nil "~A=?,"
(first l))))
data)))
(cadar data))
(mapcar #'second data))))
(results-window app "select changes()" :title table))))
(results-window app "select changes()" :title table))))
(defun on-query-tables (obj)
(let ((app (connection-data-item obj "app-data")))
(when (db-connection app)
(results-window app "select tbl_name as 'Table', sql as SQL from sqlite_master where type='table'"
:title "Click for Table"
:on-click-row (lambda (obj names data)
(results-window app
(format nil "select rowid,* from ~A"
(car data))
:title (format nil "Click to Edit Row of ~A"
(car data))
:on-click-row
(lambda (obj names row)
(edit-record obj app (car data) names row))))))))
:title "Click for Table"
:on-click-row (lambda (obj names data)
(results-window app
(format nil "select rowid,* from ~A"
(car data))
:title (format nil "Click to Edit Row of ~A"
(car data))
:on-click-row
(lambda (obj names row)
(edit-record obj app (car data) names row))))))))
(defun on-help-about (obj)
(let ((about (create-gui-window obj
:title "About"
:content "<div class='w3-black'>
:title "About"
:content "<div class='w3-black'>
<center><img src='/img/clogwicon.png'></center>
<center>CLOG</center>
<center>The Common Lisp Omnificent GUI</center></div>
<div><p><center>CLOG DB Admin</center>
<center>CLOG</center>
<center>The Common Lisp Omnificent GUI</center></div>
<div><p><center>CLOG DB Admin</center>
<center>(c) 2021 - David Botton</center></p></div>"
:width 200
:height 215
:hidden t)))
:width 200
:height 215
:hidden t)))
(window-center about)
(setf (visiblep about) t)
(set-on-window-can-size about (lambda (obj)
(declare (ignore obj))()))))
(declare (ignore obj))()))))
(defun on-new-db-admin (body)
(let ((app (make-instance 'app-data)))
@ -175,11 +175,11 @@
(clog-gui-initialize body)
(add-class body "w3-blue-grey")
(let* ((menu (create-gui-menu-bar body))
(icon (create-gui-menu-icon menu :on-click #'on-help-about))
(file (create-gui-menu-drop-down menu :content "Database"))
(qry (create-gui-menu-drop-down menu :content "Queries"))
(win (create-gui-menu-drop-down menu :content "Window"))
(help (create-gui-menu-drop-down menu :content "Help")))
(icon (create-gui-menu-icon menu :on-click #'on-help-about))
(file (create-gui-menu-drop-down menu :content "Database"))
(qry (create-gui-menu-drop-down menu :content "Queries"))
(win (create-gui-menu-drop-down menu :content "Window"))
(help (create-gui-menu-drop-down menu :content "Help")))
(declare (ignore icon))
(create-gui-menu-item file :content "Open Connection" :on-click #'on-db-open)
(create-gui-menu-item file :content "Close Connection" :on-click #'on-db-close)

10
tools/clog-new-app.lisp
View file

@ -16,15 +16,15 @@
(clog-gui-initialize body)
(add-class body "w3-blue-grey")
(let* ((menu (create-gui-menu-bar body))
(icon (create-gui-menu-icon menu :on-click #'on-help-about-builder))
(file (create-gui-menu-drop-down menu :content "New App")))
(icon (create-gui-menu-icon menu :on-click #'on-help-about-builder))
(file (create-gui-menu-drop-down menu :content "New App")))
(declare (ignore icon))
(create-gui-menu-item file :content "New Application Template" :on-click 'on-new-app-template)
(create-gui-menu-full-screen menu))
(set-on-before-unload (window body) (lambda(obj)
(declare (ignore obj))
;; return empty string to prevent nav off page
""))))
(declare (ignore obj))
;; return empty string to prevent nav off page
""))))
(defun clog-new-app (&key (port 8080) static-root)
"Start clog-new-app."