Commit ff5b2c3c authored by Dave Cooper's avatar Dave Cooper

Start cleaning and refactoring initialization actions and...

Start cleaning and refactoring initialization actions and restart-init-function. Fix cl-lite to read author, license, version from arguments or .isc files.
parent 8001f973
......@@ -25,10 +25,10 @@
#+(and mswindows allegro) (excl:crlf-base-ef :1252)
#-(and mswindows allegro) :default)
(defun system-home (system-designator)
(defun system-home (system-designator &optional (errorp t))
(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.~%")))
(when errorp (error "~&glisp:system-home was called, but cannot function because asdf is not loaded.~%"))))
(defparameter *genworks-source-home* nil)
......@@ -166,6 +166,8 @@
#+(or ecl clisp) (clos:intern-eql-specializer attr-sym)
)
(defun ensure-string (string-designator)
(string string-designator))
(defun find-feature (feature) (find feature *features*))
......@@ -176,6 +178,13 @@
;;
(defun featurep (x) (find x *features*))
(defun find-feature-version (feature &optional (errorp t))
(when (find-package :asdf)
(let ((system (funcall (read-from-string "asdf:find-system")
(intern feature :keyword) errorp)))
(when system (funcall (read-from-string "asdf:component-version") system)))))
(defun gl-class-name (class)
"Return the class name."
(#-cmu class-name #+cmu mop:class-name class))
......@@ -223,6 +232,29 @@
#+allegro (make-hash-table :values nil)
#-allegro (make-hash-table)))
(defvar *known-system-prefixes* (list "gdl" "gendl" "genworks"))
(defun other-feature (feature)
(let ((prefixes *known-system-prefixes*))
(setq feature (ensure-string feature))
(if (every #'(lambda(prefix) (not (search prefix feature))) prefixes)
(intern (concatenate 'string "gdl-" feature) :keyword)
(mapc #'(lambda(prefix)
(when (string-equal (subseq feature 0 (length prefix)) prefix)
(subseq feature (length prefix)))) prefixes))))
(defun make-versioned-features (feature)
(let ((other-feature (other-feature feature)))
(mapcar #'(lambda(sym) (intern sym :keyword))
(remove
nil
(list
feature other-feature
(let ((version (find-feature-version feature nil)))
(when version (format nil "~a-~a" feature version)))
(let ((version (find-feature-version other-feature nil)))
(when version (format nil "~a-~a" other-feature version))))))))
#-(or allegro lispworks sbcl ccl abcl ecl clisp)
(error "Need implementation for make-weak-hash-table for currently running lisp.~%")
......@@ -257,6 +289,26 @@
#-lispworks nil ;; No action needed for non-lispworks platform currently.
)
(defun set-settings (settings)
(let (anything-changed?)
(dolist (setting settings)
(destructuring-bind (symbol default new-value) setting
(unless (equalp (symbol-value symbol) new-value)
(setq anything-changed? t)
(format t "Setting ~s from default value ~s to non-default value.~%"
symbol default)
(setf (symbol-value symbol) new-value)))) anything-changed?))
(defun set-features (features)
(let (anything-changed?)
(dolist (feature features)
(dolist (feature (make-versioned-features feature))
(unless (or (null feature) (glisp:featurep feature))
(format t "Pushing ~s onto *features* list.~%" feature)
(push feature *features*)
(setq anything-changed? t)))) anything-changed?))
#-allegro(warn "Find out how to retitle relevant windows in currently running lisp.~%")
(defun set-window-titles ()
#+(and allegro mswindows)
......
......@@ -271,9 +271,11 @@ If you are interested in this effort we would love to hear from you at open-sour
#:direct-superclass-names
#:display-startup-banner
#:end-redefinitions-ok
#:ensure-string
#:eql-specializer
#:executable-homedir-pathname
#:featurep
#:find-feature-version
#:gl-class-name
#:gl-method-specializers
#:hex-string-to-integer
......@@ -281,10 +283,13 @@ If you are interested in this effort we would love to hear from you at open-sour
#:make-sans-value-equalp-hash-table
#:make-sans-value-hash-table
#:make-weak-hash-table
#:make-versioned-features
#:set-default-float-format
#:set-default-package
#:set-defpackage-behavior
#:set-local-compiler-tweaks
#:set-features
#:set-settings
#:set-window-titles
#:source-pathname
#:system-home
......@@ -310,6 +315,7 @@ If you are interested in this effort we would love to hear from you at open-sour
;;
;; Implemented in gdl/geom-base/prereqs/source/genworks.lisp
;;
#:find-gs-path
#:get-pid
#:run-gs
#:set-gs-path
......
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
......@@ -31,11 +31,37 @@
created, as a sibling to each source/ subdirectory, to contain the
compiled fasl files.
If the :create-fasl? keyword argument is specified as non-NIL, a
If the :create-fasl? keyword argument is specified as non-nil, a
concatenated fasl file, named after the last directory component of
pathname, will be created in.
Please see codebase-directory-node object for additional inputs (which can be
pathname, will be created in the (glisp:temporary-directory).
[Note: this new documentation still needs proper formatting]
If the :create-asd-file? keyword argument is specified as non-nil,
a .asd file suitable for use with ASDF will be emitted into the
directory indicated by the pathname argument. Note that
ASDF (Another System Definition Utility), possibly with help of
Quicklisp, is (as of 2013-03-12) the recommended way for handling
Common Lisp system modules. As of version 2.31.9, ASDF is also
capable of generating fasl \"bundle\" files as with
the :create-fasl? argument to cl-lite.
For the :author, :version, and :license arguments in the generated
.asd file, the files author.isc, version.isc, and license.isc,
respectively, are consulted, if they exist. They are searched for
first in the codebase toplevel directory (the pathname argument to
this function), then in the (user-homedir-pathname). The version
defaults to the current ISO-8601 date without dashes,
e.g. \"20130312\".
Please see the Genworks Documentation for an overview of Quicklisp
and ASDF, and see the Quicklisp and ASDF project documentation for
detailed information. The source code for Quicklisp and ASDF should
also be included with your Gendl distribution, and these are
typically loaded by default into the development environment.
For additional inputs to the cl-lite function, please see
codebase-directory-node object for additional inputs (which can be
given as keyword args to this function)."
(glisp:begin-redefinitions-ok)
(let ((result
......@@ -123,12 +149,27 @@ given as keyword args to this function)."
(define-object codebase-directory-node (directory-node)
:documentation (:description "Models a filesystem directory for use by the cl-lite program."
)
:documentation (:description "Models a filesystem directory for use by the cl-lite program.")
:functions ((read-isc-file
(name)
(let ((files-to-check
(mapcar #'(lambda(path)
(merge-pathnames (make-pathname :type "isc")
(merge-pathnames name path)))
(list (the pathname) (user-homedir-pathname)))))
(dolist (file files-to-check)
(when (probe-file file)
(return (with-open-file (in file) (read in))))))))
:input-slots
(("Plist of keywords and lists of strings. Maps directory names to their default type classifications."
((author (or (the (read-isc-file "author")) "John McCarthy"))
(version (or (the (read-isc-file "version"))
(replace-substring (iso-8601-date (get-universal-time)) "-" "")))
(license (or (the (read-isc-file "license"))
"Affero Gnu Public License (http://www.gnu.org/licenses/)"))
("Plist of keywords and lists of strings. Maps directory names to their default type classifications."
type-mapping (list :tables '(("tables") ("table")) :source
'(("source" "icons") ("lisp" "cl" "gdl" "gendl")) :qa '(("qa") ("lisp"))
:exercises '(("exercises"))))
......@@ -254,12 +295,11 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
(asdf-system-list
(let ((binaries (the compile-and-load)))
(append `(,(read-from-string "asdf:defsystem") ,(read-from-string (format nil "#:~a" (pathname-name (the asd-file))))
:description "Auto-generated asdf defsys from Genworks GDL cl-lite."
:author "Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated"
:description "Auto-generated asdf defsys from Genworks GenDL cl-lite. Please avoid hand-editing."
:author ,(the author)
:license ,(the license)
:serial t
:version ,(string-append
(replace-substring (iso-8601-date (get-universal-time)) "-" "") "00")
:version ,(the version)
:depends-on ,(the asdf-depends-on)
;;
;; FLAG -- maybe can get rid of binaries and need to call (the compile-and-load)
......@@ -442,6 +482,9 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
;;
;; FLAG -- read this info once in the parent directory object, not here for each file!
;;
;; FLAG -- convert to use read-isc-file function
;;
;;
(ignore-list (let ((ignore-list-file
(make-pathname
:directory (pathname-directory (the :pathname))
......@@ -545,7 +588,11 @@ Defaults to nil (i.e. we assume we are loading into a clean system and need all
parent-dir)
:computed-slots
((ordering-bias (let ((ordering-info-file
(
;;
;; FLAG -- convert to use read-isc-file function.
;;
(ordering-bias (let ((ordering-info-file
(make-pathname
:directory (pathname-directory (the :pathname))
:device (the :device)
......
(defsystem #:gdl-geom-base
: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
"2013031000"
:depends-on
(:uiop :cl-who :gdl-cl-lite :cl-typesetting)
:components
(defsystem #:gdl-geom-base :description
"Auto-generated asdf defsys from Genworks GenDL cl-lite. Please avoid hand-editing."
:author "Dave Cooper and Genworks International" :license
"Gnu Affero General Public License (please see http://www.gnu.org/licenses/)"
:serial t :version "20130312" :depends-on
(:uiop :cl-who :gdl-cl-lite :cl-typesetting) :components
((:file "prereqs/source/cl-pdf-patches")
(:file "prereqs/source/matrix")
(:file "prereqs/source/genworks")
(:file "prereqs/source/parameters")
(:file "prereqs/source/initialize")
(:file "prereqs/source/utilities")
(:file "formats/source/2d-output")
(:file "formats/source/dxf")
......
......@@ -83,20 +83,25 @@
(warn "~&run-shell-command is deprecated, please use run-program.~%")
(apply #'run-program args))
(defun set-gs-path (&optional gs-path)
(setq gdl:*gs-path*
(or (and gs-path (probe-file gs-path))
(if (featurep :mswindows)
(or (probe-file (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))
(probe-file (merge-pathnames "c:/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))
(probe-file (merge-pathnames "../gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*)))
(or (probe-file #p"~/bin/gs")
(probe-file #p"/usr/local/bin/gs")
(probe-file #p"/sw/bin/gs")
(probe-file #p"/opt/local/bin/gs")
(probe-file #p"/usr/bin/gs") "gs"))))
(if gdl:*gs-path*
(format t "~%~%Gnu GhostScript was detected at ~a and registered with GDL.~%~%" (probe-file gdl:*gs-path*))
(warn "Gnu Ghostscript was not found. PNG and JPEG output will not function.
(defun find-gs-path (&optional gs-path)
(let ((gs-path
(or (and gs-path (probe-file gs-path))
(if (featurep :mswindows)
(or (probe-file (merge-pathnames "gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))
(probe-file (merge-pathnames "c:/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*))
(probe-file (merge-pathnames "../gpl/gs/gs8.63/bin/gswin32c.exe" glisp:*gdl-home*)))
(or (probe-file #p"~/bin/gs")
(probe-file #p"/usr/local/bin/gs")
(probe-file #p"/sw/bin/gs")
(probe-file #p"/opt/local/bin/gs")
(probe-file #p"/usr/bin/gs") "gs")))))
(if gs-path
(format t "~%~%Gnu GhostScript was detected at ~a.~%~%" (probe-file gs-path))
(warn "Gnu Ghostscript was not found. PNG and JPEG output will not function.
You can set it manually with (glisp:set-gs-path <path-to-gs-executable>).~%"))
gs-path))
You can set it manually with (glisp:set-gs-path <path-to-gs-executable>).~%")))
\ No newline at end of file
(defun set-gs-path (&optional gs-path)
(setq gdl:*gs-path* (find-gs-path gs-path))
(format t "gdl:*gs-path* has been set to ~a.~%" gdl:*gs-path*))
(in-package :geom-base)
;;
;; Remember symbol, default, new setting for each global param affected by init function.
;;
(defvar *settings* (list (list 'cl-who:*prologue* cl-who:*prologue* "<!doctype HTML>")
(list 'cl-who:*attribute-quote-char* cl-who:*attribute-quote-char* #\")
(list 'cl-who:*downcase-tokens-p* cl-who:*downcase-tokens-p* nil)
(list 'gdl:*gs-path* gdl:*gs-path* (glisp:find-gs-path))))
(defvar *new-features* (list :geom-base))
(defun initialize-geom-base (&key edition)
(declare (ignore edition))
(format t "~&Initializing Generative Web Language (GWL) subsystem...~%~%")
(let (anything-changed?)
(setq anything-changed? (glisp:set-settings *settings*)
anything-changed? (glisp:set-features *new-features*))))
(pushnew 'initialize-geom-base *gdl-init-functions*)
......@@ -131,10 +131,6 @@ this will be included and documented in a future version of the GDL PDF output f
"Boolean. Controls whether the transformations of points from three-dimensional world coordinates
to two-dimensional display coordinates are cached in memory. Set this to NIL to save memory at the
expense of some execution speed. <i>Note: in the current GDL release, transform caching is temporarily
disabled, so this parameter will have no effect.</i> Defaults to T.")(defparameter *hash-transforms?* t
"Boolean. Controls whether the transformations of points from three-dimensional world coordinates
to two-dimensional display coordinates are cached in memory. Set this to NIL to save memory at the
expense of some execution speed. <i>Note: in the current GDL release, transform caching is temporarily
disabled, so this parameter will have no effect.</i> Defaults to T.")
......@@ -169,16 +165,5 @@ the value of this parameter at your own risk.")
(glisp:define-constant +rear-vector+ (make-vector 0 1 0))
(glisp:define-constant +top-vector+ (make-vector 0 0 1))
(defparameter +lh-identity-matrix+ #2A((1.0 0.0 0.0)(0.0 -1.0 0.0)(0.0 0.0 1.0)))
(defun initialize-geom-base (&key edition)
(declare (ignore edition))
(glisp:set-gs-path))
(push #'initialize-geom-base *gdl-init-functions*)
(setq cl-who:*prologue* "<!doctype HTML>")
(setq cl-who:*attribute-quote-char* #\")
(setq cl-who:*downcase-tokens-p* nil)
......@@ -272,6 +272,12 @@ please find implementation for the currently running lisp.~%")
#+allegro 'sys:with-timeout
#-allegro 'acl-compat.mp:with-timeout)
(defmacro with-timeout ((seconds &body timeout-body) &body body)
#+allegro `(mp:with-timeout (,seconds ,@timeout-body)
,@body)
#-allegro `(acl-compat.mp:with-timeout
((seconds &body timeout-body) &body body)
,@body))
;;
;; FLAG -- clean out symbol dependencies of (:net.aserve :net.aserve.client :net.uri :net.html.generator :cl-who)
......
......@@ -21,48 +21,52 @@
(in-package :gwl)
(defvar *static-home* nil)
(defun ensure-static-relative-pathname (relative)
(let ((pathname (merge-pathnames relative *static-home*)))
(or (probe-file pathname)
(error "Required static subdirectory ~a does not appear to exist.~%" pathname))))
(defun publish-images ()
(with-all-servers (server)
(publish-directory
:prefix "/images/gwl/"
:server server
:destination (cond (glisp:*genworks-source-home*
(format nil "~a" (merge-pathnames "gdl/gwl/static/gwl/images/"
glisp:*genworks-source-home*)))
(t (format nil "~a" (merge-pathnames "static/gwl/images/" glisp:*gdl-home*)))))))
:destination (namestring (ensure-static-relative-pathname "gwl/images/")))))
(defun publish-statics ()
(with-all-servers (server)
(publish-directory
:prefix "/static/"
:server server
:destination (cond (glisp:*genworks-source-home*
(format nil "~a" (merge-pathnames "gdl/gwl/static/"
glisp:*genworks-source-home*)))
(t (format nil "~a" (merge-pathnames "static/" glisp:*gdl-home*)))))))
:destination (namestring (ensure-static-relative-pathname "")))))
(defun publish-style ()
(with-all-servers (server)
(publish-directory
:prefix "/style/"
:server server
:destination (cond (glisp:*genworks-source-home*
(format nil "~a" (merge-pathnames "gdl/gwl/static/style/"
glisp:*genworks-source-home*)))
(t (format nil "~a" (merge-pathnames "static/style/" glisp:*gdl-home*)))))))
:destination (namestring (ensure-static-relative-pathname "gwl/style/")))))
(defvar *aserve-listeners* 25)
(defvar *aserve-port* 9000)
(defun client-test (port)
(multiple-value-bind (result error)
(ignore-errors
(net.aserve.client:do-http-request
(format nil "http://localhost:~a" port)))
(mp:with-timeout (2 (error "AllegroServe port probe timed out on port ~a.
Perhaps a zombie process is holding port ~a?~%" port port))
(net.aserve.client:do-http-request
(format nil "http://localhost:~a" port))))
(declare (ignore result))
(when (typep error 'error)
port)))
(defun start-gwl (&key (port 9000) (listeners *aserve-listeners*) (external-format :utf8-base))
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*)
(external-format :utf8-base))
(net.aserve:shutdown)
(let ((port port))
(do ((error (client-test port) (client-test port)))
......@@ -71,14 +75,33 @@
port)
(incf port))))
(defvar *settings* (list (list '*static-home* *static-home*
(when glisp:*genworks-source-home*
(or (probe-file (merge-pathnames "gdl/gwl/static/"
glisp:*genworks-source-home*))
(error "Static home not found"))))))
(defun initialize-gwl (&key edition) (declare (ignore edition))
;;(glisp:initialize-multiprocessing)
(publish-images)
(publish-statics)
(publish-style)
(start-gwl))
(defvar *new-features* (list :gwl))
;;
;; FLAG -- move publishes into global param with the basic publishing data and
;; call general-purpose publish function.
;; also detect changes in the publishing to include in return value.
;;
(defun initialize-gwl (&key edition)
(declare (ignore edition))
(format t "~&Initializing base geometry subsystem...~%~%")
;;
;; FLAG -- investigate if this is still needed, currently LW-only.
;;
(glisp:initialize-multiprocessing)
(let (anything-changed?)
(setq anything-changed? (glisp:set-settings *settings*)
anything-changed? (glisp:set-features *new-features*))
(publish-images) (publish-statics) (publish-style)
(start-gwl) anything-changed?))
(push #'initialize-gwl *gdl-init-functions*)
(pushnew 'initialize-gwl *gdl-init-functions*)
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