Paste number 17632: antifuchs (and whomever else): arch-to-darcs.lisp

Index of paste annotations: 1 | 2

Paste number 17632: antifuchs (and whomever else): arch-to-darcs.lisp
Pasted by: bdowning
When:8 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+DLS
Channel:#lisp
Paste contents:
Raw Source | XML | Display As
;;;; 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)))

Annotations for this paste:

Annotation number 1: fix
Pasted by: bdowning
When:8 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+DLS/1
Paste contents:
Raw Source | Display As
(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)))

Annotation number 2: test
Pasted by: jj
When:8 years, 1 month ago
Share:Tweet this! | http://paste.lisp.org/+DLS/2
Paste contents:
Raw Source | Display As
(defun f (x)
   (* x x))

Colorize as:
Show Line Numbers

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.