;;; vc-hg.el --- VC backend for the mercurial version control system -*- lexical-binding: t -*-
-;; Copyright (C) 2006-2015 Free Software Foundation, Inc.
+;; Copyright (C) 2006-2016 Free Software Foundation, Inc.
;; Author: Ivan Kanis
;; Maintainer: emacs-devel@gnu.org
;; - dir-printer (fileinfo) OK
;; * working-revision (file) OK
;; * checkout-model (files) OK
-;; - mode-line-string (file) NOT NEEDED
+;; - mode-line-string (file) OK
;; STATE-CHANGING FUNCTIONS
;; * register (files &optional rev comment) OK
;; * create-repo () OK
:version "23.1"
:group 'vc-hg)
-(defcustom vc-hg-annotate-switches nil
+(defcustom vc-hg-annotate-switches '("-u" "--follow")
"String or list of strings specifying switches for hg annotate under VC.
If nil, use the value of `vc-annotate-switches'. If t, use no
switches."
(defun vc-hg-state (file)
"Hg-specific version of `vc-state'."
+ (let ((state (vc-hg-state-fast file)))
+ (if (eq state 'unsupported) (vc-hg-state-slow file) state)))
+
+(defun vc-hg-state-slow (file)
+ "Determine status of FILE by running hg."
(setq file (expand-file-name file))
(let*
((status nil)
"parent" "--template" "{rev}")))
"0"))
+(defcustom vc-hg-symbolic-revision-styles
+ '(builtin-active-bookmark
+ "{if(bookmarks,sub(' ',',',bookmarks),if(phabdiff,phabdiff,shortest(node,6)))}")
+ "List of ways to present versions symbolically. The version
+that we use is the first one that successfully produces a
+non-empty string.
+
+Each entry in the list can be either:
+
+- The symbol `builtin-active-bookmark', which indicates that we
+should use the active bookmark if one exists. A template can
+supply this information as well, but `builtin-active-bookmark' is
+handled entirely inside Emacs and so is more efficient than using
+the generic Mercurial mechanism.
+
+- A string giving the Mercurial template to supply to \"hg
+parent\". \"hg help template\" may be useful reading.
+
+- A function to call; it should accept two arguments (a revision
+and an optional path to which to limit history) and produce a
+string. The function is called with `default-directory' set to
+within the repository.
+
+If no list entry produces a useful revision, return `nil'."
+ :type '(repeat (choice
+ (const :tag "Active bookmark" 'bookmark)
+ (string :tag "Hg template")
+ (function :tag "Custom")))
+ :version "25.2"
+ :group 'vc-hg)
+
+(defcustom vc-hg-use-file-version-for-mode-line-version nil
+ "When enabled, the modeline will contain revision informtion for the visited file.
+When not, the revision in the modeline is for the repository
+working copy. `nil' is the much faster setting for
+large repositories."
+ :type 'boolean
+ :version "25.2"
+ :group 'vc-hg)
+
+(defun vc-hg--active-bookmark-internal (rev)
+ (when (equal rev ".")
+ (let* ((current-bookmarks-file ".hg/bookmarks.current"))
+ (when (file-exists-p current-bookmarks-file)
+ (ignore-errors
+ (with-temp-buffer
+ (insert-file-contents current-bookmarks-file)
+ (buffer-substring-no-properties
+ (point-min) (point-max))))))))
+
+(defun vc-hg--run-log (template rev path)
+ (ignore-errors
+ (with-output-to-string
+ (if path
+ (vc-hg-command
+ standard-output 0 nil
+ "log" "-f" "-l1" "--template" template path)
+ (vc-hg-command
+ standard-output 0 nil
+ "log" "-r" rev "-l1" "--template" template)))))
+
+(defun vc-hg--symbolic-revision (rev &optional path)
+ "Make a Mercurial revision human-readable.
+REV is a Mercurial revision. `default-directory' is assumed to
+be in the repository root of interest. PATH, if set, is a
+specific file to query."
+ (let ((symbolic-revision nil)
+ (styles vc-hg-symbolic-revision-styles))
+ (while (and (not symbolic-revision) styles)
+ (let ((style (pop styles)))
+ (setf symbolic-revision
+ (cond ((and (null path) (eq style 'builtin-active-bookmark))
+ (vc-hg--active-bookmark-internal rev))
+ ((stringp style)
+ (vc-hg--run-log style rev path))
+ ((functionp style)
+ (funcall style rev path))))))
+ symbolic-revision))
+
+(defun vc-hg-mode-line-string (file)
+ "Hg-specific version of `vc-mode-line-string'."
+ (let* ((backend-name "Hg")
+ (truename (file-truename file))
+ (state (vc-state truename))
+ (state-echo nil)
+ (face nil)
+ (rev (and state
+ (let ((default-directory
+ (expand-file-name (vc-hg-root truename))))
+ (vc-hg--symbolic-revision
+ "."
+ (and vc-hg-use-file-version-for-mode-line-version
+ truename)))))
+ (rev (or rev "???")))
+ (propertize
+ (cond ((or (eq state 'up-to-date)
+ (eq state 'needs-update))
+ (setq state-echo "Up to date file")
+ (setq face 'vc-up-to-date-state)
+ (concat backend-name "-" rev))
+ ((eq state 'added)
+ (setq state-echo "Locally added file")
+ (setq face 'vc-locally-added-state)
+ (concat backend-name "@" rev))
+ ((eq state 'conflict)
+ (setq state-echo "File contains conflicts after the last merge")
+ (setq face 'vc-conflict-state)
+ (concat backend-name "!" rev))
+ ((eq state 'removed)
+ (setq state-echo "File removed from the VC system")
+ (setq face 'vc-removed-state)
+ (concat backend-name "!" rev))
+ ((eq state 'missing)
+ (setq state-echo "File tracked by the VC system, but missing from the file system")
+ (setq face 'vc-missing-state)
+ (concat backend-name "?" rev))
+ (t
+ (setq state-echo "Locally modified file")
+ (setq face 'vc-edited-state)
+ (concat backend-name ":" rev)))
+ 'face face
+ 'help-echo (concat state-echo " under the " backend-name
+ " version control system"))))
+
;;; History functions
(defcustom vc-hg-log-switches nil
(defvar vc-hg-log-graph nil
"If non-nil, use `--graph' in the short log output.")
+(defvar vc-hg-log-format (concat "changeset: {rev}:{node|short}\n"
+ "{tags % 'tag: {tag}\n'}"
+ "{if(parents, 'parents: {parents}\n')}"
+ "user: {author}\n"
+ "Date: {date|date}\n"
+ "summary: {desc|tabindent}\n\n")
+ "Mercurial log template for `vc-hg-print-log' long format.")
+
(defun vc-hg-print-log (files buffer &optional shortlog start-revision limit)
"Print commit log associated with FILES into specified BUFFER.
If SHORTLOG is non-nil, use a short format based on `vc-hg-root-log-format'.
(let ((inhibit-read-only t))
(with-current-buffer
buffer
- (apply 'vc-hg-command buffer 0 files "log"
+ (apply 'vc-hg-command buffer 'async files "log"
(nconc
(when start-revision (list (format "-r%s:0" start-revision)))
(when limit (list "-l" (format "%s" limit)))
- (when shortlog `(,@(if vc-hg-log-graph '("--graph"))
- "--template"
- ,(car vc-hg-root-log-format)))
+ (if shortlog
+ `(,@(if vc-hg-log-graph '("--graph"))
+ "--template"
+ ,(car vc-hg-root-log-format))
+ `("--template" ,vc-hg-log-format))
vc-hg-log-switches)))))
(defvar log-view-message-re)
(if (eq vc-log-view-type 'short)
(cadr vc-hg-root-log-format)
"^changeset:[ \t]*\\([0-9]+\\):\\(.+\\)"))
+ (set (make-local-variable 'tab-width) 2)
;; Allow expanding short log entries
(when (eq vc-log-view-type 'short)
(setq truncate-lines t)
(autoload 'vc-switches "vc")
-(defun vc-hg-diff (files &optional oldvers newvers buffer async)
+(defun vc-hg-diff (files &optional oldvers newvers buffer _async)
"Get a difference report using hg between two revisions of FILES."
(let* ((firstfile (car files))
(working (and firstfile (vc-working-revision firstfile))))
(setq oldvers working))
(apply #'vc-hg-command
(or buffer "*vc-diff*")
- (if async 'async nil)
- files "diff"
+ nil ; bug#21969
+ files "diff"
(append
(vc-switches 'hg 'diff)
(when oldvers
(defun vc-hg-expanded-log-entry (revision)
(with-temp-buffer
- (vc-hg-command t nil nil "log" "-r" revision)
+ (vc-hg-command t nil nil "log" "-r" revision "--template" vc-hg-log-format)
(goto-char (point-min))
(unless (eobp)
;; Indent the expanded log entry.
(defun vc-hg-annotate-command (file buffer &optional revision)
"Execute \"hg annotate\" on FILE, inserting the contents in BUFFER.
Optional arg REVISION is a revision to annotate from."
- (apply #'vc-hg-command buffer 0 file "annotate" "-d" "-n" "--follow"
+ (apply #'vc-hg-command buffer 0 file "annotate" "-dq" "-n"
(append (vc-switches 'hg 'annotate)
(if revision (list (concat "-r" revision))))))
(declare-function vc-annotate-convert-time "vc-annotate" (&optional time))
-;; The format for one line output by "hg annotate -d -n" looks like this:
-;;215 Wed Jun 20 21:22:58 2007 -0700: CONTENTS
-;; i.e: VERSION_NUMBER DATE: CONTENTS
-;; If the user has set the "--follow" option, the output looks like:
-;;215 Wed Jun 20 21:22:58 2007 -0700 foo.c: CONTENTS
-;; i.e. VERSION_NUMBER DATE FILENAME: CONTENTS
+;; One line printed by "hg annotate -dq -n -u --follow" looks like this:
+;; b56girard 114590 2012-03-13 CLOBBER: Lorem ipsum dolor sit
+;; i.e. AUTHOR REVISION DATE FILENAME: CONTENTS
+;; The user can omit options "-u" and/or "--follow". Then it'll look like:
+;; 114590 2012-03-13 CLOBBER:
+;; or
+;; b56girard 114590 2012-03-13:
(defconst vc-hg-annotate-re
- "^[ \t]*\\([0-9]+\\) \\(.\\{30\\}\\)\\(?:\\(: \\)\\|\\(?: +\\([^:\n]+\\(?::\\(?:[^: \n][^:\n]*\\)?\\)*\\): \\)\\)")
+ (concat
+ "^\\(?: *[^ ]+ +\\)?\\([0-9]+\\) " ;User and revision.
+ "\\([0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]\\)" ;Date.
+ "\\(?: +\\([^:]+\\)\\)?:")) ;Filename.
(defun vc-hg-annotate-time ()
(when (looking-at vc-hg-annotate-re)
(goto-char (match-end 0))
(vc-annotate-convert-time
- (date-to-time (match-string-no-properties 2)))))
+ (let ((str (match-string-no-properties 2)))
+ (encode-time 0 0 0
+ (string-to-number (substring str 6 8))
+ (string-to-number (substring str 4 6))
+ (string-to-number (substring str 0 4)))))))
(defun vc-hg-annotate-extract-revision-at-line ()
(save-excursion
(beginning-of-line)
(when (looking-at vc-hg-annotate-re)
(if (match-beginning 3)
- (match-string-no-properties 1)
- (cons (match-string-no-properties 1)
- (expand-file-name (match-string-no-properties 4)
- (vc-hg-root default-directory)))))))
+ (cons (match-string-no-properties 1)
+ (expand-file-name (match-string-no-properties 3)
+ (vc-hg-root default-directory)))
+ (match-string-no-properties 1)))))
;;; Tag system
;; TODO: update *vc-change-log* buffer so can see @ if --graph
))
+;;; Native data structure reading
+
+(defcustom vc-hg-parse-hg-data-structures t
+ "If true, try directly parsing Mercurial data structures
+directly instead of always running Mercurial. We try to be safe
+against Mercurial data structure format changes and always fall
+back to running Mercurial directly."
+ :type 'boolean
+ :version "25.2"
+ :group 'vc-hg)
+
+(defsubst vc-hg--read-u8 ()
+ "Read and advance over an unsigned byte.
+Return a fixnum."
+ (prog1 (char-after)
+ (forward-char)))
+
+(defsubst vc-hg--read-u32-be ()
+ "Read and advance over a big-endian unsigned 32-bit integer.
+Return a fixnum; on overflow, result is undefined."
+ ;; Because elisp bytecode has an instruction for multiply and
+ ;; doesn't have one for lsh, it's somewhat counter-intuitively
+ ;; faster to multiply than to shift.
+ (+ (* (vc-hg--read-u8) (* 256 256 256))
+ (* (vc-hg--read-u8) (* 256 256))
+ (* (vc-hg--read-u8) 256)
+ (identity (vc-hg--read-u8))))
+
+(defun vc-hg--raw-dirstate-search (dirstate fname)
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally dirstate)
+ (let* ((result nil)
+ (flen (length fname))
+ (case-fold-search nil)
+ (inhibit-changing-match-data t)
+ ;; Find a conservative bound for the loop below by using
+ ;; Boyer-Moore on the raw dirstate without parsing it; we
+ ;; know we can't possibly find fname _after_ the last place
+ ;; it appears, so we can bail out early if we try to parse
+ ;; past it, which especially helps when the file we're
+ ;; trying to find isn't in dirstate at all. There's no way
+ ;; to similarly bound the starting search position, since
+ ;; the file format is such that we need to parse it from
+ ;; the beginning to find record boundaries.
+ (search-limit
+ (progn
+ (goto-char (point-max))
+ (or (search-backward fname (+ (point-min) 40) t)
+ (point-min)))))
+ ;; 40 is just after the header, which contains the working
+ ;; directory parents
+ (goto-char (+ (point-min) 40))
+ ;; Iterate over all dirstate entries; we might run this loop
+ ;; hundreds of thousands of times, so performance is important
+ ;; here
+ (while (< (point) search-limit)
+ ;; 1+4*4 is the length of the dirstate item header, which we
+ ;; spell as a literal for performance, since the elisp
+ ;; compiler lacks constant propagation
+ (forward-char (1+ (* 3 4)))
+ (let ((this-flen (vc-hg--read-u32-be)))
+ (if (and (or (eq this-flen flen)
+ (and (> this-flen flen)
+ (eq (char-after (+ (point) flen)) 0)))
+ (search-forward fname (+ (point) flen) t))
+ (progn
+ (backward-char (+ flen (1+ (* 4 4))))
+ (setf result
+ (list (vc-hg--read-u8) ; status
+ (vc-hg--read-u32-be) ; mode
+ (vc-hg--read-u32-be) ; size (of file)
+ (vc-hg--read-u32-be) ; mtime
+ ))
+ (goto-char (point-max)))
+ (forward-char this-flen))))
+ result)))
+
+(define-error 'vc-hg-unsupported-syntax "unsupported hgignore syntax")
+
+(defconst vc-hg--pcre-c-escapes
+ '((?a . ?\a)
+ (?b . ?\b)
+ (?f . ?\f)
+ (?n . ?\n)
+ (?r . ?\r)
+ (?t . ?\t)
+ (?n . ?\n)
+ (?r . ?\r)
+ (?t . ?\t)
+ (?v . ?\v)))
+
+(defconst vc-hg--pcre-metacharacters
+ '(?. ?^ ?$ ?* ?+ ?? ?{ ?\\ ?\[ ?\| ?\())
+
+(defconst vc-hg--elisp-metacharacters
+ '(?. ?* ?+ ?? ?\[ ?$ ?\\))
+
+(defun vc-hg--escape-for-pcre (c)
+ (if (memq c vc-hg--pcre-metacharacters)
+ (string ?\\ c)
+ c))
+
+(defun vc-hg--parts-to-string (parts)
+ "Build a string from list PARTS. Each element is a character or string."
+ (let ((parts2 nil))
+ (while parts
+ (let* ((partcell (prog1 parts (setf parts (cdr parts))))
+ (part (car partcell)))
+ (if (stringp part)
+ (setf parts2 (nconc (append part nil) parts2))
+ (setcdr partcell parts2)
+ (setf parts2 partcell))))
+ (apply #'string parts2)))
+
+(defun vc-hg--pcre-to-elisp-re (pcre prefix)
+ "Transform PCRE, a Mercurial file PCRE, into an elisp RE against PREFIX.
+PREFIX is the directory name of the directory against which these
+patterns are rooted. We understand only a subset of PCRE syntax;
+if we don't understand a construct, we signal
+`vc-hg-unsupported-syntax'."
+ (cl-assert (string-match "^/\\(.*/\\)?$" prefix))
+ (let ((parts nil)
+ (i 0)
+ (anchored nil)
+ (state 'normal)
+ (pcrelen (length pcre)))
+ (while (< i pcrelen)
+ (let ((c (aref pcre i)))
+ (cond ((eq state 'normal)
+ (cond ((string-match
+ (rx (| "}\\?" (: "(?" (not (any ":")))))
+ pcre i)
+ (signal 'vc-hg-unsupported-syntax (list pcre)))
+ ((eq c ?\\)
+ (setf state 'backslash))
+ ((eq c ?\[)
+ (setf state 'charclass-enter)
+ (push c parts))
+ ((eq c ?^)
+ (if (eq i 0) (setf anchored t)
+ (signal 'vc-hg-unsupported-syntax (list pcre))))
+ ((eq c ?$)
+ ;; Patterns can also match directories exactly,
+ ;; ignoring everything under a matched directory
+ (push "\\(?:$\\|/\\)" parts))
+ ((memq c '(?| ?\( ?\)))
+ (push ?\\ parts)
+ (push c parts))
+ (t (push c parts))))
+ ((eq state 'backslash)
+ (cond ((memq c '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
+ ?A ?b ?B ?d ?D ?s ?S ?w ?W ?Z ?x))
+ (signal 'vc-hg-unsupported-syntax (list pcre)))
+ ((memq c vc-hg--elisp-metacharacters)
+ (push ?\\ parts)
+ (push c parts))
+ (t (push (or (cdr (assq c vc-hg--pcre-c-escapes)) c) parts)))
+ (setf state 'normal))
+ ((eq state 'charclass-enter)
+ (push c parts)
+ (setf state
+ (if (eq c ?\\)
+ 'charclass
+ 'charclass-backslash)))
+ ((eq state 'charclass-backslash)
+ (if (memq c '(?0 ?x))
+ (signal 'vc-hg-unsupported-syntax (list pcre)))
+ (push (or (cdr (assq c vc-hg--pcre-c-escapes)) c) parts)
+ (setf state 'charclass))
+ ((eq state 'charclass)
+ (push c parts)
+ (cond ((eq c ?\\) (setf state 'charclass-backslash))
+ ((eq c ?\]) (setf state 'normal))))
+ (t (error "invalid state")))
+ (setf i (1+ i))))
+ (unless (eq state 'normal)
+ (signal 'vc-hg-unsupported-syntax (list pcre)))
+ (concat
+ "^"
+ prefix
+ (if anchored "" "\\(?:.*/\\)?")
+ (vc-hg--parts-to-string parts))))
+
+(defun vc-hg--glob-to-pcre (glob)
+ "Transform a glob pattern into a Mercurial file pattern regex."
+ (let ((parts nil) (i 0) (n (length glob)) (group 0) c)
+ (cl-macrolet ((peek () '(and (< i n) (aref glob i))))
+ (while (< i n)
+ (setf c (aref glob i))
+ (cl-incf i)
+ (cond ((not (memq c '(?* ?? ?\[ ?\{ ?\} ?, ?\\)))
+ (push (vc-hg--escape-for-pcre c) parts))
+ ((eq c ?*)
+ (cond ((eq (peek) ?*)
+ (cl-incf i)
+ (cond ((eq (peek) ?/)
+ (cl-incf i)
+ (push "(?:.*/)?" parts))
+ (t
+ (push ".*" parts))))
+ (t (push "[^/]*" parts))))
+ ((eq c ??)
+ (push ?. parts))
+ ((eq c ?\[)
+ (let ((j i))
+ (when (and (< j n) (memq (aref glob j) '(?! ?\])))
+ (cl-incf j))
+ (while (and (< j n) (not (eq (aref glob j) ?\])))
+ (cl-incf j))
+ (cond ((>= j n)
+ (push "\\[" parts))
+ (t
+ (let ((x (substring glob i j)))
+ (setf x (replace-regexp-in-string
+ "\\\\" "\\\\" x t t))
+ (setf i (1+ j))
+ (cond ((eq (aref x 0) ?!)
+ (setf (aref x 0) ?^))
+ ((eq (aref x 0) ?^)
+ (setf x (concat "\\" x))))
+ (push ?\[ parts)
+ (push x parts)
+ (push ?\] parts))))))
+ ((eq c ?\{)
+ (cl-incf group)
+ (push "(?:" parts))
+ ((eq c ?\})
+ (push ?\) parts)
+ (cl-decf group))
+ ((and (eq c ?,) (> group 0))
+ (push ?| parts))
+ ((eq c ?\\)
+ (if (eq i n)
+ (push "\\\\" parts)
+ (cl-incf i)
+ (push ?\\ parts)
+ (push c parts)))
+ (t
+ (push (vc-hg--escape-for-pcre c) parts)))))
+ (concat (vc-hg--parts-to-string parts) "$")))
+
+(defvar vc-hg--hgignore-patterns)
+(defvar vc-hg--hgignore-filenames)
+
+(defun vc-hg--hgignore-add-pcre (pcre prefix)
+ (push (vc-hg--pcre-to-elisp-re pcre prefix) vc-hg--hgignore-patterns))
+
+(defun vc-hg--hgignore-add-glob (glob prefix)
+ (push (vc-hg--pcre-to-elisp-re (vc-hg--glob-to-pcre glob) prefix)
+ vc-hg--hgignore-patterns))
+
+(defun vc-hg--hgignore-add-path (path prefix)
+ (let ((parts nil))
+ (dotimes (i (length path))
+ (push (vc-hg--escape-for-pcre (aref path i)) parts))
+ (vc-hg--hgignore-add-pcre
+ (concat "^" (vc-hg--parts-to-string parts) "$")
+ prefix)))
+
+(defun vc-hg--slurp-hgignore-1 (hgignore prefix)
+ (let ((default-syntax 'vc-hg--hgignore-add-glob))
+ (with-temp-buffer
+ (let ((attr (file-attributes hgignore)))
+ (when attr (insert-file-contents hgignore))
+ (push (list hgignore (nth 5 attr) (nth 7 attr))
+ vc-hg--hgignore-filenames))
+ (while (not (eobp))
+ ;; This list of pattern-file commands isn't complete, but it
+ ;; should cover the common cases. Remember that we fall back
+ ;; to regular hg commands if we see something we don't like.
+ (save-restriction
+ (narrow-to-region (point) (point-at-eol))
+ (cond ((looking-at "[ \t]*\\(?:#.*\\)?$"))
+ ((looking-at "syntax:[ \t]*re[ \t]*$")
+ (setf default-syntax 'vc-hg--hgignore-add-pcre))
+ ((looking-at "syntax:[ \t]*glob[ \t]*$")
+ (setf default-syntax 'vc-hg--hgignore-add-glob))
+ ((looking-at "path:\\(.+?\\)[ \t]*$")
+ (vc-hg--hgignore-add-path (match-string 1) prefix))
+ ((looking-at "glob:\\(.+?\\)[ \t]*$")
+ (vc-hg--hgignore-add-glob (match-string 1) prefix))
+ ((looking-at "re:\\(.+?\\)[ \t]*$")
+ (vc-hg--hgignore-add-pcre (match-string 1) prefix))
+ ((looking-at "\\(sub\\)?include:\\(.+?\\)[ \t]*$")
+ (let* ((sub (equal (match-string 1) "sub"))
+ (arg (match-string 2))
+ (included-file
+ (if (string-match "^/" arg) arg
+ (concat (file-name-directory hgignore) arg))))
+ (vc-hg--slurp-hgignore-1
+ included-file
+ (if sub (file-name-directory included-file) prefix))))
+ ((looking-at "[a-zA-Z0-9_]*:")
+ (signal 'vc-hg-unsupported-syntax (list (match-string 0))))
+ ((looking-at ".*$")
+ (funcall default-syntax (match-string 0) prefix))))
+ (forward-line 1)))))
+
+(cl-defstruct (vc-hg--ignore-patterns
+ (:copier nil)
+ (:constructor vc-hg--ignore-patterns-make))
+ repo
+ ignore-patterns
+ file-sources)
+
+(defun vc-hg--slurp-hgignore (repo)
+ "Read hg ignore patterns from REPO.
+REPO must be the directory name of an hg repository."
+ (cl-assert (string-match "^/\\(.*/\\)?$" repo))
+ (let* ((hgignore (concat repo ".hgignore"))
+ (vc-hg--hgignore-patterns nil)
+ (vc-hg--hgignore-filenames nil))
+ (vc-hg--slurp-hgignore-1 hgignore repo)
+ (vc-hg--ignore-patterns-make
+ :repo repo
+ :ignore-patterns (nreverse vc-hg--hgignore-patterns)
+ :file-sources (nreverse vc-hg--hgignore-filenames))))
+
+(defun vc-hg--ignore-patterns-valid-p (hgip)
+ "Return whether the cached ignore patterns in HGIP are still valid"
+ (let ((valid t)
+ (file-sources (vc-hg--ignore-patterns-file-sources hgip)))
+ (while (and file-sources valid)
+ (let* ((fs (pop file-sources))
+ (saved-mtime (nth 1 fs))
+ (saved-size (nth 2 fs))
+ (attr (file-attributes (nth 0 fs)))
+ (current-mtime (nth 5 attr))
+ (current-size (nth 7 attr)))
+ (unless (and (equal saved-mtime current-mtime)
+ (equal saved-size current-size))
+ (setf valid nil))))
+ valid))
+
+(defun vc-hg--ignore-patterns-ignored-p (hgip filename)
+ "Test whether the ignore pattern set HGIP says to ignore FILENAME.
+FILENAME must be the file's true absolute name."
+ (let ((patterns (vc-hg--ignore-patterns-ignore-patterns hgip))
+ (inhibit-changing-match-data t)
+ (ignored nil))
+ (while (and patterns (not ignored))
+ (setf ignored (string-match (pop patterns) filename)))
+ ignored))
+
+(defun vc-hg--time-to-fixnum (ts)
+ (+ (* 65536 (car ts)) (cadr ts)))
+
+(defvar vc-hg--cached-ignore-patterns nil
+ "Cached pre-parsed hg ignore patterns.")
+
+(defun vc-hg--file-ignored-p (repo repo-relative-filename)
+ (let ((hgip vc-hg--cached-ignore-patterns))
+ (unless (and hgip
+ (equal repo (vc-hg--ignore-patterns-repo hgip))
+ (vc-hg--ignore-patterns-valid-p hgip))
+ (setf vc-hg--cached-ignore-patterns nil)
+ (setf hgip (vc-hg--slurp-hgignore repo))
+ (setf vc-hg--cached-ignore-patterns hgip))
+ (vc-hg--ignore-patterns-ignored-p
+ hgip
+ (concat repo repo-relative-filename))))
+
+(defun vc-hg--read-repo-requirements (repo)
+ (cl-assert (string-match "^/\\(.*/\\)?$" repo))
+ (let* ((requires-filename (concat repo ".hg/requires")))
+ (and (file-exists-p requires-filename)
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (insert-file-contents-literally requires-filename)
+ (split-string (buffer-substring-no-properties
+ (point-min) (point-max)))))))
+
+(defconst vc-hg-supported-requirements
+ '("dotencode"
+ "fncache"
+ "generaldelta"
+ "lz4revlog"
+ "remotefilelog"
+ "revlogv1"
+ "store")
+ "List of Mercurial repository requirements we understand; if a
+repository requires features not present in this list, we avoid
+attempting to parse Mercurial data structures.")
+
+(defun vc-hg--requirements-understood-p (repo)
+ "Check that we understand the format of the given repository.
+REPO is the directory name of a Mercurial repository."
+ (null (cl-set-difference (vc-hg--read-repo-requirements repo)
+ vc-hg-supported-requirements
+ :test #'equal)))
+
+(defvar vc-hg--dirstate-scan-cache nil
+ "Cache of the last result of `vc-hg--raw-dirstate-search'.
+Avoids the need to repeatedly scan dirstate on repeated calls to
+`vc-hg-state', as we see during registration queries.")
+
+(defun vc-hg--cached-dirstate-search (dirstate dirstate-attr ascii-fname)
+ (let* ((mtime (nth 5 dirstate-attr))
+ (size (nth 7 dirstate-attr))
+ (cache vc-hg--dirstate-scan-cache)
+ )
+ (if (and cache
+ (equal dirstate (pop cache))
+ (equal mtime (pop cache))
+ (equal size (pop cache))
+ (equal ascii-fname (pop cache)))
+ (pop cache)
+ (let ((result (vc-hg--raw-dirstate-search dirstate ascii-fname)))
+ (setf vc-hg--dirstate-scan-cache
+ (list dirstate mtime size ascii-fname result))
+ result))))
+
+(defun vc-hg-state-fast (filename)
+ "Like `vc-hg-state', but parse internal data structures directly.
+Returns one of the usual `vc-state' enumeration values or
+`unsupported' if we need to take the slow path and run the
+hg binary."
+ (let* (truename
+ repo
+ dirstate
+ dirstate-attr
+ repo-relative-filename
+ ascii-fname)
+ (if (or
+ ;; Explicit user disable
+ (not vc-hg-parse-hg-data-structures)
+ ;; It'll probably be faster to run hg remotely
+ (file-remote-p filename)
+ (progn
+ (setf truename (file-truename filename))
+ (file-remote-p truename))
+ (not (setf repo (vc-hg-root truename)))
+ ;; dirstate must exist
+ (not (progn
+ (setf repo (expand-file-name repo))
+ (cl-assert (string-match "^/\\(.*/\\)?$" repo))
+ (setf dirstate (concat repo ".hg/dirstate"))
+ (setf dirstate-attr (file-attributes dirstate))))
+ ;; Repository must be in an understood format
+ (not (vc-hg--requirements-understood-p repo))
+ ;; Dirstate too small to be valid
+ (< (nth 7 dirstate-attr) 40)
+ ;; We want to store 32-bit unsigned values in fixnums
+ (< most-positive-fixnum 4294967295)
+ (progn
+ (setf repo-relative-filename
+ (file-relative-name truename repo))
+ (setf ascii-fname
+ (string-as-unibyte
+ (let (last-coding-system-used)
+ (encode-coding-string
+ repo-relative-filename
+ 'us-ascii t))))
+ ;; We only try dealing with ASCII filenames
+ (not (equal ascii-fname repo-relative-filename))))
+ 'unsupported
+ (let* ((dirstate-entry
+ (vc-hg--cached-dirstate-search
+ dirstate dirstate-attr ascii-fname))
+ (state (car dirstate-entry))
+ (stat (file-attributes
+ (concat repo repo-relative-filename))))
+ (cond ((eq state ?r) 'removed)
+ ((and (not state) stat)
+ (condition-case nil
+ (if (vc-hg--file-ignored-p repo repo-relative-filename)
+ 'ignored
+ 'unregistered)
+ (vc-hg-unsupported-syntax 'unsupported)))
+ ((and state (not stat)) 'missing)
+ ((eq state ?n)
+ (let ((vc-hg-size (nth 2 dirstate-entry))
+ (vc-hg-mtime (nth 3 dirstate-entry))
+ (fs-size (nth 7 stat))
+ (fs-mtime (vc-hg--time-to-fixnum (nth 5 stat))))
+ (if (and (eql vc-hg-size fs-size) (eql vc-hg-mtime fs-mtime))
+ 'up-to-date
+ 'edited)))
+ ((eq state ?a) 'added)
+ (state 'unsupported))))))
+
;;; Miscellaneous
(defun vc-hg-previous-revision (_file rev)
- (let ((newrev (1- (string-to-number rev))))
- (when (>= newrev 0)
- (number-to-string newrev))))
+ ;; We can't simply decrement by 1, because that revision might be
+ ;; e.g. on a different branch (bug#22032).
+ (with-temp-buffer
+ (and (eq 0
+ (vc-hg-command t nil nil "id" "-n" "-r" (concat rev "^")))
+ ;; Trim the trailing newline.
+ (buffer-substring (point-min) (1- (point-max))))))
(defun vc-hg-next-revision (_file rev)
(let ((newrev (1+ (string-to-number rev)))
(declare-function log-edit-extract-headers "log-edit" (headers string))
-(defun vc-hg-checkin (files comment)
+(defun vc-hg-checkin (files comment &optional _rev)
"Hg-specific version of `vc-backend-checkin'.
REV is ignored."
(apply 'vc-hg-command nil 0 files
(vc-file-setprop buffer-file-name 'vc-state 'conflict)
(smerge-start-session)
(add-hook 'after-save-hook 'vc-hg-resolve-when-done nil t)
- (message "There are unresolved conflicts in this file")))
+ (vc-message-unresolved-conflicts buffer-file-name)))
;; Modeled after the similar function in vc-bzr.el
;; Follows vc-exec-after.
(declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
-(defun vc-hg-dir-status-files (dir files update-function)
- (apply 'vc-hg-command (current-buffer) 'async dir "status"
- (concat "-mardu" (if files "i"))
- "-C" files)
+(defun vc-hg-dir-status-files (_dir files update-function)
+ ;; XXX: We can't pass DIR directly to 'hg status' because that
+ ;; returns all ignored files if FILES is non-nil (bug#22481).
+ ;; If honoring DIR ever becomes important, try using '-I DIR/'.
+ (vc-hg-command (current-buffer) 'async files
+ "status"
+ (concat "-mardu" (if files "i"))
+ "-C")
(vc-run-delayed
(vc-hg-after-dir-status update-function)))