nasdf: Update to 0.1.7.

nasdf/compilation-tests.lisp

@@ -37,7 +37,7 @@ The logic is:
   requiring arguments.
 - If there's any other error raised by `typep', then TYPE-SPECIFIER is
   likely not a type."
-  (or (documentation type-specifier 'type)
+  (or (ignore-errors (documentation type-specifier 'type))
       (handler-case
           (progn
             (typep t type-specifier)
@@ -97,7 +97,7 @@ Uses the built-in MOP abilities of every Lisp."
                                   '(or standard-accessor-method standard-reader-method standard-writer-method))))
                         classes))))
       (do-external-symbols (s (find-package package) result)
-        (unless (or (some (lambda (doctype) (documentation s doctype))
+        (unless (or (some (lambda (doctype) (ignore-errors (documentation s doctype)))
                           '(variable function compiler-macro setf method-combination type structure))
                     (accessor-p s)
                     ;; Parenscript macros don't have documentation.

nasdf/install.lisp

@@ -84,8 +84,8 @@ Destination directory is given by the `dest-source-dir' generic function."))
       (first (last (pathname-directory
                     ;; Ensure directory _after_ truenamizing, otherwise if
                     ;; non-directory file exists it may not yield a directory.
-                    (uiop:ensure-directory-pathname
-                     (uiop:ensure-pathname pathname :truenamize t)))))))
+                    (ensure-directory-pathname
+                     (ensure-pathname pathname :truenamize t)))))))
 
 (defun path-from-env (environment-variable default)
   (let ((env (getenv environment-variable)))
@@ -120,11 +120,16 @@ Destination directory is given by the `dest-source-dir' generic function."))
   *libdir*)
 
 (export-always '*dest-source-dir*)
-(defvar *dest-source-dir* (path-from-env "NASDF_SOURCE_PATH" *datadir*))
+(defvar *dest-source-dir* (path-from-env "NASDF_SOURCE_PATH" *datadir*)
+  "Root of where the source will be installed.
+Final path is resolved in `dest-source-dir'.")
 
 (export-always 'dest-source-dir)
 (defmethod dest-source-dir ((component nasdf-source-directory))
-  *dest-source-dir*)
+  "The directory into which the source is installed."
+  (let ((name (asdf:primary-system-name (asdf:component-system component))))
+    (ensure-directory-pathname
+     (merge-pathnames* name *dest-source-dir*))))
 
 (export-always '*chmod-program*)
 (defvar *chmod-program* "chmod")
@@ -158,12 +163,12 @@ Destination directory is given by the `dest-source-dir' generic function."))
   nil)
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-file))
-  (values (list (uiop:merge-pathnames* (pathname-name (asdf:component-name c))
-                                       *prefix*))
+  (values (list (merge-pathnames* (pathname-name (asdf:component-name c))
+                                  *prefix*))
           t))
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-binary-file))
-  (values (list (uiop:merge-pathnames* (basename (asdf:component-name c)) *bindir*))
+  (values (list (merge-pathnames* (basename (asdf:component-name c)) *bindir*))
           t))
 
 (defmethod asdf:perform ((op asdf:compile-op) (c nasdf-binary-file))
@@ -172,14 +177,14 @@ Destination directory is given by the `dest-source-dir' generic function."))
   nil)
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-library-file))
-  (values (list (uiop:merge-pathnames* (basename (asdf:component-name c)) (libdir c)))
+  (values (list (merge-pathnames* (basename (asdf:component-name c)) (libdir c)))
           t))
 
 (defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-desktop-file))
-  (values (list (uiop:merge-pathnames* (uiop:merge-pathnames*
-                                        (basename (asdf:component-name c))
-                                        "applications/")
-                                       *datadir*))
+  (values (list (merge-pathnames* (merge-pathnames*
+                                   (basename (asdf:component-name c))
+                                   "applications/")
+                                  *datadir*))
           t))
 
 (defun scan-last-number (path)
@@ -192,7 +197,7 @@ Return NIL is there is none."
                                 (if result
                                     (return-from red result)
                                     result)))
-                          (uiop:native-namestring path)
+                          (native-namestring path)
                           :initial-value '()
                           :from-end t))))
     (when result
@@ -202,8 +207,8 @@ Return NIL is there is none."
   "Return all files of NASDF-ICON-DIRECTORY `type' in its directory.
 File must contain a number in their path."
   (let ((result (remove-if (complement #'scan-last-number)
-                           (uiop:directory-files (asdf:component-pathname c)
-                                                 (uiop:strcat "*." (asdf:file-type c))))))
+                           (directory-files (asdf:component-pathname c)
+                                            (strcat "*." (asdf:file-type c))))))
     (let* ((dimensions (mapcar #'scan-last-number result))
            (dups (set-difference dimensions
                                  (remove-duplicates dimensions)
@@ -242,13 +247,13 @@ File must contain a number in their path."
      (constantly t)
      (lambda (dir)
        (notany (lambda (exclusion)
-                 (uiop:string-suffix-p (basename dir) exclusion))
+                 (string-suffix-p (basename dir) exclusion))
                (mapcar #'basename exclude-subpath)))
      (lambda (subdirectory)
        (setf result (append result
                             (remove-if
                              (lambda (file) (file-excluded-type file exclude-types))
-                             (uiop:directory-files subdirectory))))))
+                             (directory-files subdirectory))))))
     result))
 
 (export-always 'copy-directory)
@@ -273,18 +278,18 @@ They are either listed with 'git ls-files' or directly if Git is not found."
   (let ((source (asdf:component-pathname component))
         (root (asdf:system-source-directory (asdf:component-system component))))
     (handler-case
-        (uiop:with-current-directory (root)
+        (with-current-directory (root)
           (let ((absolute-exclusions (mapcar (lambda (exclusion)
                                                (namestring
                                                 (merge-pathnames*
-                                                 (uiop:ensure-directory-pathname exclusion)
-                                                 (uiop:ensure-directory-pathname source))))
+                                                 (ensure-directory-pathname exclusion)
+                                                 (ensure-directory-pathname source))))
                                              (exclude-subpath component))))
             (remove-if (lambda (file)
                          (or (file-excluded-type file (exclude-types component))
                              (let ((file-string (namestring file)))
                                (some (lambda (exclusion)
-                                       (uiop:string-prefix-p exclusion file-string))
+                                       (string-prefix-p exclusion file-string))
                                      absolute-exclusions))))
                        (mapcar (lambda (path)
                                  (ensure-pathname path :truenamize t))
@@ -293,7 +298,7 @@ They are either listed with 'git ls-files' or directly if Git is not found."
                                 source)))))
       (error (c)
         (warn "~a~&Git error, falling back to direct listing." c)
-        (uiop:with-current-directory (root)
+        (with-current-directory (root)
           (list-directory source :exclude-subpath (exclude-subpath component)
                                  :exclude-types (exclude-types component)))))))
 
@@ -304,3 +309,20 @@ They are either listed with 'git ls-files' or directly if Git is not found."
                (merge-pathnames* (uiop:subpathp path root) (dest-source-dir component)))
              (asdf:input-files op component))
      t)))
+
+(export-always 'nasdf-source-file)
+(defclass nasdf-source-file (nasdf-file) ()
+  (:documentation "Common Lisp source files.
+
+Destination directory is given by the `dest-source-dir' generic function."))
+(import 'nasdf-source-file :asdf-user)
+
+(defmethod dest-source-dir ((component nasdf-source-file)) ; TODO: Factor with other method?
+  "The directory into which the source is installed."
+  (let ((name (asdf:primary-system-name (asdf:component-system component))))
+    (ensure-directory-pathname
+     (merge-pathnames* name *dest-source-dir*))))
+
+(defmethod asdf:output-files ((op asdf:compile-op) (c nasdf-source-file))
+  (values (list (merge-pathnames* (basename (asdf:component-name c)) (dest-source-dir c)))
+          t))

nasdf/nasdf.asd

@@ -2,7 +2,7 @@
 ;;;; SPDX-License-Identifier: BSD-3-Clause
 
 (defsystem "nasdf"
-  :version "0.1.5"
+  :version "0.1.7"
   :author "Atlas Engineer LLC"
   :homepage "https://github.com/atlas-engineer/ntemplate"
   :description "ASDF helpers for system setup, testing and installation."

nasdf/package.lisp

@@ -26,8 +26,11 @@
                 #:run-program
                 #:split-string
                 #:strcat
+                #:string-prefix-p
+                #:string-suffix-p
                 #:subpathp
-                #:symbol-call)
+                #:symbol-call
+                #:with-current-directory)
   (:import-from :asdf
                 #:clear-configuration
                 #:perform

nasdf/submodules.lisp

@@ -45,6 +45,13 @@ A naive benchmark on a 16 Mbps bandwidth gives us
                (system-relative-pathname component path))))
     (setf (getenv "CL_SOURCE_REGISTRY")
           (strcat
+           ;; Register this repository's NASDF path first, to ensure we don't
+           ;; use any NASDF from submodules.
+           (native-namestring
+            (ensure-directory-pathname
+             (ensure-absolute-path "libraries/nasdf" component)))
+           (inter-directory-separator)
+           ;; Submodules:
            (native-namestring
             (ensure-directory-pathname
              (ensure-absolute-path *submodules-directory* component)))