Script for generating file with information of libraries in Quicklisp

release-info.lisp

@@ -0,0 +1,90 @@
+;; Generate a list with information about current release
+;; For each source, url, commit-id, etc
+
+(defpackage :qlc/release-info
+  (:use :cl)
+  (:export #:write-releases-info-cvs)
+  (:documentation "Generate a list with information about current release
+For each source, url, commit-id, etc"))
+
+(in-package :qlc/release-info)
+
+(defvar *whitespaces* (list #\Backspace #\Tab #\Linefeed #\Newline #\Vt #\Page
+                            #\Return #\Space #\Rubout
+                            #+sbcl #\Next-Line #-sbcl (code-char 133)
+                            #+(or abcl gcl lispworks ccl) (code-char 12288) #-(or abcl gcl lispworks ccl) #\Ideographic_space
+                            #+lispworks #\no-break-space #-lispworks #\No-break_space)
+  "On some implementations, linefeed and newline represent the same character (code).")
+
+(defun trim-whitespaces (str)
+  (string-trim *whitespaces* str))
+
+(defun run-program (program &key work-directory)
+  (let ((cmd (if work-directory
+                 (format nil "cd ~a; ~a" work-directory program)
+                 program)))
+    (trim-whitespaces
+     (with-output-to-string (s)
+       (uiop/run-program:run-program cmd :output s)))))
+
+(defgeneric get-release-info (source))
+
+(defmethod get-release-info ((source quicklisp-controller::darcs-source))
+  (flet ((parse-patch-id (x)
+           (second (split-sequence:split-sequence #\space (first (split-sequence:split-sequence #\newline x))))))
+    (list :patch
+          (parse-patch-id
+           (run-program "darcs log --last 1"
+                        :work-directory (quicklisp-controller::cached-checkout-directory source))))))
+
+(defmethod get-release-info ((source quicklisp-controller::svn-source))
+  (list :revision
+        (run-program "svn info --show-item revision"
+                     :work-directory (quicklisp-controller::cached-checkout-directory source))))
+
+(defmethod get-release-info ((source quicklisp-controller::http-source))
+  (list :shasum
+        (run-program (format nil "shasum -a 512256 -c ~a"
+                             (quicklisp-controller::cache-object-file source)))))
+
+(defmethod get-release-info ((source quicklisp-controller::mercurial-source))
+  (list :commit-id
+        (run-program "hg id -i"
+                     :work-directory (quicklisp-controller::cached-checkout-directory source))))
+
+(defmethod get-release-info ((source quicklisp-controller::git-source))
+  (list :commit-id
+        (run-program "git rev-parse HEAD"
+                     :work-directory (quicklisp-controller::cached-checkout-directory source))
+        :timestamp (run-program "git --no-pager log -1 --pretty='format:%cd' --date='format:%Y-%m-%d %H:%M:%S'"
+                                :work-directory (quicklisp-controller::cached-checkout-directory source))))
+
+(defun get-releases-info ()
+  (let ((info '()))
+    (quicklisp-controller::with-skipping
+      (quicklisp-controller::map-sources
+       (lambda (source)
+         (format t "Extracting ~a info ...~%" source)
+         (push (cons source (get-release-info source)) info)))
+      (nreverse info))))
+
+(defun write-releases-info-cvs (pathname)
+  (format t "Writing ~a ...~%" pathname)
+  (with-open-file (cvs pathname :direction :output
+                                :if-does-not-exist :create
+                                :if-exists :supersede)
+    (dolist (release-info (get-releases-info))
+      (let ((source (car release-info))
+            (info (cdr release-info)))
+        (write-string (quicklisp-controller::project-name source) cvs)
+        (write-char #\, cvs)
+        (write-string (quicklisp-controller::location source) cvs)
+        (write-char #\, cvs)
+        (write-string (princ-to-string (cadr info)) cvs)
+        (loop for x in (cdddr info) by #'cddr
+              do
+                 (write-char #\, cvs)
+                 (write-string (princ-to-string x) cvs))
+        (terpri cvs)))))
+
+;; (write-releases-info-cvs #p"/root/quicklisp-controller/quicklisp-release-info.cvs")