Commit 5ca5528a authored by Dave Cooper's avatar Dave Cooper
Browse files

added context-menu everywhere

parent 758d69c6
......@@ -407,3 +407,26 @@ This function will be run in the initiating image after the build is finished."
(define-object-amendment vanilla-mixin ()
:functions
((toggle-slot! (slot) (the (set-slot! slot (not (the (evaluate slot))))))))
(defun reserved-words-for (mixins)
(apply #'append
(mapcar
#'(lambda(mixin)
(when (member (glisp:intern (package-name (symbol-package mixin)) :keyword) *packages-to-lock*)
(or (gethash mixin *reserved-words-hash*)
(setf (gethash mixin *reserved-words-hash*)
(mapcar
#'(lambda(word) (glisp:intern word :gdl-acc))
(set-difference
(the-object (make-object mixin) message-list)
(append
(the-object (make-object mixin) (message-list :category :hidden-objects))
(the-object (make-object mixin) (message-list :category :functions))
(the-object (make-object mixin) (message-list :category :required-input-slots))
(the-object (make-object mixin) (message-list :category :optional-input-slots))
(the-object (make-object mixin) (message-list :category :settable-optional-input-slots))
(the-object (make-object mixin) (message-list :category :defaulted-input-slots))
(the-object (make-object mixin) (message-list :category :settable-defaulted-input-slots)))))))))
mixins)))
......@@ -29,7 +29,7 @@
excl:without-package-locks
#-allegro progn
(defun publish-gwl-app (path string-or-symbol &key publish-args make-object-args (server *wserver*))
"Void. Publishes an application, optionally with some initial arguments to be passed in as input-slots.
"Void. Publishes an application, optionally with some initial arguments to be passed in as input-slots.
:arguments (path \"String. The URL pathname component to be published.\"
string-or-symbol \"String or symbol. The object type to insantiate.\")
......@@ -37,15 +37,15 @@
:&key (make-object-args \"Plist. Extra arguments to pass to make-object.\")
"
(apply #'publish
:path path
:server server
:function #'(lambda(req ent)
(gwl-make-object req ent
(format nil (if (stringp string-or-symbol) "~a" "~s")
string-or-symbol)
:make-object-args make-object-args))
publish-args)))
(apply #'publish
:path path
:server server
:function #'(lambda(req ent)
(gwl-make-object req ent
(format nil (if (stringp string-or-symbol) "~a" "~s")
string-or-symbol)
:make-object-args make-object-args))
publish-args)))
......@@ -56,167 +56,167 @@
excl:without-package-locks
#-allegro
progn
(defun answer (req ent)
(let ((query (request-query req)))
(defun answer (req ent)
(let ((query (request-query req)))
(when *debug?* (format t "before multi-part processing, query is: ~s~%" query))
(when *debug?* (format t "before multi-part processing, query is: ~s~%" query))
(when (null query) (setq query (process-multipart-submission req)))
(when (null query) (setq query (process-multipart-submission req)))
(when gwl::*debug?* (print-variables query))
(when gwl::*debug?* (print-variables query))
(let* ((requestor (query-arg-to-root-path query "requestor"))
(iid (make-keyword
(rest (assoc "iid" query :test #'string-equal))))
(hash-entry (gethash iid *instance-hash-table*))
;;
;; FLAG -- patch starts
;;
(let* ((requestor (query-arg-to-root-path query "requestor"))
(iid (make-keyword
(rest (assoc "iid" query :test #'string-equal))))
(hash-entry (gethash iid *instance-hash-table*))
;;
;; FLAG -- patch starts
;;
(root-object (or (first hash-entry)
(restore-from-snap iid)))
(skin (third hash-entry))
(root-object (or (first hash-entry)
(restore-from-snap iid)))
(skin (third hash-entry))
;;
;; FLAG -- patch ends
;;
(recovery-object? (typep root-object 'session-recovery))
(requestor (when (and root-object (not recovery-object?))
(the-object root-object
(follow-root-path requestor))))
(bashee (when requestor (the-object requestor bashee)))
(rest-plist (when (not recovery-object?)
(merge-plist-duplicates
(assoc-list-to-plist
(remove-if
#'(lambda(item)
(member (first item)
(list "requestor" "iid")
:test #'string-equal)) query)
:case-sensitive? t))))
(possible-nils (when (not recovery-object?)
(the-object requestor possible-nils)))
(rest-plist (when requestor
(append rest-plist
(mapcan #'(lambda(key) (list key nil))
(set-difference possible-nils
(plist-keys rest-plist))))))
(settables (when bashee (the-object bashee %settable-slots%)))
(rest-keys (plist-keys rest-plist))
(query-plist (mapcan #'(lambda(key) (list key (getf rest-plist key)))
(remove-if #'(lambda(key) (gethash (make-keyword-sensitive key) settables)) rest-keys))))
;;
;; FLAG -- patch ends
;;
(recovery-object? (typep root-object 'session-recovery))
(requestor (when (and root-object (not recovery-object?))
(the-object root-object
(follow-root-path requestor))))
(bashee (when requestor (the-object requestor bashee)))
(rest-plist (when (not recovery-object?)
(merge-plist-duplicates
(assoc-list-to-plist
(remove-if
#'(lambda(item)
(member (first item)
(list "requestor" "iid")
:test #'string-equal)) query)
:case-sensitive? t))))
(possible-nils (when (not recovery-object?)
(the-object requestor possible-nils)))
(rest-plist (when requestor
(append rest-plist
(mapcan #'(lambda(key) (list key nil))
(set-difference possible-nils
(plist-keys rest-plist))))))
(settables (when bashee (the-object bashee %settable-slots%)))
(rest-keys (plist-keys rest-plist))
(query-plist (mapcan #'(lambda(key) (list key (getf rest-plist key)))
(remove-if #'(lambda(key) (gethash (make-keyword-sensitive key) settables)) rest-keys))))
(let ((respondent (the-object requestor respondent)))
(let ((respondent (the-object requestor respondent)))
(the-object respondent root (set-remote-host! req))
(the-object respondent root (set-remote-host! req))
(unless (the-object respondent root do-security-check)
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(unless (the-object respondent root do-security-check)
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)
(let ((*req* req) (*ent* ent))
(the-object respondent root security-check-failed write-html-sheet))))
(return-from answer nil)))
(with-http-body (req ent)
(let ((*req* req) (*ent* ent))
(the-object respondent root security-check-failed write-html-sheet))))
(return-from answer nil)))
(when gwl::*debug?* (print-variables query
requestor
iid
hash-entry
root-object
recovery-object?
requestor
bashee
rest-plist
possible-nils
settables
rest-keys
query-plist))
(when gwl::*debug?* (print-variables query
requestor
iid
hash-entry
root-object
recovery-object?
requestor
bashee
rest-plist
possible-nils
settables
rest-keys
query-plist))
(let ((fe-processor (make-object 'form-element-processor
:bashee bashee
:query-plist query-plist)))
(let ((fe-processor (make-object 'form-element-processor
:bashee bashee
:query-plist query-plist)))
(cond (recovery-object? (with-http-response (req ent :response *response-moved-permanently*)
(setf (reply-header-slot-value req :location)
(defaulting (the-object root-object recovery-url) *failed-request-url*))
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent))))
((null requestor) (net.aserve::failed-request req))
(t (let ((*query-plist* query-plist) (*field-plist* rest-plist))
(the-object requestor (before-set!)))
(cond (recovery-object? (with-http-response (req ent :response *response-moved-permanently*)
(setf (reply-header-slot-value req :location)
(defaulting (the-object root-object recovery-url) *failed-request-url*))
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent))))
((null requestor) (net.aserve::failed-request req))
(t (let ((*query-plist* query-plist) (*field-plist* rest-plist))
(the-object requestor (before-set!)))
;;(when *debug?* (print-variables *query-plist* rest-plist rest-keys))
;;(when *debug?* (print-variables *query-plist* rest-plist rest-keys))
(when *debug?* (setq *f-e-p* fe-processor))
(when *debug?* (setq *f-e-p* fe-processor))
(dolist (key rest-keys)
(when (gethash (make-keyword-sensitive key) settables)
;;(when *debug?* (print-variables key))
(the-object bashee (set-slot-if-needed! (make-keyword-sensitive key) (getf rest-plist key)))))
(dolist (key rest-keys)
(when (gethash (make-keyword-sensitive key) settables)
;;(when *debug?* (print-variables key))
(the-object bashee (set-slot-if-needed! (make-keyword-sensitive key) (getf rest-plist key)))))
(the-object fe-processor validate-and-set!)
(the-object fe-processor validate-and-set!)
(when
(and (fboundp 'process-graphics-fields)
(typep (the-object requestor) (read-from-string "gwl:base-html-graphics-sheet"))
(the-object requestor (evaluate :view-object)))
(setq query-plist (funcall (read-from-string "gwl::process-graphics-fields")
query query-plist root-object requestor)))
(when (not (equalp (the-object bashee query-plist) query-plist))
(the-object bashee
(set-slot! :query-plist query-plist
:remember? (not (member :query-plist
(the-object bashee transitory-slots))))))
(when
(and (fboundp 'process-graphics-fields)
(typep (the-object requestor) (read-from-string "gwl:base-html-graphics-sheet"))
(the-object requestor (evaluate :view-object)))
(setq query-plist (funcall (read-from-string "gwl::process-graphics-fields")
query query-plist root-object requestor)))
(when (not (equalp (the-object bashee query-plist) query-plist))
(the-object bashee
(set-slot! :query-plist query-plist
:remember? (not (member :query-plist
(the-object bashee transitory-slots))))))
(let ((result (let ((*req* req) (*ent* ent) (*skin* skin)
(*query* query)) (the-object requestor (after-set!)))))
(let ((result (let ((*req* req) (*ent* ent) (*skin* skin)
(*query* query)) (the-object requestor (after-set!)))))
(let ((respondent (if (and (consp result) (eql (first result) :go-to)) (second result)
(the-object requestor respondent))))
;;
;; Dashboard stuff
;;
;;
;; FLAG - use actual application-root rather than simple root.
;;
(when (typep root-object 'session-control-mixin) (the-object root-object (set-expires-at)))
(the-object respondent root (set-time-last-touched!))
(let ((respondent (if (and (consp result) (eql (first result) :go-to)) (second result)
(the-object requestor respondent))))
;;
;; Dashboard stuff
;;
;;
;; FLAG - use actual application-root rather than simple root.
;;
(when (typep root-object 'session-control-mixin) (the-object root-object (set-expires-at)))
(the-object respondent root (set-time-last-touched!))
(the-object respondent root (set-slot! :last-visited-root-path
(the-object respondent root-path)))
;;
;;
;;
(the-object respondent root (set-slot! :last-visited-root-path
(the-object respondent root-path)))
;;
;;
;;
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(setf (reply-header-slot-value req :location) (the-object respondent url))
(setf (reply-header-slot-value req :location) (the-object respondent url))
(let ((keys (plist-keys (the-object respondent header-plist)))
(values (plist-values (the-object respondent header-plist))))
(mapc #'(lambda(key val)
(setf (reply-header-slot-value req key) val)) keys values))
(with-http-body (req ent)
(let ((*req* req) (*ent* ent) (*skin* skin))
(multiple-value-bind (check error)
(when (the-object respondent check-sanity?)
(ignore-errors (the-object respondent check-sanity)))
(declare (ignore check))
(if error (the-object respondent (sanity-error error))))))))))))))))
(let ((keys (plist-keys (the-object respondent header-plist)))
(values (plist-values (the-object respondent header-plist))))
(mapc #'(lambda(key val)
(setf (reply-header-slot-value req key) val)) keys values))
(with-http-body (req ent)
(let ((*req* req) (*ent* ent) (*skin* skin))
(multiple-value-bind (check error)
(when (the-object respondent check-sanity?)
(ignore-errors (the-object respondent check-sanity)))
(declare (ignore check))
(if error (the-object respondent (sanity-error error))))))))))))))))
;;
......@@ -348,7 +348,11 @@ package-qualified object name\")
#-allegro
progn
(define-object-amendment skeleton-ui-element ()
:input-slots (("Boolean. This switch determines whether all form-controls should be preset
:input-slots (
(div-style nil)
("Boolean. This switch determines whether all form-controls should be preset
before the final setting, in order to allow any interdependencies to be detected
for validation or detecting changed values. If this is specified as a non-nil
value, then any nil values of (the preset?) on individual form controls will be
......@@ -431,19 +435,19 @@ form-controls (default of these is also nil) will be respected. Default is nil."
(in-package :gwl)
;;
;; Merged into devo 2020-12-17
;; NOT Merged into devo 2020-12-17
;;
(#+allegro
excl:without-package-locks
#-allegro
progn
(define-object-amendment base-ajax-graphics-sheet ()
:input-slots
((viewport-js-text
(case (the image-format-selector value)
(:x3dom
(format nil "
(define-object-amendment base-ajax-graphics-sheet ()
:input-slots
((viewport-js-text
(case (the image-format-selector value)
(:x3dom
(format nil "
function x3draw ()
{
if (x3dom.type != 'undefined') x3dom.reload();
......@@ -458,10 +462,10 @@ x3draw();
" (the view-selector value)))
(:svg
""
(:svg
""
"
"
if (document.getElementById('svg-1'))
{
panZoomSVG1 = svgPanZoom('#svg-1', {
......@@ -474,12 +478,15 @@ x3draw();
center: true});
};")))
(viewport-script
(popup-menu-text nil)
(viewport-script
(progn
(the inner-html)
(cond ((member (the image-format-selector value) (list :x3dom :svg))
(cond ((member (the image-format-selector value) (list :x3dom :svg :png :jpeg))
(with-cl-who-string ()
(:div
((:script :type "text/javascript")
(str (the viewport-js-text))))))
(str (the viewport-js-text))
(str (the popup-menu-text))))))
(t "")))))))
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