Skip to content

Commit 6ffd74b

Browse files
mmontonemmontone
committed
Put systems file building in a separate file
1 parent 6da7e19 commit 6ffd74b

File tree

2 files changed

+80
-69
lines changed

2 files changed

+80
-69
lines changed

‎build-systems-file.lisp‎

Lines changed: 78 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,78 @@
1+
;; This is for buildling a systems-file (the file quicklisp-systems uses to read ASDF systems descriptions.)
2+
3+
;; How to build a systems file:
4+
5+
;; - Clone quicklisp-projects and quicklisp-controller repositories.
6+
;; - Setup quicklisp-controller: (quicklisp-controller:setup-directories "~/src/lisp/quicklisp-projects/")
7+
;; - Update the list of Quicklisp systems using QUICKLISP-CONTROLLER::UPDATE-WHAT-YOU-CAN.
8+
;; - Load all ASDF systems available in *QUICKLISP-CONTROLLER-DIRECTORY* using REGISTER-ALL-ASDF-FILES
9+
;; - Use WRITE-SYSTEMS-FILE to serialize to a QUICKLISP-SYSTEM distribution file.
10+
;; - Upload the file to the URL in QUICKLISP-SYSTEMS::*SYSTEMS-FILE-URL*
11+
12+
(require :quicklisp-systems)
13+
14+
(defpackage #:quicklisp-systems-file
15+
(:use #:cl))
16+
17+
(in-package #:quicklisp-systems-file)
18+
19+
(defparameter *quicklisp-controller-directory* #p"~/quicklisp-controller/")
20+
(defvar *failed-asdf-files* nil
21+
"Contains a list of ASDF files that failed to be loaded and the error, after calling REGISTER-ALL-ASDF-FILES.")
22+
(defparameter *conflictive-asdf-files* '("cl-quakeinfo" "qt-libs" "cl-geocode" "cl-geoip")
23+
"Some ASDF files cause conflicts when trying to be loaded. These are ignored.")
24+
25+
(defun find-files-do (path pattern function &optional (include-subdirectories t))
26+
"Find files in PATH using PATTERN. Invokes FUNCTION on found files.
27+
If INCLUDE-SUBDIRECTORIES is T, then work recursively."
28+
(dolist (file (uiop/filesystem:directory-files path pattern))
29+
(funcall function file))
30+
(when include-subdirectories
31+
(dolist (subdir (uiop/filesystem:subdirectories path))
32+
(find-files-do subdir pattern function include-subdirectories))))
33+
34+
(defun register-all-asdf-files (&optional (quicklisp-controller-directory *quicklisp-controller-directory*))
35+
"Load all ASDF system definition files found in QUICKLISP-CONTROLLER-DIRECTORY."
36+
(setf *failed-asdf-files* nil)
37+
(format *standard-output* "Finding ASDF files...~%")
38+
(find-files-do
39+
(merge-pathnames #p"upstream-cache/" quicklisp-controller-directory)
40+
"*.asd"
41+
(lambda (file)
42+
;; conflictive asdf system files
43+
(when (not (some (lambda (conflictive-system-name)
44+
(search conflictive-system-name (princ-to-string file) :test 'equalp))
45+
*conflictive-asdf-files*))
46+
(format *standard-output* "Loading ~a" file)
47+
(handler-case (progn
48+
(asdf/find-system:load-asd file)
49+
(format *standard-output* ". Success.~%"))
50+
(error (e)
51+
;;(error e)
52+
(push (cons file e) *failed-asdf-files*)
53+
(format *standard-output* ". ERROR.~%")
54+
))))))
55+
56+
(defun serialize-asdf-systems (systems stream)
57+
"Serialize all ASDF SYSTEMS to STREAM."
58+
(loop for system in systems
59+
do
60+
(prin1 `(:name ,(slot-value system 'asdf/component::name)
61+
:description ,(asdf/component:component-description system)
62+
:long-description ,(asdf/component:component-long-description system)
63+
:author ,(slot-value system 'asdf/system::author)
64+
:mailto ,(slot-value system 'asdf/system::mailto)
65+
:maintainer ,(slot-value system 'asdf/system::maintainer)
66+
:homepage ,(slot-value system 'asdf/system::homepage)
67+
:bug-tracker ,(slot-value system 'asdf/system::bug-tracker)
68+
:version ,(slot-value system 'asdf/system::version)
69+
:license ,(slot-value system 'asdf/system::licence)
70+
:depends-on ,(remove-if-not 'stringp (slot-value system 'asdf/system::depends-on)))
71+
stream)
72+
(terpri stream)))
73+
74+
(defun write-systems-file (&optional (path quicklisp-systems::*systems-file*))
75+
(with-open-file (f path :direction :output :external-format :utf-8
76+
:if-exists :supersede)
77+
(serialize-asdf-systems (asdf/system-registry:registered-systems*)
78+
f)))

‎quicklisp-systems.lisp‎

Lines changed: 2 additions & 69 deletions
Original file line numberDiff line numberDiff line change
@@ -13,14 +13,6 @@
1313
;; You should have received a copy of the GNU General Public License
1414
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
1515

16-
;; Use:
17-
18-
;; Clone quicklisp-projects and quicklisp-controller repositories.
19-
;; Setup quicklisp-controller: (quicklisp-controller:setup-directories "~/src/lisp/quicklisp-projects/")
20-
;; Update the list of Quicklisp systems using QUICKLISP-CONTROLLER::UPDATE-WHAT-YOU-CAN.
21-
;; Load all ASDF systems available in *QUICKLISP-CONTROLLER-DIRECTORY* using REGISTER-ALL-ASDF-FILES
22-
;; Then use WRITE-SYSTEMS-FILE to serialize to a QUICKLISP-SYSTEM distribution file.
23-
2416
(require :dexador)
2517
(require :asdf)
2618
(require :quicklisp)
@@ -30,13 +22,9 @@
3022

3123
(in-package #:quicklisp-systems)
3224

33-
(defparameter *quicklisp-controller-directory* #p"~/quicklisp-controller/")
3425
(defvar *systems-file* (merge-pathnames "systems" (uiop/pathname:pathname-directory-pathname *load-pathname*)))
35-
(defvar *failed-asdf-files* nil
36-
"Contains a list of ASDF files that failed to be loaded and the error, after calling REGISTER-ALL-ASDF-FILES.")
37-
(defparameter *conflictive-asdf-files* '("cl-quakeinfo" "qt-libs" "cl-geocode" "cl-geoip")
38-
"Some ASDF files cause conflicts when trying to be loaded. These are ignored.")
39-
(defparameter *systems-file-url* "https://bitbucket.org/mmontone/quicklisp-systems/downloads/systems")
26+
(defparameter *systems-file-url* "https://bitbucket.org/mmontone/quicklisp-systems/downloads/systems"
27+
"The URL from where to download the file with Quicklisp systems descriptions.")
4028

4129
(defmacro do-systems ((system &optional (path *systems-file*)) &body body)
4230
(let ((f (gensym)))
@@ -46,61 +34,6 @@
4634
while ,system
4735
do ,@body)))))
4836

49-
(defun find-files-do (path pattern function &optional (include-subdirectories t))
50-
"Find files in PATH using PATTERN. Invokes FUNCTION on found files.
51-
If INCLUDE-SUBDIRECTORIES is T, then work recursively."
52-
(dolist (file (uiop/filesystem:directory-files path pattern))
53-
(funcall function file))
54-
(when include-subdirectories
55-
(dolist (subdir (uiop/filesystem:subdirectories path))
56-
(find-files-do subdir pattern function include-subdirectories))))
57-
58-
(defun register-all-asdf-files (&optional (quicklisp-controller-directory *quicklisp-controller-directory*))
59-
"Load all ASDF system definition files found in QUICKLISP-CONTROLLER-DIRECTORY."
60-
(setf *failed-asdf-files* nil)
61-
(format *standard-output* "Finding ASDF files...~%")
62-
(find-files-do
63-
(merge-pathnames #p"upstream-cache/" quicklisp-controller-directory)
64-
"*.asd"
65-
(lambda (file)
66-
;; conflictive asdf system files
67-
(when (not (some (lambda (conflictive-system-name)
68-
(search conflictive-system-name (princ-to-string file) :test 'equalp))
69-
*conflictive-asdf-files*))
70-
(format *standard-output* "Loading ~a" file)
71-
(handler-case (progn
72-
(asdf/find-system:load-asd file)
73-
(format *standard-output* ". Success.~%"))
74-
(error (e)
75-
;;(error e)
76-
(push (cons file e) *failed-asdf-files*)
77-
(format *standard-output* ". ERROR.~%")
78-
))))))
79-
80-
(defun serialize-asdf-systems (systems stream)
81-
"Serialize all ASDF SYSTEMS to STREAM."
82-
(loop for system in systems
83-
do
84-
(prin1 `(:name ,(slot-value system 'asdf/component::name)
85-
:description ,(asdf/component:component-description system)
86-
:long-description ,(asdf/component:component-long-description system)
87-
:author ,(slot-value system 'asdf/system::author)
88-
:mailto ,(slot-value system 'asdf/system::mailto)
89-
:maintainer ,(slot-value system 'asdf/system::maintainer)
90-
:homepage ,(slot-value system 'asdf/system::homepage)
91-
:bug-tracker ,(slot-value system 'asdf/system::bug-tracker)
92-
:version ,(slot-value system 'asdf/system::version)
93-
:license ,(slot-value system 'asdf/system::licence)
94-
:depends-on ,(remove-if-not 'stringp (slot-value system 'asdf/system::depends-on)))
95-
stream)
96-
(terpri stream)))
97-
98-
(defun write-systems-file (&optional (path *systems-file*))
99-
(with-open-file (f path :direction :output :external-format :utf-8
100-
:if-exists :supersede)
101-
(serialize-asdf-systems (asdf/system-registry:registered-systems*)
102-
f)))
103-
10437
(defun check-systems-list ()
10538
(and (probe-file *systems-file*) t))
10639

0 commit comments

Comments
 (0)