Allow wildcards in a system name to exclude.

bundle.lisp

@@ -7,7 +7,9 @@
   (:import-from #:qlot/utils/ql
                 #:with-quicklisp-home)
   (:import-from #:qlot/utils
-                #:with-package-functions)
+                #:with-package-functions
+                #:starts-with
+                #:split-with)
   (:import-from #:qlot/logger
                 #:message)
   (:import-from #:qlot/errors
@@ -17,6 +19,33 @@
 
 (defvar *bundle-directory* #P".bundle-libs/")
 
+(defun compile-exclude-rule (rule)
+  (when (< 0 (length rule))
+    (let ((rule-parts (split-with #\* rule))
+          (starts-with-star
+            (char= #\* (aref rule 0)))
+          (ends-with-star
+            (char= #\* (aref rule (1- (length rule))))))
+      (lambda (str)
+        (block out
+          (when (< 0 (length str))
+            (let ((current 0))
+              (loop with initial = t
+                    for part in rule-parts
+                    do (when (or (null initial)
+                                 starts-with-star)
+                         (let ((pos (search part str :start2 current)))
+                           (unless pos
+                             (return-from out nil))
+                           (setf current pos)))
+                       (unless (starts-with part str :start current)
+                         (return-from out nil))
+                       (incf current (length part))
+                       (setf initial nil))
+              (if ends-with-star
+                  t
+                  (= current (length str))))))))))
+
 (defun %bundle-project (project-root &key exclude)
   (assert (uiop:absolute-pathname-p project-root))
 
@@ -29,7 +58,13 @@
       (load (merge-pathnames #P"setup.lisp" quicklisp-home)))
 
     (with-quicklisp-home quicklisp-home
-      (let* ((dependencies (project-dependencies project-root :exclude exclude))
+      (let* ((exclude-functions (mapcar #'compile-exclude-rule exclude))
+             (dependencies (project-dependencies project-root
+                                                 :test
+                                                 (lambda (system-name)
+                                                   (not (some (lambda (fn)
+                                                                (funcall fn system-name))
+                                                              exclude-functions)))))
              (dep-releases (with-package-functions #:ql-dist (release name)
                              (delete-duplicates
                               (mapcar #'release dependencies)

utils.lisp

@@ -19,11 +19,14 @@
    because it upcases text before making it a keyword."
   (intern (string-upcase text) :keyword))
 
-(defun starts-with (prefix value)
+(defun starts-with (prefix value &key (start 0))
   (check-type prefix string)
   (check-type value string)
-  (and (<= (length prefix) (length value))
-       (string= prefix value :end2 (length prefix))))
+  (check-type start (integer 0))
+  (and (<= (length prefix) (- (length value) start))
+       (string= prefix value
+                :start2 start
+                :end2 (+ start (length prefix)))))
 
 (defun split-with (delimiter value &key limit)
   (check-type delimiter character)

utils/asdf.lisp

@@ -189,7 +189,7 @@
               (when system-name
                 (string-downcase system-name)))))))))
 
-(defun lisp-file-dependencies (file &key exclude)
+(defun lisp-file-dependencies (file &key test)
   (flet ((ensure-car (object)
            (if (listp object)
                (car object)
@@ -206,7 +206,7 @@
       (and defpackage-form
            (typep (second defpackage-form) '(or symbol string))
            (let ((package-name (string-downcase (second defpackage-form))))
-             (and (not (member package-name exclude :test 'equal))
+             (and (funcall test package-name)
                   (values
                    (mapcar (lambda (name)
                              (let ((name-str (typecase name

utils/project.lisp

@@ -39,15 +39,15 @@
       (merge-pathnames *qlot-directory* project-root)
       *default-pathname-defaults*)))
 
-(defun project-dependencies (project-root &key exclude)
+(defun project-dependencies (project-root &key test)
   (with-package-functions #:ql-dist (find-system name)
     (let ((all-dependencies '())
           (pis-already-seen-files '())
           (loaded-asd-files '())
           (project-system-names '()))
       (with-directory (system-file system-name dependencies) project-root
         (pushnew system-name project-system-names :test 'equal)
-        (unless (member system-name exclude :test 'equal)
+        (when (funcall test system-name)
           (unless (find system-file loaded-asd-files :test 'equal)
             (push system-file loaded-asd-files)
             (message "Loading '~A'..." system-file)
@@ -71,16 +71,14 @@
                    (pis-dependencies
                     (loop for file in lisp-files
                           for (file-deps pkg-name) = (multiple-value-list
-                                                      (lisp-file-dependencies file :exclude exclude))
+                                                      (lisp-file-dependencies file :test test))
                           when pkg-name
                           append (progn (debug-log "'~A' requires ~S" pkg-name file-deps)
                                         file-deps))))
               (setf dependencies
                     (delete-duplicates
-                     (remove-if (lambda (dep-name)
-                                  (member dep-name exclude :test 'equal))
-                                (mapcar #'string-downcase
-                                        (nconc dependencies pis-dependencies)))
+                     (remove-if-not test
+                                    (nconc dependencies pis-dependencies))
                      :test 'equal))
               (setf pis-already-seen-files
                     (append pis-already-seen-files lisp-files))))