mirror of
https://github.com/rabbibotton/clog.git
synced 2025-12-06 02:30:42 -08:00
reorg code
This commit is contained in:
David Botton
parent
1f3ca8d587
commit
f0574c33fb
1 changed files with 170 additions and 167 deletions
|
|
@ -121,6 +121,19 @@
|
|||
"Increment next id and store it in CONTENT"
|
||||
(setf-next-id content (1+ (next-id content))))
|
||||
|
||||
;; Lisp code evaluation utilities
|
||||
|
||||
(defun capture-eval (form &key (eval-in-package "clog-user"))
|
||||
"Capture lisp evaluaton of FORM"
|
||||
(let ((result (make-array '(0) :element-type 'base-char
|
||||
:fill-pointer 0 :adjustable t))
|
||||
(eval-result))
|
||||
(with-output-to-string (stream result)
|
||||
(let* ((*standard-output* stream)
|
||||
(*error-output* stream)
|
||||
(*package* (find-package (string-upcase eval-in-package))))
|
||||
(setf eval-result (eval (read-from-string (format nil "(progn ~A)" form))))))
|
||||
(format nil "~A~%=>~A~%" result eval-result)))
|
||||
|
||||
;; Local file utilities
|
||||
|
||||
|
|
@ -139,19 +152,90 @@
|
|||
(with-open-file (outstream outfile :direction :output :if-exists action-if-exists)
|
||||
(write-sequence string outstream)))
|
||||
|
||||
;; Lisp code evaluation utilities
|
||||
(defun save-panel (fname content panel-id hide-loc)
|
||||
"Save panel to FNAME"
|
||||
(let ((app (connection-data-item content "builder-app-data")))
|
||||
(maphash
|
||||
(lambda (html-id control)
|
||||
(declare (ignore html-id))
|
||||
(place-inside-bottom-of hide-loc
|
||||
(get-placer control)))
|
||||
(get-control-list app panel-id))
|
||||
(let ((data
|
||||
(create-child content "<data />"
|
||||
:html-id (format nil "I~A" (get-universal-time)))))
|
||||
(place-inside-top-of content data)
|
||||
(setf (attribute data "data-in-package")
|
||||
(attribute content "data-in-package"))
|
||||
(setf (attribute data "data-custom-slots")
|
||||
(attribute content "data-custom-slots"))
|
||||
(setf (attribute data "data-clog-next-id")
|
||||
(attribute content "data-clog-next-id"))
|
||||
(setf (attribute data "data-clog-title")
|
||||
(attribute content "data-clog-name"))
|
||||
(write-file (js-query content
|
||||
(format nil
|
||||
"var z=~a.clone();~
|
||||
z.find('*').each(function(){if($(this).attr('id') !== undefined && ~
|
||||
$(this).attr('id').substring(0,5)=='CLOGB'){$(this).removeAttr('id')}});~
|
||||
z.html()"
|
||||
(clog::jquery content)))
|
||||
fname)
|
||||
(destroy data))
|
||||
(maphash
|
||||
(lambda (html-id control)
|
||||
(declare (ignore html-id))
|
||||
(place-after control (get-placer control)))
|
||||
(get-control-list app panel-id))))
|
||||
|
||||
(defun capture-eval (form &key (eval-in-package "clog-user"))
|
||||
"Capture lisp evaluaton of FORM"
|
||||
(let ((result (make-array '(0) :element-type 'base-char
|
||||
:fill-pointer 0 :adjustable t))
|
||||
(eval-result))
|
||||
(with-output-to-string (stream result)
|
||||
(let* ((*standard-output* stream)
|
||||
(*error-output* stream)
|
||||
(*package* (find-package (string-upcase eval-in-package))))
|
||||
(setf eval-result (eval (read-from-string (format nil "(progn ~A)" form))))))
|
||||
(format nil "~A~%=>~A~%" result eval-result)))
|
||||
;; Template Utilities
|
||||
|
||||
(defun walk-files-and-directories (path process)
|
||||
"Walk PATH and apply PROCESS on each (path and file)"
|
||||
(let* ((flist (uiop:directory-files path))
|
||||
(dlist (uiop:subdirectories path)))
|
||||
(dolist (f flist)
|
||||
(funcall process path (file-namestring f)))
|
||||
(dolist (d dlist)
|
||||
(walk-files-and-directories d process))))
|
||||
|
||||
(defun template-copy (sys-name start-dir filename &key panel)
|
||||
"Copy START-DIR to FILENAME processing .lt files as cl-template files,
|
||||
if PANEL each copy produces a <b>source</b> to destination added as
|
||||
create-div's"
|
||||
(walk-files-and-directories
|
||||
start-dir
|
||||
(lambda (path file)
|
||||
(let* ((tmpl-ext "lt")
|
||||
(src-file (format nil "~A~A"
|
||||
path file))
|
||||
(out-dir (format nil "~A/~A/~A"
|
||||
filename
|
||||
sys-name
|
||||
(subseq (format nil "~A" path)
|
||||
(length start-dir))))
|
||||
(out-file (format nil "~A~A"
|
||||
out-dir
|
||||
file)))
|
||||
(ensure-directories-exist out-dir)
|
||||
(cond ((equalp (pathname-type file) tmpl-ext)
|
||||
(let* ((nfile (pathname-name file))
|
||||
(afile (if (equalp (pathname-name nfile) "tmpl")
|
||||
(format nil "~A~A.~A" out-dir sys-name (pathname-type nfile))
|
||||
(format nil "~A~A" out-dir nfile))))
|
||||
(write-file (funcall (cl-template:compile-template (read-file src-file))
|
||||
(list :sys-name sys-name))
|
||||
afile)
|
||||
(when panel
|
||||
(create-div panel
|
||||
:content (format nil "<b>~A</b> -> ~A"
|
||||
src-file afile)))))
|
||||
(t
|
||||
(uiop:copy-file src-file out-file)
|
||||
(when panel
|
||||
(create-div panel
|
||||
:content (format nil "<b>~A</b> -> ~A"
|
||||
src-file out-file)))))))))
|
||||
|
||||
;; Control utilities
|
||||
|
||||
|
|
@ -433,6 +517,80 @@ not a temporary attached one when using select-control."
|
|||
(setf control (next-sibling control))))))
|
||||
(add-siblings (first-child parent)))))
|
||||
|
||||
;; Code rendering utlities
|
||||
|
||||
(defun render-clog-code (content win hide-loc)
|
||||
"Render panel to clog code and add tp CW window"
|
||||
(let* ((app (connection-data-item content "builder-app-data"))
|
||||
(panel-id (html-id content))
|
||||
(package (attribute content "data-in-package"))
|
||||
(slots (attribute content "data-custom-slots"))
|
||||
(cname (attribute content "data-clog-name"))
|
||||
cmembers vars events)
|
||||
(unless (or (equal slots "")
|
||||
(equal slots "undefined"))
|
||||
(push slots cmembers))
|
||||
(maphash (lambda (html-id control)
|
||||
(place-inside-bottom-of hide-loc
|
||||
(get-placer control))
|
||||
(let ((vname (attribute control "data-clog-name")))
|
||||
(unless (and (>= (length vname) 5)
|
||||
(equalp (subseq vname 0 5) "none-"))
|
||||
(push (format nil
|
||||
" \(~A :reader ~A\)~%"
|
||||
vname
|
||||
vname)
|
||||
cmembers)
|
||||
(push (format nil
|
||||
" \(setf (slot-value panel '~A\) ~
|
||||
\(attach-as-child clog-obj \"~A\" :clog-type \'~A\ :new-id t)\)~%"
|
||||
vname
|
||||
html-id
|
||||
(format nil "CLOG:~A" (type-of control)))
|
||||
vars)
|
||||
(let ((info (control-info (attribute control "data-clog-type"))))
|
||||
(dolist (event (getf info :events))
|
||||
(let ((handler (attribute control (format nil "data-~A" (getf event :name)))))
|
||||
(unless (or (equalp handler "undefined")
|
||||
(equal handler ""))
|
||||
(push (format nil
|
||||
" \(set-~A \(~A panel\) \(lambda \(~A\) \(declare \(ignorable ~A\)\) ~A\)\)~%"
|
||||
(getf event :name)
|
||||
vname
|
||||
(getf event :parameters)
|
||||
(getf event :parameters)
|
||||
handler)
|
||||
events))))))))
|
||||
(get-control-list app panel-id))
|
||||
(let ((result (format nil
|
||||
"\(in-package \"~A\"\)
|
||||
\(defclass ~A \(clog:clog-div\)
|
||||
\(~{~A~}\)\)
|
||||
\(defun create-~A \(clog-obj &key \(hidden nil\) \(class nil\) \(html-id nil\) \(auto-place t\)\)
|
||||
\(let \(\(panel \(change-class \(clog:create-div clog-obj :content \"~A\"
|
||||
:hidden hidden :class class :html-id html-id :auto-place auto-place\) \'~A\)\)\)
|
||||
~{~A~}~{~A~} panel\)\)~%"
|
||||
(string-upcase package)
|
||||
cname ;;defclass
|
||||
cmembers
|
||||
cname ;;defun
|
||||
(ppcre:regex-replace-all "\""
|
||||
(js-query content
|
||||
(format nil
|
||||
"var z=~a.clone();~
|
||||
z.find('*').each(function(){for(n in $(this).get(0).dataset){delete $(this).get(0).dataset[n]}});~
|
||||
z.html()"
|
||||
(clog::jquery content)))
|
||||
"\\\"")
|
||||
cname
|
||||
vars
|
||||
events)))
|
||||
(maphash (lambda (html-id control)
|
||||
(declare (ignore html-id))
|
||||
(place-after control (get-placer control)))
|
||||
(get-control-list app panel-id))
|
||||
result)))
|
||||
|
||||
;; Population of utility windows
|
||||
|
||||
(defun on-populate-control-events-win (obj)
|
||||
|
|
@ -762,114 +920,6 @@ of controls and double click to select control."
|
|||
<ctrl> place static~%<shift> child to selected"))
|
||||
(set-on-window-close win (lambda (obj) (setf (control-list-win app) nil)))))))
|
||||
|
||||
(defun render-clog-code (content win hide-loc)
|
||||
"Render panel to clog code and add tp CW window"
|
||||
(let* ((app (connection-data-item content "builder-app-data"))
|
||||
(panel-id (html-id content))
|
||||
(package (attribute content "data-in-package"))
|
||||
(slots (attribute content "data-custom-slots"))
|
||||
(cname (attribute content "data-clog-name"))
|
||||
cmembers vars events)
|
||||
(unless (or (equal slots "")
|
||||
(equal slots "undefined"))
|
||||
(push slots cmembers))
|
||||
(maphash (lambda (html-id control)
|
||||
(place-inside-bottom-of hide-loc
|
||||
(get-placer control))
|
||||
(let ((vname (attribute control "data-clog-name")))
|
||||
(unless (and (>= (length vname) 5)
|
||||
(equalp (subseq vname 0 5) "none-"))
|
||||
(push (format nil
|
||||
" \(~A :reader ~A\)~%"
|
||||
vname
|
||||
vname)
|
||||
cmembers)
|
||||
(push (format nil
|
||||
" \(setf (slot-value panel '~A\) ~
|
||||
\(attach-as-child clog-obj \"~A\" :clog-type \'~A\ :new-id t)\)~%"
|
||||
vname
|
||||
html-id
|
||||
(format nil "CLOG:~A" (type-of control)))
|
||||
vars)
|
||||
(let ((info (control-info (attribute control "data-clog-type"))))
|
||||
(dolist (event (getf info :events))
|
||||
(let ((handler (attribute control (format nil "data-~A" (getf event :name)))))
|
||||
(unless (or (equalp handler "undefined")
|
||||
(equal handler ""))
|
||||
(push (format nil
|
||||
" \(set-~A \(~A panel\) \(lambda \(~A\) \(declare \(ignorable ~A\)\) ~A\)\)~%"
|
||||
(getf event :name)
|
||||
vname
|
||||
(getf event :parameters)
|
||||
(getf event :parameters)
|
||||
handler)
|
||||
events))))))))
|
||||
(get-control-list app panel-id))
|
||||
(let ((result (format nil
|
||||
"\(in-package \"~A\"\)
|
||||
\(defclass ~A \(clog:clog-div\)
|
||||
\(~{~A~}\)\)
|
||||
\(defun create-~A \(clog-obj &key \(hidden nil\) \(class nil\) \(html-id nil\) \(auto-place t\)\)
|
||||
\(let \(\(panel \(change-class \(clog:create-div clog-obj :content \"~A\"
|
||||
:hidden hidden :class class :html-id html-id :auto-place auto-place\) \'~A\)\)\)
|
||||
~{~A~}~{~A~} panel\)\)~%"
|
||||
(string-upcase package)
|
||||
cname ;;defclass
|
||||
cmembers
|
||||
cname ;;defun
|
||||
(ppcre:regex-replace-all "\""
|
||||
(js-query content
|
||||
(format nil
|
||||
"var z=~a.clone();~
|
||||
z.find('*').each(function(){for(n in $(this).get(0).dataset){delete $(this).get(0).dataset[n]}});~
|
||||
z.html()"
|
||||
(clog::jquery content)))
|
||||
"\\\"")
|
||||
cname
|
||||
vars
|
||||
events)))
|
||||
(maphash (lambda (html-id control)
|
||||
(declare (ignore html-id))
|
||||
(place-after control (get-placer control)))
|
||||
(get-control-list app panel-id))
|
||||
result)))
|
||||
|
||||
(defun save-panel (fname content panel-id hide-loc)
|
||||
"Save panel to FNAME"
|
||||
(let ((app (connection-data-item content "builder-app-data")))
|
||||
(maphash
|
||||
(lambda (html-id control)
|
||||
(declare (ignore html-id))
|
||||
(place-inside-bottom-of hide-loc
|
||||
(get-placer control)))
|
||||
(get-control-list app panel-id))
|
||||
(let ((data
|
||||
(create-child content "<data />"
|
||||
:html-id (format nil "I~A" (get-universal-time)))))
|
||||
(place-inside-top-of content data)
|
||||
(setf (attribute data "data-in-package")
|
||||
(attribute content "data-in-package"))
|
||||
(setf (attribute data "data-custom-slots")
|
||||
(attribute content "data-custom-slots"))
|
||||
(setf (attribute data "data-clog-next-id")
|
||||
(attribute content "data-clog-next-id"))
|
||||
(setf (attribute data "data-clog-title")
|
||||
(attribute content "data-clog-name"))
|
||||
(write-file (js-query content
|
||||
(format nil
|
||||
"var z=~a.clone();~
|
||||
z.find('*').each(function(){if($(this).attr('id') !== undefined && ~
|
||||
$(this).attr('id').substring(0,5)=='CLOGB'){$(this).removeAttr('id')}});~
|
||||
z.html()"
|
||||
(clog::jquery content)))
|
||||
fname)
|
||||
(destroy data))
|
||||
(maphash
|
||||
(lambda (html-id control)
|
||||
(declare (ignore html-id))
|
||||
(place-after control (get-placer control)))
|
||||
(get-control-list app panel-id))))
|
||||
|
||||
(defun on-new-builder-panel (obj)
|
||||
"Open new panel"
|
||||
(let* ((app (connection-data-item obj "builder-app-data"))
|
||||
|
|
@ -1338,53 +1388,6 @@ of controls and double click to select control."
|
|||
(dolist (tmpl *supported-templates*)
|
||||
(add-select-option (template-box ct) (getf tmpl :code) (getf tmpl :name)))))
|
||||
|
||||
(defun walk-files-and-directories (path process)
|
||||
"Walk PATH and apply PROCESS on each (path and file)"
|
||||
(let* ((flist (uiop:directory-files path))
|
||||
(dlist (uiop:subdirectories path)))
|
||||
(dolist (f flist)
|
||||
(funcall process path (file-namestring f)))
|
||||
(dolist (d dlist)
|
||||
(walk-files-and-directories d process))))
|
||||
|
||||
(defun template-copy (sys-name start-dir filename &key panel)
|
||||
"Copy START-DIR to FILENAME processing .lt files as cl-template files,
|
||||
if PANEL each copy produces a <b>source</b> to destination added as
|
||||
create-div's"
|
||||
(walk-files-and-directories
|
||||
start-dir
|
||||
(lambda (path file)
|
||||
(let* ((tmpl-ext "lt")
|
||||
(src-file (format nil "~A~A"
|
||||
path file))
|
||||
(out-dir (format nil "~A/~A/~A"
|
||||
filename
|
||||
sys-name
|
||||
(subseq (format nil "~A" path)
|
||||
(length start-dir))))
|
||||
(out-file (format nil "~A~A"
|
||||
out-dir
|
||||
file)))
|
||||
(ensure-directories-exist out-dir)
|
||||
(cond ((equalp (pathname-type file) tmpl-ext)
|
||||
(let* ((nfile (pathname-name file))
|
||||
(afile (if (equalp (pathname-name nfile) "tmpl")
|
||||
(format nil "~A~A.~A" out-dir sys-name (pathname-type nfile))
|
||||
(format nil "~A~A" out-dir nfile))))
|
||||
(write-file (funcall (cl-template:compile-template (read-file src-file))
|
||||
(list :sys-name sys-name))
|
||||
afile)
|
||||
(when panel
|
||||
(create-div panel
|
||||
:content (format nil "<b>~A</b> -> ~A"
|
||||
src-file afile)))))
|
||||
(t
|
||||
(uiop:copy-file src-file out-file)
|
||||
(when panel
|
||||
(create-div panel
|
||||
:content (format nil "<b>~A</b> -> ~A"
|
||||
src-file out-file)))))))))
|
||||
|
||||
(defun fill-button-clicked (panel)
|
||||
"Template fill botton clicked"
|
||||
(let* ((tmpl-rec (find-if (lambda (x)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue