Changeset 10254


Ignore:
Timestamp:
Jul 30, 2008, 10:54:31 PM (11 years ago)
Author:
gb
Message:

First cut at an UPDATE-CCL function:
(update-ccl &key (verbose t))
Runs "svn update" in the ccl directory and parses the output.
Quietly resolves (via "svn revert") conflicts involving the kernel and
image.
CERRORs on other conflicts, offering to use "svn revert" on them, too.
When "verbose", reports changed files.
Returns T iff anything changed, and a second value listing unresolved
conflicts. (That may not be too well thought out; might do the
conflict resolution under control of some other option.)

REBUILD-CCL calls UPDATE-CCL if its :UPDATE arg is non-nil, and
passes :VERBOSE T unless (rebuild-ccl :update :quiet).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/compile-ccl.lisp

    r10120 r10254  
    484484    (when full
    485485      (setq clean t kernel t reload t))
    486     (when update (update-ccl))
     486    (when update (update-ccl :verbose (not (eq update :quiet))))
    487487    (let* ((cd (current-directory)))
    488488      (unwind-protect
     
    590590          (funcall f dirname target))))))
    591591
    592 (defun update-ccl ()
    593   (let* ((cvs-update "cvs -q update -d -P")
    594          (svn-update "svn update")
    595          (use-cvs (probe-file "ccl:\.svnrev"))
    596          (s (make-string-output-stream)))
    597     (multiple-value-bind (status exit-code)
    598         (external-process-status
    599          (run-program "/bin/sh"
    600                       (list "-c"
    601                             (format nil "cd ~a && ~a"
    602                                     (native-translated-namestring "ccl:")
    603                                     (if use-cvs cvs-update svn-update)))
    604                       :output s))
    605       (when (and (eq status :exited)
    606                  (eql exit-code 0))
    607         (format t "~&~a" (get-output-stream-string s))
    608         t))))
     592(defun update-ccl (&key (verbose t))
     593  (let* ((changed ())
     594         (conflicts ()))
     595    (with-output-to-string (out)
     596      (with-preserved-working-directory ("ccl:")                     
     597        (when verbose (format t "~&;Running 'svn update'."))
     598        (multiple-value-bind (status exit-code)
     599            (external-process-status
     600             (run-program "svn" '("update") :output out :error t))
     601          (when verbose (format t "~&;'svn update' complete."))
     602          (if (not (and (eq status :exited)
     603                        (eql exit-code 0)))
     604            (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code)
     605            (let* ((sout (get-output-stream-string out))
     606                   (added ())
     607                   (deleted ())
     608                   (updated ())
     609                   (merged ())
     610                   (binaries (list (standard-kernel-name) (standard-image-name ))))
     611              (flet ((svn-revert (string)
     612                       (multiple-value-bind (status exit-code)
     613                           (external-process-status (run-program "svn" `("revert" ,string)))
     614                         (when (and (eq status :exited) (eql exit-code 0))
     615                           (setq conflicts (delete string conflicts :test #'string=))
     616                           (push string updated)))))
     617                (with-input-from-string (in sout)
     618                  (do* ((line (read-line in nil nil) (read-line in nil nil)))
     619                       ((null line))
     620                    (when (and (> (length line) 2)
     621                               (eql #\space (schar line 1)))
     622                      (let* ((path (string-trim " " (subseq line 2))))
     623                        (case (schar line 0)
     624                          (#\A (push path added))
     625                          (#\D (push path deleted))
     626                          (#\U (push path updated))
     627                          (#\G (push path merged))
     628                          (#\C (push path conflicts)))))))
     629                ;; If the kernel and/or image conflict, use "svn revert"
     630                ;; to replace the working copies with the (just updated)
     631                ;; repository versions.
     632                (setq changed (if (or added deleted updated merged conflicts) t))
     633             
     634                (dolist (f binaries)
     635                  (when (member f conflicts :test #'string=)
     636                    (svn-revert f)))
     637                ;; If there are any remaining conflicts, offer
     638                ;; to revert them.
     639                (when conflicts
     640                  (with-preserved-working-directory ()
     641                    (cerror "Discard local changes to these files (using 'svn revert'."
     642                            "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~~}" (length conflicts) conflicts)
     643                    (dolist (c (copy-list conflicts))
     644                      (svn-revert c))))
     645                ;; Report other changes, if verbose.
     646                (when (and verbose
     647                           (or added deleted updated merged conflicts))
     648                  (format t "~&;Changes from svn update:")
     649                  (flet ((show-changes (herald files)
     650                           (when files
     651                             (format t "~&; ~a:~{~&;  ~a~}"
     652                                     herald files))))
     653                    (show-changes "Conflicting files" conflicts)
     654                    (show-changes "New files/directories" added)
     655                    (show-changes "Deleted files/directories" deleted)
     656                    (show-changes "Updated files" updated)
     657                    (show-changes "Files with local changes, successfully merged" merged)))))))))
     658    (values changed conflicts)))
    609659
    610660(defmacro with-preserved-working-directory ((&optional dir) &body body)
Note: See TracChangeset for help on using the changeset viewer.