Commit 3cde783f authored by Dave Cooper's avatar Dave Cooper
Browse files

factored more patches into here. most already merged.

parent f9b9d1ce
*~
*.?x64fsl
bin/
system-index.txt
\ No newline at end of file
......@@ -49,7 +49,9 @@ give to this object.
:input-slots
(("String. The name which will be used for your
((build-level :runtime)
("String. The name which will be used for your
application's executable and possibly image file. Defaults to
\"gdl-test-runtime\"." application-name "gdl-test-runtime")
......@@ -320,3 +322,29 @@ 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))
......@@ -265,3 +265,107 @@
excl:without-redefinition-warnings #-allegro progn
(define-object-amendment base-html-sheet ()
:input-slots ((instance-id nil :defaulting :settable)))))
#+nil
;;
;; FLAG -- we think the one in codbase in ajax.lisp is more complete than this.
;;
(defun restore-from-snap (iid object)
(let ((snap-file
(merge-pathnames
(make-pathname :name (format nil "~a" iid)
:type "snap") (glisp:snap-folder))))
(unless (probe-file snap-file) (error "~a not found~%" snap-file))
(read-snapshot :filename snap-file
:object object
:keys-to-ignore (list :time-last-touched
:time-instantiated
:expires-at))
(theo object (set-slot! :instance-id iid))
(setf (gethash (make-keyword-sensitive (the-object object instance-id))
*instance-hash-table*)
(list object nil))))
;;
;; 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\")))
</pre>"
(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))
(root-part-and-version
(if (or (not share?) (not current))
(list (apply #'make-object (read-safe-string part)
:instance-id instance-id :query-toplevel query
make-object-args)
*dummy-version*)
current)))
(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)))))))
;;
;; FLAG -- is this used anywhere?
;;
#+nil
(defun register-instance (instance)
(let ((iid (theo instance instance-id)))
(let ((current (first (gethash iid gwl::*instance-hash-table*))))
(cond ((and current (not (eql current instance)))
(error "Instances don't match for ~a.~%" iid))
(current iid)
(t (setf (gethash iid gwl:*instance-hash-table*) (list instance))
iid)))))
(#+allegro
excl:without-package-locks
#-allegro progn
(defmacro wmd (string)
`(str
(with-output-to-string (ss)
(markdown:markdown ,string :stream ss)))))
(eval-when (:compile-toplevel :load-toplevel :execute) (export 'wmd))
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