diff --git a/release-info.lisp b/release-info.lisp new file mode 100644 index 0000000..533b446 --- /dev/null +++ b/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")