Use our own qlmapper

Using our own version allows to:

- Fix a bug that occured when qlmapper was called from another package:
  *compile-file-truename* would point to the other package's directory.
  Fixed by using ASDF:SYSTEM-SOURCE-DIRECTORY

- Make more modifications to the way sbcl is called, including checking
  for the exit code and log the error if non null

map-declt.lisp

@@ -4,11 +4,11 @@
 (ql:quickload "net.didierverna.declt")
 
 (let ((primary-system
-	(quickref:get-primary-system-name cl-user::*qlmapper-object-name*)))
+	(quickref:get-primary-system-name cl-user::*qrmapper-object-name*)))
   ;; #### TODO: encapsulate this into an error catching form.
   (format t "STARTED BUILDING PACKAGE ~A~%" primary-system)
   (ql:quickload primary-system)
   ;; #### TODO: See about providing more information to the DECLT call.
   (net.didierverna.declt:declt primary-system
-			       :library cl-user::*qlmapper-object-name*)
+			       :library cl-user::*qrmapper-object-name*)
   (format t "FINISHED BUILDING PACKAGE ~A~%" primary-system))

qrmapper-init.lisp

+(in-package #:cl-user)
+
+(defmacro with-qrmapper-output ((stream file) &body body)
+  `(with-open-file (,stream ,file :direction :output
+                            :if-exists :append
+                            :if-does-not-exist :create)
+     ,@body))
+
+(export 'with-qrmapper-output)

qrmapper.lisp

+;; Shamelessly copied and adapted from:
+;; https://github.com/xach/qlmapper
+
+(in-package quickref)
+
+(defvar *sbcl-program* sb-ext:*runtime-pathname*)
+
+(defvar *init-file* (merge-pathnames "qrmapper-init.lisp"
+				     (asdf:system-source-directory "quickref")))
+
+(defun native-truename (file)
+  (native-namestring (truename file)))
+
+(defun eval-defvar-forms (environment-pairs)
+  (loop for (name value) on environment-pairs by #'cddr
+     for sym = (format nil "cl-user::~A" name)
+     collect "--eval"
+     collect (format nil "(defvar ~A (sb-posix:getenv ~S))" sym name)
+     collect "--eval"
+     collect (format nil "(export '~A '#:cl-user)" sym)))
+
+(defun environment-list (environment-pairs)
+  (loop for (name value) on environment-pairs by #'cddr
+     collect (format nil "~A=~A" name value)))
+
+(defun flatlist (&rest args)
+  (alexandria:flatten args))
+
+(defun run-sbcl (&key file pre-file environment-pairs evals)
+  (run-program (native-truename *sbcl-program*)
+	       (flatlist "--noinform"
+			 "--non-interactive"
+			 "--no-userinit"
+			 "--no-sysinit"
+			 "--load" (native-truename
+				   (ql-setup:qmerge "setup.lisp"))
+			 (eval-defvar-forms environment-pairs)
+			 "--eval"
+			 (format nil  "(setf cl:*default-pathname-defaults* ~
+                                       #p~S)"
+				 (native-truename *default-pathname-defaults*))
+			 "--load"
+			 (native-truename *init-file*)
+			 (when pre-file
+			   (list "--load" (native-truename pre-file)))
+			 (mapcar (lambda (eval)
+				   (list "--eval" eval))
+				 evals)
+			 "--load" (native-truename file))
+	       :environment (append (environment-list environment-pairs)
+				    (sb-ext:posix-environ))
+	       :output *standard-output*))
+
+(defgeneric base-directory (object)
+  (:method ((release ql-dist:release))
+    (ql-dist:base-directory release))
+  (:method ((system ql-dist:system))
+    (base-directory (ql-dist:release system))))
+
+(defun map-objects (file
+                    &key dist-name function (filter 'identity) evals pre-file)
+  (unless (probe-file file)
+    (error "~S does not exist" file))
+  (let ((dist (ql-dist:find-dist dist-name)))
+    (unless dist
+      (error "~S does not name any known dist" dist-name))
+    (let ((objects (funcall function dist)))
+      (dolist (object objects)
+        (let ((name (ql-dist:name object)))
+          (when (funcall filter name)
+            (ql-dist:ensure-installed object)
+            (let ((*default-pathname-defaults*
+                   (base-directory object)))
+              (run-sbcl :file file
+                        :pre-file pre-file
+                        :environment-pairs (list "*qrmapper-object-name*"
+                                                 name)
+                        :evals evals))))))))
+
+(defun map-releases (file &key (dist-name "quicklisp") (filter 'identity)
+			    pre-file)
+  "For each release in a dist (defaults to the \"quicklisp\" dist),
+  start an independent SBCL process and load FILE with the variable
+  CL-USER:*QRMAPPER-OBJECT-NAME* bound to the release's name."
+  (map-objects file
+               :pre-file pre-file
+               :dist-name dist-name
+               :function #'ql-dist:provided-releases
+               :filter filter))

quickref.asd

@@ -3,5 +3,6 @@
   :depends-on (:quicklisp :alexandria :qlmapper :net.didierverna.declt.setup)
   :serial t
   :components ((:file "quickref")
+	       (:file "qrmapper")
 	       (:file "website")
 	       (:file "file")))

quickref.lisp

 (defpackage quickref
   (:use :cl)
   (:import-from :alexandria
-   :starts-with-subseq)
+		:starts-with-subseq)
+  (:import-from :sb-ext
+		:run-program
+		:native-namestring)
   (:export :print-primary-systems
 	   :get-primary-system-name
 	   :build-texis
@@ -55,7 +58,7 @@ release.
 The resulting .texi file is placed inside the release's directory, in
 ~/quicklisp/dists/quicklisp/software/."
   (clean-or-create (from-homedir "declt-logfiles/"))
-  (qlmapper:map-releases
+  (map-releases
    (merge-pathnames "map-declt.lisp"
 		    (asdf:system-source-directory "quickref"))))