diff --git a/clog.asd b/clog.asd
index ce7effc..e7216db 100644
--- a/clog.asd
+++ b/clog.asd
@@ -76,6 +76,12 @@
;; clog-builder code
(:file "clog-builder-settings")
(:file "clog-builder")
+ (:file "clog-builder-control-list")
+ (:file "clog-builder-eval")
+ (:file "clog-builder-files")
+ (:file "clog-builder-panels")
+ (:file "clog-builder-render")
+ (:file "clog-builder-ace")
(:file "clog-builder-templates")
(:file "clog-builder-projects")
(:file "clog-builder-asdf-browser")
diff --git a/tools/clog-builder-ace.lisp b/tools/clog-builder-ace.lisp
new file mode 100644
index 0000000..119426c
--- /dev/null
+++ b/tools/clog-builder-ace.lisp
@@ -0,0 +1,344 @@
+(in-package :clog-tools)
+
+(defun setup-lisp-ace (editor status &key (package "CLOG-USER"))
+ (let ((app (connection-data-item editor "builder-app-data")))
+ ;; currently there is only one auto complete event for page
+ (unless (auto-complete-configured app)
+ (clog-ace:set-on-auto-complete editor
+ (lambda (obj prefix)
+ (declare (ignore obj))
+ (when (current-editor-is-lisp app)
+ ;; we needed to modify Ace's lisp mode to treat : as part of symbol
+ ;; otherwise lookups do not consider the symbols package. I did
+ ;; using code mathod but then the automatic replace is only on the symbol
+ (let* ((p (when (current-control app)
+ (attribute (get-placer (current-control app)) "data-panel-id")))
+ (s (if (eq (current-editor-is-lisp app) t)
+ (if (current-control app)
+ (string-upcase (attribute (attach-as-child (current-control app) p)
+ "data-in-package"))
+ "CLOG-USER")
+ (current-editor-is-lisp app)))
+ (l (car (swank:simple-completions prefix s))))
+ (when (current-control app)
+ (let ((n (get-control-list app p)))
+ (when n
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (let ((name (attribute v "data-clog-name")))
+ (push `(:caption ,name :value ,(format nil "(~A panel)" name)
+ :meta "control")
+ l)))
+ n)
+ (push '(:caption "target" :value "target"
+ :meta "builder")
+ l)
+ (push '(:caption "panel" :value "panel"
+ :meta "builder")
+ l))))
+ l)))
+ :meta "swank"))
+ ;; run apropos on symbol
+ (js-execute editor
+ (format nil
+ "~A.commands.addCommand({
+ name: 'find-definition',
+ bindKey: {win: 'Alt-.', mac: 'Command-.'},
+ exec: function(editor) {
+ var row = editor.selection.getCursor().row;
+ var column = editor.selection.getCursor().column;
+ var c;
+ while (column > 0) {
+ c=editor.session.getTextRange(new ace.Range(row, column-1, row, column));
+ if (c=='(' || c==' ') { break; }
+ column--;
+ }
+ var s=column;
+ while (column < 200) {
+ c=editor.session.getTextRange(new ace.Range(row, column, row, column+1));
+ if (c==')' || c==' ') { break; }
+ column++;
+ }
+ c = editor.session.getTextRange(new ace.Range(row, s, row, column));
+ ~A.trigger('clog-find', c);
+ },
+ readOnly: true,
+});"
+ (clog-ace::js-ace editor)
+ (jquery editor)))
+ (set-on-event-with-data editor "clog-find"
+ (lambda (obj data)
+ (declare (ignore obj))
+ (when (current-editor-is-lisp app)
+ (on-new-sys-browser editor :search data))))
+ ;; setup save key
+ (js-execute editor
+ (format nil
+ "~A.commands.addCommand({
+ name: 'save-ace',
+ bindKey: {win: 'Ctrl-s', mac: 'Command-s'},
+ exec: function(editor) {
+ ~A.trigger('clog-save-ace');
+ },
+ readOnly: true,
+});"
+ (clog-ace::js-ace editor)
+ (jquery editor)))
+ ;; eval form
+ (js-execute editor
+ (format nil
+ "~A.commands.addCommand({
+ name: 'eval-form',
+ bindKey: {win: 'Alt-[', mac: 'Command-['},
+ exec: function(editor) {
+ var position = editor.session.doc.positionToIndex (editor.selection.getCursor(), 0);
+ ~A.trigger('clog-eval-form', position);
+ },
+ readOnly: true,
+});"
+ (clog-ace::js-ace editor)
+ (jquery editor)))
+ (set-on-event-with-data editor "clog-eval-form"
+ (lambda (obj data)
+ (declare (ignore obj))
+ (let ((p (parse-integer data :junk-allowed t))
+ (tv (text-value editor))
+ (pk "CLOG-USER")
+ (lf nil)
+ (cp 0))
+ (loop
+ (setf (values lf cp) (read-from-string tv nil nil :start cp))
+ (unless lf (return nil))
+ (when (eq (car lf) 'in-package)
+ (setf pk (second lf)))
+ (when (> cp p) (return lf)))
+ (when lf
+ (let ((result (capture-eval lf
+ :clog-obj (connection-body editor)
+ :eval-in-package (format nil "~A" pk))))
+ (clog-web-alert (connection-body editor) "Result"
+ (format nil "~&result: ~A" result)
+ :color-class "w3-green"
+ :time-out 3))))))
+ ;; macroexpand
+ (js-execute editor
+ (format nil
+ "~A.commands.addCommand({
+ name: 'macroexp',
+ bindKey: {win: 'Alt-m', mac: 'Option-m'},
+ exec: function(editor) {
+ var position = editor.session.doc.positionToIndex (editor.selection.getCursor(), 0);
+ ~A.trigger('clog-macroexp', position);
+ },
+ readOnly: true,
+});"
+ (clog-ace::js-ace editor)
+ (jquery editor)))
+ (set-on-event-with-data editor "clog-macroexp"
+ (lambda (obj data)
+ (let ((p (parse-integer data :junk-allowed t))
+ (tv (text-value editor))
+ (lf nil)
+ (cp 0))
+ (loop
+ (setf (values lf cp) (read-from-string tv nil nil :start cp))
+ (unless lf (return nil))
+ (when (> cp p) (return lf)))
+ (let ((result (handler-case
+ (prin1-to-string (macroexpand lf))
+ (error (condition)
+ (format nil "Error: ~A" condition)))))
+ (on-open-file obj :title-class "w3-blue" :title "macroexpand result" :text result)))))
+ ;; expand-region
+ (js-execute editor
+ (format nil
+ "~A.commands.addCommand({
+ name: 'expand-region',
+ bindKey: {win: 'Ctrl-=', mac: 'Control-='},
+ exec: function(editor) {
+ var currentRange = editor.selection.getAllRanges()[0];
+ var start = editor.session.doc.positionToIndex(currentRange.start);
+ var end = editor.session.doc.positionToIndex(currentRange.end);
+ var positions = '(' + start + ' ' + end + ')'
+ ~A.trigger('clog-expand-region', positions);
+ },
+ readOnly: true,
+});"
+ (clog-ace::js-ace editor)
+ (jquery editor)))
+ (set-on-event-with-data editor "clog-expand-region"
+ (lambda (obj data)
+ (declare (ignore obj))
+ (let* ((positions (read-from-string data))
+ (new-region
+ (judge-expand-region (text-value editor)
+ (car positions)
+ (cadr positions))))
+ (js-execute editor
+ (format nil
+ "var startIndex = ~A;
+var endIndex = ~A;
+var startRange = ~A.session.doc.indexToPosition(startIndex);
+var endRange = ~:*~A.session.doc.indexToPosition(endIndex);
+~:*~A.selection.setRange(new ace.Range(startRange.row, startRange.column, endRange.row, endRange.column));"
+ (car new-region)
+ (cdr new-region)
+ (clog-ace::js-ace editor))))))
+
+ (set-on-change editor
+ (lambda (obj)
+ (let ((s (js-query obj (format nil
+ "var row = ~A.selection.getCursor().row; ~
+ var column = ~A.selection.getCursor().column; ~
+ var o = column;
+ var c; var charRange; var b=0; ~
+ while (column > 0) {
+ column--;
+ charRange = new ace.Range(row, column-1, row, column); ~
+ c = ~A.session.getTextRange(charRange); ~
+ if (c==')') { b++ } ~
+ if (c=='(' && b==0) { ~
+ charRange = new ace.Range(row, column, row, o); column=0;~
+ c = ~A.session.getTextRange(charRange);} ~
+ if (c=='(' && b > 0) { b-- } }~
+ c"
+ (clog-ace::js-ace obj)
+ (clog-ace::js-ace obj)
+ (clog-ace::js-ace obj)
+ (clog-ace::js-ace obj)))))
+ (unless (equal s "")
+ (with-input-from-string (i s)
+ (ignore-errors
+ (let* ((pac (if (or (eq (current-editor-is-lisp app) t)
+ (eq (current-editor-is-lisp app) nil))
+ "CLOG-USER"
+ (string-upcase (current-editor-is-lisp app))))
+ (m (read i))
+ (*PACKAGE* (find-package pac))
+ (SWANK::*buffer-package* (find-package pac))
+ (SWANK::*buffer-readtable* *readtable*)
+ (ms (format nil "~A" m))
+ r)
+ (ignore-errors
+ (setf r (swank::autodoc `(,ms swank::%CURSOR-MARKER%))))
+ (if r
+ (setf r (car r))
+ (setf r (swank:operator-arglist ms package)))
+ (when status
+ (setf (advisory-title status) (documentation (find-symbol ms) 'function)))
+ (when r
+ (when status
+ (setf (text status) (string-downcase r)))))))))))
+ (clog-ace:set-auto-completion editor t)
+ (setf (clog-ace:theme editor) *editor-theme*)
+ (setf (clog-ace:mode editor) *editor-mode*)
+ (setf (clog-ace:tab-size editor) *editor-tab-size*)
+ (js-execute editor
+ (format nil "~A.setKeyboardHandler('~A')"
+ (clog-ace::js-ace editor)
+ *editor-keybinding*))
+ (js-execute editor
+ (format nil "~A.setOptions({~A})"
+ (clog-ace::js-ace editor)
+ *editor-renderer-options*))))
+
+(defun get-package-from-string (c)
+ "Determine the currect package based on src contained in string C"
+ (with-input-from-string (ins c)
+ (loop
+ (let ((form (read ins nil)))
+ (unless form (return "clog-user"))
+ (unless (consp form) (return "clog-user"))
+ (when (eq (car form) 'in-package)
+ (return (string-downcase (second form))))))))
+
+;; Expand region
+
+(defun scan-exps (text)
+ "Scan all expressions (and strings) in the text, return a list of start-end cons.
+
+It parse the string TEXT without using READ functions."
+ (let ((char-count 0)
+ (backslash 0)
+ exps in-dquotes-p left-dquote left-braces left-brackets)
+ (loop for c across text do
+ (if (= backslash 0) ;current char isn't after a backslash
+ (if (eql c #\\)
+ (incf backslash) ;if it is a backslash, mark for the next word
+ (if (eql c #\") ;if it is double quote,
+ (if in-dquotes-p ;end the last string or start a new string
+ (progn (setf in-dquotes-p nil)
+ (push (cons left-dquote (1+ char-count))
+ exps))
+ (setf in-dquotes-p t
+ left-dquote char-count))
+ (if (not in-dquotes-p) ;if it isn't double quote,
+ (case c ;check if it's braces
+ (#\( (push char-count left-braces)) ;mark a new pair
+ (#\) (if left-braces ;end a pair
+ (push (cons (pop left-braces) (1+ char-count))
+ exps)))
+ (#\[ (push char-count left-brackets))
+ (#\] (if left-brackets
+ (push (cons (pop left-brackets) (1+ char-count))
+ exps)))))))
+ (decf backslash))
+ (incf char-count))
+ exps))
+
+(defun judge-expand-region (text start end)
+ "Judge the next wider region to expand to."
+ (declare (string text) (number start) (number end))
+ (let ((selected (subseq text start end)))
+ (or (let ((word-range ;expand to current word
+ (ignore-errors
+ (let* ((edge-scanner (ppcre:create-scanner "[^\\w]")))
+ (if (not (ppcre:scan edge-scanner selected)) ;there isn't word edge in selected
+ (cons (- start ;search for previous word edge
+ (or (car (ppcre:all-matches
+ edge-scanner
+ (reverse (subseq text 0 start))))
+ start)) ;if nothing, mark from beginning to end.
+ (+ end ;search for next word edge
+ (or (car (ppcre:all-matches edge-scanner
+ (subseq text end)))
+ (- (length text) end)))))))))
+ (if (not (equal word-range (cons start end)))
+ word-range)) ;return if it isn't same with selected
+ (let ((symbol-range ;expand to current symbol
+ ;; just like expand to word, but search for blanks, braces and double quote.
+ (ignore-errors
+ (let* ((edge-scanner (ppcre:create-scanner "[\\s\\(\\)\\[\\]\"]")))
+ (if (not (ppcre:scan edge-scanner selected))
+ (cons (- start
+ (or (car (ppcre:all-matches edge-scanner
+ (reverse (subseq text 0 start))))
+ start))
+ (+ end
+ (or (car (ppcre:all-matches edge-scanner
+ (subseq text end)))
+ (- (length text) end)))))))))
+ (if (not (equal symbol-range (cons start end)))
+ symbol-range))
+ (alexandria:if-let ;expand to curren expression/string
+ ((sexp (ignore-errors
+ (car (sort (delete nil
+ (mapcar ;find wider expressions contained selected
+ #'(lambda (pair)
+ (if (or (and (< (car pair) start)
+ (> (cdr pair) end))
+ (and (= (car pair) start)
+ (> (cdr pair) end))
+ (and (< (car pair) start)
+ (= (cdr pair) end)))
+ pair))
+ (scan-exps text)))
+ #'(lambda (obj1 obj2) ;sort it to find the smallest
+ (> (car obj1) (car obj2))))))))
+ (if (or (= (car sexp) start) ;judge "inner" or "outer" to select
+ (= (cdr sexp) end)
+ (and (= (1+ (car sexp)) start)
+ (= (1- (cdr sexp)) end)))
+ sexp
+ (cons (1+ (car sexp)) (1- (cdr sexp))))
+ (cons start end))))) ;if no expressions, select all
diff --git a/tools/clog-builder-control-list.lisp b/tools/clog-builder-control-list.lisp
new file mode 100644
index 0000000..c82e2cc
--- /dev/null
+++ b/tools/clog-builder-control-list.lisp
@@ -0,0 +1,39 @@
+(in-package :clog-tools)
+
+;; Control-List utilities
+
+(defun init-control-list (app panel-id)
+ "Initialize new control list for PANEL-ID on instance of APP."
+ (setf (gethash panel-id (control-lists app)) (make-hash-table :test #'equalp)))
+
+(defun destroy-control-list (app panel-id)
+ "Destroy the control-list on PANEL-ID"
+ (remhash panel-id (control-lists app)))
+
+(defun get-control-list (app panel-id)
+ "Rerieve the control-list hash table on PANEL-ID"
+ (let ((h (gethash panel-id (control-lists app))))
+ (if h
+ h
+ (make-hash-table* :test #'equalp)))) ;; return empty hash to avoid map fails
+
+(defun add-to-control-list (app panel-id control)
+ "Add a CONTROL on to control-list on PANEL-ID"
+ (let ((html-id (format nil "~A" (html-id control))))
+ (setf (gethash html-id (get-control-list app panel-id)) control)))
+
+(defun get-from-control-list (app panel-id html-id)
+ "Get control identified my HTML-ID from control-list on PANEL-ID"
+ (gethash html-id (get-control-list app panel-id)))
+
+(defun remove-from-control-list (app panel-id html-id)
+ "Remove a control identified by HTML-ID from control-list on PANEL-ID"
+ (remhash html-id (get-control-list app panel-id)))
+
+(defun remove-deleted-from-control-list (app panel-id)
+ "Remove any deleted control from control-list"
+ (maphash (lambda (html-id control)
+ (when (equalp (js-query control (format nil "$.contains(document.documentElement, ~A)"
+ (clog::script-id control))) "false")
+ (remove-from-control-list app panel-id html-id)))
+ (get-control-list app panel-id)))
diff --git a/tools/clog-builder-eval.lisp b/tools/clog-builder-eval.lisp
new file mode 100644
index 0000000..9073dce
--- /dev/null
+++ b/tools/clog-builder-eval.lisp
@@ -0,0 +1,55 @@
+(in-package :clog-tools)
+
+;; Lisp code evaluation utilities
+
+(defun capture-eval (form &key (clog-obj nil) (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)
+ (labels ((my-debugger (condition encapsulation)
+ (declare (ignore encapsulation))
+ (if clog-obj
+ (clog-web-alert (connection-body clog-obj) "Error"
+ (format nil "~&Error: ~A" condition)
+ :time-out 3))
+ (format t "~&Error: ~A" condition)))
+ (unless (stringp form)
+ (let ((r (make-array '(0) :element-type 'base-char
+ :fill-pointer 0 :adjustable t)))
+ (with-output-to-string (s r)
+ (print form s))
+ (setf form r)))
+ (let* ((*standard-output* stream)
+ (*error-output* stream)
+ (*debugger-hook* #'my-debugger)
+ (*package* (find-package (string-upcase eval-in-package))))
+ (setf eval-result (eval (read-from-string (format nil "(progn ~A)" form))))
+ (values
+ (format nil "~A~%=>~A~%" result eval-result)
+ *package*))))))
+
+(defun do-eval (obj form-string cname &key (package "clog-user") custom-boot)
+ "Render, evalute and run code for panel"
+ (let* ((result (capture-eval (format nil "~A~% (clog:set-on-new-window~
+ (lambda (body)~
+ (clog:debug-mode body)~
+ ~A
+ (create-~A body)) ~A:path \"/test\")"
+ form-string
+ (if custom-boot
+ ""
+ "(clog-gui:clog-gui-initialize body)
+ (clog-web:clog-web-initialize body :w3-css-url nil)")
+ cname
+ (if custom-boot
+ (format nil ":boot-file \"~A\" " custom-boot)
+ ""))
+ :eval-in-package package)))
+ (if *app-mode*
+ (open-browser :url (format nil "http://127.0.0.1:~A/test" *clog-port*))
+ (open-window (window (connection-body obj))
+ (format nil "/test" *clog-port*)))
+ (on-open-file obj :title-class "w3-yellow" :title "test eval" :text result)))
+
diff --git a/tools/clog-builder-files.lisp b/tools/clog-builder-files.lisp
new file mode 100644
index 0000000..2260174
--- /dev/null
+++ b/tools/clog-builder-files.lisp
@@ -0,0 +1,30 @@
+(in-package :clog-tools)
+
+;; Local file utilities
+
+(defun read-file (infile &key clog-obj)
+ "Read local file named INFILE"
+ (handler-case
+ (with-open-file (instream infile :direction :input :if-does-not-exist nil)
+ (when instream
+ (let* ((len (file-length instream))
+ (string (make-string len))
+ (pos (read-sequence string instream)))
+ (subseq string 0 pos))))
+ (error (condition)
+ (if clog-obj
+ (alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
+ (format t "Error: ~A" condition)))))
+
+(defun write-file (string outfile &key clog-obj (action-if-exists :rename))
+ "Write local file named OUTFILE"
+ (check-type action-if-exists (member nil :error :new-version :rename :rename-and-delete
+ :overwrite :append :supersede))
+ (handler-case
+ (with-open-file (outstream outfile :direction :output :if-exists action-if-exists)
+ (when outstream
+ (write-sequence string outstream)))
+ (error (condition)
+ (if clog-obj
+ (alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
+ (format t "Error: ~A" condition)))))
diff --git a/tools/clog-builder-panels.lisp b/tools/clog-builder-panels.lisp
new file mode 100644
index 0000000..e7bf3e3
--- /dev/null
+++ b/tools/clog-builder-panels.lisp
@@ -0,0 +1,478 @@
+(in-package :clog-tools)
+
+;; Cross page syncing
+
+(defvar *app-sync-hash* (make-hash-table* :test #'equal)
+ "Exchange app instance with new external pages")
+
+;; Handle per content next-id counts
+
+(defun next-id (content)
+ "Get next id for CONTENT"
+ (parse-integer (attribute content "data-clog-next-id") :junk-allowed t))
+
+(defun setf-next-id (content id)
+ "Store ID on CONTENT"
+ (setf (attribute content "data-clog-next-id") (format nil "~A" id)))
+
+(defun incf-next-id (content)
+ "Increment next id and store it in CONTENT"
+ (setf-next-id content (1+ (next-id content))))
+
+;; Snap-shots
+
+(defun panel-snap-shot (content panel-id hide-loc)
+ "Take a snap shot of panel"
+ (with-sync-event (content)
+ (let (snap
+ (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 ""
+ :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"))
+ (setf snap (js-query content
+ (format nil
+ "var z=~a.clone();~
+ z.find('*').each(function(){~
+ if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~
+ if($(this).attr('id') !== undefined && ~
+ $(this).attr('id').substring(0,5)=='CLOGB'){$(this).removeAttr('id')}});~
+ z.html()"
+ (jquery content))))
+ (destroy data))
+ (maphash
+ (lambda (html-id control)
+ (declare (ignore html-id))
+ (place-after control (get-placer control)))
+ (get-control-list app panel-id))
+ snap)))
+
+(defun save-panel (fname content panel-id hide-loc)
+ "Save panel to FNAME"
+ (write-file (panel-snap-shot content panel-id hide-loc) fname :clog-obj content))
+
+;; Add controls to panels
+
+(defun create-control (parent content control-record uid &key custom-query)
+ "Return a new control based on CONTROL-RECORD as a child of PARENT"
+ (let* ((create-type (getf control-record :create-type))
+ (control-type-name (getf control-record :name))
+ (control (cond ((eq create-type :base)
+ (funcall (getf control-record :create) parent
+ :html-id uid))
+ ((eq create-type :custom)
+ (funcall (getf control-record :create) parent
+ (getf control-record :create-content)
+ :html-id uid))
+ ((eq create-type :custom-block)
+ (let ((c (funcall (getf control-record :create) parent
+ :content custom-query
+ :html-id uid)))
+ (setf (attribute c "data-original-html") custom-query)
+ c))
+ ((eq create-type :custom-query)
+ (funcall (getf control-record :create) parent
+ custom-query
+ :html-id uid))
+ ((eq create-type :paste)
+ (let ((c (create-child parent custom-query
+ :html-id uid)))
+ (setf control-type-name (attribute c "data-clog-type"))
+ (when (equalp control-type-name "undefined")
+ (setf (attribute c "data-clog-type") "div")
+ (setf control-type-name "div"))
+ (let ((cr (control-info control-type-name)))
+ (change-class c (getf cr :clog-type)))
+ c))
+ ((eq create-type :element)
+ (funcall (getf control-record :create) parent
+ :html-id uid
+ :content (if (equal (getf control-record :create-content) "")
+ ""
+ (format nil "~A-~A"
+ (getf control-record :create-content)
+ (next-id content)))))
+ ((eq create-type :form)
+ (funcall (getf control-record :create) parent
+ (getf control-record :create-param)
+ :html-id uid
+ :value (if (equal (getf control-record :create-value) "")
+ ""
+ (format nil "~A-~A"
+ (getf control-record :create-value)
+ (next-id content)))))
+ ((eq create-type :textarea)
+ (funcall (getf control-record :create) parent
+ :html-id uid
+ :value (getf control-record :create-value)))
+ (t nil))))
+ (when control
+ (setf (attribute control "data-clog-type") control-type-name)
+ (when (getf control-record :setup)
+ (funcall (getf control-record :setup) control content control-record)))
+ control))
+
+(defun drop-new-control (app content data &key win)
+ "Create new control dropped at event DATA location on CONTENT of WIN"
+ ;; any click on panel directly will focus window
+ (when win
+ (window-focus win))
+ (let* ((control-record (control-info (value (select-tool app))))
+ (control-type-name (getf control-record :create-type)))
+ (cond ((eq control-type-name :custom-query)
+ (input-dialog win "Enter html (must have an outer element):"
+ (lambda (custom-query)
+ (when custom-query
+ (do-drop-new-control
+ app content data
+ :win win
+ :custom-query custom-query)))
+ :width 500
+ :height 300
+ :rows 5
+ :size 40
+ :title "Custom HTML Control"
+ :default-value (getf control-record :create-content)))
+ ((eq control-type-name :custom-block)
+ (input-dialog win "Enter html to create control:"
+ (lambda (custom-query)
+ (when custom-query
+ (do-drop-new-control
+ app content data
+ :win win
+ :custom-query custom-query)))
+ :width 500
+ :height 300
+ :rows 5
+ :size 40
+ :title "Custom HTML Block"
+ :default-value (getf control-record :create-content)))
+ (t
+ (do-drop-new-control app content data :win win)))))
+
+(defun do-drop-new-control (app content data &key win custom-query)
+ "Create new control dropped at event DATA on CONTENT of WIN)"
+ ;; create control
+ (let* ((control-record (control-info (value (select-tool app))))
+ (control-type-name (getf control-record :name))
+ (positioning (cond ((or (getf data :ctrl-key)
+ (getf data :meta-key))
+ :static)
+ ((getf control-record :positioning)
+ (getf control-record :positioning))
+ (t
+ :absolute)))
+ (parent (when (getf data :shift-key)
+ (current-control app)))
+ (control (create-control (if parent
+ parent
+ content)
+ content
+ control-record
+ (format nil "CLOGB~A~A"
+ (get-universal-time)
+ (next-id content))
+ :custom-query custom-query)))
+ (cond (control
+ ;; panel directly clicked with a control type selected
+ ;; setup control
+ (setf (attribute control "data-clog-name")
+ (format nil "~A-~A" control-type-name (next-id content)))
+ (setf (value (select-tool app)) "")
+ (setf (box-sizing control) :content-box)
+ (setf (positioning control) positioning)
+ (set-geometry control
+ :left (getf data :x)
+ :top (getf data :y))
+ (when (equalp (attribute control "data-clog-composite-control") "undefined")
+ (add-sub-controls control content :win win))
+ (setup-control content control :win win)
+ (select-control control)
+ (on-populate-control-list-win content :win win)
+ (jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')")
+ t)
+ (t
+ ;; panel directly clicked with select tool or no control type to add
+ (deselect-current-control app)
+ (on-populate-control-properties-win content :win win)
+ (on-populate-control-list-win content :win win)
+ nil))))
+
+(defun setup-control (content control &key win)
+ "Setup CONTROL by creating pacer and setting up events for manipulation"
+ (let ((app (connection-data-item content "builder-app-data"))
+ (panel-id (html-id content))
+ (touch-x 0)
+ (touch-y 0)
+ (placer (create-div control :auto-place nil
+ :class "placer"
+ :html-id (format nil "p-~A" (html-id control)))))
+ (add-to-control-list app panel-id control)
+ (setf (attribute placer "data-panel-id") panel-id)
+ ;; setup placer
+ (set-geometry placer :top (position-top control)
+ :left (position-left control)
+ :width (client-width control)
+ :height (client-height control))
+ (place-after control placer)
+ (setf (box-sizing placer) :content-box)
+ (setf (positioning placer) :absolute)
+ (jquery-execute placer (format nil "draggable({snap:'.placer',snapMode:'inner',cursor:'crosshair'})~
+ .resizable({alsoResize:'#~A',autoHide:true})"
+ (html-id control)))
+ ;; setup placer events
+ (setf (tab-index placer) "-1") ; must have a tab-index to accept keyboard input
+ (focus placer)
+ (set-on-key-down placer
+ (lambda (obj data)
+ (declare (ignore obj))
+ (let ((key (getf data :key))
+ (ctrl (getf data :ctrl-key))
+ (meta (getf data :meta-key))
+ (shift (getf data :shift-key)))
+ (cond ((equal key "ArrowUp")
+ (if shift
+ (set-geometry control :height (1- (height control)))
+ (set-geometry control :top (1- (position-top control)))))
+ ((equal key "ArrowDown")
+ (if shift
+ (set-geometry control :height (+ (height control) 2))
+ (set-geometry control :top (+ (position-top control) 2))))
+ ((equal key "ArrowRight")
+ (if shift
+ (set-geometry control :width (+ (width control) 2))
+ (set-geometry control :left (+ (position-left control) 2))))
+ ((equal key "ArrowLeft")
+ (if shift
+ (set-geometry control :width (1- (width control)))
+ (set-geometry control :left (1- (position-left control)))))
+ ((and (equal key "c")
+ (or meta ctrl))
+ (blur placer))
+ ((and (equal key "v")
+ (or meta ctrl))
+ (blur placer))
+ ((and (equal key "x")
+ (or meta ctrl))
+ (blur placer)))
+ (set-geometry placer :top (position-top control)
+ :left (position-left control)
+ :width (client-width control)
+ :height (client-height control))
+ (jquery-execute placer "trigger('clog-builder-snap-shot')")
+ (set-properties-after-geomentry-change control))))
+ (set-on-touch-start placer (lambda (obj data)
+ (declare (ignore obj))
+ (setf touch-x (getf data :X))
+ (setf touch-y (getf data :Y))))
+ (set-on-touch-move placer (lambda (obj data)
+ (declare (ignore obj))
+ (set-geometry control :top (+ (position-top control)
+ (- (getf data :y) touch-y))
+ :left (+ (position-left control)
+ (- (getf data :x) touch-x)))
+ (setf touch-x (getf data :X))
+ (setf touch-y (getf data :Y))))
+ (set-on-touch-end placer (lambda (obj data)
+ (declare (ignore obj data))
+ (set-geometry placer :units ""
+ :top (top control)
+ :left (left control))
+ (select-control control)
+ (jquery-execute placer "trigger('clog-builder-snap-shot')")
+ (set-properties-after-geomentry-change control)))
+ (set-on-mouse-up placer (lambda (obj data)
+ (declare (ignore obj data))
+ (set-geometry control :units ""
+ :top (top placer)
+ :left (left placer))
+ (set-geometry placer :units ""
+ :top (top control)
+ :left (left control))
+ (select-control control)
+ (jquery-execute placer "trigger('clog-builder-snap-shot')")
+ (set-properties-after-geomentry-change control)))
+ (set-on-mouse-down placer
+ (lambda (obj data)
+ (declare (ignore obj))
+ (let ((last (current-control app))
+ (shift (getf data :shift-key)))
+ (if (not (equal (value (select-tool app)) ""))
+ (when (do-drop-new-control app content data :win win)
+ (incf-next-id content)))
+ (cond ((and last
+ shift)
+ (let* ((control1 last)
+ (control2 control)
+ (placer1 (get-placer control1))
+ (placer2 (get-placer control2)))
+ (place-inside-bottom-of control1 control2)
+ (place-after control2 placer2)
+ (place-after control2 placer2)
+ (set-geometry placer1 :top (position-top control1)
+ :left (position-left control1)
+ :width (client-width control1)
+ :height (client-height control1))
+ (set-geometry placer2 :top (position-top control2)
+ :left (position-left control2)
+ :width (client-width control2)
+ :height (client-height control2)))
+ (select-control control)
+ (on-populate-control-properties-win content :win win)
+ (on-populate-control-list-win content :win win))
+ (t
+ (select-control control)))
+ (when win
+ (window-focus win))))
+ :cancel-event t)
+ (set-on-mouse-double-click placer
+ (lambda (obj data)
+ (declare (ignore obj data))
+ (setf (hiddenp placer) t)
+ (on-populate-control-list-win content :win win)))
+ (set-on-event placer "resize"
+ (lambda (obj)
+ (set-properties-after-geomentry-change obj)))
+ (set-on-event placer "resizestop"
+ (lambda (obj)
+ (set-properties-after-geomentry-change obj)
+ (jquery-execute placer "trigger('clog-builder-snap-shot')"))
+ :cancel-event t)
+ (set-on-event placer "drag"
+ (lambda (obj)
+ (declare (ignore obj))
+ (set-geometry control :units ""
+ :top (top placer)
+ :left (left placer))
+ (set-properties-after-geomentry-change control)))))
+
+(defun on-populate-loaded-window (content &key win)
+ "Setup html imported in to CONTENT for use with Builder"
+ (with-sync-event (content)
+ (add-sub-controls content content :win win)))
+
+(defun set-property-display (control property value)
+ "Set property in the currently displayed property panel"
+ (js-execute control (format nil "$('.clog-prop-~A').text('~A')"
+ property value)))
+
+(defun set-properties-after-geomentry-change (control)
+ "Set properties window geometry setting"
+ (set-property-display control "top" (top control))
+ (set-property-display control "left" (left control))
+ (set-property-display control "right" (right control))
+ (set-property-display control "bottom" (bottom control))
+ (set-property-display control "width" (client-width control))
+ (set-property-display control "height" (client-height control)))
+
+;; Control selection utilities
+
+(defun get-placer (control)
+ "Get placer for CONTROL. A placer is a div placed on top of CONTROL and
+prevents access to use or activate the control directy and allows
+manipulation of the control's location and size."
+ (when control
+ (attach-as-child control (format nil "p-~A" (html-id control)))))
+
+(defun deselect-current-control (app)
+ "Remove selection on current control and remove visual ques on its placer."
+ (when (current-control app)
+ (set-border (get-placer (current-control app)) (unit "px" 0) :none :blue)
+ (setf (current-control app) nil)))
+
+(defun delete-current-control (app panel-id html-id)
+ "Delete the current control"
+ (remove-from-control-list app panel-id html-id)
+ (destroy (get-placer (current-control app)))
+ (destroy (current-control app))
+ (setf (current-control app) nil)
+ (remove-deleted-from-control-list app panel-id))
+
+(defun select-control (control)
+ "Select CONTROL as the current control and highlight its placer.
+The actual original clog object used for creation must be used and
+not a temporarily attached one when using select-control."
+ (let ((app (connection-data-item control "builder-app-data"))
+ (placer (get-placer control)))
+ (unless (eq control (current-control app))
+ (deselect-current-control app)
+ (set-geometry placer :top (position-top control)
+ :left (position-left control)
+ :width (client-width control)
+ :height (client-height control))
+ (setf (current-control app) control)
+ (set-border placer (unit "px" 2) :solid :blue)
+ (on-populate-control-properties-win control))))
+
+(defun add-sub-controls (parent content &key win paste)
+ "Setup html imported in to CONTENT starting with PARENT for use with Builder"
+ (let ((panel-uid (get-universal-time)))
+ ;; Assign any elements with no id, an id, name and type
+ (let ((tmp (format nil
+ "var clog_id=~A; var clog_nid=1;~
+ $(~A).find('*').each(function() {var e=$(this);~
+ var t=e.prop('tagName').toLowerCase(); var p=e.attr('data-clog-type');~
+ if((e.attr('id') === undefined) && (e.attr('data-clog-name') === undefined))~
+ {e.attr('id','CLOGB'+clog_id++);~
+ e.attr('data-clog-name','none-'+t+'-'+clog_nid++)}~
+ if(e.attr('id') === undefined){e.attr('id','CLOGB'+clog_id++)}~
+ if(e.attr('data-clog-name') === undefined){e.attr('data-clog-name',e.attr('id'))}~
+ ~A ~
+ ~{~A~}~
+ if(e.attr('data-clog-type') === undefined){e.attr('data-clog-type','span')}})"
+ (1+ panel-uid)
+ (jquery parent)
+ (if paste
+ (prog1
+ (format nil "e.attr('data-clog-name', e.attr('data-clog-name')+'-'+~A);"
+ (next-id content))
+ (incf-next-id content))
+ "")
+ (mapcar (lambda (l)
+ (format nil "if(p === undefined && t=='~A'){e.attr('data-clog-type','~A')}"
+ (getf l :tag) (getf l :control)))
+ *import-types*))))
+ (js-execute parent tmp))
+ (unless paste
+ (let* ((data (first-child content))
+ (name (attribute data "data-clog-title"))
+ (next-id (attribute data "data-clog-next-id"))
+ (slots (attribute data "data-custom-slots"))
+ (package (attribute data "data-in-package")))
+ (unless (equalp next-id "undefined")
+ (setf-next-id content next-id))
+ (unless (equalp package "undefined")
+ (setf (attribute content "data-in-package") package))
+ (unless (equalp slots "undefined")
+ (setf (attribute content "data-custom-slots") slots))
+ (unless (equalp name "undefined")
+ (setf (attribute content "data-clog-name") name)
+ (destroy data))))
+ (labels ((add-siblings (control)
+ (let (dct)
+ (loop
+ (when (equal (html-id control) "undefined") (return))
+ (setf dct (attribute control "data-clog-type"))
+ (unless (equal dct "undefined")
+ (change-class control (getf (control-info dct) :clog-type))
+ (when (getf (control-info dct) :on-load)
+ (funcall (getf (control-info dct) :on-load) control (control-info dct)))
+ (setup-control content control :win win)
+ (unless (equal dct "block")
+ (add-siblings (first-child control))))
+ (setf control (next-sibling control))))))
+ (add-siblings (first-child parent)))))
diff --git a/tools/clog-builder-render.lisp b/tools/clog-builder-render.lisp
new file mode 100644
index 0000000..cbe6e0b
--- /dev/null
+++ b/tools/clog-builder-render.lisp
@@ -0,0 +1,134 @@
+(in-package :clog-tools)
+
+;; Code rendering utlities
+
+(defun render-clog-code (content 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 creates events)
+ (unless (or (equal slots "")
+ (equal slots "undefined"))
+ (push slots cmembers))
+ (maphash (lambda (html-id control)
+ (declare (ignore html-id))
+ (place-inside-bottom-of hide-loc
+ (get-placer control)))
+ (get-control-list app panel-id))
+ ;; crawl tree
+ ;; Insure that on-setup/on-create follow order in tree
+ (labels ((add-siblings (control)
+ (let (dct)
+ (loop
+ (unless control (return))
+ (when (equal (html-id control) "undefined") (return))
+ (setf dct (attribute control "data-clog-name"))
+ (unless (equal dct "undefined")
+ (setf control (get-from-control-list app panel-id (html-id control)))
+ (when control
+ (let ((vname (attribute control "data-clog-name"))
+ (control-record (control-info (attribute control "data-clog-type"))))
+ (unless (and (>= (length vname) 5)
+ (equalp (subseq vname 0 5) "none-"))
+ ;; Add to members of the panel's class for each control
+ (push (format nil
+ " \(~A :reader ~A\)~%"
+ vname
+ vname)
+ cmembers)
+ ;; On instance of class, set member value for each control
+ (push (format nil
+ " \(setf (slot-value panel '~A\) ~
+ \(attach-as-child clog-obj \"~A\" :clog-type \'~A\ :new-id t)\)~%"
+ vname
+ (html-id control)
+ (format nil "~S" (getf control-record :clog-type)))
+ vars)
+ ;; On instance of class, set handers defined for each control
+ (dolist (event (getf control-record :events))
+ ;; Set regular handlers
+ (let ((handler (attribute control (format nil "data-~A" (getf event :name)))))
+ (unless (or (equalp handler "undefined")
+ (equal handler ""))
+ (unless (equalp (getf event :name) "on-create")
+ (let ((event-package (or (getf event :package) "clog")))
+ (push (format nil
+ " \(~A:set-~A \(~A panel\) \(lambda \(~A\) \(declare \(ignorable ~A\)\) ~A\)\)~%"
+ event-package
+ (getf event :name)
+ vname
+ (getf event :parameters)
+ (getf event :parameters)
+ handler)
+ events))))))
+ ;; Set on-create (from user in builder) and on-setup (from control-record)
+ (let ((handler (attribute control "data-on-create")))
+ (when (equalp handler "undefined")
+ (setf handler ""))
+ (when (getf control-record :on-setup)
+ (setf handler (format nil "~A~A"
+ (funcall (getf control-record :on-setup)
+ control control-record)
+ handler)))
+ (unless (equal handler "")
+ (push (format nil
+ " \(let \(\(target \(~A panel\)\)\) ~
+ \(declare \(ignorable target\)\) ~
+ ~A\)~%"
+ vname
+ handler)
+ creates)))))
+ (add-siblings (first-child control))))
+ (when control
+ (setf control (next-sibling control)))))))
+ (add-siblings (first-child content)))
+ (let ((result (format nil
+ "\(in-package :~A)
+\(defclass ~A \(clog:clog-panel\)
+ \(~{~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~}~{~A~} panel\)\)~%"
+ (string-downcase package)
+ cname ;;defclass
+ cmembers
+ cname ;;defun
+ (ppcre:regex-replace-all "\""
+ (js-query content
+ (format nil
+ "var z=~a.clone();~
+ z.find('*').each(function(){~
+ var m=$(this).attr('data-clog-name');
+ if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~
+ if($(this).attr('data-clog-composite-control') == 'b'){$(this).html($(this).attr('data-original-html'))}~
+ for(n in $(this).get(0).dataset){delete $(this).get(0).dataset[n]}~
+ if(m){$(this).attr('data-clog-name', m);}~
+ });~
+ z.html()"
+ (jquery content)))
+ "\\\"")
+ cname
+ vars
+ (reverse creates) ; Insure that on-setup/on-create follow order in tree
+ (reverse events))))
+ (maphash (lambda (html-id control)
+ (declare (ignore html-id))
+ (place-after control (get-placer control)))
+ (get-control-list app panel-id))
+ ;; prety print the code
+ (let ((r (make-array '(0) :element-type 'base-char
+ :fill-pointer 0 :adjustable t)))
+ (with-output-to-string (s r)
+ (with-input-from-string (n result)
+ (let ((*standard-output* s)
+ (*print-case* :downcase))
+ (format t ";;;; CLOG Builder generated code - modify original .clog file and rerender")
+ (loop
+ (let ((l (read n nil)))
+ (unless l (return))
+ (pprint l))))))
+ r))))
diff --git a/tools/clog-builder-templates.lisp b/tools/clog-builder-templates.lisp
index 52e0f19..f99d6e3 100644
--- a/tools/clog-builder-templates.lisp
+++ b/tools/clog-builder-templates.lisp
@@ -1,5 +1,59 @@
(in-package :clog-tools)
+;; 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 source 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 (cond ((equalp (pathname-name nfile) "tmpl")
+ (format nil "~A~A.~A" out-dir sys-name (pathname-type nfile)))
+ ((equalp (pathname-name nfile) "tmpl-tools")
+ (format nil "~A~A-tools.~A" out-dir sys-name (pathname-type nfile)))
+ (t
+ (format nil "~A~A" out-dir nfile)))))
+ (write-file (funcall (cl-template:compile-template (read-file src-file :clog-obj panel))
+ (list :sys-name sys-name))
+ afile :clog-obj panel)
+ (when panel
+ (create-div panel
+ :content (format nil "~A -> ~A"
+ src-file afile)))))
+ (t
+ (uiop:copy-file src-file out-file)
+ (when panel
+ (create-div panel
+ :content (format nil "~A -> ~A"
+ src-file out-file)))))))))
+
+;; Handle panel-clog-templates events
+
(defun fill-button-clicked (panel)
"Template fill botton clicked"
(let* ((app (connection-data-item panel "builder-app-data"))
diff --git a/tools/clog-builder.lisp b/tools/clog-builder.lisp
index ba2f045..c28fc9a 100644
--- a/tools/clog-builder.lisp
+++ b/tools/clog-builder.lisp
@@ -10,7 +10,6 @@
(defparameter *start-project* nil)
(defparameter *start-dir* nil)
-
(defparameter *client-side-movement* nil)
;; Per instance app data
@@ -121,222 +120,10 @@
:initform (make-hash-table* :test #'equalp)
:documentation "Panel -> Control List - hash table")))
-;; Cross page syncing
-
-(defvar *app-sync-hash* (make-hash-table* :test #'equal)
- "Exchange app instance with new external pages")
-
-;; Control-List utilities
-
-(defun init-control-list (app panel-id)
- "Initialize new control list for PANEL-ID on instance of APP."
- (setf (gethash panel-id (control-lists app)) (make-hash-table :test #'equalp)))
-
-(defun destroy-control-list (app panel-id)
- "Destroy the control-list on PANEL-ID"
- (remhash panel-id (control-lists app)))
-
-(defun get-control-list (app panel-id)
- "Rerieve the control-list hash table on PANEL-ID"
- (let ((h (gethash panel-id (control-lists app))))
- (if h
- h
- (make-hash-table* :test #'equalp)))) ;; return empty hash to avoid map fails
-
-(defun add-to-control-list (app panel-id control)
- "Add a CONTROL on to control-list on PANEL-ID"
- (let ((html-id (format nil "~A" (html-id control))))
- (setf (gethash html-id (get-control-list app panel-id)) control)))
-
-(defun get-from-control-list (app panel-id html-id)
- "Get control identified my HTML-ID from control-list on PANEL-ID"
- (gethash html-id (get-control-list app panel-id)))
-
-(defun remove-from-control-list (app panel-id html-id)
- "Remove a control identified by HTML-ID from control-list on PANEL-ID"
- (remhash html-id (get-control-list app panel-id)))
-
-(defun remove-deleted-from-control-list (app panel-id)
- "Remove any deleted control from control-list"
- (maphash (lambda (html-id control)
- (when (equalp (js-query control (format nil "$.contains(document.documentElement, ~A)"
- (clog::script-id control))) "false")
- (remove-from-control-list app panel-id html-id)))
- (get-control-list app panel-id)))
-
-;; Handle per content next-id counts
-
-(defun next-id (content)
- "Get next id for CONTENT"
- (parse-integer (attribute content "data-clog-next-id") :junk-allowed t))
-
-(defun setf-next-id (content id)
- "Store ID on CONTENT"
- (setf (attribute content "data-clog-next-id") (format nil "~A" id)))
-
-(defun incf-next-id (content)
- "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 (clog-obj nil) (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)
- (labels ((my-debugger (condition encapsulation)
- (declare (ignore encapsulation))
- (if clog-obj
- (clog-web-alert (connection-body clog-obj) "Error"
- (format nil "~&Error: ~A" condition)
- :time-out 3))
- (format t "~&Error: ~A" condition)))
- (unless (stringp form)
- (let ((r (make-array '(0) :element-type 'base-char
- :fill-pointer 0 :adjustable t)))
- (with-output-to-string (s r)
- (print form s))
- (setf form r)))
- (let* ((*standard-output* stream)
- (*error-output* stream)
- (*debugger-hook* #'my-debugger)
- (*package* (find-package (string-upcase eval-in-package))))
- (setf eval-result (eval (read-from-string (format nil "(progn ~A)" form))))
- (values
- (format nil "~A~%=>~A~%" result eval-result)
- *package*))))))
-
-;; Local file utilities
-
-(defun read-file (infile &key clog-obj)
- "Read local file named INFILE"
- (handler-case
- (with-open-file (instream infile :direction :input :if-does-not-exist nil)
- (when instream
- (let* ((len (file-length instream))
- (string (make-string len))
- (pos (read-sequence string instream)))
- (subseq string 0 pos))))
- (error (condition)
- (if clog-obj
- (alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
- (format t "Error: ~A" condition)))))
-
-(defun write-file (string outfile &key clog-obj (action-if-exists :rename))
- "Write local file named OUTFILE"
- (check-type action-if-exists (member nil :error :new-version :rename :rename-and-delete
- :overwrite :append :supersede))
- (handler-case
- (with-open-file (outstream outfile :direction :output :if-exists action-if-exists)
- (when outstream
- (write-sequence string outstream)))
- (error (condition)
- (if clog-obj
- (alert-toast clog-obj "File Error" (format nil "Error: ~A" condition))
- (format t "Error: ~A" condition)))))
-
-(defun panel-snap-shot (content panel-id hide-loc)
- "Take a snap shot of panel"
- (with-sync-event (content)
- (let (snap
- (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 ""
- :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"))
- (setf snap (js-query content
- (format nil
- "var z=~a.clone();~
- z.find('*').each(function(){~
- if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~
- if($(this).attr('id') !== undefined && ~
- $(this).attr('id').substring(0,5)=='CLOGB'){$(this).removeAttr('id')}});~
- z.html()"
- (jquery content))))
- (destroy data))
- (maphash
- (lambda (html-id control)
- (declare (ignore html-id))
- (place-after control (get-placer control)))
- (get-control-list app panel-id))
- snap)))
-
-(defun save-panel (fname content panel-id hide-loc)
- "Save panel to FNAME"
- (write-file (panel-snap-shot content panel-id hide-loc) fname :clog-obj content))
-
-;; 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 source 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 (cond ((equalp (pathname-name nfile) "tmpl")
- (format nil "~A~A.~A" out-dir sys-name (pathname-type nfile)))
- ((equalp (pathname-name nfile) "tmpl-tools")
- (format nil "~A~A-tools.~A" out-dir sys-name (pathname-type nfile)))
- (t
- (format nil "~A~A" out-dir nfile)))))
- (write-file (funcall (cl-template:compile-template (read-file src-file :clog-obj panel))
- (list :sys-name sys-name))
- afile :clog-obj panel)
- (when panel
- (create-div panel
- :content (format nil "~A -> ~A"
- src-file afile)))))
- (t
- (uiop:copy-file src-file out-file)
- (when panel
- (create-div panel
- :content (format nil "~A -> ~A"
- src-file out-file)))))))))
-
-;; Control utilities
+;; Control Record Utilities / Plugin Controls API
(defun control-info (control-type-name)
- "Return the control-record for CONTROL-TYPE-NAME from supported controls."
+ "Return the control-record for CONTROL-TYPE-NAME from supported controls. (Exported)"
(if (equal control-type-name "clog-data")
`(:name "clog-data"
:description "Panel Properties"
@@ -357,7 +144,7 @@ create-div's"
(defun add-supported-controls (control-records)
"Add a list of control-records to builder's supported controls. If control exists it is
-replaced."
+replaced. (Exported)"
(dolist (r control-records)
(setf *supported-controls*
(append (remove-if (lambda (x)
@@ -375,545 +162,6 @@ replaced."
(add-select-optgroup pallete (getf control :description))
(add-select-option pallete (getf control :name) (getf control :description))))))
-(defun create-control (parent content control-record uid &key custom-query)
- "Return a new control based on CONTROL-RECORD as a child of PARENT"
- (let* ((create-type (getf control-record :create-type))
- (control-type-name (getf control-record :name))
- (control (cond ((eq create-type :base)
- (funcall (getf control-record :create) parent
- :html-id uid))
- ((eq create-type :custom)
- (funcall (getf control-record :create) parent
- (getf control-record :create-content)
- :html-id uid))
- ((eq create-type :custom-block)
- (let ((c (funcall (getf control-record :create) parent
- :content custom-query
- :html-id uid)))
- (setf (attribute c "data-original-html") custom-query)
- c))
- ((eq create-type :custom-query)
- (funcall (getf control-record :create) parent
- custom-query
- :html-id uid))
- ((eq create-type :paste)
- (let ((c (create-child parent custom-query
- :html-id uid)))
- (setf control-type-name (attribute c "data-clog-type"))
- (when (equalp control-type-name "undefined")
- (setf (attribute c "data-clog-type") "div")
- (setf control-type-name "div"))
- (let ((cr (control-info control-type-name)))
- (change-class c (getf cr :clog-type)))
- c))
- ((eq create-type :element)
- (funcall (getf control-record :create) parent
- :html-id uid
- :content (if (equal (getf control-record :create-content) "")
- ""
- (format nil "~A-~A"
- (getf control-record :create-content)
- (next-id content)))))
- ((eq create-type :form)
- (funcall (getf control-record :create) parent
- (getf control-record :create-param)
- :html-id uid
- :value (if (equal (getf control-record :create-value) "")
- ""
- (format nil "~A-~A"
- (getf control-record :create-value)
- (next-id content)))))
- ((eq create-type :textarea)
- (funcall (getf control-record :create) parent
- :html-id uid
- :value (getf control-record :create-value)))
- (t nil))))
- (when control
- (setf (attribute control "data-clog-type") control-type-name)
- (when (getf control-record :setup)
- (funcall (getf control-record :setup) control content control-record)))
- control))
-
-(defun drop-new-control (app content data &key win)
- "Create new control dropped at event DATA location on CONTENT of WIN"
- ;; any click on panel directly will focus window
- (when win
- (window-focus win))
- (let* ((control-record (control-info (value (select-tool app))))
- (control-type-name (getf control-record :create-type)))
- (cond ((eq control-type-name :custom-query)
- (input-dialog win "Enter html (must have an outer element):"
- (lambda (custom-query)
- (when custom-query
- (do-drop-new-control
- app content data
- :win win
- :custom-query custom-query)))
- :width 500
- :height 300
- :rows 5
- :size 40
- :title "Custom HTML Control"
- :default-value (getf control-record :create-content)))
- ((eq control-type-name :custom-block)
- (input-dialog win "Enter html to create control:"
- (lambda (custom-query)
- (when custom-query
- (do-drop-new-control
- app content data
- :win win
- :custom-query custom-query)))
- :width 500
- :height 300
- :rows 5
- :size 40
- :title "Custom HTML Block"
- :default-value (getf control-record :create-content)))
- (t
- (do-drop-new-control app content data :win win)))))
-
-(defun do-drop-new-control (app content data &key win custom-query)
- "Create new control dropped at event DATA on CONTENT of WIN)"
- ;; create control
- (let* ((control-record (control-info (value (select-tool app))))
- (control-type-name (getf control-record :name))
- (positioning (cond ((or (getf data :ctrl-key)
- (getf data :meta-key))
- :static)
- ((getf control-record :positioning)
- (getf control-record :positioning))
- (t
- :absolute)))
- (parent (when (getf data :shift-key)
- (current-control app)))
- (control (create-control (if parent
- parent
- content)
- content
- control-record
- (format nil "CLOGB~A~A"
- (get-universal-time)
- (next-id content))
- :custom-query custom-query)))
- (cond (control
- ;; panel directly clicked with a control type selected
- ;; setup control
- (setf (attribute control "data-clog-name")
- (format nil "~A-~A" control-type-name (next-id content)))
- (setf (value (select-tool app)) "")
- (setf (box-sizing control) :content-box)
- (setf (positioning control) positioning)
- (set-geometry control
- :left (getf data :x)
- :top (getf data :y))
- (when (equalp (attribute control "data-clog-composite-control") "undefined")
- (add-sub-controls control content :win win))
- (setup-control content control :win win)
- (select-control control)
- (on-populate-control-list-win content :win win)
- (jquery-execute (get-placer content) "trigger('clog-builder-snap-shot')")
- t)
- (t
- ;; panel directly clicked with select tool or no control type to add
- (deselect-current-control app)
- (on-populate-control-properties-win content :win win)
- (on-populate-control-list-win content :win win)
- nil))))
-
-(defun setup-control (content control &key win)
- "Setup CONTROL by creating pacer and setting up events for manipulation"
- (let ((app (connection-data-item content "builder-app-data"))
- (panel-id (html-id content))
- (touch-x 0)
- (touch-y 0)
- (placer (create-div control :auto-place nil
- :class "placer"
- :html-id (format nil "p-~A" (html-id control)))))
- (add-to-control-list app panel-id control)
- (setf (attribute placer "data-panel-id") panel-id)
- ;; setup placer
- (set-geometry placer :top (position-top control)
- :left (position-left control)
- :width (client-width control)
- :height (client-height control))
- (place-after control placer)
- (setf (box-sizing placer) :content-box)
- (setf (positioning placer) :absolute)
- (jquery-execute placer (format nil "draggable({snap:'.placer',snapMode:'inner',cursor:'crosshair'})~
- .resizable({alsoResize:'#~A',autoHide:true})"
- (html-id control)))
- ;; setup placer events
- (setf (tab-index placer) "-1") ; must have a tab-index to accept keyboard input
- (focus placer)
- (set-on-key-down placer
- (lambda (obj data)
- (declare (ignore obj))
- (let ((key (getf data :key))
- (ctrl (getf data :ctrl-key))
- (meta (getf data :meta-key))
- (shift (getf data :shift-key)))
- (cond ((equal key "ArrowUp")
- (if shift
- (set-geometry control :height (1- (height control)))
- (set-geometry control :top (1- (position-top control)))))
- ((equal key "ArrowDown")
- (if shift
- (set-geometry control :height (+ (height control) 2))
- (set-geometry control :top (+ (position-top control) 2))))
- ((equal key "ArrowRight")
- (if shift
- (set-geometry control :width (+ (width control) 2))
- (set-geometry control :left (+ (position-left control) 2))))
- ((equal key "ArrowLeft")
- (if shift
- (set-geometry control :width (1- (width control)))
- (set-geometry control :left (1- (position-left control)))))
- ((and (equal key "c")
- (or meta ctrl))
- (blur placer))
- ((and (equal key "v")
- (or meta ctrl))
- (blur placer))
- ((and (equal key "x")
- (or meta ctrl))
- (blur placer)))
- (set-geometry placer :top (position-top control)
- :left (position-left control)
- :width (client-width control)
- :height (client-height control))
- (jquery-execute placer "trigger('clog-builder-snap-shot')")
- (set-properties-after-geomentry-change control))))
- (set-on-touch-start placer (lambda (obj data)
- (declare (ignore obj))
- (setf touch-x (getf data :X))
- (setf touch-y (getf data :Y))))
- (set-on-touch-move placer (lambda (obj data)
- (declare (ignore obj))
- (set-geometry control :top (+ (position-top control)
- (- (getf data :y) touch-y))
- :left (+ (position-left control)
- (- (getf data :x) touch-x)))
- (setf touch-x (getf data :X))
- (setf touch-y (getf data :Y))))
- (set-on-touch-end placer (lambda (obj data)
- (declare (ignore obj data))
- (set-geometry placer :units ""
- :top (top control)
- :left (left control))
- (select-control control)
- (jquery-execute placer "trigger('clog-builder-snap-shot')")
- (set-properties-after-geomentry-change control)))
- (set-on-mouse-up placer (lambda (obj data)
- (declare (ignore obj data))
- (set-geometry control :units ""
- :top (top placer)
- :left (left placer))
- (set-geometry placer :units ""
- :top (top control)
- :left (left control))
- (select-control control)
- (jquery-execute placer "trigger('clog-builder-snap-shot')")
- (set-properties-after-geomentry-change control)))
- (set-on-mouse-down placer
- (lambda (obj data)
- (declare (ignore obj))
- (let ((last (current-control app))
- (shift (getf data :shift-key)))
- (if (not (equal (value (select-tool app)) ""))
- (when (do-drop-new-control app content data :win win)
- (incf-next-id content)))
- (cond ((and last
- shift)
- (let* ((control1 last)
- (control2 control)
- (placer1 (get-placer control1))
- (placer2 (get-placer control2)))
- (place-inside-bottom-of control1 control2)
- (place-after control2 placer2)
- (place-after control2 placer2)
- (set-geometry placer1 :top (position-top control1)
- :left (position-left control1)
- :width (client-width control1)
- :height (client-height control1))
- (set-geometry placer2 :top (position-top control2)
- :left (position-left control2)
- :width (client-width control2)
- :height (client-height control2)))
- (select-control control)
- (on-populate-control-properties-win content :win win)
- (on-populate-control-list-win content :win win))
- (t
- (select-control control)))
- (when win
- (window-focus win))))
- :cancel-event t)
- (set-on-mouse-double-click placer
- (lambda (obj data)
- (declare (ignore obj data))
- (setf (hiddenp placer) t)
- (on-populate-control-list-win content :win win)))
- (set-on-event placer "resize"
- (lambda (obj)
- (set-properties-after-geomentry-change obj)))
- (set-on-event placer "resizestop"
- (lambda (obj)
- (set-properties-after-geomentry-change obj)
- (jquery-execute placer "trigger('clog-builder-snap-shot')"))
- :cancel-event t)
- (set-on-event placer "drag"
- (lambda (obj)
- (declare (ignore obj))
- (set-geometry control :units ""
- :top (top placer)
- :left (left placer))
- (set-properties-after-geomentry-change control)))))
-
-(defun set-property-display (control property value)
- "Set property in the currently displayed property panel"
- (js-execute control (format nil "$('.clog-prop-~A').text('~A')"
- property value)))
-
-(defun set-properties-after-geomentry-change (control)
- "Set properties window geometry setting"
- (set-property-display control "top" (top control))
- (set-property-display control "left" (left control))
- (set-property-display control "right" (right control))
- (set-property-display control "bottom" (bottom control))
- (set-property-display control "width" (client-width control))
- (set-property-display control "height" (client-height control)))
-
-
-;; Control selection utilities
-
-(defun get-placer (control)
- "Get placer for CONTROL. A placer is a div placed on top of CONTROL and
-prevents access to use or activate the control directy and allows
-manipulation of the control's location and size."
- (when control
- (attach-as-child control (format nil "p-~A" (html-id control)))))
-
-(defun deselect-current-control (app)
- "Remove selection on current control and remove visual ques on its placer."
- (when (current-control app)
- (set-border (get-placer (current-control app)) (unit "px" 0) :none :blue)
- (setf (current-control app) nil)))
-
-(defun delete-current-control (app panel-id html-id)
- "Delete the current control"
- (remove-from-control-list app panel-id html-id)
- (destroy (get-placer (current-control app)))
- (destroy (current-control app))
- (setf (current-control app) nil)
- (remove-deleted-from-control-list app panel-id))
-
-(defun select-control (control)
- "Select CONTROL as the current control and highlight its placer.
-The actual original clog object used for creation must be used and
-not a temporarily attached one when using select-control."
- (let ((app (connection-data-item control "builder-app-data"))
- (placer (get-placer control)))
- (unless (eq control (current-control app))
- (deselect-current-control app)
- (set-geometry placer :top (position-top control)
- :left (position-left control)
- :width (client-width control)
- :height (client-height control))
- (setf (current-control app) control)
- (set-border placer (unit "px" 2) :solid :blue)
- (on-populate-control-properties-win control))))
-
-(defun add-sub-controls (parent content &key win paste)
- "Setup html imported in to CONTENT starting with PARENT for use with Builder"
- (let ((panel-uid (get-universal-time)))
- ;; Assign any elements with no id, an id, name and type
- (let ((tmp (format nil
- "var clog_id=~A; var clog_nid=1;~
- $(~A).find('*').each(function() {var e=$(this);~
- var t=e.prop('tagName').toLowerCase(); var p=e.attr('data-clog-type');~
- if((e.attr('id') === undefined) && (e.attr('data-clog-name') === undefined))~
- {e.attr('id','CLOGB'+clog_id++);~
- e.attr('data-clog-name','none-'+t+'-'+clog_nid++)}~
- if(e.attr('id') === undefined){e.attr('id','CLOGB'+clog_id++)}~
- if(e.attr('data-clog-name') === undefined){e.attr('data-clog-name',e.attr('id'))}~
- ~A ~
- ~{~A~}~
- if(e.attr('data-clog-type') === undefined){e.attr('data-clog-type','span')}})"
- (1+ panel-uid)
- (jquery parent)
- (if paste
- (prog1
- (format nil "e.attr('data-clog-name', e.attr('data-clog-name')+'-'+~A);"
- (next-id content))
- (incf-next-id content))
- "")
- (mapcar (lambda (l)
- (format nil "if(p === undefined && t=='~A'){e.attr('data-clog-type','~A')}"
- (getf l :tag) (getf l :control)))
- *import-types*))))
- (js-execute parent tmp))
- (unless paste
- (let* ((data (first-child content))
- (name (attribute data "data-clog-title"))
- (next-id (attribute data "data-clog-next-id"))
- (slots (attribute data "data-custom-slots"))
- (package (attribute data "data-in-package")))
- (unless (equalp next-id "undefined")
- (setf-next-id content next-id))
- (unless (equalp package "undefined")
- (setf (attribute content "data-in-package") package))
- (unless (equalp slots "undefined")
- (setf (attribute content "data-custom-slots") slots))
- (unless (equalp name "undefined")
- (setf (attribute content "data-clog-name") name)
- (destroy data))))
- (labels ((add-siblings (control)
- (let (dct)
- (loop
- (when (equal (html-id control) "undefined") (return))
- (setf dct (attribute control "data-clog-type"))
- (unless (equal dct "undefined")
- (change-class control (getf (control-info dct) :clog-type))
- (when (getf (control-info dct) :on-load)
- (funcall (getf (control-info dct) :on-load) control (control-info dct)))
- (setup-control content control :win win)
- (unless (equal dct "block")
- (add-siblings (first-child control))))
- (setf control (next-sibling control))))))
- (add-siblings (first-child parent)))))
-
-;; Code rendering utlities
-
-(defun render-clog-code (content 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 creates events)
- (unless (or (equal slots "")
- (equal slots "undefined"))
- (push slots cmembers))
- (maphash (lambda (html-id control)
- (declare (ignore html-id))
- (place-inside-bottom-of hide-loc
- (get-placer control)))
- (get-control-list app panel-id))
- ;; crawl tree
- ;; Insure that on-setup/on-create follow order in tree
- (labels ((add-siblings (control)
- (let (dct)
- (loop
- (unless control (return))
- (when (equal (html-id control) "undefined") (return))
- (setf dct (attribute control "data-clog-name"))
- (unless (equal dct "undefined")
- (setf control (get-from-control-list app panel-id (html-id control)))
- (when control
- (let ((vname (attribute control "data-clog-name"))
- (control-record (control-info (attribute control "data-clog-type"))))
- (unless (and (>= (length vname) 5)
- (equalp (subseq vname 0 5) "none-"))
- ;; Add to members of the panel's class for each control
- (push (format nil
- " \(~A :reader ~A\)~%"
- vname
- vname)
- cmembers)
- ;; On instance of class, set member value for each control
- (push (format nil
- " \(setf (slot-value panel '~A\) ~
- \(attach-as-child clog-obj \"~A\" :clog-type \'~A\ :new-id t)\)~%"
- vname
- (html-id control)
- (format nil "~S" (getf control-record :clog-type)))
- vars)
- ;; On instance of class, set handers defined for each control
- (dolist (event (getf control-record :events))
- ;; Set regular handlers
- (let ((handler (attribute control (format nil "data-~A" (getf event :name)))))
- (unless (or (equalp handler "undefined")
- (equal handler ""))
- (unless (equalp (getf event :name) "on-create")
- (let ((event-package (or (getf event :package) "clog")))
- (push (format nil
- " \(~A:set-~A \(~A panel\) \(lambda \(~A\) \(declare \(ignorable ~A\)\) ~A\)\)~%"
- event-package
- (getf event :name)
- vname
- (getf event :parameters)
- (getf event :parameters)
- handler)
- events))))))
- ;; Set on-create (from user in builder) and on-setup (from control-record)
- (let ((handler (attribute control "data-on-create")))
- (when (equalp handler "undefined")
- (setf handler ""))
- (when (getf control-record :on-setup)
- (setf handler (format nil "~A~A"
- (funcall (getf control-record :on-setup)
- control control-record)
- handler)))
- (unless (equal handler "")
- (push (format nil
- " \(let \(\(target \(~A panel\)\)\) ~
- \(declare \(ignorable target\)\) ~
- ~A\)~%"
- vname
- handler)
- creates)))))
- (add-siblings (first-child control))))
- (when control
- (setf control (next-sibling control)))))))
- (add-siblings (first-child content)))
- (let ((result (format nil
- "\(in-package :~A)
-\(defclass ~A \(clog:clog-panel\)
- \(~{~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~}~{~A~} panel\)\)~%"
- (string-downcase package)
- cname ;;defclass
- cmembers
- cname ;;defun
- (ppcre:regex-replace-all "\""
- (js-query content
- (format nil
- "var z=~a.clone();~
- z.find('*').each(function(){~
- var m=$(this).attr('data-clog-name');
- if($(this).attr('data-clog-composite-control') == 't'){$(this).text('')}~
- if($(this).attr('data-clog-composite-control') == 'b'){$(this).html($(this).attr('data-original-html'))}~
- for(n in $(this).get(0).dataset){delete $(this).get(0).dataset[n]}~
- if(m){$(this).attr('data-clog-name', m);}~
- });~
- z.html()"
- (jquery content)))
- "\\\"")
- cname
- vars
- (reverse creates) ; Insure that on-setup/on-create follow order in tree
- (reverse events))))
- (maphash (lambda (html-id control)
- (declare (ignore html-id))
- (place-after control (get-placer control)))
- (get-control-list app panel-id))
- ;; prety print the code
- (let ((r (make-array '(0) :element-type 'base-char
- :fill-pointer 0 :adjustable t)))
- (with-output-to-string (s r)
- (with-input-from-string (n result)
- (let ((*standard-output* s)
- (*print-case* :downcase))
- (format t ";;;; CLOG Builder generated code - modify original .clog file and rerender")
- (loop
- (let ((l (read n nil)))
- (unless l (return))
- (pprint l))))))
- r))))
-
;; Population of utility windows
(defun on-populate-control-events-win (obj)
@@ -988,7 +236,7 @@ not a temporarily attached one when using select-control."
(on-populate-control-ps-events-win obj)
(on-populate-control-js-events-win obj))
- (defun on-populate-control-js-events-win (obj)
+(defun on-populate-control-js-events-win (obj)
"Populate the control js events for the current control"
(let* ((app (connection-data-item obj "builder-app-data"))
(event-win (control-js-events-win app))
@@ -1058,7 +306,7 @@ not a temporarily attached one when using select-control."
(set-on-blur (event-js-editor app) #'on-blur)))))))
(populate-options)))))))
- (defun on-populate-control-ps-events-win (obj)
+(defun on-populate-control-ps-events-win (obj)
"Populate the control ps events for the current control"
(let* ((app (connection-data-item obj "builder-app-data"))
(event-win (control-ps-events-win app))
@@ -1252,11 +500,6 @@ not a temporarily attached one when using select-control."
:width (client-width control)
:height (client-height control)))))))))))))
-(defun on-populate-loaded-window (content &key win)
- "Setup html imported in to CONTENT for use with Builder"
- (with-sync-event (content)
- (add-sub-controls content content :win win)))
-
(defun on-populate-control-list-win (content &key win)
"Populate the control-list-window to allow drag and drop adjust of order
of controls and double click to select control."
@@ -1350,375 +593,7 @@ of controls and double click to select control."
(setf control (next-sibling control))))))
(add-siblings (first-child content) ""))))))))
-;; Editor Utilities
-
-(defun setup-lisp-ace (editor status &key (package "CLOG-USER"))
- (let ((app (connection-data-item editor "builder-app-data")))
- ;; currently there is only one auto complete event for page
- (unless (auto-complete-configured app)
- (clog-ace:set-on-auto-complete editor
- (lambda (obj prefix)
- (declare (ignore obj))
- (when (current-editor-is-lisp app)
- ;; we needed to modify Ace's lisp mode to treat : as part of symbol
- ;; otherwise lookups do not consider the symbols package. I did
- ;; using code mathod but then the automatic replace is only on the symbol
- (let* ((p (when (current-control app)
- (attribute (get-placer (current-control app)) "data-panel-id")))
- (s (if (eq (current-editor-is-lisp app) t)
- (if (current-control app)
- (string-upcase (attribute (attach-as-child (current-control app) p)
- "data-in-package"))
- "CLOG-USER")
- (current-editor-is-lisp app)))
- (l (car (swank:simple-completions prefix s))))
- (when (current-control app)
- (let ((n (get-control-list app p)))
- (when n
- (maphash (lambda (k v)
- (declare (ignore k))
- (let ((name (attribute v "data-clog-name")))
- (push `(:caption ,name :value ,(format nil "(~A panel)" name)
- :meta "control")
- l)))
- n)
- (push '(:caption "target" :value "target"
- :meta "builder")
- l)
- (push '(:caption "panel" :value "panel"
- :meta "builder")
- l))))
- l)))
- :meta "swank"))
- ;; run apropos on symbol
- (js-execute editor
- (format nil
- "~A.commands.addCommand({
- name: 'find-definition',
- bindKey: {win: 'Alt-.', mac: 'Command-.'},
- exec: function(editor) {
- var row = editor.selection.getCursor().row;
- var column = editor.selection.getCursor().column;
- var c;
- while (column > 0) {
- c=editor.session.getTextRange(new ace.Range(row, column-1, row, column));
- if (c=='(' || c==' ') { break; }
- column--;
- }
- var s=column;
- while (column < 200) {
- c=editor.session.getTextRange(new ace.Range(row, column, row, column+1));
- if (c==')' || c==' ') { break; }
- column++;
- }
- c = editor.session.getTextRange(new ace.Range(row, s, row, column));
- ~A.trigger('clog-find', c);
- },
- readOnly: true,
-});"
- (clog-ace::js-ace editor)
- (jquery editor)))
- (set-on-event-with-data editor "clog-find"
- (lambda (obj data)
- (declare (ignore obj))
- (when (current-editor-is-lisp app)
- (on-new-sys-browser editor :search data))))
- ;; setup save key
- (js-execute editor
- (format nil
- "~A.commands.addCommand({
- name: 'save-ace',
- bindKey: {win: 'Ctrl-s', mac: 'Command-s'},
- exec: function(editor) {
- ~A.trigger('clog-save-ace');
- },
- readOnly: true,
-});"
- (clog-ace::js-ace editor)
- (jquery editor)))
- ;; eval form
- (js-execute editor
- (format nil
- "~A.commands.addCommand({
- name: 'eval-form',
- bindKey: {win: 'Alt-[', mac: 'Command-['},
- exec: function(editor) {
- var position = editor.session.doc.positionToIndex (editor.selection.getCursor(), 0);
- ~A.trigger('clog-eval-form', position);
- },
- readOnly: true,
-});"
- (clog-ace::js-ace editor)
- (jquery editor)))
- (set-on-event-with-data editor "clog-eval-form"
- (lambda (obj data)
- (declare (ignore obj))
- (let ((p (parse-integer data :junk-allowed t))
- (tv (text-value editor))
- (pk "CLOG-USER")
- (lf nil)
- (cp 0))
- (loop
- (setf (values lf cp) (read-from-string tv nil nil :start cp))
- (unless lf (return nil))
- (when (eq (car lf) 'in-package)
- (setf pk (second lf)))
- (when (> cp p) (return lf)))
- (when lf
- (let ((result (capture-eval lf
- :clog-obj (connection-body editor)
- :eval-in-package (format nil "~A" pk))))
- (clog-web-alert (connection-body editor) "Result"
- (format nil "~&result: ~A" result)
- :color-class "w3-green"
- :time-out 3))))))
- ;; macroexpand
- (js-execute editor
- (format nil
- "~A.commands.addCommand({
- name: 'macroexp',
- bindKey: {win: 'Alt-m', mac: 'Option-m'},
- exec: function(editor) {
- var position = editor.session.doc.positionToIndex (editor.selection.getCursor(), 0);
- ~A.trigger('clog-macroexp', position);
- },
- readOnly: true,
-});"
- (clog-ace::js-ace editor)
- (jquery editor)))
- (set-on-event-with-data editor "clog-macroexp"
- (lambda (obj data)
- (let ((p (parse-integer data :junk-allowed t))
- (tv (text-value editor))
- (lf nil)
- (cp 0))
- (loop
- (setf (values lf cp) (read-from-string tv nil nil :start cp))
- (unless lf (return nil))
- (when (> cp p) (return lf)))
- (let ((result (handler-case
- (prin1-to-string (macroexpand lf))
- (error (condition)
- (format nil "Error: ~A" condition)))))
- (on-open-file obj :title-class "w3-blue" :title "macroexpand result" :text result)))))
- ;; expand-region
- (js-execute editor
- (format nil
- "~A.commands.addCommand({
- name: 'expand-region',
- bindKey: {win: 'Ctrl-=', mac: 'Control-='},
- exec: function(editor) {
- var currentRange = editor.selection.getAllRanges()[0];
- var start = editor.session.doc.positionToIndex(currentRange.start);
- var end = editor.session.doc.positionToIndex(currentRange.end);
- var positions = '(' + start + ' ' + end + ')'
- ~A.trigger('clog-expand-region', positions);
- },
- readOnly: true,
-});"
- (clog-ace::js-ace editor)
- (jquery editor)))
- (set-on-event-with-data editor "clog-expand-region"
- (lambda (obj data)
- (declare (ignore obj))
- (let* ((positions (read-from-string data))
- (new-region
- (judge-expand-region (text-value editor)
- (car positions)
- (cadr positions))))
- (js-execute editor
- (format nil
- "var startIndex = ~A;
-var endIndex = ~A;
-var startRange = ~A.session.doc.indexToPosition(startIndex);
-var endRange = ~:*~A.session.doc.indexToPosition(endIndex);
-~:*~A.selection.setRange(new ace.Range(startRange.row, startRange.column, endRange.row, endRange.column));"
- (car new-region)
- (cdr new-region)
- (clog-ace::js-ace editor))))))
-
- (set-on-change editor
- (lambda (obj)
- (let ((s (js-query obj (format nil
- "var row = ~A.selection.getCursor().row; ~
- var column = ~A.selection.getCursor().column; ~
- var o = column;
- var c; var charRange; var b=0; ~
- while (column > 0) {
- column--;
- charRange = new ace.Range(row, column-1, row, column); ~
- c = ~A.session.getTextRange(charRange); ~
- if (c==')') { b++ } ~
- if (c=='(' && b==0) { ~
- charRange = new ace.Range(row, column, row, o); column=0;~
- c = ~A.session.getTextRange(charRange);} ~
- if (c=='(' && b > 0) { b-- } }~
- c"
- (clog-ace::js-ace obj)
- (clog-ace::js-ace obj)
- (clog-ace::js-ace obj)
- (clog-ace::js-ace obj)))))
- (unless (equal s "")
- (with-input-from-string (i s)
- (ignore-errors
- (let* ((pac (if (or (eq (current-editor-is-lisp app) t)
- (eq (current-editor-is-lisp app) nil))
- "CLOG-USER"
- (string-upcase (current-editor-is-lisp app))))
- (m (read i))
- (*PACKAGE* (find-package pac))
- (SWANK::*buffer-package* (find-package pac))
- (SWANK::*buffer-readtable* *readtable*)
- (ms (format nil "~A" m))
- r)
- (ignore-errors
- (setf r (swank::autodoc `(,ms swank::%CURSOR-MARKER%))))
- (if r
- (setf r (car r))
- (setf r (swank:operator-arglist ms package)))
- (when status
- (setf (advisory-title status) (documentation (find-symbol ms) 'function)))
- (when r
- (when status
- (setf (text status) (string-downcase r)))))))))))
- (clog-ace:set-auto-completion editor t)
- (setf (clog-ace:theme editor) *editor-theme*)
- (setf (clog-ace:mode editor) *editor-mode*)
- (setf (clog-ace:tab-size editor) *editor-tab-size*)
- (js-execute editor
- (format nil "~A.setKeyboardHandler('~A')"
- (clog-ace::js-ace editor)
- *editor-keybinding*))
- (js-execute editor
- (format nil "~A.setOptions({~A})"
- (clog-ace::js-ace editor)
- *editor-renderer-options*))))
-
-(defun get-package-from-string (c)
- "Determine the currect package based on src contained in string C"
- (with-input-from-string (ins c)
- (loop
- (let ((form (read ins nil)))
- (unless form (return "clog-user"))
- (unless (consp form) (return "clog-user"))
- (when (eq (car form) 'in-package)
- (return (string-downcase (second form))))))))
-
-;; Expand region
-
-(defun scan-exps (text)
- "Scan all expressions (and strings) in the text, return a list of start-end cons.
-
-It parse the string TEXT without using READ functions."
- (let ((char-count 0)
- (backslash 0)
- exps in-dquotes-p left-dquote left-braces left-brackets)
- (loop for c across text do
- (if (= backslash 0) ;current char isn't after a backslash
- (if (eql c #\\)
- (incf backslash) ;if it is a backslash, mark for the next word
- (if (eql c #\") ;if it is double quote,
- (if in-dquotes-p ;end the last string or start a new string
- (progn (setf in-dquotes-p nil)
- (push (cons left-dquote (1+ char-count))
- exps))
- (setf in-dquotes-p t
- left-dquote char-count))
- (if (not in-dquotes-p) ;if it isn't double quote,
- (case c ;check if it's braces
- (#\( (push char-count left-braces)) ;mark a new pair
- (#\) (if left-braces ;end a pair
- (push (cons (pop left-braces) (1+ char-count))
- exps)))
- (#\[ (push char-count left-brackets))
- (#\] (if left-brackets
- (push (cons (pop left-brackets) (1+ char-count))
- exps)))))))
- (decf backslash))
- (incf char-count))
- exps))
-
-(defun judge-expand-region (text start end)
- "Judge the next wider region to expand to."
- (declare (string text) (number start) (number end))
- (let ((selected (subseq text start end)))
- (or (let ((word-range ;expand to current word
- (ignore-errors
- (let* ((edge-scanner (ppcre:create-scanner "[^\\w]")))
- (if (not (ppcre:scan edge-scanner selected)) ;there isn't word edge in selected
- (cons (- start ;search for previous word edge
- (or (car (ppcre:all-matches
- edge-scanner
- (reverse (subseq text 0 start))))
- start)) ;if nothing, mark from beginning to end.
- (+ end ;search for next word edge
- (or (car (ppcre:all-matches edge-scanner
- (subseq text end)))
- (- (length text) end)))))))))
- (if (not (equal word-range (cons start end)))
- word-range)) ;return if it isn't same with selected
- (let ((symbol-range ;expand to current symbol
- ;; just like expand to word, but search for blanks, braces and double quote.
- (ignore-errors
- (let* ((edge-scanner (ppcre:create-scanner "[\\s\\(\\)\\[\\]\"]")))
- (if (not (ppcre:scan edge-scanner selected))
- (cons (- start
- (or (car (ppcre:all-matches edge-scanner
- (reverse (subseq text 0 start))))
- start))
- (+ end
- (or (car (ppcre:all-matches edge-scanner
- (subseq text end)))
- (- (length text) end)))))))))
- (if (not (equal symbol-range (cons start end)))
- symbol-range))
- (alexandria:if-let ;expand to curren expression/string
- ((sexp (ignore-errors
- (car (sort (delete nil
- (mapcar ;find wider expressions contained selected
- #'(lambda (pair)
- (if (or (and (< (car pair) start)
- (> (cdr pair) end))
- (and (= (car pair) start)
- (> (cdr pair) end))
- (and (< (car pair) start)
- (= (cdr pair) end)))
- pair))
- (scan-exps text)))
- #'(lambda (obj1 obj2) ;sort it to find the smallest
- (> (car obj1) (car obj2))))))))
- (if (or (= (car sexp) start) ;judge "inner" or "outer" to select
- (= (cdr sexp) end)
- (and (= (1+ (car sexp)) start)
- (= (1- (cdr sexp)) end)))
- sexp
- (cons (1+ (car sexp)) (1- (cdr sexp))))
- (cons start end))))) ;if no expressions, select all
-
-;; Menu handlers
-
-(defun do-eval (obj form-string cname &key (package "clog-user") custom-boot)
- "Render, evalute and run code for panel"
- (let* ((result (capture-eval (format nil "~A~% (clog:set-on-new-window~
- (lambda (body)~
- (clog:debug-mode body)~
- ~A
- (create-~A body)) ~A:path \"/test\")"
- form-string
- (if custom-boot
- ""
- "(clog-gui:clog-gui-initialize body)
- (clog-web:clog-web-initialize body :w3-css-url nil)")
- cname
- (if custom-boot
- (format nil ":boot-file \"~A\" " custom-boot)
- ""))
- :eval-in-package package)))
- (if *app-mode*
- (open-browser :url (format nil "http://127.0.0.1:~A/test" *clog-port*))
- (open-window (window (connection-body obj))
- (format nil "/test" *clog-port*)))
- (on-open-file obj :title-class "w3-yellow" :title "test eval" :text result)))
+;; Show utility windows
(defun on-show-control-properties-win (obj)
"Show control properties window"
@@ -2839,7 +1714,7 @@ It parse the string TEXT without using READ functions."
"
+ (c) 2022-2024 - David Botton"
img-clog-icon)
:width 200
:height 215