Move custom group here from calendar.el.
[emacs.git] / lisp / vc-hg.el
blob2a65691cb9df559d9cae35cccfbb010734912ce3
1 ;;; vc-hg.el --- VC backend for the mercurial version control system
3 ;; Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
5 ;; Author: Ivan Kanis
6 ;; Keywords: tools
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 3, or (at your option)
13 ;; any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
25 ;;; Commentary:
27 ;; This is a mercurial version control backend
29 ;;; Thanks:
31 ;;; Bugs:
33 ;;; Installation:
35 ;;; Todo:
37 ;; Implement the rest of the vc interface. See the comment at the
38 ;; beginning of vc.el. The current status is:
40 ;; FUNCTION NAME STATUS
41 ;; BACKEND PROPERTIES
42 ;; * revision-granularity OK
43 ;; STATE-QUERYING FUNCTIONS
44 ;; * registered (file) OK
45 ;; * state (file) OK
46 ;; - state-heuristic (file) ?? PROBABLY NOT NEEDED
47 ;; - dir-state (dir) OK
48 ;; * working-revision (file) OK
49 ;; - latest-on-branch-p (file) ??
50 ;; * checkout-model (file) OK
51 ;; - workfile-unchanged-p (file) OK
52 ;; - mode-line-string (file) NOT NEEDED
53 ;; - dired-state-info (file) OK
54 ;; STATE-CHANGING FUNCTIONS
55 ;; * register (files &optional rev comment) OK
56 ;; * create-repo () OK
57 ;; - init-revision () NOT NEEDED
58 ;; - responsible-p (file) OK
59 ;; - could-register (file) OK
60 ;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
61 ;; - unregister (file) COMMENTED OUT, MAY BE INCORRECT
62 ;; * checkin (files rev comment) OK
63 ;; * find-revision (file rev buffer) OK
64 ;; * checkout (file &optional editable rev) OK
65 ;; * revert (file &optional contents-done) OK
66 ;; - rollback (files) ?? PROBABLY NOT NEEDED
67 ;; - merge (file rev1 rev2) NEEDED
68 ;; - merge-news (file) NEEDED
69 ;; - steal-lock (file &optional revision) NOT NEEDED
70 ;; HISTORY FUNCTIONS
71 ;; * print-log (files &optional buffer) OK
72 ;; - log-view-mode () OK
73 ;; - show-log-entry (revision) NOT NEEDED, DEFAULT IS GOOD
74 ;; - wash-log (file) ??
75 ;; - logentry-check () NOT NEEDED
76 ;; - comment-history (file) NOT NEEDED
77 ;; - update-changelog (files) NOT NEEDED
78 ;; * diff (files &optional rev1 rev2 buffer) OK
79 ;; - revision-completion-table (files) OK?
80 ;; - annotate-command (file buf &optional rev) OK
81 ;; - annotate-time () OK
82 ;; - annotate-current-time () ?? NOT NEEDED
83 ;; - annotate-extract-revision-at-line () OK
84 ;; SNAPSHOT SYSTEM
85 ;; - create-snapshot (dir name branchp) NEEDED (probably branch?)
86 ;; - assign-name (file name) NOT NEEDED
87 ;; - retrieve-snapshot (dir name update) ?? NEEDED??
88 ;; MISCELLANEOUS
89 ;; - make-version-backups-p (file) ??
90 ;; - repository-hostname (dirname) ??
91 ;; - previous-revision (file rev) OK
92 ;; - next-revision (file rev) OK
93 ;; - check-headers () ??
94 ;; - clear-headers () ??
95 ;; - delete-file (file) TEST IT
96 ;; - rename-file (old new) OK
97 ;; - find-file-hook () PROBABLY NOT NEEDED
98 ;; - find-file-not-found-hook () PROBABLY NOT NEEDED
100 ;; Implement Stefan Monnier's advice:
101 ;; vc-hg-registered and vc-hg-state
102 ;; Both of those functions should be super extra careful to fail gracefully in
103 ;; unexpected circumstances. The reason this is important is that any error
104 ;; there will prevent the user from even looking at the file :-(
105 ;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
106 ;; mercurial's control and extracting the current revision should be done
107 ;; without even using `hg' (this way even if you don't have `hg' installed,
108 ;; Emacs is able to tell you this file is under mercurial's control).
110 ;;; History:
113 ;;; Code:
115 (eval-when-compile
116 (require 'cl)
117 (require 'vc))
119 ;;; Customization options
121 (defcustom vc-hg-global-switches nil
122 "*Global switches to pass to any Hg command."
123 :type '(choice (const :tag "None" nil)
124 (string :tag "Argument String")
125 (repeat :tag "Argument List"
126 :value ("")
127 string))
128 :version "22.2"
129 :group 'vc)
132 ;;; Properties of the backend
134 (defun vc-hg-revision-granularity ()
135 'repository)
137 ;;; State querying functions
139 ;;;###autoload (defun vc-hg-registered (file)
140 ;;;###autoload "Return non-nil if FILE is registered with hg."
141 ;;;###autoload (if (vc-find-root file ".hg") ; short cut
142 ;;;###autoload (progn
143 ;;;###autoload (load "vc-hg")
144 ;;;###autoload (vc-hg-registered file))))
146 ;; Modelled after the similar function in vc-bzr.el
147 (defun vc-hg-registered (file)
148 "Return non-nil if FILE is registered with hg."
149 (when (vc-hg-root file) ; short cut
150 (let ((state (vc-hg-state file))) ; expensive
151 (vc-file-setprop file 'vc-state state)
152 (and state (not (memq state '(ignored unregistered)))))))
154 (defun vc-hg-state (file)
155 "Hg-specific version of `vc-state'."
156 (let*
157 ((status nil)
158 (out
159 (with-output-to-string
160 (with-current-buffer
161 standard-output
162 (setq status
163 (condition-case nil
164 ;; Ignore all errors.
165 (call-process
166 "hg" nil t nil "--cwd" (file-name-directory file)
167 "status" "-A" (file-name-nondirectory file))
168 ;; Some problem happened. E.g. We can't find an `hg'
169 ;; executable.
170 (error nil)))))))
171 (when (eq 0 status)
172 (when (null (string-match ".*: No such file or directory$" out))
173 (let ((state (aref out 0)))
174 (cond
175 ((eq state ?=) 'up-to-date)
176 ((eq state ?A) 'added)
177 ((eq state ?M) 'edited)
178 ((eq state ?I) 'ignored)
179 ((eq state ?R) 'removed)
180 ((eq state ?!) 'missing)
181 ((eq state ??) 'unregistered)
182 ((eq state ?C) 'up-to-date) ;; Older mercurials use this
183 (t 'up-to-date)))))))
185 (defun vc-hg-dir-state (dir)
186 (with-temp-buffer
187 (buffer-disable-undo) ;; Because these buffers can get huge
188 (vc-hg-command (current-buffer) nil dir "status" "-A")
189 (goto-char (point-min))
190 (let ((status-char nil)
191 (file nil))
192 (while (not (eobp))
193 (setq status-char (char-after))
194 (setq file
195 (expand-file-name
196 (buffer-substring-no-properties (+ (point) 2)
197 (line-end-position))))
198 (cond
199 ;; State flag for a clean file is now C, might change to =.
200 ;; The rest of the possible states in "hg status" output:
201 ;; ! = deleted, but still tracked
202 ;; should not show up in vc-dired, so don't deal with them
203 ;; here.
205 ;; Mercurial up to 0.9.5 used C, = is used now.
206 ((or (eq status-char ?=) (eq status-char ?C))
207 (vc-file-setprop file 'vc-backend 'Hg)
208 (vc-file-setprop file 'vc-state 'up-to-date))
209 ((eq status-char ?A)
210 (vc-file-setprop file 'vc-backend 'Hg)
211 (vc-file-setprop file 'vc-working-revision "0")
212 (vc-file-setprop file 'vc-state 'added))
213 ((eq status-char ?R)
214 (vc-file-setprop file 'vc-backend 'Hg)
215 (vc-file-setprop file 'vc-state 'removed))
216 ((eq status-char ?M)
217 (vc-file-setprop file 'vc-backend 'Hg)
218 (vc-file-setprop file 'vc-state 'edited))
219 ((eq status-char ?I)
220 (vc-file-setprop file 'vc-backend 'Hg)
221 (vc-file-setprop file 'vc-state 'ignored))
222 ((eq status-char ??)
223 (vc-file-setprop file 'vc-backend 'none)
224 (vc-file-setprop file 'vc-state 'unregistered))
225 ((eq status-char ?!)
226 (vc-file-setprop file 'vc-backend 'Hg)
227 (vc-file-setprop file 'vc-state 'missing))
228 (t ;; Presently C, might change to = in 0.9.6
229 (vc-file-setprop file 'vc-backend 'Hg)
230 (vc-file-setprop file 'vc-state 'up-to-date)))
231 (forward-line)))))
233 (defun vc-hg-working-revision (file)
234 "Hg-specific version of `vc-working-revision'."
235 (let*
236 ((status nil)
237 (out
238 (with-output-to-string
239 (with-current-buffer
240 standard-output
241 (setq status
242 (condition-case nil
243 ;; Ignore all errors.
244 (call-process
245 "hg" nil t nil "--cwd" (file-name-directory file)
246 "log" "-l1" (file-name-nondirectory file))
247 ;; Some problem happened. E.g. We can't find an `hg'
248 ;; executable.
249 (error nil)))))))
250 (when (eq 0 status)
251 (if (string-match "changeset: *\\([0-9]*\\)" out)
252 (match-string 1 out)
253 "0"))))
255 ;;; History functions
257 (defun vc-hg-print-log (files &optional buffer)
258 "Get change log associated with FILES."
259 ;; `log-view-mode' needs to have the file names in order to function
260 ;; correctly. "hg log" does not print it, so we insert it here by
261 ;; hand.
263 ;; `vc-do-command' creates the buffer, but we need it before running
264 ;; the command.
265 (vc-setup-buffer buffer)
266 ;; If the buffer exists from a previous invocation it might be
267 ;; read-only.
268 (let ((inhibit-read-only t))
269 ;; We need to loop and call "hg log" on each file separately.
270 ;; "hg log" with multiple file arguments mashes all the logs
271 ;; together. Ironically enough, this puts us back near CVS
272 ;; which can't generate proper fileset logs either.
273 (dolist (file files)
274 (with-current-buffer
275 buffer
276 (insert "Working file: " file "\n")) ;; Like RCS/CVS.
277 (vc-hg-command buffer 0 file "log"))))
279 (defvar log-view-message-re)
280 (defvar log-view-file-re)
281 (defvar log-view-font-lock-keywords)
283 (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
284 (require 'add-log) ;; we need the add-log faces
285 (set (make-local-variable 'log-view-file-re) "^Working file:[ \t]+\\(.+\\)")
286 (set (make-local-variable 'log-view-message-re)
287 "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)")
288 (set (make-local-variable 'log-view-font-lock-keywords)
289 (append
290 log-view-font-lock-keywords
292 ;; Handle the case:
293 ;; user: FirstName LastName <foo@bar>
294 ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
295 (1 'change-log-name)
296 (2 'change-log-email))
297 ;; Handle the cases:
298 ;; user: foo@bar
299 ;; and
300 ;; user: foo
301 ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
302 (1 'change-log-email))
303 ("^date: \\(.+\\)" (1 'change-log-date))
304 ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))
306 (defun vc-hg-diff (files &optional oldvers newvers buffer)
307 "Get a difference report using hg between two revisions of FILES."
308 (let ((working (vc-working-revision (car files))))
309 (if (and (equal oldvers working) (not newvers))
310 (setq oldvers nil))
311 (if (and (not oldvers) newvers)
312 (setq oldvers working))
313 (apply #'vc-hg-command (or buffer "*vc-diff*") nil
314 (mapcar (lambda (file) (file-name-nondirectory file)) files)
315 "--cwd" (file-name-directory (car files))
316 "diff"
317 (append
318 (if oldvers
319 (if newvers
320 (list "-r" oldvers "-r" newvers)
321 (list "-r" oldvers)))))))
323 (defun vc-hg-revision-table (files)
324 (let ((default-directory (file-name-directory (car files))))
325 (with-temp-buffer
326 (vc-hg-command t nil files "log" "--template" "{rev} ")
327 (split-string
328 (buffer-substring-no-properties (point-min) (point-max))))))
330 ;; Modelled after the similar function in vc-cvs.el
331 (defun vc-hg-revision-completion-table (files)
332 (lexical-let ((files files)
333 table)
334 (setq table (lazy-completion-table
335 table (lambda () (vc-hg-revision-table files))))
336 table))
338 (defun vc-hg-annotate-command (file buffer &optional revision)
339 "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
340 Optional arg REVISION is a revision to annotate from."
341 (vc-hg-command buffer 0 file "annotate" "-d" "-n" (if revision (concat "-r" revision)))
342 (with-current-buffer buffer
343 (goto-char (point-min))
344 (re-search-forward "^[0-9]")
345 (delete-region (point-min) (1- (point)))))
348 ;; The format for one line output by "hg annotate -d -n" looks like this:
349 ;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
350 ;; i.e: VERSION_NUMBER DATE: CONTENTS
351 (defconst vc-hg-annotate-re "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\): ")
353 (defun vc-hg-annotate-time ()
354 (when (looking-at vc-hg-annotate-re)
355 (goto-char (match-end 0))
356 (vc-annotate-convert-time
357 (date-to-time (match-string-no-properties 2)))))
359 (defun vc-hg-annotate-extract-revision-at-line ()
360 (save-excursion
361 (beginning-of-line)
362 (if (looking-at vc-hg-annotate-re) (match-string-no-properties 1))))
364 (defun vc-hg-previous-revision (file rev)
365 (let ((newrev (1- (string-to-number rev))))
366 (when (>= newrev 0)
367 (number-to-string newrev))))
369 (defun vc-hg-next-revision (file rev)
370 (let ((newrev (1+ (string-to-number rev)))
371 (tip-revision
372 (with-temp-buffer
373 (vc-hg-command t 0 nil "tip")
374 (goto-char (point-min))
375 (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
376 (string-to-number (match-string-no-properties 1)))))
377 ;; We don't want to exceed the maximum possible revision number, ie
378 ;; the tip revision.
379 (when (<= newrev tip-revision)
380 (number-to-string newrev))))
382 ;; Modelled after the similar function in vc-bzr.el
383 (defun vc-hg-delete-file (file)
384 "Delete FILE and delete it in the hg repository."
385 (condition-case ()
386 (delete-file file)
387 (file-error nil))
388 (vc-hg-command nil 0 file "remove" "--after" "--force"))
390 ;; Modelled after the similar function in vc-bzr.el
391 (defun vc-hg-rename-file (old new)
392 "Rename file from OLD to NEW using `hg mv'."
393 (vc-hg-command nil 0 new old "mv"))
395 (defun vc-hg-register (files &optional rev comment)
396 "Register FILES under hg.
397 REV is ignored.
398 COMMENT is ignored."
399 (vc-hg-command nil 0 files "add"))
401 (defun vc-hg-create-repo ()
402 "Create a new Mercurial repository."
403 (vc-hg-command nil 0 nil "init"))
405 (defalias 'vc-hg-responsible-p 'vc-hg-root)
407 ;; Modelled after the similar function in vc-bzr.el
408 (defun vc-hg-could-register (file)
409 "Return non-nil if FILE could be registered under hg."
410 (and (vc-hg-responsible-p file) ; shortcut
411 (condition-case ()
412 (with-temp-buffer
413 (vc-hg-command t nil file "add" "--dry-run"))
414 ;; The command succeeds with no output if file is
415 ;; registered.
416 (error))))
418 ;; XXX This would remove the file. Is that correct?
419 ;; (defun vc-hg-unregister (file)
420 ;; "Unregister FILE from hg."
421 ;; (vc-hg-command nil nil file "remove"))
423 (defun vc-hg-checkin (files rev comment)
424 "Hg-specific version of `vc-backend-checkin'.
425 REV is ignored."
426 (vc-hg-command nil 0 files "commit" "-m" comment))
428 (defun vc-hg-find-revision (file rev buffer)
429 (let ((coding-system-for-read 'binary)
430 (coding-system-for-write 'binary))
431 (if rev
432 (vc-hg-command buffer 0 file "cat" "-r" rev)
433 (vc-hg-command buffer 0 file "cat"))))
435 ;; Modelled after the similar function in vc-bzr.el
436 (defun vc-hg-checkout (file &optional editable rev)
437 "Retrieve a revision of FILE.
438 EDITABLE is ignored.
439 REV is the revision to check out into WORKFILE."
440 (let ((coding-system-for-read 'binary)
441 (coding-system-for-write 'binary))
442 (with-current-buffer (or (get-file-buffer file) (current-buffer))
443 (if rev
444 (vc-hg-command t 0 file "cat" "-r" rev)
445 (vc-hg-command t 0 file "cat")))))
447 (defun vc-hg-checkout-model (file)
448 'implicit)
450 ;; Modelled after the similar function in vc-bzr.el
451 (defun vc-hg-workfile-unchanged-p (file)
452 (eq 'up-to-date (vc-hg-state file)))
454 ;; Modelled after the similar function in vc-bzr.el
455 (defun vc-hg-revert (file &optional contents-done)
456 (unless contents-done
457 (with-temp-buffer (vc-hg-command t 0 file "revert"))))
459 ;;; Hg specific functionality.
461 ;; XXX This functionality is experimental/work in progress. It might
462 ;; change without notice.
463 (defvar vc-hg-extra-menu-map
464 (let ((map (make-sparse-keymap)))
465 (define-key map [incoming] '(menu-item "Show incoming" vc-hg-incoming))
466 (define-key map [outgoing] '(menu-item "Show outgoing" vc-hg-outgoing))
467 map))
469 (defun vc-hg-extra-menu () vc-hg-extra-menu-map)
471 (defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
473 (define-derived-mode vc-hg-outgoing-mode vc-hg-log-view-mode "Hg-Outgoing")
475 (define-derived-mode vc-hg-incoming-mode vc-hg-log-view-mode "Hg-Incoming")
477 ;; XXX Experimental function for the vc-dired replacement.
478 (defun vc-hg-after-dir-status (update-function status-buffer)
479 (let ((status-char nil)
480 (file nil)
481 (translation '((?= . up-to-date)
482 (?C . up-to-date)
483 (?A . added)
484 (?R . removed)
485 (?M . edited)
486 (?I . ignored)
487 (?! . missing)
488 (?? . unregistered)))
489 (translated nil)
490 (result nil))
491 (goto-char (point-min))
492 (while (not (eobp))
493 (setq status-char (char-after))
494 (setq file
495 (buffer-substring-no-properties (+ (point) 2)
496 (line-end-position)))
497 (setq translated (assoc status-char translation))
498 (when (and translated (not (eq (cdr translated) 'up-to-date)))
499 (push (list file (cdr translated)) result))
500 (forward-line))
501 (funcall update-function result status-buffer)))
503 ;; XXX Experimental function for the vc-dired replacement.
504 (defun vc-hg-dir-status (dir update-function status-buffer)
505 (vc-hg-command (current-buffer) 'async dir "status")
506 (vc-exec-after
507 `(vc-hg-after-dir-status (quote ,update-function) ,status-buffer)))
509 ;; XXX this adds another top level menu, instead figure out how to
510 ;; replace the Log-View menu.
511 (easy-menu-define log-view-mode-menu vc-hg-outgoing-mode-map
512 "Hg-outgoing Display Menu"
513 `("Hg-outgoing"
514 ["Push selected" vc-hg-push]))
516 (easy-menu-define log-view-mode-menu vc-hg-incoming-mode-map
517 "Hg-incoming Display Menu"
518 `("Hg-incoming"
519 ["Pull selected" vc-hg-pull]))
521 (defun vc-hg-outgoing ()
522 (interactive)
523 (let ((bname "*Hg outgoing*"))
524 (vc-hg-command bname 0 nil "outgoing" "-n")
525 (pop-to-buffer bname)
526 (vc-hg-outgoing-mode)))
528 (defun vc-hg-incoming ()
529 (interactive)
530 (let ((bname "*Hg incoming*"))
531 (vc-hg-command bname 0 nil "incoming" "-n")
532 (pop-to-buffer bname)
533 (vc-hg-incoming-mode)))
535 (declare-function log-view-get-marked "log-view" ())
537 ;; XXX maybe also add key bindings for these functions.
538 (defun vc-hg-push ()
539 (interactive)
540 (let ((marked-list (log-view-get-marked)))
541 (if marked-list
542 (vc-hg-command
543 nil 0 nil
544 (cons "push"
545 (apply 'nconc
546 (mapcar (lambda (arg) (list "-r" arg)) marked-list))))
547 (error "No log entries selected for push"))))
549 (defun vc-hg-pull ()
550 (interactive)
551 (let ((marked-list (log-view-get-marked)))
552 (if marked-list
553 (vc-hg-command
554 nil 0 nil
555 (cons "pull"
556 (apply 'nconc
557 (mapcar (lambda (arg) (list "-r" arg)) marked-list))))
558 (error "No log entries selected for pull"))))
560 ;;; Internal functions
562 (defun vc-hg-command (buffer okstatus file-or-list &rest flags)
563 "A wrapper around `vc-do-command' for use in vc-hg.el.
564 The difference to vc-do-command is that this function always invokes `hg',
565 and that it passes `vc-hg-global-switches' to it before FLAGS."
566 (apply 'vc-do-command buffer okstatus "hg" file-or-list
567 (if (stringp vc-hg-global-switches)
568 (cons vc-hg-global-switches flags)
569 (append vc-hg-global-switches
570 flags))))
572 (defun vc-hg-root (file)
573 (vc-find-root file ".hg"))
575 (provide 'vc-hg)
577 ;; arch-tag: bd094dc5-715a-434f-a331-37b9fb7cd954
578 ;;; vc-hg.el ends here