Commit 8a98e6dd authored by Dave Cooper's avatar Dave Cooper
Browse files

fixed duplicate submit in tasty inspector show-settables.

parent f49f866f
......@@ -216,7 +216,7 @@
(when (the settables-form show-settables?)
(htm (:tr ((:td :colspan 2)
(str (the settables-form main-div))))))
(str (the settables-form inner-html))))))
(let ((count -1))
(dolist (value-inspector (list-elements (the values)))
......@@ -439,8 +439,9 @@
(submit-fields-button :type 'button-form-control
:label " OK "
:onclick (the (gdl-ajax-call
:form-controls (list-elements (the form-fields)))))
:onclick nil #+nil
(the (gdl-ajax-call
:form-controls (list-elements (the form-fields)))))
(form-fields :type 'text-form-control
:pseudo-inputs (keyword)
......@@ -461,7 +462,8 @@
;; FLAG -- Comment this out to disable ajax submittal
;;
:ajax-submit-on-change? t
;;:ajax-submit-on-enter? t
:domain :pass-thru
:keyword (nth (the-child index)(the settables))
:default (with-error-handling ()
......
......@@ -510,62 +510,62 @@ from
value
(cons 'the (append (reverse (the-object (first *notify-cons*) root-path))
(list (make-keyword (second *notify-cons*)))))))
(unless (eql attribute :%primary?%)
(when (not *run-with-dependency-tracking?*)
(error "Dependency Tracking must be enabled in order to forcibly
(progn ;; bt:with-lock-held (*binding-lock*) FLAG - bring in later in bootstrapping.
(unless (eql attribute :%primary?%)
(when (not *run-with-dependency-tracking?*)
(error "Dependency Tracking must be enabled in order to forcibly
set slot values.
Please setq the variable `*run-with-dependency-tracking?*' to T,
make a fresh root-level object, and start again."))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(list value nil t)))
(when remember?
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
(root-path (the root-path)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(pushnew (list root-path)
(gdl-acc::%version-tree% root)
:test #'equalp
:key #'(lambda(item) (list (first item))))
(let (*leaf-resets*)
(let ((slot (glisp:intern (symbol-name attribute) :gdl-acc)))
(unbind-dependent-slots self slot)
(setf (slot-value self slot)
(list value nil t)))
(when remember?
(let ((root (let ((maybe-root (the :root)))
(if (the-object maybe-root root?)
maybe-root
(the-object maybe-root parent))))
(root-path (the root-path)
;;(remove :root-object-object (the root-path))
;;(the root-path)
))
(pushnew (list root-path)
(gdl-acc::%version-tree% root)
:test #'equalp
:key #'(lambda(item) (list (first item))))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2))))))
(setf (gdl-acc::%version-tree% root)
(sort (gdl-acc::%version-tree% root)
#'(lambda(item1 item2)
(< (length (first item1)) (length (first item2))))))
(when (the primary?)
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) :%primary?%)
t))
(let ((non-root (remove nil (gdl-acc::%version-tree% root) :key #'first))
(root-list (find nil (gdl-acc::%version-tree% root) :key #'first)))
(let ((primaries (remove-if-not #'(lambda(item)
(getf (rest item) :%primary?%))
non-root))
(non-primaries (remove-if #'(lambda(item)
(getf (rest item) :%primary?%))
non-root)))
(setf (gdl-acc::%version-tree% root)
(cons (or root-list (list nil))
(append primaries non-primaries)))))
(when (the primary?)
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) :%primary?%)
t))
(let ((non-root (remove nil (gdl-acc::%version-tree% root) :key #'first))
(root-list (find nil (gdl-acc::%version-tree% root) :key #'first)))
(let ((primaries (remove-if-not #'(lambda(item)
(getf (rest item) :%primary?%))
non-root))
(non-primaries (remove-if #'(lambda(item)
(getf (rest item) :%primary?%))
non-root)))
(setf (gdl-acc::%version-tree% root)
(cons (or root-list (list nil))
(append primaries non-primaries)))))
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) attribute)
value)))
(setf (getf (rest (assoc root-path (gdl-acc::%version-tree% root) :test #'equalp)) attribute)
value)))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset))))))))
(when *eager-setting-enabled?*
(dolist (reset *leaf-resets*)
(the-object (first reset) (evaluate (second reset)))))))))
(modify-attribute!
......@@ -886,6 +886,10 @@ a separate object hierarchy." object self)))
(defparameter *unbound-slots* nil)
;;
;; FLAG -- bring this in later in bootstrapping when we have bordeaux-threads.
;;
;;(defparameter *binding-lock* (bt:make-lock "unbinding-lock"))
(defun unbind-dependent-slots (object slot &key updating?)
(let ((*unbound-slots* (glisp:make-sans-value-equalp-hash-table)))
......@@ -900,28 +904,32 @@ a separate object hierarchy." object self)))
(setf (gethash (list object slot) *unbound-slots*) t)
(if (slot-exists-p object slot)
(let ((slot-value (slot-value object slot)))
(when (not (eq (first (ensure-list slot-value)) 'gdl-rule::%unbound%))
(when (not (eq (first (ensure-list slot-value)) 'gdl-rule:%unbound%))
(when (and *eager-setting-enabled?* (null (second slot-value)))
(push (list object slot) *leaf-resets*))
(let ((list-or-hash (second (slot-value object slot))))
(let ((list-or-hash (second slot-value)))
(if (listp list-or-hash)
(mapc #'(lambda(notify-cons)
(destructuring-bind (node . messages) notify-cons
(mapc #'(lambda(message)
(%unbind-dependent-slots% node message :updating? updating?)) messages))) list-or-hash)
(%unbind-dependent-slots% node message
:updating? updating?))
messages))) list-or-hash)
(maphash #'(lambda(node messages)
(mapc #'(lambda(message)
(%unbind-dependent-slots% node message :updating? updating?)) messages)) list-or-hash)))
(setf (second (slot-value object slot)) nil)
(when (not (third slot-value))
(setf (slot-value object slot)
(if (or updating? (not *remember-previous-slot-values?*))
'gdl-rule::%unbound%
(list 'gdl-rule::%unbound% nil nil (first (slot-value object slot))))))))
(when (and (find-class 'gdl-remote nil) (typep object 'gdl-remote))
(the-object object (unbind-remote-slot slot)))))))
(%unbind-dependent-slots% node message
:updating? updating?))
messages)) list-or-hash)))
(if (third slot-value)
(setf (second (slot-value object slot)) nil)
(setf (slot-value object slot)
(if (or updating? (not *remember-previous-slot-values?*))
'gdl-rule::%unbound%
(list 'gdl-rule::%unbound% nil nil (first (slot-value object slot))))))))
(when (and (find-class 'gdl-remote nil) (typep object 'gdl-remote))
(the-object object (unbind-remote-slot slot)))))))
#+nil
......
......@@ -69,15 +69,17 @@
new-self)))
(defparameter *new-debug?* nil)
(defun gdlAjax (req ent)
(let* ((query-plist (gwl::assoc-list-to-plist (request-query req)))
(plist (progn (when *debug?* (print-variables query-plist))
(read-safe-string
(base64-decode-safe (coerce (getf query-plist :|args|) 'string)))))
(plist (progn ;;(when *debug?* (print-variables query-plist))
(when *new-debug?* (print-variables query-plist))
(read-safe-string
(base64-decode-safe (coerce (getf query-plist :|args|) 'string)))))
(fields
(progn (when *debug?* (print-variables plist))
(progn (when *new-debug?* (print-variables plist))
(let ((encoded-fields
(read-safe-string
(base64-decode-safe (coerce (getf query-plist :|fields|)
......
......@@ -300,7 +300,8 @@ and the error string will be appended to the html-string by default. </li>
;;(list :validated-value value :error nil)
))
(ajax-submit-on-change? nil)
("Boolean. If set to non-nil, this field's value will be sent to server upon change. Default is nil." ajax-submit-on-change? nil)
("Boolean. If set to non-nil, this field's value will be sent to server upon enter. Default is nil." ajax-submit-on-enter? nil)
("String. Text to place in the field by default, overwritten as soon as the field is selected. Works only in HTML5. Default is nil." placeholder nil)
("Boolean. Maps to HTML form control attribute of the same name. Default is nil." disabled? nil)
......@@ -316,8 +317,10 @@ and the error string will be appended to the html-string by default. </li>
("String or nil. Maps to HTML form control attribute of the same name. Default is nil." onfocus nil)
("String or nil. Maps to HTML form control attribute of the same name. Default is nil." onblur nil)
("String or nil. Maps to HTML form control attribute of the same name. Default is nil." onselect nil)
("String or nil. Maps to HTML form control attribute of the same name. Default is nil."
("String or nil. Maps to HTML form control attribute of the same name. Default is nil, unless ajax-submit-on-change? is non-nil, in which case it calls ajax to set current form value."
onchange (when (the ajax-submit-on-change?) (the parent (gdl-ajax-call :form-controls (list self)))))
("String or nil. Maps to HTML form control attribute of the same name. Default is nil, unless ajax-submit-on-enter? is non-nil, in which case it calls ajax to set current form value."
onenter (when (the ajax-submit-on-enter?) (the parent (gdl-ajax-call :form-controls (list self)))))
("String or nil. Maps to HTML form control attribute of the same name. Default is nil." onclick nil)
("String or nil. Maps to HTML form control attribute of the same name. Default is nil." ondblclick nil)
("String or nil. Maps to HTML form control attribute of the same name. Default is nil." onmousedown nil)
......
......@@ -171,10 +171,12 @@ the browser in development mode). Defaults to NIL (the empty list)."
("String. The web address in the current session which points at this page. Published on demand."
url (let ((url
(if (the plain-url?) (format nil "~a/~a"
(if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "")
(the (compute-url)))
(format nil "~a/sessions/~a/~a" (if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "")
(if (the plain-url?)
(format nil "~a/~a"
(if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "")
(the (compute-url)))
(format nil "~a/sessions/~a/~a" (if (the fixed-url-prefix)
(format nil "/~a" (the fixed-url-prefix)) "")
(the :instance-id) (the (compute-url))))))
(publish
:path url
......@@ -250,10 +252,21 @@ the submitted form fields automatically."
escaped-strings-for-display))))
url))
(url-base
()
(if (the root?)
""
(string-append (the parent url-base)
(string-downcase (glisp:replace-regexp (the strings-for-display)
"\\s"
"-")) "/")))
(compute-url
()
(compute-url (the root-path)))
(string-append (the url-base) "index.html")
;;(compute-url (the root-path))
)
(set-self ()
(if *break-on-set-self?*
......
......@@ -82,9 +82,11 @@ FLAG -- fill in.
(let ((%enctype% (gensym))
(fixed-prefix (gensym)))
;;(fixed-prefix (gensym))
)
`(let ((,%enctype% (cond (,enctype ,enctype) (,multipart? "multipart/form-data")))
(,fixed-prefix (the fixed-url-prefix)))
;;(,fixed-prefix (the fixed-url-prefix))
)
(,@(if cl-who? '(with-html-output (*stream* nil :indent t))
'(html
......
......@@ -44,9 +44,6 @@
(read-from-string component)) result-list)))
(t (push (make-keyword component) result-list))))))
;;
;; FLAG -- start using ensure-keyword here.
;;
......@@ -64,14 +61,18 @@
(components (split url #\/))
(cookies (unless (string-equal (first components) "sessions")
(get-cookie-values req))))
(let* ((hash-entry (gethash (ensure-keyword (or instance-id
(cdr (assoc "iid" cookies :test #'string-equal))
(second components)))
*instance-hash-table*))
(root-object (first hash-entry)) (skin (third hash-entry))
(let* ((hash-entry
(or (gethash (ensure-keyword (or instance-id
(cdr (assoc "iid" cookies :test #'string-equal))
(second components)))
*instance-hash-table*)
(error "object not found - must add logic to create new instance~%")))
(root-object (first hash-entry)) (skin (third hash-entry))
(root-path (multiple-value-bind (value found?) (gethash url *descriptive-url-hash*)
(if found? value
(compute-root-path (reverse (if instance-id components (rest (rest components))))))))
(compute-root-path
(reverse (if instance-id components (rest (rest components))))))))
(respondent (when root-object (the-object root-object (follow-root-path root-path)))))
(when *debug?* (print-variables components instance-id root-object root-path respondent))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment