1;;; mq.el --- Emacs support for Mercurial Queues
2
3;; Copyright (C) 2006 Bryan O'Sullivan
4
5;; Author: Bryan O'Sullivan <bos@serpentine.com>
6
7;; mq.el is free software; you can redistribute it and/or modify it
8;; under the terms of the GNU General Public License version 2 or any
9;; later version.
10
11;; mq.el is distributed in the hope that it will be useful, but
12;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;; General Public License for more details.
15
16;; You should have received a copy of the GNU General Public License
17;; along with mq.el, GNU Emacs, or XEmacs; see the file COPYING (`C-h
18;; C-l').  If not, see <http://www.gnu.org/licenses/>.
19
20(eval-when-compile (require 'cl))
21(require 'mercurial)
22
23
24(defcustom mq-mode-hook nil
25  "Hook run when a buffer enters mq-mode."
26  :type 'sexp
27  :group 'mercurial)
28
29(defcustom mq-global-prefix "\C-cq"
30  "The global prefix for Mercurial Queues keymap bindings."
31  :type 'sexp
32  :group 'mercurial)
33
34(defcustom mq-edit-mode-hook nil
35  "Hook run after a buffer is populated to edit a patch description."
36  :type 'sexp
37  :group 'mercurial)
38
39(defcustom mq-edit-finish-hook nil
40  "Hook run before a patch description is finished up with."
41  :type 'sexp
42  :group 'mercurial)
43
44(defcustom mq-signoff-address nil
45  "Address with which to sign off on a patch."
46  :type 'string
47  :group 'mercurial)
48
49
50;;; Internal variables.
51
52(defvar mq-mode nil
53  "Is this file managed by MQ?")
54(make-variable-buffer-local 'mq-mode)
55(put 'mq-mode 'permanent-local t)
56
57(defvar mq-patch-history nil)
58
59(defvar mq-top-patch '(nil))
60
61(defvar mq-prev-buffer nil)
62(make-variable-buffer-local 'mq-prev-buffer)
63(put 'mq-prev-buffer 'permanent-local t)
64
65(defvar mq-top nil)
66(make-variable-buffer-local 'mq-top)
67(put 'mq-top 'permanent-local t)
68
69;;; Global keymap.
70
71(defvar mq-global-map
72  (let ((map (make-sparse-keymap)))
73    (define-key map "." 'mq-push)
74    (define-key map ">" 'mq-push-all)
75    (define-key map "," 'mq-pop)
76    (define-key map "<" 'mq-pop-all)
77    (define-key map "=" 'mq-diff)
78    (define-key map "r" 'mq-refresh)
79    (define-key map "e" 'mq-refresh-edit)
80    (define-key map "i" 'mq-new)
81    (define-key map "n" 'mq-next)
82    (define-key map "o" 'mq-signoff)
83    (define-key map "p" 'mq-previous)
84    (define-key map "s" 'mq-edit-series)
85    (define-key map "t" 'mq-top)
86    map))
87
88(global-set-key mq-global-prefix mq-global-map)
89
90(add-minor-mode 'mq-mode 'mq-mode)
91
92
93;;; Refresh edit mode keymap.
94
95(defvar mq-edit-mode-map
96  (let ((map (make-sparse-keymap)))
97    (define-key map "\C-c\C-c" 'mq-edit-finish)
98    (define-key map "\C-c\C-k" 'mq-edit-kill)
99    (define-key map "\C-c\C-s" 'mq-signoff)
100    map))
101
102
103;;; Helper functions.
104
105(defun mq-read-patch-name (&optional source prompt force)
106  "Read a patch name to use with a command.
107May return nil, meaning \"use the default\"."
108  (let ((patches (split-string
109		  (hg-chomp (hg-run0 (or source "qseries"))) "\n")))
110    (when force
111      (completing-read (format "Patch%s: " (or prompt ""))
112		       (mapcar (lambda (x) (cons x x)) patches)
113		       nil
114		       nil
115		       nil
116		       'mq-patch-history))))
117
118(defun mq-refresh-buffers (root)
119  (save-excursion
120    (dolist (buf (hg-buffers-visiting-repo root))
121      (when (not (verify-visited-file-modtime buf))
122	(set-buffer buf)
123	(let ((ctx (hg-buffer-context)))
124	  (message "Refreshing %s..." (buffer-name))
125	  (revert-buffer t t t)
126	  (hg-restore-context ctx)
127	  (message "Refreshing %s...done" (buffer-name))))))
128  (hg-update-mode-lines root)
129  (mq-update-mode-lines root))
130
131(defun mq-last-line ()
132  (goto-char (point-max))
133  (beginning-of-line)
134  (when (looking-at "^$")
135    (forward-line -1))
136  (let ((bol (point)))
137    (end-of-line)
138    (let ((line (buffer-substring bol (point))))
139      (when (> (length line) 0)
140	line))))
141
142(defun mq-push (&optional patch)
143  "Push patches until PATCH is reached.
144If PATCH is nil, push at most one patch."
145  (interactive (list (mq-read-patch-name "qunapplied" " to push"
146					 current-prefix-arg)))
147  (let ((root (hg-root))
148	(prev-buf (current-buffer))
149	last-line ok)
150    (unless root
151      (error "Cannot push outside a repository!"))
152    (hg-sync-buffers root)
153    (let ((buf-name (format "MQ: Push %s" (or patch "next patch"))))
154      (kill-buffer (get-buffer-create buf-name))
155      (split-window-vertically)
156      (other-window 1)
157      (switch-to-buffer (get-buffer-create buf-name))
158      (cd root)
159      (message "Pushing...")
160      (setq ok (= 0 (apply 'call-process (hg-binary) nil t t "qpush"
161			   (if patch (list patch))))
162	    last-line (mq-last-line))
163      (let ((lines (count-lines (point-min) (point-max))))
164	(if (or (<= lines 1)
165		(and (equal lines 2) (string-match "Now at:" last-line)))
166	    (progn
167	      (kill-buffer (current-buffer))
168	      (delete-window))
169	  (hg-view-mode prev-buf))))
170    (mq-refresh-buffers root)
171    (sit-for 0)
172    (when last-line
173      (if ok
174	  (message "Pushing... %s" last-line)
175	(error "Pushing... %s" last-line)))))
176
177(defun mq-push-all ()
178  "Push patches until all are applied."
179  (interactive)
180  (mq-push "-a"))
181
182(defun mq-pop (&optional patch)
183  "Pop patches until PATCH is reached.
184If PATCH is nil, pop at most one patch."
185  (interactive (list (mq-read-patch-name "qapplied" " to pop to"
186					 current-prefix-arg)))
187  (let ((root (hg-root))
188	last-line ok)
189    (unless root
190      (error "Cannot pop outside a repository!"))
191    (hg-sync-buffers root)
192    (set-buffer (generate-new-buffer "qpop"))
193    (cd root)
194    (message "Popping...")
195    (setq ok (= 0 (apply 'call-process (hg-binary) nil t t "qpop"
196			 (if patch (list patch))))
197	  last-line (mq-last-line))
198    (kill-buffer (current-buffer))
199    (mq-refresh-buffers root)
200    (sit-for 0)
201    (when last-line
202      (if ok
203	  (message "Popping... %s" last-line)
204	(error "Popping... %s" last-line)))))
205
206(defun mq-pop-all ()
207  "Push patches until none are applied."
208  (interactive)
209  (mq-pop "-a"))
210
211(defun mq-refresh-internal (root &rest args)
212  (hg-sync-buffers root)
213  (let ((patch (mq-patch-info "qtop")))
214    (message "Refreshing %s..." patch)
215    (let ((ret (apply 'hg-run "qrefresh" args)))
216      (if (equal (car ret) 0)
217	  (message "Refreshing %s... done." patch)
218	(error "Refreshing %s... %s" patch (hg-chomp (cdr ret)))))))
219
220(defun mq-refresh (&optional git)
221  "Refresh the topmost applied patch.
222With a prefix argument, generate a git-compatible patch."
223  (interactive "P")
224  (let ((root (hg-root)))
225    (unless root
226      (error "Cannot refresh outside of a repository!"))
227    (apply 'mq-refresh-internal root (if git '("--git")))))
228
229(defun mq-patch-info (cmd &optional msg)
230  (let* ((ret (hg-run cmd))
231	 (info (hg-chomp (cdr ret))))
232    (if (equal (car ret) 0)
233	(if msg
234	    (message "%s patch: %s" msg info)
235	  info)
236      (error "%s" info))))
237
238(defun mq-top ()
239  "Print the name of the topmost applied patch."
240  (interactive)
241  (mq-patch-info "qtop" "Top"))
242
243(defun mq-next ()
244  "Print the name of the next patch to be pushed."
245  (interactive)
246  (mq-patch-info "qnext" "Next"))
247
248(defun mq-previous ()
249  "Print the name of the first patch below the topmost applied patch.
250This would become the active patch if popped to."
251  (interactive)
252  (mq-patch-info "qprev" "Previous"))
253
254(defun mq-edit-finish ()
255  "Finish editing the description of this patch, and refresh the patch."
256  (interactive)
257  (unless (equal (mq-patch-info "qtop") mq-top)
258    (error "Topmost patch has changed!"))
259  (hg-sync-buffers hg-root)
260  (run-hooks 'mq-edit-finish-hook)
261  (mq-refresh-internal hg-root "-m" (buffer-substring (point-min) (point-max)))
262  (let ((buf mq-prev-buffer))
263    (kill-buffer nil)
264    (switch-to-buffer buf)))
265
266(defun mq-edit-kill ()
267  "Kill the edit currently being prepared."
268  (interactive)
269  (when (or (not (buffer-modified-p)) (y-or-n-p "Really kill this edit? "))
270    (let ((buf mq-prev-buffer))
271      (kill-buffer nil)
272      (switch-to-buffer buf))))
273
274(defun mq-get-top (root)
275  (let ((entry (assoc root mq-top-patch)))
276    (if entry
277        (cdr entry))))
278
279(defun mq-set-top (root patch)
280  (let ((entry (assoc root mq-top-patch)))
281    (if entry
282        (if patch
283            (setcdr entry patch)
284          (setq mq-top-patch (delq entry mq-top-patch)))
285      (setq mq-top-patch (cons (cons root patch) mq-top-patch)))))
286
287(defun mq-update-mode-lines (root)
288  (let ((cwd default-directory))
289    (cd root)
290    (condition-case nil
291        (mq-set-top root (mq-patch-info "qtop"))
292      (error (mq-set-top root nil)))
293    (cd cwd))
294  (let ((patch (mq-get-top root)))
295    (save-excursion
296      (dolist (buf (hg-buffers-visiting-repo root))
297        (set-buffer buf)
298        (if mq-mode
299            (setq mq-mode (or (and patch (concat " MQ:" patch)) " MQ")))))))
300
301(defun mq-mode (&optional arg)
302  "Minor mode for Mercurial repositories with an MQ patch queue"
303  (interactive "i")
304  (cond ((hg-root)
305         (setq mq-mode (if (null arg) (not mq-mode)
306                         arg))
307         (mq-update-mode-lines (hg-root))))
308  (run-hooks 'mq-mode-hook))
309
310(defun mq-edit-mode ()
311  "Mode for editing the description of a patch.
312
313Key bindings
314------------
315\\[mq-edit-finish]	use this description
316\\[mq-edit-kill]	abandon this description"
317  (interactive)
318  (use-local-map mq-edit-mode-map)
319  (set-syntax-table text-mode-syntax-table)
320  (setq local-abbrev-table text-mode-abbrev-table
321	major-mode 'mq-edit-mode
322	mode-name "MQ-Edit")
323  (set-buffer-modified-p nil)
324  (setq buffer-undo-list nil)
325  (run-hooks 'text-mode-hook 'mq-edit-mode-hook))
326
327(defun mq-refresh-edit ()
328  "Refresh the topmost applied patch, editing the patch description."
329  (interactive)
330  (while mq-prev-buffer
331    (set-buffer mq-prev-buffer))
332  (let ((root (hg-root))
333	(prev-buffer (current-buffer))
334	(patch (mq-patch-info "qtop")))
335    (hg-sync-buffers root)
336    (let ((buf-name (format "*MQ: Edit description of %s*" patch)))
337      (switch-to-buffer (get-buffer-create buf-name))
338      (when (= (point-min) (point-max))
339	(set (make-local-variable 'hg-root) root)
340	(set (make-local-variable 'mq-top) patch)
341	(setq mq-prev-buffer prev-buffer)
342	(insert (hg-run0 "qheader"))
343	(goto-char (point-min)))
344      (mq-edit-mode)
345      (cd root)))
346  (message "Type `C-c C-c' to finish editing and refresh the patch."))
347
348(defun mq-new (name)
349  "Create a new empty patch named NAME.
350The patch is applied on top of the current topmost patch.
351With a prefix argument, forcibly create the patch even if the working
352directory is modified."
353  (interactive (list (mq-read-patch-name "qseries" " to create" t)))
354  (message "Creating patch...")
355  (let ((ret (if current-prefix-arg
356		 (hg-run "qnew" "-f" name)
357	       (hg-run "qnew" name))))
358    (if (equal (car ret) 0)
359	(progn
360	  (hg-update-mode-lines (buffer-file-name))
361	  (message "Creating patch... done."))
362      (error "Creating patch... %s" (hg-chomp (cdr ret))))))
363
364(defun mq-edit-series ()
365  "Edit the MQ series file directly."
366  (interactive)
367  (let ((root (hg-root)))
368    (unless root
369      (error "Not in an MQ repository!"))
370    (find-file (concat root ".hg/patches/series"))))
371
372(defun mq-diff (&optional git)
373  "Display a diff of the topmost applied patch.
374With a prefix argument, display a git-compatible diff."
375  (interactive "P")
376  (hg-view-output ((format "MQ: Diff of %s" (mq-patch-info "qtop")))
377    (if git
378	(call-process (hg-binary) nil t nil "qdiff" "--git")
379    (call-process (hg-binary) nil t nil "qdiff"))
380    (diff-mode)
381    (font-lock-fontify-buffer)))
382
383(defun mq-signoff ()
384  "Sign off on the current patch, in the style used by the Linux kernel.
385If the variable mq-signoff-address is non-nil, it will be used, otherwise
386the value of the ui.username item from your hgrc will be used."
387  (interactive)
388  (let ((was-editing (eq major-mode 'mq-edit-mode))
389	signed)
390    (unless was-editing
391      (mq-refresh-edit))
392    (save-excursion
393      (let* ((user (or mq-signoff-address
394		       (hg-run0 "debugconfig" "ui.username")))
395	     (signoff (concat "Signed-off-by: " user)))
396	(if (search-forward signoff nil t)
397	    (message "You have already signed off on this patch.")
398	  (goto-char (point-max))
399	  (let ((case-fold-search t))
400	    (if (re-search-backward "^Signed-off-by: " nil t)
401		(forward-line 1)
402	      (insert "\n")))
403	  (insert signoff)
404	  (message "%s" signoff)
405	  (setq signed t))))
406    (unless was-editing
407      (if signed
408	  (mq-edit-finish)
409	(mq-edit-kill)))))
410
411
412(provide 'mq)
413
414
415;;; Local Variables:
416;;; prompt-to-byte-compile: nil
417;;; end:
418