Commit 87a2bdd7 authored by Dave Cooper's avatar Dave Cooper
Browse files

collapsed out merged patches

parent 5ca5528a
......@@ -23,67 +23,4 @@
(in-package :cl-lite)
;; FLAG -- Merged but delete commented-out old code in devo 2020-08-20
(define-object-amendment codebase-directory-node ()
((source-files :type 'file
:files (append (getf (the file-computation relevant-files) :source)
(getf (the file-computation relevant-files) :tables))
:pseudo-inputs (files)
:sequence (:size (length (the-child files)))
:pathname (nth (the-child index) (the-child files))))
(let ((sexpr (glisp:sexpr-from-file (merge-pathnames (make-pathname :name "defsystem-depends-on"
:type "isc")
(the ppathname)))))
(if (and sexpr (not (or (stringp sexpr) (consp sexpr))))
(error "defsystem-depends-on.isc should be either nil or a string containing the expression
to go inside the actual list form in the asdf file, or the list form for the asdf file.
It came in as ~s instead.~%"
sexpr) sexpr)))
(let ((binaries (the compile-and-load)))
(append `("%%remove%%asdf:defsystem%%remove%%"
,(read-from-string (format nil "#:~a" (pathname-name (the asd-file))))
:description ,(the description)
:author ,(the author)
:license ,(the license)
:serial t
:version ,(the version)
:depends-on ,(the asdf-depends-on)
:defsystem-depends-on ,(cond ((stringp (the asdf-defsystem-depends-on))
(read-from-string (format nil "(~a)" (the asdf-defsystem-depends-on))))
((null (the asdf-defsystem-depends-on)) nil)
(t (the asdf-defsystem-depends-on)))
;; FLAG -- maybe can get rid of binaries and need to call (the compile-and-load)
:components ,(mapcar #'(lambda(binary source)
(let ((binary (make-pathname :directory (remove "bin"
(pathname-directory binary)
:test #'string-equal)
:defaults binary)))
(let ((namestring (replace-substring
(make-pathname :name (pathname-name binary)
:type nil ;;(pathname-type source)
(enough-namestring binary (the ppathname))))
"\\" "/")))
(list (if (string-equal (pathname-type source) "lisp")
(make-keyword (pathname-type source)))
binaries (the source-file-list)))))
......@@ -317,116 +317,4 @@ This function will be run in the initiating image after the build is finished."
(when (the post-make-function) (funcall (the post-make-function)))))))
;; Merged into devo 2020-08-18
(defmacro theo (object &rest reference-chain)
`(the-object ,object ,@reference-chain))
;; Merged into devo 2020-08-18
(defmacro thech (&rest reference-chain)
`(the-child ,@reference-chain))
;; Merged into devo 2020-08-18
(defmacro le (aggregate &optional expression filter)
`(list-elements ,aggregate ,expression ,filter))
;; Merged into devo 2020-08-18
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(theo thech le) :gendl))
;; Already merged into devo (below is coming from codebase)
#-allegro progn
(defun computed-slots-section (name computed-slots &key query?)
(let ((attr-remarks (message-strings attribute))
(attr-sym (intern (symbol-name (message-symbol attribute)) :gdl-acc))
(attr-expr (message-source-code attribute)))
(when (and name *compile-documentation-database?* attr-remarks)
`(when *load-documentation-database?*
(let ((ht (or (message-documentation (find-class ',name))
(setf (message-documentation (find-class ',name)) (make-hash-table)))))
(setf (gethash (make-keyword ',attr-sym) ht) ,attr-remarks))))
(when (and name *compile-source-code-database?*)
`(when *load-source-code-database?*
(let ((ht (or (message-source (find-class ',name))
(setf (message-source (find-class ',name)) (make-hash-table)))))
(setf (gethash (make-keyword ',attr-sym) ht) ',attr-expr))))
(when name
`(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((self ,name) &rest ,args-arg)
(declare (ignore ,args-arg))
(let ((*error-on-not-handled?* t))
(with-dependency-tracking (,attr-sym)
,(if query? `(iq:qlet (()) ,attr-expr) attr-expr))
(with-dependency-tracking (,attr-sym)
,(if query? (error "Query-slots are not supported in this distribution of Genworks GDL.")
(when (and *compile-for-dgdl?* (not (string-equal (symbol-name name) "remote-object")))
`(when (or (not (fboundp ',(glisp:intern attr-sym :gdl-slots)))
(not (find-method (symbol-function ',(glisp:intern attr-sym :gdl-slots))
nil (list (find-class 'gdl-remote)) nil)))
(defmethod ,(glisp:intern attr-sym :gdl-slots) ((,self-arg gdl-remote) &rest ,args-arg)
(the-object ,self-arg (send (:apply (cons ,(make-keyword (symbol-name attr-sym))
(unless query?
`(unless (find-method (symbol-function ',(glisp:intern (symbol-name attr-sym) :gdl-slots))
nil (list (find-class 'gdl-basis)) nil)
(defmethod ,(glisp:intern (symbol-name attr-sym) :gdl-slots) ((,self-arg gdl-basis) &rest ,args-arg)
;;(declare (ignore ,args-arg))
(let ((,parent-arg (the-object ,self-arg %parent%)))
(if (or (null ,parent-arg) ,args-arg) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg)
(let ((,val-arg (let (*error-on-not-handled?*)
(,(glisp:intern (symbol-name attr-sym) :gdl-inputs)
,parent-arg (the-object ,self-arg :%name%) ,self-arg))))
(if (eql ,val-arg 'gdl-rule:%not-handled%) (not-handled ,self-arg ,(make-keyword attr-sym) ,args-arg) ,val-arg)))))))))))
;; Merged into devo 2020-12-17
(define-object-amendment vanilla-mixin ()
((toggle-slot! (slot) (the (set-slot! slot (not (the (evaluate slot))))))))
(defun reserved-words-for (mixins)
(apply #'append
(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*)
#'(lambda(word) (glisp:intern word :gdl-acc))
(the-object (make-object mixin) message-list)
(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)))))))))
......@@ -21,59 +21,3 @@
(in-package :glisp)
;; 4 forms below merged into devo 2020-08-17
(defun getuid ()
#-(or allegro ccl) (error "need getuid impl.")
#+(or allegro ccl)
(#+allegro excl.osi:getuid #+ccl ccl::getuid))
(defun setuid (num)
#-(or allegro ccl) (error "need setuid impl.")
(#+allegro excl.osi:setuid #+ccl ccl::setuid num))
(defun setgid (num)
#-(or allegro ccl) (error "need setgid impl.")
(#+allegro excl.osi:setgid #+ccl ccl::setgid num))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export 'getuid :glisp) (export 'setuid :glisp) (export 'setgid :glisp))
;; Merged into devo 2020-08-17
#-(or allegro lispworks cmu sbcl ccl abcl ecl clasp clisp)
(error "Need implementation for executable-homedir-pathname for currently running lisp.~%")
excl:without-package-locks #-allegro progn
(defun executable-homedir-pathname ()
#+allegro (translate-logical-pathname "sys:")
#+sbcl (make-pathname :name nil :type nil :defaults sb-ext:*core-pathname*)
#+(or lispworks ccl ecl clisp)
(let* ((exe (first (glisp:basic-command-line-arguments)))
(exe-dir (pathname-directory exe)))
(if (eql (first exe-dir) :relative)
(merge-pathnames (make-pathname :directory exe-dir :defaults nil)
(make-pathname :name nil :type nil :defaults exe)))
#+clasp (core:argv 0)
(warn "Don't know how to get executable-homedir-pathname on ~a! Please find out.~%"
;; Merged into devo 2020-08-17.
excl:without-package-locks #-allegro progn
excl:without-redefinition-warnings #-allegro progn
(defun process-run-function (name-or-options preset-function &rest initial-bindings)
(bt:make-thread preset-function :name name-or-options :initial-bindings initial-bindings))))
......@@ -20,418 +20,6 @@
(in-package :gwl)
;; Merged into devo 2020-08-14
#-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.
:arguments (path \"String. The URL pathname component to be published.\"
string-or-symbol \"String or symbol. The object type to insantiate.\")
:&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")
:make-object-args make-object-args))
;; Merged into devo 2020-08-17
(defun answer (req ent)
(let ((query (request-query req)))
(when *debug?* (format t "before multi-part processing, query is: ~s~%" query))
(when (null query) (setq query (process-multipart-submission req)))
(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
(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?)
(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)))
(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")
(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
(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!)))
;;(when *debug?* (print-variables *query-plist* rest-plist rest-keys))
(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)))))
(the-object fe-processor validate-and-set!)
(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 ((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)))
(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))
(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))))))))))))))))
;; Merged into devo 2020-08-17.
excl:without-package-locks #-allegro progn
excl:without-redefinition-warnings #-allegro progn
(defun start-session-reaper (&key (minutes 20) (debug? t) (listeners 20) extra-functions restart-server?)
(format t "~2%Lauching Expired Session Reaper to awaken and run every ~a minute~:p~2%" minutes)
"GWL Session Reaper"
(do ()(nil) (sleep (* minutes 60))
(when debug? (format t "~&Reaper waking up...~%"))
(when *reap-expired-sessions?*
(maphash #'(lambda(key val) (declare (ignore key))
(when (typep (first val) 'session-control-mixin)
(the-object (first val) (clear-expired-session :debug? debug?))))
(when restart-server?
(let ((port (server-port)))
(when (and port (>= port 1000))
(net.aserve:shutdown) (net.aserve:start :port port :listeners listeners)))))
(mapc #'funcall (ensure-list extra-functions)) (glisp:gc-full))))))))
;; Merged into devo 2020-08-17.
excl:without-package-locks #-allegro progn
excl:without-redefinition-warnings #-allegro progn
(define-object-amendment base-html-sheet ()
:input-slots ((instance-id nil :defaulting :settable)))))
;; Merged into devo 2020-08-18
(defun gwl-make-object (req ent part &key make-object-args share? skin (instance-id (when share? "share")))
"Void. Used within the context of the body of a :function argument to Allegroserve's
publish function, makes an instance of the specified part and responds to the request
with a redirect to a URI representing the instance.
:arguments (req \"Allegroserve request object, as used in the function of a publish\"
ent \"Allegroserve entity object, as used in the function of a publish\"
package-and-part \"String. Should name the colon- (or double-colon)-separated
package-qualified object name\")
:&key ((make-object-args nil) \"Plist of keys and values. These are passed to the object upon instantiation.\"
(share? nil) \"Boolean. If non-nil, the instance ID will be the constant string ``share'' rather than a real instance id.\")
:example <pre>
(publish :path \"/calendar\"
:function #'(lambda(req ent) (gwl-make-object req ent \"calendar:assembly\")))
(unless instance-id (setq instance-id (make-new-instance-id)))
(let ((query (request-query req)))
(let ((part (or part (rest (assoc "part" query :test #'string-equal)))))
(let* ((current (gethash (make-keyword-sensitive instance-id) *instance-hash-table*))
(skin (if skin (make-instance skin) t))
(if (or (not share?) (not current))
(list (apply #'make-object (read-safe-string part)
:instance-id instance-id :query-toplevel query
(setf (gethash (first root-part-and-version) *weak-objects*) t)
(setq root-part-and-version (append root-part-and-version (list skin)))
(when (or (not share?) (not current))
(setf (gethash (make-keyword-sensitive instance-id) *instance-hash-table*) root-part-and-version))
(let ((object (first root-part-and-version)))
(when (typep object 'session-control-mixin)
(the-object object set-expires-at))
(the-object object set-instantiation-time!)
(the-object object set-time-last-touched!)
(the-object object (set-remote-host! req :original? t)))
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :location)
(format nil "~a" (the-object (first root-part-and-version) 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)))))))
(defmacro wmd (string)
(with-output-to-string (ss)
(markdown:markdown ,string :stream ss))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export 'wmd :gwl))
;; Merged into devo 2020-12-17
(defmacro wmd (string)
(with-output-to-string (ss)
(markdown:markdown ,string :stream ss)))))
(eval-when (:compile-toplevel :load-toplevel :execute) (export 'wmd))
;; Merged into devo 2020-12-17
(define-object-amendment skeleton-ui-element ()
: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
ignored. If this is specified as nil, then (the preset?) of individual
form-controls (default of these is also nil) will be respected. Default is nil."
preset-all? nil))))
;; Merged into devo 2020-12-17
(defun initialize ()
;; FLAG -- investigate if this initialize-multiprocessing business
;; is still needed, currently LW-only.
(when (find-package :zacl)
(setq excl:*initial-terminal-io* *terminal-io*)
(setq net.aserve:*wserver* (make-instance 'net.aserve:wserver)))
(setq *iid-random-state* (make-random-state t))
(let (anything-changed?)
(setq anything-changed? (glisp:set-settings *settings*))