Added tools/try-systems.lisp

Pascal J. Bourguignon [2015-07-09 03:07]
Added tools/try-systems.lisp
Filename
clisp/com.informatimago.clisp.asd
tools/asdf-file.lisp
tools/script.lisp
tools/try-systems.lisp
diff --git a/clisp/com.informatimago.clisp.asd b/clisp/com.informatimago.clisp.asd
index 37b8898..a048915 100644
--- a/clisp/com.informatimago.clisp.asd
+++ b/clisp/com.informatimago.clisp.asd
@@ -43,6 +43,7 @@
   :maintainer "Pascal J. Bourguignon <pjb@informatimago.com>"
   :license "AGPL3"
   :version "1.2.4"
+  #+asdf-unicode :encoding #+asdf-unicode :utf-8
   :depends-on ()
   :components ())

diff --git a/tools/asdf-file.lisp b/tools/asdf-file.lisp
index d70fcda..e86e4c9 100644
--- a/tools/asdf-file.lisp
+++ b/tools/asdf-file.lisp
@@ -49,6 +49,8 @@
    "MAKE-COMPONENTS"
    "GENERATE-ASD"
    ;; Reading and writing asd files:
+   "FIND-ASD-FILES"
+   "ASD-SYSTEMS-IN-ASD-FILE"
    "READ-ASDF-SYSTEM-DEFINITIONS"
    "WRITE-ASDF-SYSTEM-DEFINITION"
    "SAVE-ASDF-SYSTEM-FILE"
@@ -298,15 +300,45 @@ VANILLAP:  if true, then generate a simple, vanilla system.
 (defun read-asdf-system-definitions (stream)
   "
 Reads an ASD file stream and return a list of asdf:defsystem forms
-found.  DEFPACKAGE and IN-PACKAGE forms are evaluated.
+found.
+
+DEFPACKAGE and IN-PACKAGE forms are evaluated, but IN-PACKAGE forms
+are neutralized with a local dynamic binding of *PACKAGE*.
 "
-  (let ((forms (read-source-code stream
+  (let ((*package* *package*)
+        (forms (read-source-code stream
                                  :test (lambda (sexp)
                                          (and (consp sexp)
                                               (eql (first sexp) 'asdf:defsystem))))))
     (cdr (assoc :test forms))))


+(defun find-asd-files (root-directory)
+  "Returns a list of pathnames to asd files found recursively in the ROOT-DIRECTORY."
+  (directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)
+                                             :name :wild
+                                             :type "asd"
+                                             :case :local
+                                             :defaults root-directory)
+                              root-directory nil)))
+
+
+(defun asd-systems-in-asd-file (asd-file-pathname)
+  "
+Returns a list of system names found in the asd file ASD-FILE-PATHNAME.
+
+DEFPACKAGE and IN-PACKAGE forms are evaluated, but IN-PACKAGE forms
+are neutralized with a local dynamic binding of *PACKAGE*.
+"
+  (with-open-file (stream asd-file-pathname)
+    (mapcan (lambda (defsystem-form)
+              (ignore-errors
+               (destructuring-bind (defsystem name &rest ignored) defsystem-form
+                 (declare (ignore defsystem ignored))
+                 (list (string-downcase name)))))
+            (read-asdf-system-definitions stream))))
+
+
 (defun write-asdf-system-definition (stream defsystem-form)
   "Writes the defsystem-form to the STREAM."
   (pop defsystem-form)
diff --git a/tools/script.lisp b/tools/script.lisp
index 181392f..0569a1b 100644
--- a/tools/script.lisp
+++ b/tools/script.lisp
@@ -54,7 +54,8 @@
            "EX-IOERR" "EX-TEMPFAIL" "EX-PROTOCOL" "EX-NOPERM"
            "EX-CONFIG" "EX--MAX"
            ;;
-           "*SHELL-OUTPUT*" "*SHELL-ERROR*" "SHELL" "UNAME" "PARSE-OPTIONS"))
+           "*SHELL-OUTPUT*" "*SHELL-ERROR*" "SHELL" "UNAME"
+           "SHELL-QUOTE-ARGUMENT" "PARSE-OPTIONS"))
 (in-package "COM.INFORMATIMAGO.TOOLS.SCRIPT")


@@ -468,6 +469,26 @@ RETURN:     The lisp-name of the option (this is a symbol
   "The stream where the error  stream of the shell commands is set to.")


+(defun shell-quote-argument (argument)
+  "
+DO:      Quote an argument for passing as argument to an inferior shell.
+RETURN:  A string containing the quoted argument.
+"
+  (do ((i 0 (1+ i))
+       (ch)
+       (result '()))
+      ((<= (length argument) i) (coerce (nreverse result) 'string))
+    (setq ch (char argument i))
+    (unless (or (char= (character "-") ch)
+                (char= (character ".") ch)
+                (char= (character "/") ch)
+                (and (char<= (character "A") ch) (char<= ch (character "Z")))
+                (and (char<= (character "a") ch) (char<= ch (character "z")))
+                (and (char<= (character "0") ch) (char<= ch (character "9"))))
+      (push (character "\\") result))
+    (push ch result)))
+
+

 ;; From stream.lisp (to be stand alone):

diff --git a/tools/try-systems.lisp b/tools/try-systems.lisp
new file mode 100644
index 0000000..ee9f611
--- /dev/null
+++ b/tools/try-systems.lisp
@@ -0,0 +1,197 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               try-systems.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Tries to compile all the systems in an environment similar to
+;;;;    the one used by quicklisp when validating systems.
+;;;;
+;;;;    Report errors.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2015-07-08 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2015 - 2015
+;;;;
+;;;;    This program is 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 program 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 program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+(in-package "COMMON-LISP-USER")
+(defpackage "COM.INFORMATIMAGO.TOOLS.TRY-SYSTEMS"
+  (:use "COMMON-LISP"
+        "SPLIT-SEQUENCE"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.FILE"
+        "COM.INFORMATIMAGO.TOOLS.ASDF-FILE"
+        "COM.INFORMATIMAGO.TOOLS.SCRIPT"))
+(in-package "COM.INFORMATIMAGO.TOOLS.TRY-SYSTEMS")
+
+(defmacro in-home (relative-path)
+  `(load-time-value (merge-pathnames ,relative-path
+                                     (user-homedir-pathname)
+                                     nil)))
+
+(defvar *reports-directory*
+  (in-home #P"try-system-reports/")
+  "Pathname of the directory where to store reports.")
+
+(defvar *asdf*
+  (in-home #P"quicklisp/asdf.lisp")
+  "Pathname of the asdf.lisp source file.")
+
+(defvar *releases-file*
+  (in-home #P"quicklisp/dists/quicklisp/releases.txt")
+  "The quicklisp files listing all the releases.")
+
+(defvar *local-projects-directory*
+  (in-home #P"quicklisp/local-projects/")
+  "The quicklisp files listing all the releases.")
+
+(defvar *software-directory*
+  (in-home #P"quicklisp/dists/quicklisp/software/")
+  "The directory where the quicklisp systems are stored.")
+
+
+(defun directory-of (pathname)
+  (make-pathname :name nil :type nil :version nil
+                 :defaults pathname))
+
+(defun find-asd-systems-in-directory (root-directory)
+  (mapcar (lambda (asd-file-pathname)
+            (cons (directory-of asd-file-pathname)
+                  (asd-systems-in-asd-file asd-file-pathname)))
+          (find-asd-files root-directory)))
+
+(defun quicklisp-registry ()
+  "Returns a list of all the directories where there's a ASD file managed by quicklisp."
+  (let ((paths '()))
+    (flet ((process-files (files)
+             (dolist (asdf files)
+               (push (directory-of asdf) paths))))
+      (dolist (line (remove-if (lambda (line) (or (zerop (length line)) (char= #\# (aref line 0))))
+                               (string-list-text-file-contents *releases-file*)))
+        (destructuring-bind (dir &rest files) (nthcdr 5 (split-sequence #\space line :remove-empty-subseqs t))
+          (let ((base (merge-pathnames (make-pathname :directory (list :relative dir)
+                                                      :defaults  *software-directory*)
+                                       *software-directory*
+                                       nil)))
+            (process-files (mapcar (lambda (asdf) (merge-pathnames asdf base nil)) files)))))
+      (process-files (directory (merge-pathnames (make-pathname :directory '(:relative :wild-inferiors)
+                                                                :name :wild :type "asd" :case :local
+                                                                :defaults *local-projects-directory*)
+                                                 *local-projects-directory* nil))))
+    (remove-duplicates paths :test (function equalp))))
+
+(defun run (date system operation
+            lisp &rest arguments)
+  (let* ((report-dir  (merge-pathnames (make-pathname :directory (list :relative date)
+                                                      :defaults *reports-directory*)
+                                       *reports-directory* nil))
+         (output-file (make-pathname :name (format nil "~A-~A-~A" date operation system)
+                                     :type "output"
+                                     :case :local
+                                     :defaults report-dir))
+         (error-file  (make-pathname :type "error"
+                                     :case :local
+                                     :defaults output-file)))
+    (ensure-directories-exist error-file)
+    (ignore-errors
+     (progn
+       (format *trace-output* "~A~%" output-file)
+       (force-output *trace-output*)
+       (uiop:run-program (mapconcat (function shell-quote-argument)
+                                    (cons lisp arguments)
+                                    " ")
+                         :input nil
+                         :output output-file
+                         :error-output error-file
+                         :if-output-exists :supersede
+                         :if-error-output-exists :supersede)
+       :success))))
+
+(defun date ()
+  "Return the current date in YYYYMMDD format."
+  (multiple-value-bind (se mi ho da mo ye) (decode-universal-time (get-universal-time) 0)
+    (declare (ignore se mi ho))
+    (format nil "~4,'0D~2,'0D~2,'0D" ye mo da)))
+
+(defun try-systems-in-directory (root-directory
+                                 &key
+                                   (asdf *asdf*)
+                                   ((:reports-directory *reports-directory*) *reports-directory*))
+  (loop
+    :with results  := '()
+    :with date     := (date)
+    :with registry := (merge-pathnames (make-pathname :name "registry" :type "lisp" :case :local
+                                                      :directory (list :relative date)
+                                                      :defaults *reports-directory*)
+                                       *reports-directory* nil)
+    :for (asd-directory . systems) :in (find-asd-systems-in-directory root-directory)
+      :initially (ensure-directories-exist registry)
+                 (with-open-file (src registry :direction :output
+                                               :if-does-not-exist :create
+                                               :if-exists :supersede)
+                   (let ((*print-pretty*   t)
+                         (*print-readably* t))
+                     (format src "(setf asdf:*central-registry* '~S)~%" (quicklisp-registry))))
+    :do (loop
+          :for asd-system :in systems
+          :for success := (run date asd-system "load"
+                               "sbcl"
+                               "--noinform"
+                               "--no-userinit"
+                               "--non-interactive"
+                               "--load" (namestring asdf)
+                               "--load" (namestring registry)
+                               ;; We cannot use prin1-to-string in case we don't have the same asdf version.
+                               "--eval" (format nil "(let ((asdf:*compile-file-warnings-behaviour* :warn) (asdf:*compile-file-failure-behaviour* :error)) (asdf:oos 'asdf:load-op ~S))" asd-system))
+          :do (push (list success asd-directory asd-system) results))
+    :finally (loop :for (success nil asd-system) :in results
+                   :when (and success (not (test-system-p `(defsystem ,asd-system))))
+                     :do (run date asd-system "test"
+                              "sbcl"
+                              "--noinform"
+                              "--no-userinit"
+                              "--non-interactive"
+                              "--load" (namestring asdf)
+                              "--load" (namestring registry)
+                              ;; We cannot use prin1-to-string in case we don't have the same asdf version.
+                              "--eval" (format nil "(let ((asdf:*compile-file-warnings-behaviour* :warn) (asdf:*compile-file-failure-behaviour* :error)) (asdf:oos 'asdf:test-op ~S))" asd-system)))))
+
+;; (try-systems-in-directory #P"~/src/public/lisp/")
+
+;; asdf:*compile-file-warnings-behaviour*
+;; asdf:*compile-file-errors-behaviour*
+;; control the handling of any such events.
+;; The valid values for these variables are :error, :warn, and :ignore.
+
+
+
+
+
+#-(and)
+(run "sbcl"
+     "--noinform"
+     "--no-userinit"
+     "--non-interactive"
+     "--load" (namestring (merge-pathnames "quicklisp/asdf.lisp"
+                                           (user-homedir-pathname) nil))
+     "--eval" (prin1-to-string `(push ,asd-directory asdf:*central-registry*))
+     "--eval" (prin1-to-string `(asdf:oos 'asdf:load-op ,asd-system)))
ViewGit