Paste number 17632: antifuchs (and whomever else): arch-to-darcs.lisp Pasted by: bdowning When: 14 years, 6 months ago Share: Tweet this! | http://paste.lisp.org/+DLS Channel: #lisp Paste contents: Raw Source | XML | Display As text/plain image/svg+xml text/html application/xhtml+xml

;;;; 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)))