Line data Source code
1 : ;;; vc-hg.el --- VC backend for the mercurial version control system -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 2006-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Ivan Kanis
6 : ;; Maintainer: emacs-devel@gnu.org
7 : ;; Keywords: vc tools
8 : ;; Package: vc
9 :
10 : ;; This file is part of GNU Emacs.
11 :
12 : ;; GNU Emacs is free software: you can redistribute it and/or modify
13 : ;; it under the terms of the GNU General Public License as published by
14 : ;; the Free Software Foundation, either version 3 of the License, or
15 : ;; (at your option) any later version.
16 :
17 : ;; GNU Emacs is distributed in the hope that it will be useful,
18 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 : ;; GNU General Public License for more details.
21 :
22 : ;; You should have received a copy of the GNU General Public License
23 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 :
25 : ;;; Commentary:
26 :
27 : ;; This is a mercurial version control backend
28 :
29 : ;;; Thanks:
30 :
31 : ;;; Bugs:
32 :
33 : ;;; Installation:
34 :
35 : ;;; Todo:
36 :
37 : ;; 1) Implement the rest of the vc interface. See the comment at the
38 : ;; beginning of vc.el. The current status is:
39 :
40 : ;; FUNCTION NAME STATUS
41 : ;; BACKEND PROPERTIES
42 : ;; * revision-granularity OK
43 : ;; STATE-QUERYING FUNCTIONS
44 : ;; * registered (file) OK
45 : ;; * state (file) OK
46 : ;; - dir-status-files (dir files uf) OK
47 : ;; - dir-extra-headers (dir) OK
48 : ;; - dir-printer (fileinfo) OK
49 : ;; * working-revision (file) OK
50 : ;; * checkout-model (files) OK
51 : ;; - mode-line-string (file) OK
52 : ;; STATE-CHANGING FUNCTIONS
53 : ;; * register (files &optional rev comment) OK
54 : ;; * create-repo () OK
55 : ;; - responsible-p (file) OK
56 : ;; - receive-file (file rev) ?? PROBABLY NOT NEEDED
57 : ;; - unregister (file) OK
58 : ;; * checkin (files rev comment) OK
59 : ;; * find-revision (file rev buffer) OK
60 : ;; * checkout (file &optional rev) OK
61 : ;; * revert (file &optional contents-done) OK
62 : ;; - merge (file rev1 rev2) NEEDED
63 : ;; - merge-news (file) NEEDED
64 : ;; - steal-lock (file &optional revision) NOT NEEDED
65 : ;; HISTORY FUNCTIONS
66 : ;; * print-log (files buffer &optional shortlog start-revision limit) OK
67 : ;; - log-view-mode () OK
68 : ;; - show-log-entry (revision) NOT NEEDED, DEFAULT IS GOOD
69 : ;; - comment-history (file) NOT NEEDED
70 : ;; - update-changelog (files) NOT NEEDED
71 : ;; * diff (files &optional rev1 rev2 buffer) OK
72 : ;; - revision-completion-table (files) OK?
73 : ;; - annotate-command (file buf &optional rev) OK
74 : ;; - annotate-time () OK
75 : ;; - annotate-current-time () NOT NEEDED
76 : ;; - annotate-extract-revision-at-line () OK
77 : ;; TAG SYSTEM
78 : ;; - create-tag (dir name branchp) OK
79 : ;; - retrieve-tag (dir name update) OK
80 : ;; MISCELLANEOUS
81 : ;; - make-version-backups-p (file) ??
82 : ;; - previous-revision (file rev) OK
83 : ;; - next-revision (file rev) OK
84 : ;; - check-headers () ??
85 : ;; - delete-file (file) TEST IT
86 : ;; - rename-file (old new) OK
87 : ;; - find-file-hook () added for bug#10709
88 :
89 : ;; 2) Implement Stefan Monnier's advice:
90 : ;; vc-hg-registered and vc-hg-state
91 : ;; Both of those functions should be super extra careful to fail gracefully in
92 : ;; unexpected circumstances. The reason this is important is that any error
93 : ;; there will prevent the user from even looking at the file :-(
94 : ;; Ideally, just like in vc-arch and vc-cvs, checking that the file is under
95 : ;; mercurial's control and extracting the current revision should be done
96 : ;; without even using `hg' (this way even if you don't have `hg' installed,
97 : ;; Emacs is able to tell you this file is under mercurial's control).
98 :
99 : ;;; History:
100 : ;;
101 :
102 : ;;; Code:
103 :
104 : (eval-when-compile
105 : (require 'vc)
106 : (require 'vc-dir))
107 :
108 : (require 'cl-lib)
109 :
110 : (declare-function vc-compilation-mode "vc-dispatcher" (backend))
111 :
112 : ;;; Customization options
113 :
114 : (defgroup vc-hg nil
115 : "VC Mercurial (hg) backend."
116 : :version "24.1"
117 : :group 'vc)
118 :
119 : (defcustom vc-hg-global-switches nil
120 : "Global switches to pass to any Hg command."
121 : :type '(choice (const :tag "None" nil)
122 : (string :tag "Argument String")
123 : (repeat :tag "Argument List" :value ("") string))
124 : :version "22.2"
125 : :group 'vc-hg)
126 :
127 : (defcustom vc-hg-diff-switches t ; Hg doesn't support common args like -u
128 : "String or list of strings specifying switches for Hg diff under VC.
129 : If nil, use the value of `vc-diff-switches'. If t, use no switches."
130 : :type '(choice (const :tag "Unspecified" nil)
131 : (const :tag "None" t)
132 : (string :tag "Argument String")
133 : (repeat :tag "Argument List" :value ("") string))
134 : :version "23.1"
135 : :group 'vc-hg)
136 :
137 : (defcustom vc-hg-annotate-switches '("-u" "--follow")
138 : "String or list of strings specifying switches for hg annotate under VC.
139 : If nil, use the value of `vc-annotate-switches'. If t, use no
140 : switches."
141 : :type '(choice (const :tag "Unspecified" nil)
142 : (const :tag "None" t)
143 : (string :tag "Argument String")
144 : (repeat :tag "Argument List" :value ("") string))
145 : :version "25.1"
146 : :group 'vc-hg)
147 :
148 : (defcustom vc-hg-program "hg"
149 : "Name of the Mercurial executable (excluding any arguments)."
150 : :type 'string
151 : :group 'vc-hg)
152 :
153 : (defcustom vc-hg-root-log-format
154 : `(,(concat "{rev}:{ifeq(branch, 'default','', '{branch}')}"
155 : ":{bookmarks}:{tags}:{author|person}"
156 : " {date|shortdate} {desc|firstline}\\n")
157 : ,(concat "^\\(?:[+@o x|-]*\\)" ;Graph data.
158 : "\\([0-9]+\\):\\([^:]*\\)"
159 : ":\\([^:]*\\):\\([^:]*\\):\\(.*?\\)"
160 : "[ \t]+\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)")
161 : ((1 'log-view-message)
162 : (2 'change-log-file)
163 : (3 'change-log-list)
164 : (4 'change-log-conditionals)
165 : (5 'change-log-name)
166 : (6 'change-log-date)))
167 : "Mercurial log template for `vc-hg-print-log' short format.
168 : This should be a list (TEMPLATE REGEXP KEYWORDS), where TEMPLATE
169 : is the \"--template\" argument string to pass to Mercurial,
170 : REGEXP is a regular expression matching the resulting Mercurial
171 : output, and KEYWORDS is a list of `font-lock-keywords' for
172 : highlighting the Log View buffer."
173 : :type '(list string string (repeat sexp))
174 : :group 'vc-hg
175 : :version "24.5")
176 :
177 :
178 : ;;; Properties of the backend
179 :
180 : (defvar vc-hg-history nil)
181 :
182 : (defun vc-hg-revision-granularity () 'repository)
183 : (defun vc-hg-checkout-model (_files) 'implicit)
184 :
185 : ;;; State querying functions
186 :
187 : ;;;###autoload (defun vc-hg-registered (file)
188 : ;;;###autoload "Return non-nil if FILE is registered with hg."
189 : ;;;###autoload (if (vc-find-root file ".hg") ; short cut
190 : ;;;###autoload (progn
191 : ;;;###autoload (load "vc-hg" nil t)
192 : ;;;###autoload (vc-hg-registered file))))
193 :
194 : ;; Modeled after the similar function in vc-bzr.el
195 : (defun vc-hg-registered (file)
196 : "Return non-nil if FILE is registered with hg."
197 12 : (when (vc-hg-root file) ; short cut
198 0 : (let ((state (vc-hg-state file))) ; expensive
199 12 : (and state (not (memq state '(ignored unregistered)))))))
200 :
201 : (defun vc-hg-state (file)
202 : "Hg-specific version of `vc-state'."
203 0 : (let ((state (vc-hg-state-fast file)))
204 0 : (if (eq state 'unsupported) (vc-hg-state-slow file) state)))
205 :
206 : (defun vc-hg-state-slow (file)
207 : "Determine status of FILE by running hg."
208 0 : (setq file (expand-file-name file))
209 0 : (let*
210 : ((status nil)
211 0 : (default-directory (file-name-directory file))
212 : (out
213 0 : (with-output-to-string
214 0 : (with-current-buffer
215 0 : standard-output
216 0 : (setq status
217 0 : (condition-case nil
218 : ;; Ignore all errors.
219 0 : (let ((process-environment
220 : ;; Avoid localization of messages so we
221 : ;; can parse the output. Disable pager.
222 0 : (append
223 0 : (list "TERM=dumb" "LANGUAGE=C" "HGPLAIN=1")
224 0 : process-environment)))
225 0 : (process-file
226 0 : vc-hg-program nil t nil
227 : "--config" "alias.status=status"
228 : "--config" "defaults.status="
229 0 : "status" "-A" (file-relative-name file)))
230 : ;; Some problem happened. E.g. We can't find an `hg'
231 : ;; executable.
232 0 : (error nil)))))))
233 0 : (when (and (eq 0 status)
234 0 : (> (length out) 0)
235 0 : (null (string-match ".*: No such file or directory$" out)))
236 0 : (let ((state (aref out 0)))
237 0 : (cond
238 0 : ((eq state ?=) 'up-to-date)
239 0 : ((eq state ?A) 'added)
240 0 : ((eq state ?M) 'edited)
241 0 : ((eq state ?I) 'ignored)
242 0 : ((eq state ?R) 'removed)
243 0 : ((eq state ?!) 'missing)
244 0 : ((eq state ??) 'unregistered)
245 0 : ((eq state ?C) 'up-to-date) ;; Older mercurial versions use this.
246 0 : (t 'up-to-date))))))
247 :
248 : (defun vc-hg-working-revision (file)
249 : "Hg-specific version of `vc-working-revision'."
250 0 : (or (ignore-errors
251 0 : (with-output-to-string
252 0 : (vc-hg-command standard-output 0 file
253 0 : "parent" "--template" "{rev}")))
254 0 : "0"))
255 :
256 : (defcustom vc-hg-symbolic-revision-styles
257 : '(builtin-active-bookmark
258 : "{if(bookmarks,sub(' ',',',bookmarks),if(phabdiff,phabdiff,shortest(node,6)))}")
259 : "List of ways to present versions symbolically. The version
260 : that we use is the first one that successfully produces a
261 : non-empty string.
262 :
263 : Each entry in the list can be either:
264 :
265 : - The symbol `builtin-active-bookmark', which indicates that we
266 : should use the active bookmark if one exists. A template can
267 : supply this information as well, but `builtin-active-bookmark' is
268 : handled entirely inside Emacs and so is more efficient than using
269 : the generic Mercurial mechanism.
270 :
271 : - A string giving the Mercurial template to supply to \"hg
272 : parent\". \"hg help template\" may be useful reading.
273 :
274 : - A function to call; it should accept two arguments (a revision
275 : and an optional path to which to limit history) and produce a
276 : string. The function is called with `default-directory' set to
277 : within the repository.
278 :
279 : If no list entry produces a useful revision, return `nil'."
280 : :type '(repeat (choice
281 : (const :tag "Active bookmark" 'bookmark)
282 : (string :tag "Hg template")
283 : (function :tag "Custom")))
284 : :version "26.1"
285 : :group 'vc-hg)
286 :
287 : (defcustom vc-hg-use-file-version-for-mode-line-version nil
288 : "When enabled, the modeline contains revision information for the visited file.
289 : When not, the revision in the modeline is for the repository
290 : working copy. `nil' is the much faster setting for
291 : large repositories."
292 : :type 'boolean
293 : :version "26.1"
294 : :group 'vc-hg)
295 :
296 : (defun vc-hg--active-bookmark-internal (rev)
297 0 : (when (equal rev ".")
298 0 : (let* ((current-bookmarks-file ".hg/bookmarks.current"))
299 0 : (when (file-exists-p current-bookmarks-file)
300 0 : (ignore-errors
301 0 : (with-temp-buffer
302 0 : (insert-file-contents current-bookmarks-file)
303 0 : (buffer-substring-no-properties
304 0 : (point-min) (point-max))))))))
305 :
306 : (defun vc-hg--run-log (template rev path)
307 0 : (ignore-errors
308 0 : (with-output-to-string
309 0 : (if path
310 0 : (vc-hg-command
311 0 : standard-output 0 nil
312 0 : "log" "-f" "-l1" "--template" template path)
313 0 : (vc-hg-command
314 0 : standard-output 0 nil
315 0 : "log" "-r" rev "-l1" "--template" template)))))
316 :
317 : (defun vc-hg--symbolic-revision (rev &optional path)
318 : "Make a Mercurial revision human-readable.
319 : REV is a Mercurial revision. `default-directory' is assumed to
320 : be in the repository root of interest. PATH, if set, is a
321 : specific file to query."
322 0 : (let ((symbolic-revision nil)
323 0 : (styles vc-hg-symbolic-revision-styles))
324 0 : (while (and (not symbolic-revision) styles)
325 0 : (let ((style (pop styles)))
326 0 : (setf symbolic-revision
327 0 : (cond ((and (null path) (eq style 'builtin-active-bookmark))
328 0 : (vc-hg--active-bookmark-internal rev))
329 0 : ((stringp style)
330 0 : (vc-hg--run-log style rev path))
331 0 : ((functionp style)
332 0 : (funcall style rev path))))))
333 0 : symbolic-revision))
334 :
335 : (defun vc-hg-mode-line-string (file)
336 : "Hg-specific version of `vc-mode-line-string'."
337 0 : (let* ((backend-name "Hg")
338 0 : (truename (file-truename file))
339 0 : (state (vc-state truename))
340 : (state-echo nil)
341 : (face nil)
342 0 : (rev (and state
343 0 : (let ((default-directory
344 0 : (expand-file-name (vc-hg-root truename))))
345 0 : (vc-hg--symbolic-revision
346 : "."
347 0 : (and vc-hg-use-file-version-for-mode-line-version
348 0 : truename)))))
349 0 : (rev (or rev "???")))
350 0 : (propertize
351 0 : (cond ((or (eq state 'up-to-date)
352 0 : (eq state 'needs-update))
353 0 : (setq state-echo "Up to date file")
354 0 : (setq face 'vc-up-to-date-state)
355 0 : (concat backend-name "-" rev))
356 0 : ((eq state 'added)
357 0 : (setq state-echo "Locally added file")
358 0 : (setq face 'vc-locally-added-state)
359 0 : (concat backend-name "@" rev))
360 0 : ((eq state 'conflict)
361 0 : (setq state-echo "File contains conflicts after the last merge")
362 0 : (setq face 'vc-conflict-state)
363 0 : (concat backend-name "!" rev))
364 0 : ((eq state 'removed)
365 0 : (setq state-echo "File removed from the VC system")
366 0 : (setq face 'vc-removed-state)
367 0 : (concat backend-name "!" rev))
368 0 : ((eq state 'missing)
369 0 : (setq state-echo "File tracked by the VC system, but missing from the file system")
370 0 : (setq face 'vc-missing-state)
371 0 : (concat backend-name "?" rev))
372 : (t
373 0 : (setq state-echo "Locally modified file")
374 0 : (setq face 'vc-edited-state)
375 0 : (concat backend-name ":" rev)))
376 0 : 'face face
377 0 : 'help-echo (concat state-echo " under the " backend-name
378 0 : " version control system"))))
379 :
380 : ;;; History functions
381 :
382 : (defcustom vc-hg-log-switches nil
383 : "String or list of strings specifying switches for hg log under VC."
384 : :type '(choice (const :tag "None" nil)
385 : (string :tag "Argument String")
386 : (repeat :tag "Argument List" :value ("") string))
387 : :group 'vc-hg)
388 :
389 : (autoload 'vc-setup-buffer "vc-dispatcher")
390 :
391 : (defvar vc-hg-log-graph nil
392 : "If non-nil, use `--graph' in the short log output.")
393 :
394 : (defvar vc-hg-log-format (concat "changeset: {rev}:{node|short}\n"
395 : "{tags % 'tag: {tag}\n'}"
396 : "{if(parents, 'parents: {parents}\n')}"
397 : "user: {author}\n"
398 : "Date: {date|date}\n"
399 : "summary: {desc|tabindent}\n\n")
400 : "Mercurial log template for `vc-hg-print-log' long format.")
401 :
402 : (defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
403 : "Print commit log associated with FILES into specified BUFFER.
404 : If SHORTLOG is non-nil, use a short format based on `vc-hg-root-log-format'.
405 : If START-REVISION is non-nil, it is the newest revision to show.
406 : If LIMIT is non-nil, show no more than this many entries."
407 : ;; `vc-do-command' creates the buffer, but we need it before running
408 : ;; the command.
409 0 : (vc-setup-buffer buffer)
410 : ;; If the buffer exists from a previous invocation it might be
411 : ;; read-only.
412 0 : (let ((inhibit-read-only t))
413 0 : (with-current-buffer
414 0 : buffer
415 0 : (apply 'vc-hg-command buffer 'async files "log"
416 0 : (nconc
417 0 : (when start-revision (list (format "-r%s:0" start-revision)))
418 0 : (when limit (list "-l" (format "%s" limit)))
419 0 : (if shortlog
420 0 : `(,@(if vc-hg-log-graph '("--graph"))
421 : "--template"
422 0 : ,(car vc-hg-root-log-format))
423 0 : `("--template" ,vc-hg-log-format))
424 0 : vc-hg-log-switches)))))
425 :
426 : (defvar log-view-message-re)
427 : (defvar log-view-file-re)
428 : (defvar log-view-font-lock-keywords)
429 : (defvar log-view-per-file-logs)
430 : (defvar log-view-expanded-log-entry-function)
431 :
432 : (define-derived-mode vc-hg-log-view-mode log-view-mode "Hg-Log-View"
433 0 : (require 'add-log) ;; we need the add-log faces
434 0 : (set (make-local-variable 'log-view-file-re) "\\`a\\`")
435 0 : (set (make-local-variable 'log-view-per-file-logs) nil)
436 0 : (set (make-local-variable 'log-view-message-re)
437 0 : (if (eq vc-log-view-type 'short)
438 0 : (cadr vc-hg-root-log-format)
439 0 : "^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
440 0 : (set (make-local-variable 'tab-width) 2)
441 : ;; Allow expanding short log entries
442 0 : (when (eq vc-log-view-type 'short)
443 0 : (setq truncate-lines t)
444 0 : (set (make-local-variable 'log-view-expanded-log-entry-function)
445 0 : 'vc-hg-expanded-log-entry))
446 0 : (set (make-local-variable 'log-view-font-lock-keywords)
447 0 : (if (eq vc-log-view-type 'short)
448 0 : (list (cons (nth 1 vc-hg-root-log-format)
449 0 : (nth 2 vc-hg-root-log-format)))
450 0 : (append
451 0 : log-view-font-lock-keywords
452 : '(
453 : ;; Handle the case:
454 : ;; user: FirstName LastName <foo@bar>
455 : ("^user:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
456 : (1 'change-log-name)
457 : (2 'change-log-email))
458 : ;; Handle the cases:
459 : ;; user: foo@bar
460 : ;; and
461 : ;; user: foo
462 : ("^user:[ \t]+\\([A-Za-z0-9_.+-]+\\(?:@[A-Za-z0-9_.-]+\\)?\\)"
463 : (1 'change-log-email))
464 : ("^date: \\(.+\\)" (1 'change-log-date))
465 : ("^tag: +\\([^ ]+\\)$" (1 'highlight))
466 0 : ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
467 :
468 : (autoload 'vc-switches "vc")
469 :
470 : (defun vc-hg-diff (files &optional oldvers newvers buffer _async)
471 : "Get a difference report using hg between two revisions of FILES."
472 0 : (let* ((firstfile (car files))
473 0 : (working (and firstfile (vc-working-revision firstfile))))
474 0 : (when (and (equal oldvers working) (not newvers))
475 0 : (setq oldvers nil))
476 0 : (when (and (not oldvers) newvers)
477 0 : (setq oldvers working))
478 0 : (apply #'vc-hg-command
479 0 : (or buffer "*vc-diff*")
480 : nil ; bug#21969
481 0 : files "diff"
482 0 : (append
483 0 : (vc-switches 'hg 'diff)
484 0 : (when oldvers
485 0 : (if newvers
486 0 : (list "-r" oldvers "-r" newvers)
487 0 : (list "-r" oldvers)))))))
488 :
489 : (defun vc-hg-expanded-log-entry (revision)
490 0 : (with-temp-buffer
491 0 : (vc-hg-command t nil nil "log" "-r" revision "--template" vc-hg-log-format)
492 0 : (goto-char (point-min))
493 0 : (unless (eobp)
494 : ;; Indent the expanded log entry.
495 0 : (indent-region (point-min) (point-max) 2)
496 0 : (goto-char (point-max))
497 0 : (buffer-string))))
498 :
499 : (defun vc-hg-revision-table (files)
500 0 : (let ((default-directory (file-name-directory (car files))))
501 0 : (with-temp-buffer
502 0 : (vc-hg-command t nil files "log" "--template" "{rev} ")
503 0 : (split-string
504 0 : (buffer-substring-no-properties (point-min) (point-max))))))
505 :
506 : ;; Modeled after the similar function in vc-cvs.el
507 : (defun vc-hg-revision-completion-table (files)
508 0 : (letrec ((table (lazy-completion-table
509 0 : table (lambda () (vc-hg-revision-table files)))))
510 0 : table))
511 :
512 : (defun vc-hg-annotate-command (file buffer &optional revision)
513 : "Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
514 : Optional arg REVISION is a revision to annotate from."
515 0 : (apply #'vc-hg-command buffer 0 file "annotate" "-dq" "-n"
516 0 : (append (vc-switches 'hg 'annotate)
517 0 : (if revision (list (concat "-r" revision))))))
518 :
519 : (declare-function vc-annotate-convert-time "vc-annotate" (&optional time))
520 :
521 : ;; One line printed by "hg annotate -dq -n -u --follow" looks like this:
522 : ;; b56girard 114590 2012-03-13 CLOBBER: Lorem ipsum dolor sit
523 : ;; i.e. AUTHOR REVISION DATE FILENAME: CONTENTS
524 : ;; The user can omit options "-u" and/or "--follow". Then it'll look like:
525 : ;; 114590 2012-03-13 CLOBBER:
526 : ;; or
527 : ;; b56girard 114590 2012-03-13:
528 : (defconst vc-hg-annotate-re
529 : (concat
530 : "^\\(?: *[^ ]+ +\\)?\\([0-9]+\\) " ;User and revision.
531 : "\\([0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]\\)" ;Date.
532 : "\\(?: +\\([^:]+\\)\\)?:")) ;Filename.
533 :
534 : (defun vc-hg-annotate-time ()
535 0 : (when (looking-at vc-hg-annotate-re)
536 0 : (goto-char (match-end 0))
537 0 : (vc-annotate-convert-time
538 0 : (let ((str (match-string-no-properties 2)))
539 0 : (encode-time 0 0 0
540 0 : (string-to-number (substring str 6 8))
541 0 : (string-to-number (substring str 4 6))
542 0 : (string-to-number (substring str 0 4)))))))
543 :
544 : (defun vc-hg-annotate-extract-revision-at-line ()
545 0 : (save-excursion
546 0 : (beginning-of-line)
547 0 : (when (looking-at vc-hg-annotate-re)
548 0 : (if (match-beginning 3)
549 0 : (cons (match-string-no-properties 1)
550 0 : (expand-file-name (match-string-no-properties 3)
551 0 : (vc-hg-root default-directory)))
552 0 : (match-string-no-properties 1)))))
553 :
554 : ;;; Tag system
555 :
556 : (defun vc-hg-create-tag (dir name branchp)
557 : "Attach the tag NAME to the state of the working copy."
558 0 : (let ((default-directory dir))
559 0 : (and (vc-hg-command nil 0 nil "status")
560 0 : (vc-hg-command nil 0 nil (if branchp "bookmark" "tag") name))))
561 :
562 : (defun vc-hg-retrieve-tag (dir name _update)
563 : "Retrieve the version tagged by NAME of all registered files at or below DIR."
564 0 : (let ((default-directory dir))
565 0 : (vc-hg-command nil 0 nil "update" name)
566 : ;; TODO: update *vc-change-log* buffer so can see @ if --graph
567 0 : ))
568 :
569 : ;;; Native data structure reading
570 :
571 : (defcustom vc-hg-parse-hg-data-structures t
572 : "If true, try directly parsing Mercurial data structures
573 : directly instead of always running Mercurial. We try to be safe
574 : against Mercurial data structure format changes and always fall
575 : back to running Mercurial directly."
576 : :type 'boolean
577 : :version "26.1"
578 : :group 'vc-hg)
579 :
580 : (defsubst vc-hg--read-u8 ()
581 : "Read and advance over an unsigned byte.
582 : Return a fixnum."
583 0 : (prog1 (char-after)
584 0 : (forward-char)))
585 :
586 : (defsubst vc-hg--read-u32-be ()
587 : "Read and advance over a big-endian unsigned 32-bit integer.
588 : Return a fixnum; on overflow, result is undefined."
589 : ;; Because elisp bytecode has an instruction for multiply and
590 : ;; doesn't have one for lsh, it's somewhat counter-intuitively
591 : ;; faster to multiply than to shift.
592 0 : (+ (* (vc-hg--read-u8) (* 256 256 256))
593 0 : (* (vc-hg--read-u8) (* 256 256))
594 0 : (* (vc-hg--read-u8) 256)
595 0 : (identity (vc-hg--read-u8))))
596 :
597 : (defun vc-hg--raw-dirstate-search (dirstate fname)
598 0 : (with-temp-buffer
599 0 : (set-buffer-multibyte nil)
600 0 : (insert-file-contents-literally dirstate)
601 0 : (let* ((result nil)
602 0 : (flen (length fname))
603 : (case-fold-search nil)
604 : (inhibit-changing-match-data t)
605 : ;; Find a conservative bound for the loop below by using
606 : ;; Boyer-Moore on the raw dirstate without parsing it; we
607 : ;; know we can't possibly find fname _after_ the last place
608 : ;; it appears, so we can bail out early if we try to parse
609 : ;; past it, which especially helps when the file we're
610 : ;; trying to find isn't in dirstate at all. There's no way
611 : ;; to similarly bound the starting search position, since
612 : ;; the file format is such that we need to parse it from
613 : ;; the beginning to find record boundaries.
614 : (search-limit
615 0 : (progn
616 0 : (goto-char (point-max))
617 0 : (or (search-backward fname (+ (point-min) 40) t)
618 0 : (point-min)))))
619 : ;; 40 is just after the header, which contains the working
620 : ;; directory parents
621 0 : (goto-char (+ (point-min) 40))
622 : ;; Iterate over all dirstate entries; we might run this loop
623 : ;; hundreds of thousands of times, so performance is important
624 : ;; here
625 0 : (while (< (point) search-limit)
626 : ;; 1+4*4 is the length of the dirstate item header, which we
627 : ;; spell as a literal for performance, since the elisp
628 : ;; compiler lacks constant propagation
629 0 : (forward-char (1+ (* 3 4)))
630 0 : (let ((this-flen (vc-hg--read-u32-be)))
631 0 : (if (and (or (eq this-flen flen)
632 0 : (and (> this-flen flen)
633 0 : (eq (char-after (+ (point) flen)) 0)))
634 0 : (search-forward fname (+ (point) flen) t))
635 0 : (progn
636 0 : (backward-char (+ flen (1+ (* 4 4))))
637 0 : (setf result
638 0 : (list (vc-hg--read-u8) ; status
639 0 : (vc-hg--read-u32-be) ; mode
640 0 : (vc-hg--read-u32-be) ; size (of file)
641 0 : (vc-hg--read-u32-be) ; mtime
642 0 : ))
643 0 : (goto-char (point-max)))
644 0 : (forward-char this-flen))))
645 0 : result)))
646 :
647 : (define-error 'vc-hg-unsupported-syntax "unsupported hgignore syntax")
648 :
649 : (defconst vc-hg--pcre-c-escapes
650 : '((?a . ?\a)
651 : (?b . ?\b)
652 : (?f . ?\f)
653 : (?n . ?\n)
654 : (?r . ?\r)
655 : (?t . ?\t)
656 : (?n . ?\n)
657 : (?r . ?\r)
658 : (?t . ?\t)
659 : (?v . ?\v)))
660 :
661 : (defconst vc-hg--pcre-metacharacters
662 : '(?. ?^ ?$ ?* ?+ ?? ?{ ?\\ ?\[ ?\| ?\())
663 :
664 : (defconst vc-hg--elisp-metacharacters
665 : '(?. ?* ?+ ?? ?\[ ?$ ?\\))
666 :
667 : (defun vc-hg--escape-for-pcre (c)
668 0 : (if (memq c vc-hg--pcre-metacharacters)
669 0 : (string ?\\ c)
670 0 : c))
671 :
672 : (defun vc-hg--parts-to-string (parts)
673 : "Build a string from list PARTS. Each element is a character or string."
674 0 : (let ((parts2 nil))
675 0 : (while parts
676 0 : (let* ((partcell (prog1 parts (setf parts (cdr parts))))
677 0 : (part (car partcell)))
678 0 : (if (stringp part)
679 0 : (setf parts2 (nconc (append part nil) parts2))
680 0 : (setcdr partcell parts2)
681 0 : (setf parts2 partcell))))
682 0 : (apply #'string parts2)))
683 :
684 : (defun vc-hg--pcre-to-elisp-re (pcre prefix)
685 : "Transform PCRE, a Mercurial file PCRE, into an elisp RE against PREFIX.
686 : PREFIX is the directory name of the directory against which these
687 : patterns are rooted. We understand only a subset of PCRE syntax;
688 : if we don't understand a construct, we signal
689 : `vc-hg-unsupported-syntax'."
690 0 : (cl-assert (string-match "^/\\(.*/\\)?$" prefix))
691 0 : (let ((parts nil)
692 : (i 0)
693 : (anchored nil)
694 : (state 'normal)
695 0 : (pcrelen (length pcre)))
696 0 : (while (< i pcrelen)
697 0 : (let ((c (aref pcre i)))
698 0 : (cond ((eq state 'normal)
699 0 : (cond ((string-match
700 0 : (rx (| "}\\?" (: "(?" (not (any ":")))))
701 0 : pcre i)
702 0 : (signal 'vc-hg-unsupported-syntax (list pcre)))
703 0 : ((eq c ?\\)
704 0 : (setf state 'backslash))
705 0 : ((eq c ?\[)
706 0 : (setf state 'charclass-enter)
707 0 : (push c parts))
708 0 : ((eq c ?^)
709 0 : (if (eq i 0) (setf anchored t)
710 0 : (signal 'vc-hg-unsupported-syntax (list pcre))))
711 0 : ((eq c ?$)
712 : ;; Patterns can also match directories exactly,
713 : ;; ignoring everything under a matched directory
714 0 : (push "\\(?:$\\|/\\)" parts))
715 0 : ((memq c '(?| ?\( ?\)))
716 0 : (push ?\\ parts)
717 0 : (push c parts))
718 0 : (t (push c parts))))
719 0 : ((eq state 'backslash)
720 0 : (cond ((memq c '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
721 0 : ?A ?b ?B ?d ?D ?s ?S ?w ?W ?Z ?x))
722 0 : (signal 'vc-hg-unsupported-syntax (list pcre)))
723 0 : ((memq c vc-hg--elisp-metacharacters)
724 0 : (push ?\\ parts)
725 0 : (push c parts))
726 0 : (t (push (or (cdr (assq c vc-hg--pcre-c-escapes)) c) parts)))
727 0 : (setf state 'normal))
728 0 : ((eq state 'charclass-enter)
729 0 : (push c parts)
730 0 : (setf state
731 0 : (if (eq c ?\\)
732 : 'charclass
733 0 : 'charclass-backslash)))
734 0 : ((eq state 'charclass-backslash)
735 0 : (if (memq c '(?0 ?x))
736 0 : (signal 'vc-hg-unsupported-syntax (list pcre)))
737 0 : (push (or (cdr (assq c vc-hg--pcre-c-escapes)) c) parts)
738 0 : (setf state 'charclass))
739 0 : ((eq state 'charclass)
740 0 : (push c parts)
741 0 : (cond ((eq c ?\\) (setf state 'charclass-backslash))
742 0 : ((eq c ?\]) (setf state 'normal))))
743 0 : (t (error "invalid state")))
744 0 : (setf i (1+ i))))
745 0 : (unless (eq state 'normal)
746 0 : (signal 'vc-hg-unsupported-syntax (list pcre)))
747 0 : (concat
748 : "^"
749 0 : prefix
750 0 : (if anchored "" "\\(?:.*/\\)?")
751 0 : (vc-hg--parts-to-string parts))))
752 :
753 : (defun vc-hg--glob-to-pcre (glob)
754 : "Transform a glob pattern into a Mercurial file pattern regex."
755 0 : (let ((parts nil) (i 0) (n (length glob)) (group 0) c)
756 0 : (cl-macrolet ((peek () '(and (< i n) (aref glob i))))
757 0 : (while (< i n)
758 0 : (setf c (aref glob i))
759 0 : (cl-incf i)
760 0 : (cond ((not (memq c '(?* ?? ?\[ ?\{ ?\} ?, ?\\)))
761 0 : (push (vc-hg--escape-for-pcre c) parts))
762 0 : ((eq c ?*)
763 0 : (cond ((eq (peek) ?*)
764 0 : (cl-incf i)
765 0 : (cond ((eq (peek) ?/)
766 0 : (cl-incf i)
767 0 : (push "(?:.*/)?" parts))
768 : (t
769 0 : (push ".*" parts))))
770 0 : (t (push "[^/]*" parts))))
771 0 : ((eq c ??)
772 0 : (push ?. parts))
773 0 : ((eq c ?\[)
774 0 : (let ((j i))
775 0 : (when (and (< j n) (memq (aref glob j) '(?! ?\])))
776 0 : (cl-incf j))
777 0 : (while (and (< j n) (not (eq (aref glob j) ?\])))
778 0 : (cl-incf j))
779 0 : (cond ((>= j n)
780 0 : (push "\\[" parts))
781 : (t
782 0 : (let ((x (substring glob i j)))
783 0 : (setf x (replace-regexp-in-string
784 0 : "\\\\" "\\\\" x t t))
785 0 : (setf i (1+ j))
786 0 : (cond ((eq (aref x 0) ?!)
787 0 : (setf (aref x 0) ?^))
788 0 : ((eq (aref x 0) ?^)
789 0 : (setf x (concat "\\" x))))
790 0 : (push ?\[ parts)
791 0 : (push x parts)
792 0 : (push ?\] parts))))))
793 0 : ((eq c ?\{)
794 0 : (cl-incf group)
795 0 : (push "(?:" parts))
796 0 : ((eq c ?\})
797 0 : (push ?\) parts)
798 0 : (cl-decf group))
799 0 : ((and (eq c ?,) (> group 0))
800 0 : (push ?| parts))
801 0 : ((eq c ?\\)
802 0 : (if (eq i n)
803 0 : (push "\\\\" parts)
804 0 : (cl-incf i)
805 0 : (push ?\\ parts)
806 0 : (push c parts)))
807 : (t
808 0 : (push (vc-hg--escape-for-pcre c) parts)))))
809 0 : (concat (vc-hg--parts-to-string parts) "$")))
810 :
811 : (defvar vc-hg--hgignore-patterns)
812 : (defvar vc-hg--hgignore-filenames)
813 :
814 : (defun vc-hg--hgignore-add-pcre (pcre prefix)
815 0 : (push (vc-hg--pcre-to-elisp-re pcre prefix) vc-hg--hgignore-patterns))
816 :
817 : (defun vc-hg--hgignore-add-glob (glob prefix)
818 0 : (push (vc-hg--pcre-to-elisp-re (vc-hg--glob-to-pcre glob) prefix)
819 0 : vc-hg--hgignore-patterns))
820 :
821 : (defun vc-hg--hgignore-add-path (path prefix)
822 0 : (let ((parts nil))
823 0 : (dotimes (i (length path))
824 0 : (push (vc-hg--escape-for-pcre (aref path i)) parts))
825 0 : (vc-hg--hgignore-add-pcre
826 0 : (concat "^" (vc-hg--parts-to-string parts) "$")
827 0 : prefix)))
828 :
829 : (defun vc-hg--slurp-hgignore-1 (hgignore prefix)
830 0 : (let ((default-syntax 'vc-hg--hgignore-add-pcre))
831 0 : (with-temp-buffer
832 0 : (let ((attr (file-attributes hgignore)))
833 0 : (when attr (insert-file-contents hgignore))
834 0 : (push (list hgignore (nth 5 attr) (nth 7 attr))
835 0 : vc-hg--hgignore-filenames))
836 0 : (while (not (eobp))
837 : ;; This list of pattern-file commands isn't complete, but it
838 : ;; should cover the common cases. Remember that we fall back
839 : ;; to regular hg commands if we see something we don't like.
840 0 : (save-restriction
841 0 : (narrow-to-region (point) (point-at-eol))
842 0 : (cond ((looking-at "[ \t]*\\(?:#.*\\)?$"))
843 0 : ((looking-at "syntax:[ \t]*re[ \t]*$")
844 0 : (setf default-syntax 'vc-hg--hgignore-add-pcre))
845 0 : ((looking-at "syntax:[ \t]*glob[ \t]*$")
846 0 : (setf default-syntax 'vc-hg--hgignore-add-glob))
847 0 : ((looking-at "path:\\(.+?\\)[ \t]*$")
848 0 : (vc-hg--hgignore-add-path (match-string 1) prefix))
849 0 : ((looking-at "glob:\\(.+?\\)[ \t]*$")
850 0 : (vc-hg--hgignore-add-glob (match-string 1) prefix))
851 0 : ((looking-at "re:\\(.+?\\)[ \t]*$")
852 0 : (vc-hg--hgignore-add-pcre (match-string 1) prefix))
853 0 : ((looking-at "\\(sub\\)?include:\\(.+?\\)[ \t]*$")
854 0 : (let* ((sub (equal (match-string 1) "sub"))
855 0 : (arg (match-string 2))
856 : (included-file
857 0 : (if (string-match "^/" arg) arg
858 0 : (concat (file-name-directory hgignore) arg))))
859 0 : (vc-hg--slurp-hgignore-1
860 0 : included-file
861 0 : (if sub (file-name-directory included-file) prefix))))
862 0 : ((looking-at "[a-zA-Z0-9_]*:")
863 0 : (signal 'vc-hg-unsupported-syntax (list (match-string 0))))
864 0 : ((looking-at ".*$")
865 0 : (funcall default-syntax (match-string 0) prefix))))
866 0 : (forward-line 1)))))
867 :
868 : (cl-defstruct (vc-hg--ignore-patterns
869 : (:copier nil)
870 : (:constructor vc-hg--ignore-patterns-make))
871 : repo
872 : ignore-patterns
873 : file-sources)
874 :
875 : (defun vc-hg--slurp-hgignore (repo)
876 : "Read hg ignore patterns from REPO.
877 : REPO must be the directory name of an hg repository."
878 0 : (cl-assert (string-match "^/\\(.*/\\)?$" repo))
879 0 : (let* ((hgignore (concat repo ".hgignore"))
880 : (vc-hg--hgignore-patterns nil)
881 : (vc-hg--hgignore-filenames nil))
882 0 : (vc-hg--slurp-hgignore-1 hgignore repo)
883 0 : (vc-hg--ignore-patterns-make
884 0 : :repo repo
885 0 : :ignore-patterns (nreverse vc-hg--hgignore-patterns)
886 0 : :file-sources (nreverse vc-hg--hgignore-filenames))))
887 :
888 : (defun vc-hg--ignore-patterns-valid-p (hgip)
889 : "Return whether the cached ignore patterns in HGIP are still valid"
890 0 : (let ((valid t)
891 0 : (file-sources (vc-hg--ignore-patterns-file-sources hgip)))
892 0 : (while (and file-sources valid)
893 0 : (let* ((fs (pop file-sources))
894 0 : (saved-mtime (nth 1 fs))
895 0 : (saved-size (nth 2 fs))
896 0 : (attr (file-attributes (nth 0 fs)))
897 0 : (current-mtime (nth 5 attr))
898 0 : (current-size (nth 7 attr)))
899 0 : (unless (and (equal saved-mtime current-mtime)
900 0 : (equal saved-size current-size))
901 0 : (setf valid nil))))
902 0 : valid))
903 :
904 : (defun vc-hg--ignore-patterns-ignored-p (hgip filename)
905 : "Test whether the ignore pattern set HGIP says to ignore FILENAME.
906 : FILENAME must be the file's true absolute name."
907 0 : (let ((patterns (vc-hg--ignore-patterns-ignore-patterns hgip))
908 : (inhibit-changing-match-data t)
909 : (ignored nil))
910 0 : (while (and patterns (not ignored))
911 0 : (setf ignored (string-match (pop patterns) filename)))
912 0 : ignored))
913 :
914 : (defun vc-hg--time-to-fixnum (ts)
915 0 : (+ (* 65536 (car ts)) (cadr ts)))
916 :
917 : (defvar vc-hg--cached-ignore-patterns nil
918 : "Cached pre-parsed hg ignore patterns.")
919 :
920 : (defun vc-hg--file-ignored-p (repo repo-relative-filename)
921 0 : (let ((hgip vc-hg--cached-ignore-patterns))
922 0 : (unless (and hgip
923 0 : (equal repo (vc-hg--ignore-patterns-repo hgip))
924 0 : (vc-hg--ignore-patterns-valid-p hgip))
925 0 : (setf vc-hg--cached-ignore-patterns nil)
926 0 : (setf hgip (vc-hg--slurp-hgignore repo))
927 0 : (setf vc-hg--cached-ignore-patterns hgip))
928 0 : (vc-hg--ignore-patterns-ignored-p
929 0 : hgip
930 0 : (concat repo repo-relative-filename))))
931 :
932 : (defun vc-hg--read-repo-requirements (repo)
933 0 : (cl-assert (string-match "^/\\(.*/\\)?$" repo))
934 0 : (let* ((requires-filename (concat repo ".hg/requires")))
935 0 : (and (file-exists-p requires-filename)
936 0 : (with-temp-buffer
937 0 : (set-buffer-multibyte nil)
938 0 : (insert-file-contents-literally requires-filename)
939 0 : (split-string (buffer-substring-no-properties
940 0 : (point-min) (point-max)))))))
941 :
942 : (defconst vc-hg-supported-requirements
943 : '("dotencode"
944 : "fncache"
945 : "generaldelta"
946 : "lz4revlog"
947 : "remotefilelog"
948 : "revlogv1"
949 : "store")
950 : "List of Mercurial repository requirements we understand; if a
951 : repository requires features not present in this list, we avoid
952 : attempting to parse Mercurial data structures.")
953 :
954 : (defun vc-hg--requirements-understood-p (repo)
955 : "Check that we understand the format of the given repository.
956 : REPO is the directory name of a Mercurial repository."
957 0 : (null (cl-set-difference (vc-hg--read-repo-requirements repo)
958 0 : vc-hg-supported-requirements
959 0 : :test #'equal)))
960 :
961 : (defvar vc-hg--dirstate-scan-cache nil
962 : "Cache of the last result of `vc-hg--raw-dirstate-search'.
963 : Avoids the need to repeatedly scan dirstate on repeated calls to
964 : `vc-hg-state', as we see during registration queries.")
965 :
966 : (defun vc-hg--cached-dirstate-search (dirstate dirstate-attr ascii-fname)
967 0 : (let* ((mtime (nth 5 dirstate-attr))
968 0 : (size (nth 7 dirstate-attr))
969 0 : (cache vc-hg--dirstate-scan-cache)
970 : )
971 0 : (if (and cache
972 0 : (equal dirstate (pop cache))
973 0 : (equal mtime (pop cache))
974 0 : (equal size (pop cache))
975 0 : (equal ascii-fname (pop cache)))
976 0 : (pop cache)
977 0 : (let ((result (vc-hg--raw-dirstate-search dirstate ascii-fname)))
978 0 : (setf vc-hg--dirstate-scan-cache
979 0 : (list dirstate mtime size ascii-fname result))
980 0 : result))))
981 :
982 : (defun vc-hg-state-fast (filename)
983 : "Like `vc-hg-state', but parse internal data structures directly.
984 : Returns one of the usual `vc-state' enumeration values or
985 : `unsupported' if we need to take the slow path and run the
986 : hg binary."
987 0 : (let* (truename
988 : repo
989 : dirstate
990 : dirstate-attr
991 : repo-relative-filename)
992 0 : (if (or
993 : ;; Explicit user disable
994 0 : (not vc-hg-parse-hg-data-structures)
995 : ;; It'll probably be faster to run hg remotely
996 0 : (file-remote-p filename)
997 0 : (progn
998 0 : (setf truename (file-truename filename))
999 0 : (file-remote-p truename))
1000 0 : (not (setf repo (vc-hg-root truename)))
1001 : ;; dirstate must exist
1002 0 : (not (progn
1003 0 : (setf repo (expand-file-name repo))
1004 0 : (cl-assert (string-match "^/\\(.*/\\)?$" repo))
1005 0 : (setf dirstate (concat repo ".hg/dirstate"))
1006 0 : (setf dirstate-attr (file-attributes dirstate))))
1007 : ;; Repository must be in an understood format
1008 0 : (not (vc-hg--requirements-understood-p repo))
1009 : ;; Dirstate too small to be valid
1010 0 : (< (nth 7 dirstate-attr) 40)
1011 : ;; We want to store 32-bit unsigned values in fixnums
1012 0 : (< most-positive-fixnum 4294967295)
1013 0 : (progn
1014 0 : (setf repo-relative-filename
1015 0 : (file-relative-name truename repo))
1016 : ;; We only try dealing with ASCII filenames
1017 0 : (string-match-p "[^[:ascii:]]" repo-relative-filename)))
1018 : 'unsupported
1019 0 : (let* ((dirstate-entry
1020 0 : (vc-hg--cached-dirstate-search
1021 0 : dirstate dirstate-attr repo-relative-filename))
1022 0 : (state (car dirstate-entry))
1023 0 : (stat (file-attributes
1024 0 : (concat repo repo-relative-filename))))
1025 0 : (cond ((eq state ?r) 'removed)
1026 0 : ((and (not state) stat)
1027 0 : (condition-case nil
1028 0 : (if (vc-hg--file-ignored-p repo repo-relative-filename)
1029 : 'ignored
1030 0 : 'unregistered)
1031 0 : (vc-hg-unsupported-syntax 'unsupported)))
1032 0 : ((and state (not stat)) 'missing)
1033 0 : ((eq state ?n)
1034 0 : (let ((vc-hg-size (nth 2 dirstate-entry))
1035 0 : (vc-hg-mtime (nth 3 dirstate-entry))
1036 0 : (fs-size (nth 7 stat))
1037 0 : (fs-mtime (vc-hg--time-to-fixnum (nth 5 stat))))
1038 0 : (if (and (eql vc-hg-size fs-size) (eql vc-hg-mtime fs-mtime))
1039 : 'up-to-date
1040 0 : 'edited)))
1041 0 : ((eq state ?a) 'added)
1042 0 : (state 'unsupported))))))
1043 :
1044 : ;;; Miscellaneous
1045 :
1046 : (defun vc-hg-previous-revision (_file rev)
1047 : ;; We can't simply decrement by 1, because that revision might be
1048 : ;; e.g. on a different branch (bug#22032).
1049 0 : (with-temp-buffer
1050 0 : (and (eq 0
1051 0 : (vc-hg-command t nil nil "id" "-n" "-r" (concat rev "^")))
1052 : ;; Trim the trailing newline.
1053 0 : (buffer-substring (point-min) (1- (point-max))))))
1054 :
1055 : (defun vc-hg-next-revision (_file rev)
1056 0 : (let ((newrev (1+ (string-to-number rev)))
1057 : (tip-revision
1058 0 : (with-temp-buffer
1059 0 : (vc-hg-command t 0 nil "tip" "--style=default")
1060 0 : (goto-char (point-min))
1061 0 : (re-search-forward "^changeset:[ \t]*\\([0-9]+\\):")
1062 0 : (string-to-number (match-string-no-properties 1)))))
1063 : ;; We don't want to exceed the maximum possible revision number, ie
1064 : ;; the tip revision.
1065 0 : (when (<= newrev tip-revision)
1066 0 : (number-to-string newrev))))
1067 :
1068 : ;; Modeled after the similar function in vc-bzr.el
1069 : (defun vc-hg-delete-file (file)
1070 : "Delete FILE and delete it in the hg repository."
1071 0 : (condition-case ()
1072 0 : (delete-file file)
1073 0 : (file-error nil))
1074 0 : (vc-hg-command nil 0 file "remove" "--after" "--force"))
1075 :
1076 : ;; Modeled after the similar function in vc-bzr.el
1077 : (defun vc-hg-rename-file (old new)
1078 : "Rename file from OLD to NEW using `hg mv'."
1079 0 : (vc-hg-command nil 0 new "mv" old))
1080 :
1081 : (defun vc-hg-register (files &optional _comment)
1082 : "Register FILES under hg. COMMENT is ignored."
1083 0 : (vc-hg-command nil 0 files "add"))
1084 :
1085 : (defun vc-hg-create-repo ()
1086 : "Create a new Mercurial repository."
1087 0 : (vc-hg-command nil 0 nil "init"))
1088 :
1089 : (defalias 'vc-hg-responsible-p 'vc-hg-root)
1090 :
1091 : (defun vc-hg-unregister (file)
1092 : "Unregister FILE from hg."
1093 0 : (vc-hg-command nil 0 file "forget"))
1094 :
1095 : (declare-function log-edit-extract-headers "log-edit" (headers string))
1096 :
1097 : (defun vc-hg-checkin (files comment &optional _rev)
1098 : "Hg-specific version of `vc-backend-checkin'.
1099 : REV is ignored."
1100 0 : (apply 'vc-hg-command nil 0 files
1101 0 : (nconc (list "commit" "-m")
1102 0 : (log-edit-extract-headers '(("Author" . "--user")
1103 : ("Date" . "--date"))
1104 0 : comment))))
1105 :
1106 : (defun vc-hg-find-revision (file rev buffer)
1107 0 : (let ((coding-system-for-read 'binary)
1108 : (coding-system-for-write 'binary))
1109 0 : (if rev
1110 0 : (vc-hg-command buffer 0 file "cat" "-r" rev)
1111 0 : (vc-hg-command buffer 0 file "cat"))))
1112 :
1113 : (defun vc-hg-find-ignore-file (file)
1114 : "Return the root directory of the repository of FILE."
1115 0 : (expand-file-name ".hgignore"
1116 0 : (vc-hg-root file)))
1117 :
1118 : ;; Modeled after the similar function in vc-bzr.el
1119 : (defun vc-hg-checkout (file &optional rev)
1120 : "Retrieve a revision of FILE.
1121 : EDITABLE is ignored.
1122 : REV is the revision to check out into WORKFILE."
1123 0 : (let ((coding-system-for-read 'binary)
1124 : (coding-system-for-write 'binary))
1125 0 : (with-current-buffer (or (get-file-buffer file) (current-buffer))
1126 0 : (if rev
1127 0 : (vc-hg-command t 0 file "cat" "-r" rev)
1128 0 : (vc-hg-command t 0 file "cat")))))
1129 :
1130 : (defun vc-hg-resolve-when-done ()
1131 : "Call \"hg resolve -m\" if the conflict markers have been removed."
1132 0 : (save-excursion
1133 0 : (goto-char (point-min))
1134 0 : (unless (re-search-forward "^<<<<<<< " nil t)
1135 0 : (vc-hg-command nil 0 buffer-file-name "resolve" "-m")
1136 : ;; Remove the hook so that it is not called multiple times.
1137 0 : (remove-hook 'after-save-hook 'vc-hg-resolve-when-done t))))
1138 :
1139 : (defun vc-hg-find-file-hook ()
1140 0 : (when (and buffer-file-name
1141 0 : (file-exists-p (concat buffer-file-name ".orig"))
1142 : ;; Hg does not seem to have a "conflict" status, eg
1143 : ;; hg http://bz.selenic.com/show_bug.cgi?id=2724
1144 0 : (memq (vc-file-getprop buffer-file-name 'vc-state)
1145 0 : '(edited conflict))
1146 : ;; Maybe go on to check that "hg resolve -l" says "U"?
1147 : ;; If "hg resolve -l" says there's a conflict but there are no
1148 : ;; conflict markers, it's not clear what we should do.
1149 0 : (save-excursion
1150 0 : (goto-char (point-min))
1151 0 : (re-search-forward "^<<<<<<< " nil t)))
1152 : ;; Hg may not recognize "conflict" as a state, but we can do better.
1153 0 : (vc-file-setprop buffer-file-name 'vc-state 'conflict)
1154 0 : (smerge-start-session)
1155 0 : (add-hook 'after-save-hook 'vc-hg-resolve-when-done nil t)
1156 0 : (vc-message-unresolved-conflicts buffer-file-name)))
1157 :
1158 :
1159 : ;; Modeled after the similar function in vc-bzr.el
1160 : (defun vc-hg-revert (file &optional contents-done)
1161 0 : (unless contents-done
1162 0 : (with-temp-buffer (vc-hg-command t 0 file "revert"))))
1163 :
1164 : ;;; Hg specific functionality.
1165 :
1166 : (defvar vc-hg-extra-menu-map
1167 : (let ((map (make-sparse-keymap)))
1168 : map))
1169 :
1170 0 : (defun vc-hg-extra-menu () vc-hg-extra-menu-map)
1171 :
1172 0 : (defun vc-hg-extra-status-menu () vc-hg-extra-menu-map)
1173 :
1174 : (defvar log-view-vc-backend)
1175 :
1176 : (cl-defstruct (vc-hg-extra-fileinfo
1177 : (:copier nil)
1178 : (:constructor vc-hg-create-extra-fileinfo (rename-state extra-name))
1179 : (:conc-name vc-hg-extra-fileinfo->))
1180 : rename-state ;; rename or copy state
1181 : extra-name) ;; original name for copies and rename targets, new name for
1182 :
1183 : (declare-function vc-default-dir-printer "vc-dir" (backend fileentry))
1184 :
1185 : (defun vc-hg-dir-printer (info)
1186 : "Pretty-printer for the vc-dir-fileinfo structure."
1187 0 : (let ((extra (vc-dir-fileinfo->extra info)))
1188 0 : (vc-default-dir-printer 'Hg info)
1189 0 : (when extra
1190 0 : (insert (propertize
1191 0 : (format " (%s %s)"
1192 0 : (pcase (vc-hg-extra-fileinfo->rename-state extra)
1193 : (`copied "copied from")
1194 : (`renamed-from "renamed from")
1195 0 : (`renamed-to "renamed to"))
1196 0 : (vc-hg-extra-fileinfo->extra-name extra))
1197 0 : 'face 'font-lock-comment-face)))))
1198 :
1199 : (defun vc-hg-after-dir-status (update-function)
1200 0 : (let ((file nil)
1201 : (translation '((?= . up-to-date)
1202 : (?C . up-to-date)
1203 : (?A . added)
1204 : (?R . removed)
1205 : (?M . edited)
1206 : (?I . ignored)
1207 : (?! . missing)
1208 : (? . copy-rename-line)
1209 : (?? . unregistered)))
1210 : (translated nil)
1211 : (result nil)
1212 : (last-added nil)
1213 : (last-line-copy nil))
1214 0 : (goto-char (point-min))
1215 0 : (while (not (eobp))
1216 0 : (setq translated (cdr (assoc (char-after) translation)))
1217 0 : (setq file
1218 0 : (buffer-substring-no-properties (+ (point) 2)
1219 0 : (line-end-position)))
1220 0 : (cond ((not translated)
1221 0 : (setq last-line-copy nil))
1222 0 : ((eq translated 'up-to-date)
1223 0 : (setq last-line-copy nil))
1224 0 : ((eq translated 'copy-rename-line)
1225 : ;; For copied files the output looks like this:
1226 : ;; A COPIED_FILE_NAME
1227 : ;; ORIGINAL_FILE_NAME
1228 0 : (setf (nth 2 last-added)
1229 0 : (vc-hg-create-extra-fileinfo 'copied file))
1230 0 : (setq last-line-copy t))
1231 0 : ((and last-line-copy (eq translated 'removed))
1232 : ;; For renamed files the output looks like this:
1233 : ;; A NEW_FILE_NAME
1234 : ;; ORIGINAL_FILE_NAME
1235 : ;; R ORIGINAL_FILE_NAME
1236 : ;; We need to adjust the previous entry to not think it is a copy.
1237 0 : (setf (vc-hg-extra-fileinfo->rename-state (nth 2 last-added))
1238 0 : 'renamed-from)
1239 0 : (push (list file translated
1240 0 : (vc-hg-create-extra-fileinfo
1241 0 : 'renamed-to (nth 0 last-added))) result)
1242 0 : (setq last-line-copy nil))
1243 : (t
1244 0 : (setq last-added (list file translated nil))
1245 0 : (push last-added result)
1246 0 : (setq last-line-copy nil)))
1247 0 : (forward-line))
1248 0 : (funcall update-function result)))
1249 :
1250 : ;; Follows vc-hg-command (or vc-do-async-command), which uses vc-do-command
1251 : ;; from vc-dispatcher.
1252 : (declare-function vc-exec-after "vc-dispatcher" (code))
1253 : ;; Follows vc-exec-after.
1254 : (declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
1255 :
1256 : (defun vc-hg-dir-status-files (_dir files update-function)
1257 : ;; XXX: We can't pass DIR directly to 'hg status' because that
1258 : ;; returns all ignored files if FILES is non-nil (bug#22481).
1259 : ;; If honoring DIR ever becomes important, try using '-I DIR/'.
1260 0 : (vc-hg-command (current-buffer) 'async files
1261 : "status"
1262 0 : (concat "-mardu" (if files "i"))
1263 0 : "-C")
1264 0 : (vc-run-delayed
1265 0 : (vc-hg-after-dir-status update-function)))
1266 :
1267 : (defun vc-hg-dir-extra-header (name &rest commands)
1268 0 : (concat (propertize name 'face 'font-lock-type-face)
1269 0 : (propertize
1270 0 : (with-temp-buffer
1271 0 : (apply 'vc-hg-command (current-buffer) 0 nil commands)
1272 0 : (buffer-substring-no-properties (point-min) (1- (point-max))))
1273 0 : 'face 'font-lock-variable-name-face)))
1274 :
1275 : (defun vc-hg-dir-extra-headers (dir)
1276 : "Generate extra status headers for a Mercurial tree."
1277 0 : (let ((default-directory dir))
1278 0 : (concat
1279 0 : (vc-hg-dir-extra-header "Root : " "root") "\n"
1280 0 : (vc-hg-dir-extra-header "Branch : " "id" "-b") "\n"
1281 0 : (vc-hg-dir-extra-header "Tags : " "id" "-t") ; "\n"
1282 : ;; these change after each commit
1283 : ;; (vc-hg-dir-extra-header "Local num : " "id" "-n") "\n"
1284 : ;; (vc-hg-dir-extra-header "Global id : " "id" "-i")
1285 0 : )))
1286 :
1287 : (defun vc-hg-log-incoming (buffer remote-location)
1288 0 : (vc-hg-command buffer 1 nil "incoming" "-n" (unless (string= remote-location "")
1289 0 : remote-location)))
1290 :
1291 : (defun vc-hg-log-outgoing (buffer remote-location)
1292 0 : (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "")
1293 0 : remote-location)))
1294 :
1295 : (defvar vc-hg-error-regexp-alist nil
1296 : ;; 'hg pull' does not list modified files, so, for now, the only
1297 : ;; benefit of `vc-compilation-mode' is that one can get rid of
1298 : ;; *vc-hg* buffer with 'q' or 'z'.
1299 : ;; TODO: call 'hg incoming' before pull/merge to get the list of
1300 : ;; modified files
1301 : "Value of `compilation-error-regexp-alist' in *vc-hg* buffers.")
1302 :
1303 : (autoload 'vc-do-async-command "vc-dispatcher")
1304 : (autoload 'log-view-get-marked "log-view")
1305 : (defvar compilation-directory)
1306 : (defvar compilation-arguments) ; defined in compile.el
1307 :
1308 : (defun vc-hg--pushpull (command prompt &optional obsolete)
1309 : "Run COMMAND (a string; either push or pull) on the current Hg branch.
1310 : If PROMPT is non-nil, prompt for the Hg command to run.
1311 : If OBSOLETE is non-nil, behave like the old versions of the Hg push/pull
1312 : commands, which only operated on marked files."
1313 0 : (let (marked-list)
1314 : ;; The `vc-hg-pull' and `vc-hg-push' commands existed before the
1315 : ;; `pull'/`push' VC actions were implemented.
1316 : ;; The following is for backwards compatibility.
1317 0 : (if (and obsolete (setq marked-list (log-view-get-marked)))
1318 0 : (apply #'vc-hg-command
1319 : nil 0 nil
1320 0 : command
1321 0 : (apply 'nconc
1322 0 : (mapcar (lambda (arg) (list "-r" arg)) marked-list)))
1323 0 : (let* ((root (vc-hg-root default-directory))
1324 0 : (buffer (format "*vc-hg : %s*" (expand-file-name root)))
1325 0 : (hg-program vc-hg-program)
1326 : ;; Fixme: before updating the working copy to the latest
1327 : ;; state, should check if it's visiting an old revision.
1328 0 : (args (if (equal command "pull") '("-u"))))
1329 : ;; If necessary, prompt for the exact command.
1330 : ;; TODO if pushing, prompt if no default push location - cf bzr.
1331 0 : (when prompt
1332 0 : (setq args (split-string
1333 0 : (read-shell-command
1334 0 : (format "Hg %s command: " command)
1335 0 : (format "%s %s%s" hg-program command
1336 0 : (if (not args) ""
1337 0 : (concat " " (mapconcat 'identity args " "))))
1338 0 : 'vc-hg-history)
1339 0 : " " t))
1340 0 : (setq hg-program (car args)
1341 0 : command (cadr args)
1342 0 : args (cddr args)))
1343 0 : (apply 'vc-do-async-command buffer root hg-program command args)
1344 0 : (with-current-buffer buffer
1345 0 : (vc-run-delayed
1346 0 : (vc-compilation-mode 'hg)
1347 0 : (setq-local compile-command
1348 0 : (concat hg-program " " command " "
1349 0 : (if args (mapconcat 'identity args " ") "")))
1350 0 : (setq-local compilation-directory root)
1351 : ;; Either set `compilation-buffer-name-function' locally to nil
1352 : ;; or use `compilation-arguments' to set `name-function'.
1353 : ;; See `compilation-buffer-name'.
1354 0 : (setq-local compilation-arguments
1355 0 : (list compile-command nil
1356 0 : (lambda (_name-of-mode) buffer)
1357 0 : nil))))
1358 0 : (vc-set-async-update buffer)))))
1359 :
1360 : (defun vc-hg-pull (prompt)
1361 : "Issue a Mercurial pull command.
1362 : If called interactively with a set of marked Log View buffers,
1363 : call \"hg pull -r REVS\" to pull in the specified revisions REVS.
1364 :
1365 : With a prefix argument or if PROMPT is non-nil, prompt for a
1366 : specific Mercurial pull command. The default is \"hg pull -u\",
1367 : which fetches changesets from the default remote repository and
1368 : then attempts to update the working directory."
1369 : (interactive "P")
1370 0 : (vc-hg--pushpull "pull" prompt (called-interactively-p 'interactive)))
1371 :
1372 : (defun vc-hg-push (prompt)
1373 : "Push changes from the current Mercurial branch.
1374 : Normally, this runs \"hg push\". If PROMPT is non-nil, prompt
1375 : for the Hg command to run.
1376 :
1377 : If called interactively with a set of marked Log View buffers,
1378 : call \"hg push -r REVS\" to push the specified revisions REVS."
1379 : (interactive "P")
1380 0 : (vc-hg--pushpull "push" prompt (called-interactively-p 'interactive)))
1381 :
1382 : (defun vc-hg-merge-branch ()
1383 : "Merge incoming changes into the current working directory.
1384 : This runs the command \"hg merge\"."
1385 0 : (let* ((root (vc-hg-root default-directory))
1386 0 : (buffer (format "*vc-hg : %s*" (expand-file-name root))))
1387 0 : (apply 'vc-do-async-command buffer root vc-hg-program '("merge"))
1388 0 : (with-current-buffer buffer (vc-run-delayed (vc-compilation-mode 'hg)))
1389 0 : (vc-set-async-update buffer)))
1390 :
1391 : ;;; Internal functions
1392 :
1393 : (defun vc-hg-command (buffer okstatus file-or-list &rest flags)
1394 : "A wrapper around `vc-do-command' for use in vc-hg.el.
1395 : This function differs from vc-do-command in that it invokes
1396 : `vc-hg-program', and passes `vc-hg-global-switches' to it before FLAGS."
1397 0 : (apply 'vc-do-command (or buffer "*vc*") okstatus vc-hg-program file-or-list
1398 0 : (if (stringp vc-hg-global-switches)
1399 0 : (cons vc-hg-global-switches flags)
1400 0 : (append vc-hg-global-switches
1401 0 : flags))))
1402 :
1403 : (defun vc-hg-root (file)
1404 12 : (vc-find-root file ".hg"))
1405 :
1406 : (provide 'vc-hg)
1407 :
1408 : ;;; vc-hg.el ends here
|