Commit bb1edaeb authored by Dave Cooper's avatar Dave Cooper
Browse files

initial populating

parent b880a9a1
;;
;; Copyright© 2020 Genworks International and David J Cooper Jr.
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gdl)
#-genworks-gdl
(define-object gdl-app ()
:documentation (:description "
This object serves as the driver for the build process for GDL runtime
applications. There is also an undocumented function called
<tt>make-gdl-app</tt>; in order to perform a runtime build process,
simply make an instance of this object with the appropriate input
values, and invoke <tt> (the make!) </tt> on it, or call
<tt>make-gdl-app</tt> with the same arguments as the input-slot you
give to this object.
"
:examples "<pre>
(in-package :gdl-user)
(make-gdl-app :application-name \"moon-shot\" :destination-directory \"/tmp/moon-shot/\"
:overwrite? t :application-fasls (list \"/fasl-home/booster-rocket.fasl\"
\"/fasl-home/lunar-module.fasl\"))
</pre>
"
:author "Dave Cooper, Genworks International")
:input-slots
(("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")
("Lisp Function of zero arguments.
This function will be run in the initiating image before the build is begun."
pre-make-function nil)
("Lisp Function of zero arguments.
This function will be run in the initiating image after the build is finished."
post-make-function nil)
("Lisp expression. This form will be evaluated in the image being
built, before the loading of application-fasls begins, but
after the GDL runtime modules are loaded. Defaults to nil."
pre-load-form nil)
("Lisp expression. This form will be evaluated in the image being
built, after the loading of application-fasls is complete.
Defaults to nil."
post-load-form nil)
("Boolean. Indicates whether a build will overwrite a previously
existing destination directory. Defaults to nil."
overwrite? nil)
("Pathname. Indicates the directory to be created or overwritten
for producing the runtime distribution. Defaults to a
directory called <tt>(the application-name)</tt> in the system
temporary directory, returned by
<tt>(glisp:temporary-folder)</tt>."
destination-directory
(merge-pathnames
(make-pathname :directory (list :relative (the application-name)))
(glisp:temporary-folder)))
(display-string (string-capitalize (the application-name)))
("Lambda expression with empty argument list or symbol naming a
function with no arguments. This will be run when the runtime
application starts up. The alternative to using this to achieve
initializations is to put expressions in a gdlinit.cl or
.gdlinit.cl in the application directory or user home
directory. Defaults to nil." restart-init-function nil)
("List of pathnames. This list should contain the pre-compiled
fasls for your GDL application, in correct load order. These
can be produced, for example, by calling
<tt>genworks:cl-lite</tt> with the <tt>:create-fasl?</tt>
keyword argument set to <tt>t</tt>. If you are using the ASDF
build management system, note that ASDF3 is now capable of
producing a single fasl file for your application including its
ASDF/Quicklisp dependencies, using <pre>
(asdf:operate 'asdf:monolithic-compile-bundle-op :your-application-system-name)
(asdf:output-file 'asdf:monolithic-compile-bundle-op :your-application-system-name)
</pre>
See the ASDF documentation for details. "
application-fasls nil)
("Number. The size of the reserved space which will be requested
from the OS when the produced application starts up. Defaults
to 800000000 (eight hundred million) bytes." lisp-heap-size
800000000)
("String. The contents of this string will be copied to a file
gdlinit.cl and placed in the destination-directory. Default is
empty string."
gdlinit-content ""))
:computed-slots
((destination-exe (merge-pathnames (format nil "~a~a"
(the application-name)
#+windows ".exe" #-windows "")
(the destination-directory)))
(parent-directory (merge-pathnames "../" (the destination-directory)))
(load-fasls-expression (when (the application-fasls)
`(mapcar #'load ',(the application-fasls))))
(save-appliction-and-die-form
#+ccl
`(progn
(ccl:save-application (progn (ensure-directories-exist ,(the destination-exe))
,(the destination-exe))
:prepend-kernel t
;;:clear-clos-caches t
;;:purify t
:toplevel-function ,(the toplevel-function))
(ccl:quit))
#-ccl (error "Please implement save-application-and-die-form for ~a.~%"
(lisp-implementation-type)))
(toplevel-function `(lambda ()
,@(remove
nil
`(
(uiop:setup-temporary-directory)
;;
;; FLAG -- sort out initialization so we don't have to do it surgically/internally like this.
;;
(gendl::initialize)
(setq glisp:*gdl-home* glisp:*gdl-program-home*)
;;
;; FLAG -- supposed to come from gwl:initialize but need to customize for now
;;
(glisp:initialize-multiprocessing)
(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))
(glisp:set-settings gwl::*settings*)
;;
;; end of stuff from gwl:initialize
;;
;;
;; FLAG -- make all this boilerplate into a funciton
;;
,(when (member (the build-level)
(list :runtime :pro :geom-base :gwl-graphics))
`(setq pdf::*cl-pdf-base-directory* glisp:*gdl-program-home*))
,(when (member (the build-level)
(list :runtime :pro :geom-base :gwl-graphics))
`(setq pdf::*afm-files-directories*
(list (merge-pathnames "afm/" pdf::*cl-pdf-base-directory*))))
,(when (member (the build-level)
(list :runtime :pro :geom-base :gwl-graphics))
`(setq cl-typesetting-hyphen::*cl-typesetting-base-directory*
glisp:*gdl-program-home*))
,(when (member (the build-level)
(list :runtime :pro :geom-base :gwl-graphics))
`(setq cl-typesetting-hyphen::*hyphen-patterns-directory*
(merge-pathnames
"hyphen-patterns/"
cl-typesetting-hyphen::*cl-typesetting-base-directory*)))
,(when (member (the build-level)
(list :runtime :pro :geom-base :gwl-graphics))
`(cl-typesetting::initialize!
:afm-files-directories pdf::*afm-files-directories*
:hyphen-patterns-directory
cl-typesetting-hyphen::*hyphen-patterns-directory*))
,(when (the restart-init-function) `(funcall #',(the restart-init-function)))
(gdl::load-gdl-init-files))))))
:functions
((copy-with-warning
(source target &key (overwrite? t))
(if (not (and source (probe-file source)))
(warn "Could not find ~a.~%Not copying to ~a~%" source target)
(progn
(when (and overwrite? (probe-file target))
(uiop:delete-directory-tree
target :validate #'(lambda(dir)
(search (namestring (the destination-directory))
(namestring dir)))))
(glisp:copy-directory source target))))
(populate-static-folders
()
(ensure-directories-exist (the destination-directory))
(when (and (the gdlinit-content) (not (zerop (length (the gdlinit-content)))))
(with-open-file (out (merge-pathnames "gdlinit.cl" (the destination-directory))
:direction :output :if-exists :supersede :if-does-not-exist :create)
(write-string (the gdlinit-content) out)))
(when (member (the build-level) (list :pro :runtime :gwl-graphics :gwl))
(the (copy-with-warning (merge-pathnames "static/" glisp:*gdl-home*)
(merge-pathnames "static/" (the destination-directory)))))
(when (member (the build-level) (list :pro :runtime :gwl-graphics :geom-base))
(the (copy-with-warning (or (probe-file (merge-pathnames "afm/" glisp:*gdl-home*))
(when (find-package :asdf)
(probe-file (merge-pathnames "afm/"
(glisp:system-home :cl-pdf)))))
(merge-pathnames "afm/" (the destination-directory))))
(the (copy-with-warning (or (probe-file (merge-pathnames "hyphen-patterns/" glisp:*gdl-home*))
(when (find-package :asdf)
(probe-file
(merge-pathnames "hyphen-patterns/"
(glisp:system-home :cl-typesetting)))))
(merge-pathnames "hyphen-patterns/" (the destination-directory))))))
("Void. Does the application build and creates or replaces
<tt>(the destination-directory)</tt> ."
make!
()
(when (the pre-make-function) (funcall (the pre-make-function)))
(let ((load-file (merge-pathnames (format nil "~a-load.lisp" (gensym)) (glisp:temporary-folder))))
(with-open-file (out load-file :direction :output :if-exists :supersede
:if-does-not-exist :create)
(when (the pre-load-form) (print (the pre-load-form) out))
(when (the load-fasls-expression) (print (the load-fasls-expression) out))
(when (the post-load-form) (print (the post-load-form) out))
(print (the save-appliction-and-die-form) out))
;;
;; Now fire up the appropriate executable with argument to load the above
;; load-file
;;
#+ccl
(multiple-value-bind
(output error return-code)
(uiop:run-program
(list (first (glisp:basic-command-line-arguments))
"-n" "--batch" "-l" (namestring load-file) "-e" "(ccl:quit)")
:ignore-error-status t
:error-output :string
:output nil)
(declare (ignore output))
(unless (zerop return-code) (print error) (ccl:quit return-code)))
#+nil
(uiop:run-program
(list (first (glisp:basic-command-line-arguments))
"-n" "--batch" "-l" (namestring load-file) "-e" "(ccl:quit)")
:ignore-error-status t
:error-output :string
:output :string)
#-ccl (error "Please implement make! for ~a." (lisp-implementation-type))
(the populate-static-folders)
(when (the post-make-function) (funcall (the post-make-function)))))))
;;
;; Copyright© 2020 Genworks International and David J Cooper Jr.
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :glisp)
(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))
#-(or allegro lispworks cmu sbcl ccl abcl ecl clasp clisp)
(error "Need implementation for executable-homedir-pathname for currently running lisp.~%")
(#+allegro
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)
(probe-file
(merge-pathnames (make-pathname :directory exe-dir :defaults nil)
(uiop/os:getcwd)))
(make-pathname :name nil :type nil :defaults exe)))
#+clasp (core:argv 0)
#+abcl
(warn "Don't know how to get executable-homedir-pathname on ~a! Please find out.~%"
(lisp-implementation-type))))
;;
;; Copyright© 2020 Genworks International and David J Cooper Jr.
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(in-package :gwl)
;;
;; Merged into devo 2020-08-14
;;
(#+allegro
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.
: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")
string-or-symbol)
:make-object-args make-object-args))
publish-args)))
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