From: Robin Green <[email protected]>
To: [email protected]
Subject: Strange bug in xdarcs.el
User-Agent: Wanderlust/2.15.7 (Almost Unreal) SEMI/1.14.6 (Maruoka)
FLIM/1.14.8 (=?UTF-8?B?U2hpasWN?=) APEL/10.7 Emacs/23.1
(i386-redhat-linux-gnu) MULE/6.0 (HANACHIRUSATO)
Organization: Swansea University
MIME-Version: 1.0 (generated by SEMI 1.14.6 - "Maruoka")
Content-Type: multipart/mixed; boundary="Multipart_Sun_Nov__1_08:47:41_2009-1"
--Multipart_Sun_Nov__1_08:47:41_2009-1
Content-Type: text/plain; charset=US-ASCII
I don't think this is a bug in darcs, but maybe someone can give some
insight.
I'm trying to use xdarcs.el (patched by me, as attached, to append
'-q' to all commands to avoid confusing xdarcs with progress output
from darcs) as an emacs front-end to darcs record. Everything goes
fine, until xdarcs talks to darcs. Here is the complete contents of
the *darcs output* buffer:
hunk ./Distribution/Client/Configure.hs 21
+import qualified Distribution.Client.GeneralPackageIndex as GeneralPackageIndex
Shall I record this change? (1/202) [ynWsfvplxdaqjk], or ? for help: n
So after xdarcs supplies a response to the first question (doesn't
matter whether it's "y" or "n"), nothing happens. darcs appears to
just sit there. Indeed, I have confirmed with gdb that emacs never
calls read_process_output to process any more output from darcs. Not
sure yet whether emacs actually does receive any more output - I guess
that's the next thing to check, but I'm not familiar with how
asynchronous I/O code works in C.
Most likely this is a bug in emacs 23.1, then. I don't think it could
be a failure-to-flush-output bug in darcs, because emacs uses a
psuedoterminal to communicate with subprocesses (at least in this
case, anyway), and so such a bug would have been evident when using
darcs directly.
So, time for me to read up on select() and friends, then...
--
Robin
--Multipart_Sun_Nov__1_08:47:41_2009-1
Content-Type: application/octet-stream; type=emacs-lisp
Content-Disposition: attachment; filename="xdarcs.el"
Content-Transfer-Encoding: 7bit
;;; xdarcs.el --- Implements Emacs integration for darcs
;; Copyright (C) 2007 James Wright
;; Author: James Wright <[email protected]>
;; Created: 12 May 2007
;; This file is not yet part of GNU Emacs.
;; xdarcs.el is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; xdarcs.el is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This is a set of commands for integrating darcs with Emacs
;; (either of GNU Emacs or XEmacs ought to work). It was inspired by
;; John Wiegley and Christian Neukirchen's darcsum.el.
;;
;; To get started, visit a file that is in a darcs repository. Make
;; some changes, and then type `M-x darcs-whatsnew'. Select the
;; patches that you want to include (space toggles inclusion), and hit
;; `C-c C-c' to record them.
;;; Code:
(require 'xml)
(require 'timezone)
(require 'cl)
;;;; ======================================= rendezvous variables =======================================
(unless (boundp 'running-xemacs)
(defconst running-xemacs (if (string-match "XEmacs\\|Lucid" emacs-version) t)))
(defvar darcs-patch-responses nil
"Patch responses for the currently-running interactive darcs process")
(make-variable-buffer-local 'darcs-patch-responses)
(defvar *darcs-narrow-target* nil
"If `darcs-whatsnew' was called with TARGET-LOCATION-ONLY, contains the target that was displayed.")
;;;; ======================================== Convenience macros ========================================
(defmacro darcs-do-command-async (root-dir-options-list &rest body)
"Run darcs asynchronously in ROOT-DIR, passing it OPTIONS.
Output will be sent to the current buffer. When the process
terminates, the body of the macro will be executed in the
current buffer."
(let ((root-dir (car root-dir-options-list))
(options (cdr root-dir-options-list)))
`(darcs-do-command-async-fn ,root-dir (lambda () ,@body) ,@options)))
;;;; =============================================== faces ==============================================
(defface darcs-blame-author-face
'((((class color) (background dark))
(:foreground "royalblue4"))
(((class color) (background light))
(:foreground "royalblue4"))
(t (:bold t)))
"Face used to highlight the author column of blame output"
:group 'darcs)
(defface darcs-blame-date-face
'((((class color) (background dark))
(:foreground "gray38"))
(((class color) (background light))
(:foreground "gray38"))
(t (:bold t)))
"Face used to highlight the date column of blame output"
:group 'darcs)
(defface darcs-patch-name-face
'((((class color) (background dark))
(:foreground "black" :bold t))
(((class color) (background light))
(:foreground "black" :bold t))
(t (:bold t)))
"Face used to highlight patch names"
:group 'darcs)
(defface darcs-tag-name-face
'((((class color) (background dark))
(:foreground "red" :bold t))
(((class color) (background light))
(:foreground "red" :bold t))
(t (:bold t)))
"Face used to highlight tag names"
:group 'darcs)
(defface darcs-file-link-face
'((((class color) (background dark))
(:foreground "yellow" :bold t))
(((class color) (background light))
(:foreground "black" :bold t))
(t (:bold t)))
"Face used to highlight filename links"
:group 'darcs)
(defface darcs-line-added-face
'((((class color) (background dark))
(:foreground "blue"))
(((class color) (background light))
(:foreground "blue"))
(t (:bold t)))
"Face used for lines added"
:group 'darcs)
(defface darcs-line-removed-face
'((((class color) (background dark))
(:foreground "red"))
(((class color) (background light))
(:foreground "red"))
(t (:bold t)))
"Face used for lines removed"
:group 'darcs)
(defface darcs-header-line-face
'((((class color) (background dark))
(:background "gray90" :foreground "black"))
(((class color) (background light))
(:background "gray90" :foreground "black"))
(t (:bold t)))
"Face used for header lines (eg atomic patch description)"
:group 'darcs)
(defface darcs-excluded-patch-face
'((((class color) (background dark))
(:foreground "gray50"))
(((class color) (background light))
(:foreground "gray50"))
(t (:bold t)))
"Face used for patches that have been excluded"
:group 'darcs)
(defface darcs-excluded-header-line-face
'((((class color) (background dark))
(:background "gray90" :strikethru t))
(((class color) (background light))
(:background "gray90" :strikethru t))
(t (:bold t)))
"Face used for header lines of excluded patches"
:group 'darcs)
(defface darcs-excluded-patch-name-face
'((((class color) (background dark))
(:strikethru t))
(((class color) (background light))
(:strikethru t))
(t (:bold t)))
"Face used for header lines of excluded patches"
:group 'darcs)
;;;; ---------------------------- Other customizable settings ----------------------------
(defcustom darcs-command-prefix [(control x) ?t]
"Prefix key sequence for darcs commands."
:group 'darcs)
(defcustom darcs-ediff-requires-workaround t
"Set to true to use the manual workaround for darcs 2.0's Windows/diff woes"
:type 'boolean
:group 'darcs)
(defcustom darcs-debug nil
"When true, the *darcs output* buffer is never deleted"
:type 'boolean
:group 'darcs)
;;;; ============================================== keymaps =============================================
;;;; ----------------------------------- global keymap -----------------------------------
(defvar darcs-prefix-map
(let ((map (make-sparse-keymap)))
(define-key map [?a] 'darcs-add)
(define-key map [?b] 'darcs-blame)
(define-key map [?c] 'darcs-changes)
(define-key map [?=] 'darcs-diff)
(define-key map [??] 'darcs-describe-bindings)
(define-key map [?d] 'darcs-describe-patch)
(define-key map [?-] 'darcs-ediff)
(define-key map [?f] 'darcs-filelog)
(define-key map [?h] 'darcs-filelog)
(define-key map [?G] 'darcs-pull)
(define-key map [?l] 'darcs-pull)
(define-key map [?S] 'darcs-push)
(define-key map [?u] 'darcs-push)
(define-key map [?i] 'darcs-init)
(define-key map [?r] 'darcs-record)
(define-key map [(control ?r)] 'darcs-revert)
(define-key map [?m] 'darcs-query-manifest)
(define-key map [?q] 'darcs-query-manifest)
(define-key map [?w] 'darcs-whatsnew)
(define-key map [?x] 'darcs-remove)
map)
"The prefix for darcs commands")
(if (not (keymapp (lookup-key global-map darcs-command-prefix)))
(define-key global-map darcs-command-prefix darcs-prefix-map))
(defun darcs-describe-bindings ()
"Show a buffer describing the keys for darcs functions"
(interactive)
(if (fboundp 'describe-bindings-internal)
(let ((map (make-sparse-keymap)))
(save-selected-window
(switch-to-buffer-other-window "*darcs bindings*")
(define-key map [?q] 'darcs-quit-current)
(use-local-map map)
(erase-buffer)
(describe-bindings-internal darcs-prefix-map)))
(describe-bindings [(control x) ?t])))
;;;; --------------------------------- mode-specific maps --------------------------------
(defvar darcs-base-map
(let ((map (make-sparse-keymap 'darcs-base-map)))
(if running-xemacs
(define-key map 'button2 'darcs-mouse-follow-link)
(define-key map [mouse-2] 'darcs-mouse-follow-link))
map)
"Base keymap for darcs buffers. For many this will be sufficient.")
(defvar darcs-link-map
(let ((map (make-sparse-keymap 'darcs-link-map)))
(suppress-keymap map)
(define-key map [?q] 'darcs-quit-current)
(define-key map [?\r] 'darcs-follow-link)
(if running-xemacs
(define-key map 'button2 'darcs-mouse-follow-link)
(define-key map [mouse-2] 'darcs-mouse-follow-link))
map)
"Keymap for darcs links")
(defvar darcs-patch-display-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map darcs-link-map)
(define-key map [?\ ] 'darcs-toggle-patch-included)
(define-key map [?\r] 'darcs-toggle-patch-expanded)
(define-key map [(control return)] 'darcs-find-patch-in-other-window)
(define-key map [?n] 'darcs-next-patch)
(define-key map [?p] 'darcs-prev-patch)
(define-key map [?y] 'darcs-include-patch)
(define-key map [?x] 'darcs-exclude-patch)
(define-key map [?s] 'darcs-exclude-all-in-current-file)
(define-key map [?f] 'darcs-include-all-in-current-file)
(define-key map [?a] 'darcs-expand-all-patches)
(define-key map [?z] 'darcs-collapse-all-patches)
(define-key map [?Y] 'darcs-include-all-patches)
(define-key map [?X] 'darcs-exclude-all-patches)
(define-key map [?j] 'darcs-next-named-patch)
(define-key map [?k] 'darcs-prev-named-patch)
(define-key map [?N] 'darcs-next-named-patch) ;??? Should we keep N and P?
(define-key map [?P] 'darcs-prev-named-patch)
(define-key map [?A] 'darcs-expand-only-named-patches)
map)
"Keymap for displaying lists of atomic patches")
(defvar darcs-record-map
(let ((map (make-sparse-keymap 'darcs-record-map)))
(set-keymap-parent map darcs-base-map)
(define-key map [(control ?c) (control ?c)] 'darcs-commit-record)
(define-key map [(control ?x) ?#] 'darcs-commit-record)
map)
"Keymap for darcs-record-mode")
(defvar darcs-whatsnew-map
(let ((map (make-sparse-keymap 'darcs-whatsnew-map)))
(set-keymap-parent map darcs-base-map)
(define-key map [(control ?c) (control ?c)] 'darcs-record-from-whatsnew)
(define-key map [(control ?c) (control ?r)] 'darcs-commit-revert)
(define-key map [(control ?x) ?#] 'darcs-record-record-from-whatsnew)
map)
"Keymap for darcs-whatsnew-mode")
(defvar darcs-revert-map
(let ((map (make-sparse-keymap 'darcs-revert-map)))
(set-keymap-parent map darcs-base-map)
(define-key map [(control ?c) (control ?r)] 'darcs-commit-revert)
map)
"Keymap for darcs-revert-mode")
(defvar darcs-pull-map
(let ((map (make-sparse-keymap 'darcs-pull-map)))
(set-keymap-parent map darcs-base-map)
(define-key map [(control ?c) (control ?c)] 'darcs-commit-pull)
(define-key map [(control ?x) ?#] 'darcs-commit-pull)
map)
"Keymap for darcs-pull-mode")
(defvar darcs-push-map
(let ((map (make-sparse-keymap 'darcs-push-map)))
(set-keymap-parent map darcs-base-map)
(define-key map [(control ?c) (control ?c)] 'darcs-commit-push)
(define-key map [(control ?x) ?#] 'darcs-commit-push)
map)
"Keymap for darcs-push-mode")
;;;; ============================================ darcs links ===========================================
(defun darcs-make-link-overlay (start end action)
"Make an overlay that highlights when hovered over, and which when double-clicked or RET'ed on will
perform ACTION."
(let ((ov (make-overlay start end)))
(overlay-put ov 'mouse-face 'highlight)
(overlay-put ov 'read-only t)
(overlay-put ov 'darcs-select-action action)
(set-overlay-keymap ov darcs-link-map)
ov))
(defun darcs-quit-current ()
"Hide the current buffer"
(interactive)
(if (one-window-p)
(bury-buffer)
(bury-buffer)
(delete-window)))
(defun darcs-follow-link ()
"In the other window, perform the action in the 'darcs-select-action property of the nearest
enclosing overlay of point"
(interactive)
(let ((ov (overlay-at (point) 'darcs-select-action)))
(unless ov
(error "No link on current line"))
(apply (car (overlay-get ov 'darcs-select-action)) (cdr (overlay-get ov 'darcs-select-action)))))
(defun darcs-mouse-follow-link (evt)
"Function to translate mouse clicks to character events"
(interactive "e")
(let ((win (event-window evt))
(pnt (event-point evt)))
(select-window win)
(goto-char pnt)
(darcs-follow-link)))
(defvar darcs-editable-patch-name-overlay nil
"The overlay that we use to highlight the patch name in a darcs record buffer")
(make-variable-buffer-local 'darcs-editable-patch-name-overlay)
(defun darcs-pre-idle-hook ()
"Displays tool-tips on active overlays when point is over them, and maintains font-locking"
(when darcs-editable-patch-name-overlay
(save-excursion
(goto-char (point-min))
(move-overlay darcs-editable-patch-name-overlay
(point-at-bol) (point-at-eol))))
(let ((ov (overlay-at (point) 'darcs-tool-tip)))
(when ov
(message "%s" (overlay-get ov 'darcs-tool-tip)))))
(add-hook 'post-command-hook 'darcs-pre-idle-hook)
;;;; ============================== specialized handling for patch display ==============================
(defvar darcs-exclude-enabled-function (lambda (ov) t)
"This function is called to determine whether `darcs-include-patch' and `darcs-exclude-patch'
functions should be permitted on a given overlay.")
(make-variable-buffer-local 'darcs-exclude-enabled-function)
(defun darcs-nearest-patch ()
"Returns the nearest patch to point"
(or (overlay-at (point) 'darcs-patch-ov)
(progn (beginning-of-line-text) (overlay-at (point) 'darcs-patch-ov))
(darcs-move-to-patch -1)
(error "no patch around point")))
(defun darcs-toggle-patch-included ()
"If a patch is included, then exclude it; else re-include it"
(interactive)
(let ((ov (darcs-nearest-patch)))
(unless (funcall darcs-exclude-enabled-function ov)
(error "`darcs-exclude-patch' is not enabled for this patch"))
(if (overlay-get ov 'patch-excluded)
(darcs-include-patch t)
(darcs-exclude-patch t))))
(defun darcs-exclude-patch (&optional recursive-p)
"Exclude the current patch and skip to the next patch"
(interactive)
(let ((ov (darcs-nearest-patch)))
(unless (or recursive-p
(funcall darcs-exclude-enabled-function ov))
(error "`darcs-exclude-patch' is not enabled for this patch"))
(let ((desc-ov (overlay-get ov 'darcs-patch-ov)))
(overlay-put ov 'patch-excluded t)
(set-overlay-face ov (if (darcs-named-patch-p ov)
'darcs-excluded-patch-name-face
'darcs-excluded-header-line-face))
(set-overlay-face desc-ov 'darcs-excluded-patch-face)
(set-overlay-priority desc-ov 10)
(when (darcs-named-patch-p ov)
(save-restriction
(save-excursion
(narrow-to-region (overlay-start desc-ov) (overlay-end desc-ov))
(goto-char (overlay-start ov))
(when (darcs-move-to-patch 1)
(darcs-on-all-patches
(lambda (ov)
(unless (darcs-named-patch-p ov)
(darcs-exclude-patch t))))))))
(darcs-collapse-patch)
(unless recursive-p
(if (darcs-named-patch-p ov)
(darcs-next-named-patch)
(darcs-next-patch))))))
(defun darcs-include-patch (&optional recursive-p)
"Include the current patch and skip to the next patch"
(interactive)
(let* ((ov (darcs-nearest-patch))
(desc-ov (overlay-get ov 'darcs-patch-ov)))
(unless (or recursive-p
(funcall darcs-exclude-enabled-function ov))
(error "`darcs-include-patch' is not enabled for this patch"))
(overlay-put ov 'patch-excluded nil)
(set-overlay-face ov (if (darcs-named-patch-p ov)
'darcs-patch-name-face
'darcs-header-line-face))
(set-overlay-face (overlay-get ov 'darcs-patch-ov) nil)
(darcs-expand-patch)
(when (darcs-named-patch-p ov)
(save-restriction
(save-excursion
(narrow-to-region (overlay-start desc-ov) (overlay-end desc-ov))
(goto-char (overlay-start ov))
(when (darcs-move-to-patch 1)
(darcs-on-all-patches
(lambda (ov)
(unless (darcs-named-patch-p ov)
(darcs-include-patch t)))))
(goto-char (point-min))
(darcs-collapse-all-atomic-patches))))
(unless recursive-p
(if (darcs-named-patch-p ov)
(darcs-next-named-patch)
(darcs-next-patch)))))
(defun darcs-patch-collapsed-p ()
"Returns non-NIL if patch at point is collapsed"
(let* ((ov (darcs-nearest-patch)))
(= ?\^M (char-after (or (overlay-get ov 'darcs-collapse-point)
(overlay-end ov))))))
(defun darcs-toggle-patch-expanded ()
"Expands or collapses the current patch"
(interactive)
(save-excursion
(if (darcs-patch-collapsed-p)
(darcs-expand-patch)
(darcs-collapse-patch))))
(defun darcs-flag-patch (flag-char)
"Set all newlines to ^M or vice versa. (if FLAG-CHAR is ?\n, set all to ?\n).
Applies to the description region of the current patch."
(let* ((inhibit-read-only t)
(ov (darcs-nearest-patch))
(desc-ov (overlay-get ov 'darcs-patch-ov))
(collapse-point (overlay-get ov 'darcs-collapse-point)))
;; A little bit of hackery here. We assume that the collapse-point precedes a space; we convert
;; that space to a ^M to hide the rest of the line. When expanding, we convert it back to a
;; space. If collapse-point ever precedes a non-space we're screwed, so include an explicit
;; check.
(when collapse-point
(save-excursion
(goto-char collapse-point)
(delete-char 1)
(if (= flag-char ?\n)
(insert-char ?\ 1)
(unless (looking-at " ")
(error "assertion failed: (looking-at \" \")"))
(insert-char ?\^M 1))))
(subst-char-in-region (or collapse-point
(overlay-end ov))
(overlay-end desc-ov)
(if (= flag-char ?\n) ?\^M ?\n) flag-char)))
(defun darcs-expand-patch ()
"Expand the current patch"
(interactive)
(let* ((ov (darcs-nearest-patch))
(desc-ov (overlay-get ov 'darcs-patch-ov)))
(darcs-flag-patch ?\n)
;; More special-case hackery. If we expand a named patch, collapse all its children afterward.
(when (darcs-named-patch-p ov)
(save-excursion
(save-restriction
(narrow-to-region (overlay-start desc-ov) (overlay-end desc-ov))
(darcs-collapse-all-atomic-patches))))))
(defun darcs-collapse-patch ()
"Hide the current patch"
(interactive)
(darcs-flag-patch ?\^M))
(defun darcs-find-patch-in-other-window ()
"Opens the file associated with the nearest patch in the other window and moves point to the
associated line, if any"
(interactive)
(let ((root-dir (darcs-root-directory default-directory))
(ov (darcs-nearest-patch)))
(when ov
(let ((file (darcs-associated-file root-dir (overlay-string ov)))
(line (darcs-associated-line root-dir (overlay-string ov))))
(unless file
(error (format "no file associated with change '%s'" (overlay-string ov))))
(find-file-other-window file)
(when line
(goto-line line))))))
(defun darcs-move-to-patch (delta)
"Move to the next patch (when DELTA is 1) or the previous patch (when DELTA is -1).
Skips over intermediate patches when (> (abs DELTA) 1)"
(interactive)
(when (zerop delta)
(error "DELTA must not be 0"))
(let ((orig-point (point))
(ov nil))
(goto-char (point-at-bol))
(while (and (null ov)
(zerop (forward-line delta))
(/= (point) (point-max)))
(beginning-of-line-text)
(setq ov (overlay-at (point) 'darcs-patch-ov)))
(if (and ov (/= (point) orig-point))
ov
(goto-char orig-point)
nil)))
;(defun darcs-maybe-recenter ()
; "Recenter if necessary to bring the current patch into full view"
; (let* ((ov (darcs-nearest-patch))
; (desc-ov (overlay-get ov 'darcs-patch-ov))
; (ws (line-number (window-start)))
; (we (line-number (window-end)))
; (l (line-number))
; (oe (overlay-end desc-ov)))
; (when (> oe we)
; (let ((top (- (- l ws) (- oe we))))
; (message (format "Recentering at %d or %d" top 5))
; (recenter (max top 5))))))
(defun darcs-maybe-recenter (&optional median-height)
"Recenter if we are more than MEDIAN-HEIGHT lines from the top of the buffer"
(setq median-height (or median-height (/ (window-body-height) 4)))
(let ((median-line (+ (line-number (window-start))
median-height)))
(when (> (line-number) median-line)
(recenter median-height))))
(defun darcs-next-patch ()
"Move point to the beginning of the next patch heading"
(interactive)
(if (darcs-move-to-patch 1)
(darcs-maybe-recenter)
(message "No more patches")))
(defun darcs-prev-patch ()
"Move point to the beginning of the previous patch heading"
(interactive)
(if (darcs-move-to-patch -1)
(darcs-maybe-recenter)
(message "No more patches")))
(defun darcs-named-patch-p (ov)
"Return non-NIL if OV is an overlay representing a named patch"
;; only named patches have a collapse-point
(overlay-get ov 'darcs-collapse-point))
(defun darcs-next-named-patch ()
"Move point to the beginning of the next named patch"
(interactive)
(let ((orig-point (point))
(ov (darcs-move-to-patch 1)))
(while (and ov
(not (darcs-named-patch-p ov)))
(setq ov (darcs-move-to-patch 1)))
(if ov
(darcs-maybe-recenter)
(goto-char orig-point)
(message "No more named patches"))))
(defun darcs-prev-named-patch ()
"Move point to the beginning of the next named patch"
(interactive)
(let ((orig-point (point))
(ov (darcs-move-to-patch -1)))
(while (and ov
(not (darcs-named-patch-p ov)))
(setq ov (darcs-move-to-patch -1)))
(if ov
(darcs-maybe-recenter)
(goto-char orig-point)
(message "No more named patches"))))
(defun darcs-on-all-patches (thunk)
"Evaluates THUNK with point set to the beginning of each patch in the current buffer"
(save-excursion
(goto-char (point-min))
(let ((ov (or (overlay-at (point) 'darcs-patch-ov)
(darcs-move-to-patch 1))))
(while ov
(funcall thunk ov)
(setq ov (darcs-move-to-patch 1))))))
(defun darcs-collapse-all-patches ()
"Collapse all patches in the current buffer"
(interactive)
(darcs-on-all-patches (lambda (ov) (darcs-flag-patch ?\^M))))
(defun darcs-expand-all-patches ()
"Expand all patches in the current buffer"
(interactive)
(darcs-on-all-patches (lambda (ov) (darcs-flag-patch ?\n))))
(defun darcs-include-all-patches ()
"Include all patches in the current buffer"
(interactive)
(darcs-on-all-patches (lambda(ov) (darcs-include-patch t))))
(defun darcs-exclude-all-patches ()
"Exclude all patches in the current buffer"
(interactive)
(darcs-on-all-patches (lambda(ov) (darcs-exclude-patch t))))
(defun darcs-collect-patch-responses ()
"Returns a list of cells of the form (PATCH-DESC . PLIST), where PATCH-DESC is a string
describing the patch (eg, \"hunk ./notes/darcs-mode 35\") and PLIST contains two properties:
:INCLUDED = non-NIL for included patches
:EXPANDED = non-NIL for expanded patches"
(let ((responses nil))
(darcs-on-all-patches (lambda (ov)
(push (list (overlay-string ov)
:named (darcs-named-patch-p ov)
:included (not (overlay-get ov 'patch-excluded))
:expanded (not (darcs-patch-collapsed-p)))
responses)))
responses))
(defun darcs-apply-patch-responses (patch-responses)
"Ensures that every patch in the current buffer is excluded if it is excluded in PATCH-RESPONSES."
;; ??? make number of patches etc. match??
(darcs-on-all-patches (lambda (ov)
(let ((cell (assoc (overlay-string ov) patch-responses)))
(when cell
(if (plist-get-with-default (cdr cell) :included t)
(darcs-include-patch t)
(darcs-exclude-patch t))
(if (plist-get-with-default (cdr cell) :expanded t)
(darcs-expand-patch)
(darcs-collapse-patch)))))))
(defun darcs-on-all-henceforth-patches-in-current-file (thunk)
"Apply THUNK with point on the current patch, and on each _subsequent_ patch with the same
associate file. On completion, point will be either on the last patch, or on the first subsequent
patch associated with a different file."
(let* ((ov (darcs-nearest-patch))
(file (when (and ov (not (darcs-named-patch-p ov)))
(darcs-associated-file default-directory
(overlay-string ov)))))
(while (and ov file
(not (darcs-named-patch-p ov))
(string= file (darcs-associated-file default-directory
(overlay-string ov))))
(funcall thunk)
(setq ov (darcs-move-to-patch 1)))))
(defun darcs-include-all-in-current-file ()
"Includes current patch, and all following patches in the same file"
(interactive)
(unless (funcall darcs-exclude-enabled-function (darcs-nearest-patch))
(error "`darcs-include-patch' is not enabled for this patch"))
(darcs-on-all-henceforth-patches-in-current-file
(lambda ()
(darcs-include-patch t))))
(defun darcs-exclude-all-in-current-file ()
"Excludes current patch, and all following patches in the same file"
(interactive)
(unless (funcall darcs-exclude-enabled-function (darcs-nearest-patch))
(error "`darcs-exclude-patch' is not enabled for this patch"))
(darcs-on-all-henceforth-patches-in-current-file
(lambda ()
(darcs-exclude-patch t))))
(defun darcs-collapse-all-atomic-patches ()
"Excludes all atomic (ie, unnamed) patches while leaving named patches unchanged"
(darcs-on-all-patches
(lambda (ov)
(unless (darcs-named-patch-p ov)
(darcs-flag-patch ?\^M)))))
(defun darcs-expand-only-named-patches ()
"Expands all named patches but collapses all others"
(interactive)
(darcs-on-all-patches
(lambda (ov)
(if (darcs-named-patch-p ov)
(darcs-expand-patch)
(darcs-collapse-patch)))))
;;;; ======================================= interactive functions ======================================
;;;;; XML format
;;;
;;; The XML produced by 'darcs annotate' appears to have the following features:
;;; a single tag of the form
;;;
;;; <modified><modified_how></<modified_how><patch></patch></modified>
;;;
;;; describing the most-recent patch to be applied to the file, followed by several of
;;;
;;; <normal_line><added_by><patch></patch></added_by> ...text... </normal_line>
;;;
;;; for lines that are part of the file due to previous (ie, not the most-recent) patches, plus
;;; several of
;;;
;;; <added_line> ...text... </added_line>
;;; <removed_line> ...text... </removed_line>
;;;
;;; for lines that were added or removed by the most-recent patch.
;;;;; code
(defun darcs-blame (file)
"Evaluates the darcs annotate command on FILE and outputs it with author and date annotations"
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(unless (darcs-file-registered-p file)
(if (darcs-root-directory file)
(error (format "%s is not part of darcs repo at %s" file (darcs-root-directory file)))
(error (format "No darcs repo at or around %s" (file-name-directory file)))))
(let* ((root-dir (darcs-root-directory file))
(data (with-temp-buffer
(darcs-do-command root-dir
"annotate"
(darcs-canonical-name file)
"--xml")
(xml-parse-region (point-min) (point-max))))
(inhibit-read-only t))
(switch-to-buffer (darcs-format-buffername 'blame (file-name-nondirectory file)))
(erase-buffer)
(darcs-set-mode-from-name file)
(let ((modified-tag (car (xml-get-children* (car data) 'modified))))
(dolist (child (xml-node-children (car data)))
(when (and (listp child)
(or (eq 'normal_line (xml-node-name child))
(eq 'added_line (xml-node-name child))))
(let* ((chg-spec (or (car (xml-get-children* child 'added_by))
modified-tag))
(patch-tag (car (xml-get-children* chg-spec 'patch)))
(local-date (xml-get-attribute patch-tag 'local_date))
(author (xml-substitute-special
(xml-get-attribute patch-tag 'author)))
(patch-name (darcs-xml-node-text
(car (xml-get-children* patch-tag 'name))))
(hash (xml-get-attribute patch-tag 'hash))
(line (darcs-xml-node-text child)))
(when (> (length line) 0)
(let (pa1 pa2 pd1 pd2 pn1 pn2
author-ov date-ov name-ov all-ov)
(setq pd1 (point))
(insert (substring (darcs-cook-date local-date)
0 11))
(setq pd2 (point))
(insert " ")
(setq pa1 (point))
(insert (format "%-7s" (if (> (length author) 7)
(substring author 0 7)
author)))
(setq pa2 (point))
(insert " ")
(setq pn1 (point))
(insert (format "%-15s" (if (> (length patch-name) 15)
(substring patch-name 0 15)
patch-name)))
(setq pn2 (point))
(insert ": ")
(setq e (point))
(insert (format "%s\n" (darcs-trim-newlines line)))
(setq author-ov (make-overlay pa1 pa2))
(setq date-ov (make-overlay pd1 pd2))
(setq name-ov (make-overlay pn1 pn2))
(setq all-ov (darcs-make-link-overlay
pd1 e (list 'darcs-describe-patch root-dir patch-name hash)))
(overlay-put all-ov 'darcs-tool-tip
(format "%s [%s %s]"
patch-name
(darcs-cook-date local-date)
author))
(set-overlay-priority date-ov 5)
(set-overlay-priority author-ov 5)
(set-overlay-priority name-ov 5)
(set-overlay-face author-ov 'darcs-blame-author-face)
(set-overlay-face date-ov 'darcs-blame-date-face)
(set-overlay-face name-ov 'darcs-patch-name-face))))))
(goto-char (point-min)))))
(defun darcs-add (filename)
"Add FILENAME to the nearest darcs repository"
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(let ((root-dir (darcs-root-directory filename))
(canonical-name (darcs-canonical-name filename)))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory filename))))
(with-temp-buffer
(unless (zerop (darcs-do-command root-dir "add" canonical-name))
(error (one-line-buffer)))
(message "Added %s to darcs repo %s" canonical-name root-dir)
(darcs-refresh-query-manifest))))
(defun darcs-remove (filename)
"Removes FILENAME from the nearest darcs repository"
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(let ((root-dir (darcs-root-directory filename))
(canonical-name (darcs-canonical-name filename)))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory filename))))
(with-temp-buffer
(unless (zerop (darcs-do-command root-dir "remove" canonical-name))
(error (one-line-buffer)))
(message "Removed %s from darcs repo %s" canonical-name root-dir)
(darcs-refresh-query-manifest))))
(defun darcs-query-manifest (file-or-dir &optional recursive-p)
"Shows the files managed in the repo at or around FILE-OR-DIR. If RECURSIVE-P in non-nil, does
not for the window to display."
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(let ((root-dir (darcs-root-directory file-or-dir))
(inhibit-read-only t))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory file-or-dir))))
(save-excursion
(darcs-set-buffer 'query-manifest root-dir recursive-p)
(erase-buffer)
(dolist (file (darcs-manifest file-or-dir))
(let (p1 p2 ov)
(setq p1 (point))
(insert (format "%s" file))
(setq p2 (point))
(insert "\n")
(setq ov (darcs-make-link-overlay p1 p2 (list 'find-file-other-window (expand-file-name (concat root-dir file)))))
(set-overlay-face ov 'bold)))
(when (= (point-min) (point-max))
(insert "No files managed in this repo"))
(unless recursive-p
(goto-char (point-min))))))
(defun darcs-refresh-query-manifest ()
"Refresh the appropriate query-manifest window if it exists (based on the current buffer's default
directory)"
(let ((root-dir (darcs-root-directory default-directory)))
(save-excursion
(when (get-buffer (darcs-format-buffername 'query-manifest root-dir))
(darcs-query-manifest root-dir t)))))
(defvar darcs-patch-headers-re
(regexp-opt
'("hunk" "replace" "binary" "addfile" "adddir" "rmfile" "rmdir" "move"
"changepref" "merger" "regrem" "conflict" "tcilfnoc"))
"All the different kinds of atomic patch that can be part of a patch")
(defun darcs-describe-patch (file-or-dir patch-name &optional patch-hash)
"Describe a particular patch"
(interactive (list (or (buffer-truename (current-buffer))
default-directory)
(read-string "Patch name/regexp: ")))
(let ((root-dir (darcs-root-directory file-or-dir))
(inhibit-read-only t))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory file-or-dir))))
(darcs-set-buffer 'describe (or patch-name patch-hash))
(erase-buffer)
(setq darcs-exclude-enabled-function (lambda (ov) nil))
(darcs-do-command root-dir
"annotate"
(if patch-hash
(format "--match=hash %s" patch-hash)
(format "--patch=%s" patch-name))
"-u")
(goto-char (point-min))
(darcs-markup-patch-descriptions)
(goto-char (point-min))
(toggle-read-only 1)))
(defun darcs-whatsnew (location &optional recursive-p target-location-only)
"Show all unrecorded changes in the specified repo. If RECURSIVE-P is non-NIL, updates an
existing buffer without necessarily displaying it. If TARGET-LOCATION-ONLY is non-NIL, only
shows differences for LOCATION."
(interactive (list (or (buffer-truename (current-buffer))
default-directory)))
(let ((root-dir (darcs-root-directory location))
(inhibit-read-only t))
(unless root-dir
(error (format "No darcs repo at or around %s" (file-name-directory location))))
(darcs-set-buffer 'whatsnew root-dir recursive-p)
(erase-buffer)
(if target-location-only
(set (make-local-variable '*darcs-narrow-target*) (darcs-canonical-name location))
(set (make-local-variable '*darcs-narrow-target*) nil))
(save-excursion
(unless (zerop (darcs-do-command root-dir "whatsnew" "-u" *darcs-narrow-target*))
(set-overlay-keymap (make-overlay (point-min) (point-max)) darcs-patch-display-map)
(toggle-read-only 1)
(unless recursive-p
(message (one-line-buffer))))
(goto-char (point-min))
(darcs-markup-patch-descriptions))
(or (progn (beginning-of-line-text) (overlay-at (point) 'darcs-patch-ov))
(darcs-move-to-patch -1)
--Multipart_Sun_Nov__1_08:47:41_2009-1--_______________________________________________
darcs-users mailing list
[email protected]
http://lists.osuosl.org/mailman/listinfo/darcs-users
