;;;; Based on arch2darcs.hs, Copyright (C) 2005 John Goerzen
;;;; <jgoerzen@complete.org>, which is under the GPL.
(defpackage :arch-to-darcs
(:use :common-lisp :sb-ext))
(in-package :arch-to-darcs)
(defun string-starts-with (stuff string)
(string= stuff string :end2 (min (length stuff) (length string))))
(defun default-replay-ignore (file)
(or (string-starts-with "{arch}/" file)
(search ".arch-ids" file)))
(defvar *replay-ignore-hook*
(list 'default-replay-ignore))
(defvar *post-record-hook* nil)
(defvar *edit-log-hook* nil)
(defun run (program args &key input output)
(let ((process (run-program "/usr/bin/env" (list* "env" program args)
:input input :output output)))
(values
(cond ((eql input :stream) (process-input process))
((eql output :stream) (process-output process)))
process)))
(defun get-lines (stream)
(prog1 (loop for line = (read-line stream nil)
while line collect line)
(close stream)))
(defun safe-run-input (program args &key input)
(multiple-value-bind (stream process)
(run program args :input input :output :stream)
(let ((lines (get-lines stream)))
(unless (zerop (process-exit-code process))
(error "While running ~A~{ ~A~}: process exit code was ~D"
program args (process-exit-code process)))
lines)))
(defun safe-run (program &rest args)
(safe-run-input program args))
(defun find-header (header lines)
(let* ((prefix (format nil "~A: " header))
(match (find-if #'(lambda (line)
(or (string= prefix line
:end2 (min (length line)
(length prefix)))
(string= line "")))
lines)))
(when (and match (not (string= match "")))
(subseq match (length prefix)))))
(defun find-log (lines)
(rest (member-if #'(lambda (line) (string= line "")) lines)))
(defun join-lines (lines)
(format nil "~{~A~%~}" lines))
(defun parse-log (lines)
(values (remove-if-not #'digit-char-p
(find-header "Standard-date" lines))
(find-header "Creator" lines)
(find-header "Summary" lines)
(find-log lines)))
(defun record (date author summary log &optional extra-args)
(dolist (fn (reverse *edit-log-hook*))
(setf log (funcall fn log)))
(with-input-from-string
(input (format nil "~A~%~A~%~A~%~{~A~%~}" date author summary log))
(safe-run-input "darcs" (list* "record" "--all" "--pipe" extra-args)
:input input)
(dolist (fn (reverse *post-record-hook*))
(funcall fn date author summary log))))
(defun tag (date author version &optional extra-args)
(with-input-from-string
(input (format nil "~A~%~A~%~A~%" date author version))
(safe-run-input "darcs" (list* "tag" "--pipe" extra-args) :input input)))
(defun record-log (patch-name &optional extra-args)
(multiple-value-bind (date author summary log)
(parse-log (safe-run "baz" "cat-log" patch-name))
(let ((log (append log (list "" (format nil "(:arch-revision ~S)"
patch-name)))))
(record date author summary log extra-args))))
(defun initialize-darcs ()
(record-log (first (last (safe-run "baz" "logs" "--full"))) '("-l")))
(defun darcs-rename (src dest)
(let ((temp-name ",,arch-to-darcs-temp-rename"))
(flet ((darcs-mv () (safe-run "darcs" "mv" "--case-ok" src dest)))
(unless (or (string= src dest)
(string= src (format nil "./~A" dest))
(string= (format nil "./~A" src) dest))
(cond ((probe-file src)
;; If the source file exists, darcs mv gives an error
;; because the dest file is already there. Temporarily
;; hide the source file from darcs mv so there's no
;; error, then move it back.
(sb-posix:rename src temp-name)
(darcs-mv)
(sb-posix:rename temp-name src))
(t (darcs-mv)))))))
(defun split (element sequence)
(loop for last = 0 then (1+ point)
for point = (position element sequence :start last)
collect (subseq sequence last point)
while point))
(defun split-replay-line (line)
(values (elt line 0)
(subseq line 4)))
(defun process-replay-line (line)
(multiple-value-bind (command rest) (split-replay-line line)
(unless (some #'(lambda (fn) (funcall fn rest))
*replay-ignore-hook*)
(case command
(#\A (safe-run "darcs" "add" "--case-ok" rest))
((#\= #\/) (apply #'darcs-rename (split #\Tab rest)))
(#\C (error "Conflict on replay in ~A" rest))
((#\M #\D #\- #\* #\c))
(otherwise (error "Unknown replay code ~A for ~A"
command rest))))))
(defun handle-replay (lines)
(mapc #'process-replay-line lines))
(defun process-patch (patch-name)
(format t "Processing patch ~A.~%" patch-name)
;; Rename the dir to something uninteresting to both darcs and arch
(sb-posix:rename "_darcs" "_darcs.bak")
(let (lines)
(unwind-protect
(setf lines (safe-run "baz" "replay" "--unescaped" patch-name))
(sb-posix:rename "_darcs.bak" "_darcs"))
(handle-replay lines)
(record-log patch-name)))
(defun arch-to-darcs (&key initialize (stop-test (constantly nil)))
(when initialize (initialize-darcs))
(let ((missing (safe-run "baz" "missing")))
(dolist (patch missing)
(process-patch patch)
(when (funcall stop-test patch)
(return-from arch-to-darcs)))))
;;; SBCL-specific stuff follows
(defparameter *tagged-versions*
(make-hash-table :test #'equal))
(defun maybe-tag-sbcl-release (date author summary log)
(declare (ignore summary log))
(let* ((*read-eval* nil)
(version (ignore-errors (with-open-file (v "version.lisp-expr")
(read v)))))
(when (and (not (gethash version *tagged-versions*))
(stringp version)
(or (string= version "0.6.7.1")
(and (< (length (split #\. version)) 4)
(not (search "pre" version)))))
(format t "Tagging version ~A.~%" version)
(tag date author version)
(setf (gethash version *tagged-versions*) t))))
(pushnew 'maybe-tag-sbcl-release *post-record-hook*)
(defun append-sbcl-version (log)
(let* ((*read-eval* nil)
(version (ignore-errors (with-open-file (v "version.lisp-expr")
(read v))))
(*print-case* :downcase))
(append log (list (prin1-to-string (list :sbcl-version version))))))
(pushnew 'append-sbcl-version *edit-log-hook*)
(defparameter *sbcl-branch-sequence*
'("sbcl@boinkor.net--2004-2/sbcl--main--0.6"
"sbcl@boinkor.net--2004-2/sbcl--main--0.7"
"sbcl@boinkor.net--2004-2/sbcl--main--0.8"
"sbcl@boinkor.net--2005/sbcl--main--0.9"))
(defun sbcl-arch-to-darcs ()
"Run in a checkout of:
sbcl@boinkor.net--2004-2/sbcl--main--0.6--base-0
that has had `darcs initialize' run in it. Optionally place
version.lisp-expr in _darcs/prefs/boring before running for
better patch algebra.
You probably don't want to be running with a UTF-8
external-format, either."
(loop for branch in *sbcl-branch-sequence*
for first = t then nil do
(unless first
(safe-run "baz" "tree-version" branch))
(arch-to-darcs :initialize first)))
(defun run (program args &key input output (wait t))
(let ((process (run-program "/usr/bin/env" (list* "env" program args)
:input input :output output :wait wait)))
(values
(cond ((eql input :stream) (process-input process))
((eql output :stream) (process-output process)))
process)))
(defun safe-run-input (program args &key input)
(multiple-value-bind (stream process)
(run program args :input input :output :stream :wait nil)
(let ((lines (get-lines stream)))
(process-wait process)
(unless (zerop (process-exit-code process))
(error "While running ~A~{ ~A~}: process exit code was ~D"
program args (process-exit-code process)))
lines)))