Commit 4ee5d709 authored by Dave Cooper's avatar Dave Cooper
Browse files

removed platform-dependent build directory, cleaned any dependency on asdf from main build.

parent 72df31a2
(:gdl-geom-base :cl-fad)
(asdf:defsystem #:gdl-build :description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2012090900" :depends-on (:gdl-geom-base :cl-fad)
:components
((:lisp "source/package") (:lisp "source/genworks")
(:lisp "source/app") (:lisp "source/distro")))
\ No newline at end of file
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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-build)
(define-object app ()
:computed-slots ((hey-now "hey now"))
:input-slots
(("String. The name which will be used for your application's executable and dxl file.
Defaults to \"my-gdl-app\""
application-name "my-gdl-app")
("Keyword symbol. Should be one of <tt>:runtime</tt>, <tt>:development</tt>,
or <tt>:enterprise</tt>.
Indicates which level of application should be made. Defaults to :development."
application-class :runtime)
(lisp-heap-size 900000000)
(implementation-identifier (glisp:implementation-identifier))
("Pathname. Indicates the directory to be created or overwritten for producing
the distribution.
Defaults to a directory called <tt>(the application-name)</tt> in the user
temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
destination-directory
(make-pathname :name nil :type nil
:directory (append (pathname-directory (glisp:temporary-folder))
(ensure-list (the application-name)))
:defaults (glisp:temporary-folder)))
(overwrite? t)
(load-core-gdl-form `(progn (load ,(merge-pathnames "../build"
glisp:*genworks-source-home*))
#+nil
(setf (symbol-value (read-from-string
"asdf:*central-registry*")) nil)))
(pre-load-form (the load-core-gdl-form))
(post-load-form '(progn (setf (symbol-value (read-from-string
"asdf:*central-registry*")) nil)
(asdf:map-systems #'asdf:clear-system)
(asdf:clear-output-translations)
(asdf:disable-output-translations)
))
(init-file-names nil)
(restart-init-function nil)
(modules nil)
(demo-days 30)
)
:functions
((make!
()
(print-variables (the init-file-names))
(when (and (probe-file (the destination-directory)) (the overwrite?))
(glisp:delete-directory-and-files (the destination-directory)))
(glisp:make-gdl-app :application-name (the application-name)
:destination-directory (the destination-directory)
:modules (the modules)
:pre-load-form (the pre-load-form)
:post-load-form (the post-load-form)
:application-class (the application-class)
:demo-days (the demo-days)
:lisp-heap-size (the lisp-heap-size)
;;
;; FLAG -- leave this to nil for now while we are working
;; on the basic build.
;;
:init-file-names (the init-file-names)
;;
:restart-init-function (the restart-init-function)
;;
;;
))))
(defun app (&rest args)
(let ((self (apply #'make-object 'app args)))
(the make!)))
;;
;;
;; FLAG -- this is given as an example for how one might create a
;; standalone runtime executable. Note that its restart-init-function
;; modifies the Quicklisp environment, so you would only do this when
;; the user does not already have a known Quicklisp environment.
;;
;;
(defun gdl-runtime ()
(let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
(prefix (merge-pathnames #+mswindows "e:/staging/" #-mswindows "~/share/staging/")))
(merge-pathnames
(make-pathname :directory
(list :relative
(format nil "~a-~a" implementation-identifier
(glisp:next-datestamp prefix implementation-identifier)))) prefix))))
(app :application-name "gdl-runtime"
:application-class :runtime
:destination-directory destination-directory
:modules (list :agraph)
:restart-init-function '(lambda()
(setq glisp:*gdl-home* (glisp:current-directory))
(setq glisp:*genworks-source-home* (merge-pathnames "src/" glisp:*gdl-home*))
(setf (symbol-value (read-from-string "ql:*quicklisp-home*")) (merge-pathnames "quicklisp/" glisp:*gdl-home*))
(gdl:start-gdl :edition :trial)
(glisp:set-gs-path (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))))
destination-directory))
(defun gdl ()
(let ((destination-directory
(let ((implementation-identifier (glisp:implementation-identifier))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
(prefix (merge-pathnames #+mswindows (or (probe-file "e:/staging/")
(probe-file "z:/staging/"))
#-mswindows "~/share/staging/")))
(merge-pathnames
(make-pathname :directory
(list :relative
(format nil "~a-~a" implementation-identifier
(glisp:next-datestamp prefix implementation-identifier)))) prefix))))
(app :application-name "gdl"
:application-class #+64bit :runtime #-64bit :development
:destination-directory destination-directory
:modules (list #-64bit :agraph #-64bit :ide)
:restart-init-function '(lambda()
(gdl:start-gdl :edition :trial)))
destination-directory))
(defun site ()
(app :post-load-form
'(progn
(require :smtp)
(require :ftp)
(load (merge-pathnames "demos/gdl-demos.asd" glisp:*genworks-source-home*))
(asdf:load-system :gdl-demos)
(load (merge-pathnames "../downloads/gdl-downloads.asd" glisp:*genworks-source-home*))
(asdf:load-system :gdl-downloads)
(load (merge-pathnames "demos/newsite/gdl-newsite.asd" glisp:*genworks-source-home*))
(asdf:load-system :gdl-newsite)
(setf (symbol-value (read-from-string
"glisp:*genworks-source-home*")) nil))
:destination-directory
(merge-pathnames "~/share/staging/site/" glisp:*genworks-source-home*)
:overwrite? t
:application-name "genworks-site"
:application-class :development
:demo-days nil
:restart-init-function '(lambda()
(gdl:start-gdl :edition :trial)
(setf (symbol-value (read-from-string "www.genworks.com::*smtp-server*")) "localhost")
(glisp:set-gs-path
#+mswindows (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*)))))
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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-build)
(define-object distro ()
:input-slots
((overwrite? nil)
(staging-directory #+mswindows (or (probe-file "e:/staging/")
(probe-file "z:/staging/"))
#-mswindows "~/share/staging/")
(release-directory #+mswindows (or (probe-file "e:/release/")
(probe-file "z:/release/"))
#-mswindows "~/share/release/")
(release-name-mapping '(("acl-8.2m-linux-x86" . "gdl1581-linux")
("acl-8.2m-win-x86" . "gdl1581-windows")
("acl-9.0m-linux-x86" . "gdl1582-linux")
("acl-9.0m-win-x86" . "gdl1582-windows")
("acl-9.0ms-win-x64" . "gdl1582-win64smp")
))
(os-name-mapping '(("win" . "windows")
("linux" . "linux")
("macos" . "macos")))
(known-releases (mapcar #'first (the release-name-mapping))))
:computed-slots
((staging-release-pairs (let (result)
(dolist (entry (glisp:directory-list (the staging-directory)) (nreverse result))
(when (glisp:file-directory-p entry)
(let* ((full-name (lastcar (pathname-directory entry)))
(base (when (>= (length full-name)(length "-2011010100"))
(subseq full-name 0 (- (length full-name)
(length "-2011010100"))))))
(when (member base (the known-releases) :test #'string-equal)
(push (cons entry
(merge-pathnames (format nil "~a/~a~a/program/"
(the (os-name-lookup base))
(rest (assoc base (the release-name-mapping)
:test #'string-equal))
(subseq full-name (length base)))
(the release-directory))) result))))))))
:objects
((pairs :type 'staging-release-pair
:sequence (:size (length (the staging-release-pairs)))
:pair (nth (the-child index) (the staging-release-pairs))
:pass-down (overwrite?)))
:functions
((os-name-lookup
(base)
(dolist (mapping (the os-name-mapping))
(when (search (first mapping) base) (return (rest mapping)))))
(make!
()
(dolist (pair (list-elements (the pairs))) (the-object pair make!)))))
(define-object staging-release-pair ()
:input-slots (pair overwrite?)
:computed-slots ((source (first (the pair)))
(target (rest (the pair)))
(target-parent (merge-pathnames "../" (the target)))
(os (lastcar (butlast (pathname-directory (the target-parent)))))
(distributed? (probe-file (merge-pathnames "distributed.txt" (the source)))))
:functions
((make!
()
(if (the distributed?)
(format t "~% ~a is Already Distributed (fill in time & date here from contents of distributed.txt)~%~%" (the source))
(progn
(when (and (probe-file (the target)) (the overwrite?))
(glisp:delete-directory-and-files (the target-parent) :quiet t))
(unless (probe-file (the target-parent))
(glisp:copy-directory (the source) (the target))
;;
;; Documentation:
;;
(ensure-directories-exist (merge-pathnames "documentation/" (the target-parent)))
(glisp:copy-file (merge-pathnames "documentation/gdl-documentation.pdf" glisp:*genworks-source-home*)
(merge-pathnames "documentation/gdl-documentation.pdf" (the target-parent)))
;;
;; GDL source code:
;;
(glisp:copy-directory glisp:*genworks-source-home*
(merge-pathnames "src/" (the target-parent)))
(glisp:delete-directory-and-files (merge-pathnames "src/.git/" (the target-parent)) :quiet t)
(delete-file (merge-pathnames "src/.gitignore" (the target-parent)))
;;
;; Quicklisp:
;;
#+nil
(glisp:copy-directory (merge-pathnames "../../common/quicklisp/" glisp:*genworks-source-home*)
(merge-pathnames "quicklisp/" (the target-parent)))
;;
;; eli:
;;
(ensure-directories-exist (merge-pathnames "emacs/" (the target-parent)))
(glisp:copy-directory (translate-logical-pathname "sys:eli;")
(merge-pathnames "emacs/eli/" (the target-parent)))
(glisp:copy-file (merge-pathnames "dist/emacs/gdl.el" glisp:*genworks-source-home*)
(merge-pathnames "emacs/gdl.el" (the target-parent)))
;;
;; Startup batch file or script:
;;
(if (string-equal (the os) "windows")
(glisp:copy-file (merge-pathnames "dist/run-gdl.bat" glisp:*genworks-source-home*)
(merge-pathnames "run-gdl.bat" (the target-parent)))
(glisp:copy-file (merge-pathnames "dist/run-gdl" glisp:*genworks-source-home*)
(merge-pathnames "run-gdl" (the target-parent))))
;;
;; smlib shared library
;;
(let ((smlib-version "8.51"))
(ensure-directories-exist (merge-pathnames (format nil "SMLib~a/" smlib-version) (the target-parent)))
(let ((smlib-name (if (find-package :smlib) (funcall (read-from-string "glisp:smlib-name"))
(error "smlib-name not known (smlib module probably not loaded)."))))
(glisp:copy-file (merge-pathnames (format nil "../../common/SMLib~a/~a" smlib-version smlib-name)
glisp:*genworks-source-home*)
(merge-pathnames (format nil "SMLib~a/~a" smlib-version smlib-name)
(the target-parent)))))
;;
;; gpl on windows
;;
#+nil
(when (string-equal (the os) "windows")
(glisp:copy-directory (merge-pathnames "../../common/gpl/" glisp:*genworks-source-home*)
(merge-pathnames "gpl/" (the target-parent))))))))))
(defun distro (&rest args)
(let ((self (apply #'make-object 'distro args)))
(the make!)))
\ No newline at end of file
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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 :com.genworks.lisp)
(defun copy-file (from to &key overwrite?)
(fad:copy-file from to :overwrite overwrite?))
;;
;; FLAG -- replace with cl-fad version.
;;
(defun copy-directory (from-dir to-dir &rest args)
(declare (ignore args))
#+allegro (excl:copy-directory from-dir to-dir)
#+lispworks (cl-copy-directory to-dir from-dir)
#+clozure (ccl::recursive-copy-directory from-dir to-dir ))
(defun delete-directory-and-files (target &key force quiet (if-does-not-exist :error))
#-allegro (declare (ignore force quiet))
(cond ((probe-file target)
#+lispworks (system:run-shell-command (format nil "rm -rf ~a" target))
#+allegro (excl.osi:delete-directory-and-files
target :force force :quiet quiet)
#-(or allegro (and unix lispworks))
(cl-fad:delete-directory-and-files target :if-does-not-exist if-does-not-exist))
((null if-does-not-exist) nil)
(t (ecase if-does-not-exist
(:ignore nil)
(:warn (warn "Target ~s does not exist.~%" target))
(:error (error "Target ~s does not exist.~%" target))))))
#+allegro
(ff: def-foreign-call (memory-status-dump "memory_status_dump") ())
(defun dump-memory (&key (output-name "mem")
(output-type "txt")
(output-path (merge-pathnames (make-pathname :name output-name
:type output-type)
(glisp:temporary-folder))))
#+allegro
(let ((status (memory-status-dump (namestring (translate-logical-pathname output-path)))))
(unless (zerop status) (error "~&memory-status-dump failed with non-zero return code: ~a~%~%" status))
output-path)
#-allegro (declare (ignore output-path))
#-allegro
(error "Need implementation of dump-memory for currently running lisp."))
(defun implementation-identifier ()
(asdf::implementation-identifier))
#-allegro(warn "~&Please implement generate-application for the currently running lisp.~%")
(defun make-gdl-app (&rest args)
#+allegro
(let ((app-name (getf args :application-name))
(target (getf args :destination-directory))
(modules (append (list :asdf :compftype
:aserve :phtml #+mswindows :winapi)
(getf args :modules)))
(args (normalize-generate-application-args args)))
(apply #'excl:generate-application app-name target modules args))
#-allegro (declare (ignore args))
#-allegro (error "~&generate-application is not implemented for the currently running lisp.~%"))
#+allegro
(defun normalize-generate-application-args (args)
(let ((class (getf args :application-class)))
(list :runtime (case class
(:development :partners)
(otherwise :standard))
:include-compiler (case class
(:development t)
(otherwise nil))
:include-devel-env (case class
(:development t)
(otherwise nil))
:icon-file (merge-pathnames "gdl/gwl/static/gwl/images/favicon.ico"
glisp:*genworks-source-home*)
:demo (getf args :demo-days)
:lisp-heap-size (getf args :lisp-heap-size)
:close-oldspace t
:init-file-names (getf args :init-file-names)
:pre-load-form (getf args :pre-load-form)
:post-load-form (getf args :post-load-form)
:restart-init-function (getf args :restart-init-function)
:purify t
:autoload-warning nil
:runtime-bundle t
:suppress-allegro-cl-banner t)))
(defun next-datestamp (prefix base)
(let* ((base-length (length base))
(directory (directory prefix))
(files (mapcar #'(lambda(item)
(let ((name (pathname-name item))
(type (pathname-type item)))
(format nil "~a~a~a" name
(if type "." "")
(or type "")))) directory))
(matches (sort (remove-if-not #'(lambda(file)
(and (> (length file) base-length)
(string-equal (subseq file 0 base-length) base))) files)
#'string-greaterp))
(datestamps (remove
nil
(mapcar #'(lambda(match)
(let ((datestamp (subseq match (1+ base-length))))
(if (not (get-decoded-datestamp datestamp))
(warn "Invalid datestamp ~a on file ~a in directory ~a.~%"
datestamp match prefix) datestamp))) matches)))
(latest (first datestamps)))
(multiple-value-bind (latest-serial-number latest-date latest-month latest-year)
(when latest (get-decoded-datestamp latest))
(multiple-value-bind (seconds minutes hours date month year) (get-decoded-time)
(declare (ignore seconds minutes hours))
(let ((new-serial-number (if (and latest (= latest-date date)
(= latest-month month) (= latest-year year))
(1+ latest-serial-number) 0)))
(format nil "~a~2,'0d~2,'0d~2,'0d" year month date new-serial-number))))))
(defun get-decoded-datestamp (datestamp)
(let (*read-eval*)
(when (and (= (length datestamp) 10)
(integerp (read-from-string datestamp)))
(let ((year (read-from-string (subseq datestamp 0 4)))
(month (read-from-string (subseq datestamp 4 6)))
(date (read-from-string (subseq datestamp 6 8)))
(serial-number (read-from-string (subseq datestamp 8 10))))
(when (ignore-errors (encode-universal-time 0 0 0 date month year))
(values serial-number date month year))))))
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; 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-user)
(gdl:define-package :gdl-build (:export #:app #:gdl #:distro #:site))
......@@ -455,7 +455,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
pdf-file)))
(let ((return-value
(glisp:run-shell-command command :show-window? nil)))
(glisp:run-program command :show-window? nil)))
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
......
......@@ -26,15 +26,27 @@
#-(and mswindows allegro) :default)
(defun system-home (system-designator)
(asdf:system-source-directory system-designator))
(defparameter *genworks-source-home*
(let ((gdl-base-home (system-home "gdl-base")))
(make-pathname :name nil
:type nil
:directory (butlast
(butlast (pathname-directory gdl-base-home)))
:defaults gdl-base-home)))
(if (find-package :asdf)
(funcall (read-from-string "asdf:system-source-directory") system-designator)
(error "~&glisp:system-home was called, but cannot function because asdf is not loaded.~%")))
(defparameter *genworks-source-home* nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun set-genworks-source-home-if-known ()
(when (find-package :asdf)
(multiple-value-bind (gdl-base-home error)
(ignore-errors (funcall (read-from-string "asdf:system-source-directory") "gdl-base"))
(if (typep error 'error)
(warn "~&ASDF is loaded, but :gdl-base is not registered. glisp:*genworks-source-home* remains unknown and set to nil.~%")
(setq *genworks-source-home*
(make-pathname :name nil
:type nil
:directory (butlast