code.delx.au - gnu-emacs/blob - lisp/vc/vc-git.el

   1 ;;; vc-git.el --- VC backend for the git version control system -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2006-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Alexandre Julliard <julliard@winehq.org>
   6 ;; Keywords: vc tools
   7 ;; Package: vc
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This file contains a VC backend for the git version control
  27 ;; system.
  28 ;;
  29
  30 ;;; Installation:
  31
  32 ;; To install: put this file on the load-path and add Git to the list
  33 ;; of supported backends in `vc-handled-backends'; the following line,
  34 ;; placed in your init file, will accomplish this:
  35 ;;
  36 ;;     (add-to-list 'vc-handled-backends 'Git)
  37
  38 ;;; Todo:
  39 ;;  - check if more functions could use vc-git-command instead
  40 ;;     of start-process.
  41 ;;  - changelog generation
  42
  43 ;; Implement the rest of the vc interface. See the comment at the
  44 ;; beginning of vc.el. The current status is:
  45 ;; ("??" means: "figure out what to do about it")
  46 ;;
  47 ;; FUNCTION NAME                                   STATUS
  48 ;; BACKEND PROPERTIES
  49 ;; * revision-granularity                          OK
  50 ;; STATE-QUERYING FUNCTIONS
  51 ;; * registered (file)                             OK
  52 ;; * state (file)                                  OK
  53 ;; - state-heuristic (file)                        NOT NEEDED
  54 ;; * working-revision (file)                       OK
  55 ;; - latest-on-branch-p (file)                     NOT NEEDED
  56 ;; * checkout-model (files)                        OK
  57 ;; - workfile-unchanged-p (file)                   OK
  58 ;; - mode-line-string (file)                       OK
  59 ;; STATE-CHANGING FUNCTIONS
  60 ;; * create-repo ()                                OK
  61 ;; * register (files &optional rev comment)        OK
  62 ;; - init-revision (file)                          NOT NEEDED
  63 ;; - responsible-p (file)                          OK
  64 ;; - could-register (file)                         NOT NEEDED, DEFAULT IS GOOD
  65 ;; - receive-file (file rev)                       NOT NEEDED
  66 ;; - unregister (file)                             OK
  67 ;; * checkin (files rev comment)                   OK
  68 ;; * find-revision (file rev buffer)               OK
  69 ;; * checkout (file &optional editable rev)        OK
  70 ;; * revert (file &optional contents-done)         OK
  71 ;; - rollback (files)                              COULD BE SUPPORTED
  72 ;; - merge (file rev1 rev2)                   It would be possible to merge
  73 ;;                                          changes into a single file, but
  74 ;;                                          when committing they wouldn't
  75 ;;                                          be identified as a merge
  76 ;;                                          by git, so it's probably
  77 ;;                                          not a good idea.
  78 ;; - merge-news (file)                     see `merge'
  79 ;; - steal-lock (file &optional revision)          NOT NEEDED
  80 ;; HISTORY FUNCTIONS
  81 ;; * print-log (files buffer &optional shortlog start-revision limit)   OK
  82 ;; - log-view-mode ()                              OK
  83 ;; - show-log-entry (revision)                     OK
  84 ;; - comment-history (file)                        ??
  85 ;; - update-changelog (files)                      COULD BE SUPPORTED
  86 ;; * diff (file &optional rev1 rev2 buffer)        OK
  87 ;; - revision-completion-table (files)             OK
  88 ;; - annotate-command (file buf &optional rev)     OK
  89 ;; - annotate-time ()                              OK
  90 ;; - annotate-current-time ()                      NOT NEEDED
  91 ;; - annotate-extract-revision-at-line ()          OK
  92 ;; TAG SYSTEM
  93 ;; - create-tag (dir name branchp)                 OK
  94 ;; - retrieve-tag (dir name update)                OK
  95 ;; MISCELLANEOUS
  96 ;; - make-version-backups-p (file)                 NOT NEEDED
  97 ;; - repository-hostname (dirname)                 NOT NEEDED
  98 ;; - previous-revision (file rev)                  OK
  99 ;; - next-revision (file rev)                      OK
 100 ;; - check-headers ()                              COULD BE SUPPORTED
 101 ;; - clear-headers ()                              NOT NEEDED
 102 ;; - delete-file (file)                            OK
 103 ;; - rename-file (old new)                         OK
 104 ;; - find-file-hook ()                             NOT NEEDED
 105
 106 (eval-when-compile
 107   (require 'cl-lib)
 108   (require 'vc)
 109   (require 'vc-dir)
 110   (require 'grep))
 111
 112 (defgroup vc-git nil
 113   "VC Git backend."
 114   :version "24.1"
 115   :group 'vc)
 116
 117 (defcustom vc-git-diff-switches t
 118   "String or list of strings specifying switches for Git diff under VC.
 119 If nil, use the value of `vc-diff-switches'.  If t, use no switches."
 120   :type '(choice (const :tag "Unspecified" nil)
 121                  (const :tag "None" t)
 122                  (string :tag "Argument String")
 123                  (repeat :tag "Argument List" :value ("") string))
 124   :version "23.1"
 125   :group 'vc-git)
 126
 127 (defcustom vc-git-program "git"
 128   "Name of the Git executable (excluding any arguments)."
 129   :version "24.1"
 130   :type 'string
 131   :group 'vc-git)
 132
 133 (defcustom vc-git-root-log-format
 134   '("%d%h..: %an %ad %s"
 135     ;; The first shy group matches the characters drawn by --graph.
 136     ;; We use numbered groups because `log-view-message-re' wants the
 137     ;; revision number to be group 1.
 138     "^\\(?:[*/\\| ]+ \\)?\\(?2: ([^)]+)\\)?\\(?1:[0-9a-z]+\\)..: \
 139 \\(?3:.*?\\)[ \t]+\\(?4:[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\)"
 140     ((1 'log-view-message-face)
 141      (2 'change-log-list nil lax)
 142      (3 'change-log-name)
 143      (4 'change-log-date)))
 144   "Git log format for `vc-print-root-log'.
 145 This should be a list (FORMAT REGEXP KEYWORDS), where FORMAT is a
 146 format string (which is passed to \"git log\" via the argument
 147 \"--pretty=tformat:FORMAT\"), REGEXP is a regular expression
 148 matching the resulting Git log output, and KEYWORDS is a list of
 149 `font-lock-keywords' for highlighting the Log View buffer."
 150   :type '(list string string (repeat sexp))
 151   :group 'vc-git
 152   :version "24.1")
 153
 154 (defvar vc-git-commits-coding-system 'utf-8
 155   "Default coding system for git commits.")
 156
 157 ;; History of Git commands.
 158 (defvar vc-git-history nil)
 159
 160 ;;; BACKEND PROPERTIES
 161
 162 (defun vc-git-revision-granularity () 'repository)
 163 (defun vc-git-checkout-model (_files) 'implicit)
 164
 165 ;;; STATE-QUERYING FUNCTIONS
 166
 167 ;;;###autoload (defun vc-git-registered (file)
 168 ;;;###autoload   "Return non-nil if FILE is registered with git."
 169 ;;;###autoload   (if (vc-find-root file ".git")       ; Short cut.
 170 ;;;###autoload       (progn
 171 ;;;###autoload         (load "vc-git")
 172 ;;;###autoload         (vc-git-registered file))))
 173
 174 (defun vc-git-registered (file)
 175   "Check whether FILE is registered with git."
 176   (let ((dir (vc-git-root file)))
 177     (when dir
 178       (with-temp-buffer
 179         (let* (process-file-side-effects
 180                ;; Do not use the `file-name-directory' here: git-ls-files
 181                ;; sometimes fails to return the correct status for relative
 182                ;; path specs.
 183                ;; See also: http://marc.info/?l=git&m=125787684318129&w=2
 184                (name (file-relative-name file dir))
 185                (str (ignore-errors
 186                       (cd dir)
 187                       (vc-git--out-ok "ls-files" "-c" "-z" "--" name)
 188                       ;; If result is empty, use ls-tree to check for deleted
 189                       ;; file.
 190                       (when (eq (point-min) (point-max))
 191                         (vc-git--out-ok "ls-tree" "--name-only" "-z" "HEAD"
 192                                         "--" name))
 193                       (buffer-string))))
 194           (and str
 195                (> (length str) (length name))
 196                (string= (substring str 0 (1+ (length name)))
 197                         (concat name "\0"))))))))
 198
 199 (defun vc-git--state-code (code)
 200   "Convert from a string to a added/deleted/modified state."
 201   (pcase (string-to-char code)
 202     (?M 'edited)
 203     (?A 'added)
 204     (?D 'removed)
 205     (?U 'edited)     ;; FIXME
 206     (?T 'edited)))   ;; FIXME
 207
 208 (defun vc-git-state (file)
 209   "Git-specific version of `vc-state'."
 210   ;; FIXME: This can't set 'ignored or 'conflict yet
 211   ;; The 'ignored state could be detected with `git ls-files -i -o
 212   ;; --exclude-standard` It also can't set 'needs-update or
 213   ;; 'needs-merge. The rough equivalent would be that upstream branch
 214   ;; for current branch is in fast-forward state i.e. current branch
 215   ;; is direct ancestor of corresponding upstream branch, and the file
 216   ;; was modified upstream.  But we can't check that without a network
 217   ;; operation.
 218   ;; This assumes that status is known to be not `unregistered' because
 219   ;; we've been successfully dispatched here from `vc-state', that
 220   ;; means `vc-git-registered' returned t earlier once.  Bug#11757
 221   (let ((diff (vc-git--run-command-string
 222                file "diff-index" "-p" "--raw" "-z" "HEAD" "--")))
 223     (if (and diff
 224              (string-match ":[0-7]\\{6\\} [0-7]\\{6\\} [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\([ADMUT]\\)\0[^\0]+\0\\(.*\n.\\)?"
 225                            diff))
 226         (let ((diff-letter (match-string 1 diff)))
 227           (if (not (match-beginning 2))
 228               ;; Empty diff: file contents is the same as the HEAD
 229               ;; revision, but timestamps are different (eg, file
 230               ;; was "touch"ed).  Update timestamp in index:
 231               (prog1 'up-to-date
 232                 (vc-git--call nil "add" "--refresh" "--"
 233                               (file-relative-name file)))
 234             (vc-git--state-code diff-letter)))
 235       (if (vc-git--empty-db-p) 'added 'up-to-date))))
 236
 237 (defun vc-git-working-revision (_file)
 238   "Git-specific version of `vc-working-revision'."
 239   (let* (process-file-side-effects
 240          (str (with-output-to-string
 241                 (with-current-buffer standard-output
 242                   (vc-git--out-ok "symbolic-ref" "HEAD")))))
 243     (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
 244         (match-string 2 str)
 245       str)))
 246
 247 (defun vc-git-workfile-unchanged-p (file)
 248   (eq 'up-to-date (vc-git-state file)))
 249
 250 (defun vc-git-mode-line-string (file)
 251   "Return a string for `vc-mode-line' to put in the mode line for FILE."
 252   (let* ((branch (vc-working-revision file))
 253          (def-ml (vc-default-mode-line-string 'Git file))
 254          (help-echo (get-text-property 0 'help-echo def-ml)))
 255     (if (zerop (length branch))
 256         (propertize
 257          (concat def-ml "!")
 258          'help-echo (concat help-echo "\nNo current branch (detached HEAD)"))
 259       (propertize def-ml
 260                   'help-echo (concat help-echo "\nCurrent branch: " branch)))))
 261
 262 (cl-defstruct (vc-git-extra-fileinfo
 263             (:copier nil)
 264             (:constructor vc-git-create-extra-fileinfo
 265                           (old-perm new-perm &optional rename-state orig-name))
 266             (:conc-name vc-git-extra-fileinfo->))
 267   old-perm new-perm   ;; Permission flags.
 268   rename-state        ;; Rename or copy state.
 269   orig-name)          ;; Original name for renames or copies.
 270
 271 (defun vc-git-escape-file-name (name)
 272   "Escape a file name if necessary."
 273   (if (string-match "[\n\t\"\\]" name)
 274       (concat "\""
 275               (mapconcat (lambda (c)
 276                    (pcase c
 277                      (?\n "\\n")
 278                      (?\t "\\t")
 279                      (?\\ "\\\\")
 280                      (?\" "\\\"")
 281                      (_ (char-to-string c))))
 282                  name "")
 283               "\"")
 284     name))
 285
 286 (defun vc-git-file-type-as-string (old-perm new-perm)
 287   "Return a string describing the file type based on its permissions."
 288   (let* ((old-type (lsh (or old-perm 0) -9))
 289          (new-type (lsh (or new-perm 0) -9))
 290          (str (pcase new-type
 291                 (?\100  ;; File.
 292                  (pcase old-type
 293                    (?\100 nil)
 294                    (?\120 "   (type change symlink -> file)")
 295                    (?\160 "   (type change subproject -> file)")))
 296                  (?\120  ;; Symlink.
 297                   (pcase old-type
 298                     (?\100 "   (type change file -> symlink)")
 299                     (?\160 "   (type change subproject -> symlink)")
 300                     (t "   (symlink)")))
 301                   (?\160  ;; Subproject.
 302                    (pcase old-type
 303                      (?\100 "   (type change file -> subproject)")
 304                      (?\120 "   (type change symlink -> subproject)")
 305                      (t "   (subproject)")))
 306                   (?\110 nil)  ;; Directory (internal, not a real git state).
 307                   (?\000  ;; Deleted or unknown.
 308                    (pcase old-type
 309                      (?\120 "   (symlink)")
 310                      (?\160 "   (subproject)")))
 311                   (_ (format "   (unknown type %o)" new-type)))))
 312     (cond (str (propertize str 'face 'font-lock-comment-face))
 313           ((eq new-type ?\110) "/")
 314           (t ""))))
 315
 316 (defun vc-git-rename-as-string (state extra)
 317   "Return a string describing the copy or rename associated with INFO,
 318 or an empty string if none."
 319   (let ((rename-state (when extra
 320                         (vc-git-extra-fileinfo->rename-state extra))))
 321     (if rename-state
 322         (propertize
 323          (concat "   ("
 324                  (if (eq rename-state 'copy) "copied from "
 325                    (if (eq state 'added) "renamed from "
 326                      "renamed to "))
 327                  (vc-git-escape-file-name
 328                   (vc-git-extra-fileinfo->orig-name extra))
 329                  ")")
 330          'face 'font-lock-comment-face)
 331       "")))
 332
 333 (defun vc-git-permissions-as-string (old-perm new-perm)
 334   "Format a permission change as string."
 335   (propertize
 336    (if (or (not old-perm)
 337            (not new-perm)
 338            (eq 0 (logand ?\111 (logxor old-perm new-perm))))
 339        "  "
 340      (if (eq 0 (logand ?\111 old-perm)) "+x" "-x"))
 341   'face 'font-lock-type-face))
 342
 343 (defun vc-git-dir-printer (info)
 344   "Pretty-printer for the vc-dir-fileinfo structure."
 345   (let* ((isdir (vc-dir-fileinfo->directory info))
 346          (state (if isdir "" (vc-dir-fileinfo->state info)))
 347          (extra (vc-dir-fileinfo->extra info))
 348          (old-perm (when extra (vc-git-extra-fileinfo->old-perm extra)))
 349          (new-perm (when extra (vc-git-extra-fileinfo->new-perm extra))))
 350     (insert
 351      "  "
 352      (propertize (format "%c" (if (vc-dir-fileinfo->marked info) ?* ? ))
 353                  'face 'font-lock-type-face)
 354      "  "
 355      (propertize
 356       (format "%-12s" state)
 357       'face (cond ((eq state 'up-to-date) 'font-lock-builtin-face)
 358                   ((eq state 'missing) 'font-lock-warning-face)
 359                   (t 'font-lock-variable-name-face))
 360       'mouse-face 'highlight)
 361      "  " (vc-git-permissions-as-string old-perm new-perm)
 362      "    "
 363      (propertize (vc-git-escape-file-name (vc-dir-fileinfo->name info))
 364                  'face (if isdir 'font-lock-comment-delimiter-face
 365                          'font-lock-function-name-face)
 366                  'help-echo
 367                  (if isdir
 368                      "Directory\nVC operations can be applied to it\nmouse-3: Pop-up menu"
 369                    "File\nmouse-3: Pop-up menu")
 370                  'keymap vc-dir-filename-mouse-map
 371                  'mouse-face 'highlight)
 372      (vc-git-file-type-as-string old-perm new-perm)
 373      (vc-git-rename-as-string state extra))))
 374
 375 (defun vc-git-after-dir-status-stage (stage files update-function)
 376   "Process sentinel for the various dir-status stages."
 377   (let (next-stage result)
 378     (goto-char (point-min))
 379     (pcase stage
 380       (`update-index
 381        (setq next-stage (if (vc-git--empty-db-p) 'ls-files-added
 382                           (if files 'ls-files-up-to-date 'diff-index))))
 383       (`ls-files-added
 384        (setq next-stage 'ls-files-unknown)
 385        (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
 386          (let ((new-perm (string-to-number (match-string 1) 8))
 387                (name (match-string 2)))
 388            (push (list name 'added (vc-git-create-extra-fileinfo 0 new-perm))
 389                  result))))
 390       (`ls-files-up-to-date
 391        (setq next-stage 'diff-index)
 392        (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t)
 393          (let ((perm (string-to-number (match-string 1) 8))
 394                (name (match-string 2)))
 395            (push (list name 'up-to-date
 396                        (vc-git-create-extra-fileinfo perm perm))
 397                  result))))
 398       (`ls-files-unknown
 399        (when files (setq next-stage 'ls-files-ignored))
 400        (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
 401          (push (list (match-string 1) 'unregistered
 402                      (vc-git-create-extra-fileinfo 0 0))
 403                result)))
 404       (`ls-files-ignored
 405        (while (re-search-forward "\\([^\0]*?\\)\0" nil t 1)
 406          (push (list (match-string 1) 'ignored
 407                      (vc-git-create-extra-fileinfo 0 0))
 408                result)))
 409       (`diff-index
 410        (setq next-stage 'ls-files-unknown)
 411        (while (re-search-forward
 412                ":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0"
 413                nil t 1)
 414          (let ((old-perm (string-to-number (match-string 1) 8))
 415                (new-perm (string-to-number (match-string 2) 8))
 416                (state (or (match-string 4) (match-string 6)))
 417                (name (or (match-string 5) (match-string 7)))
 418                (new-name (match-string 8)))
 419            (if new-name  ; Copy or rename.
 420                (if (eq ?C (string-to-char state))
 421                    (push (list new-name 'added
 422                                (vc-git-create-extra-fileinfo old-perm new-perm
 423                                                              'copy name))
 424                          result)
 425                  (push (list name 'removed
 426                              (vc-git-create-extra-fileinfo 0 0
 427                                                            'rename new-name))
 428                        result)
 429                  (push (list new-name 'added
 430                              (vc-git-create-extra-fileinfo old-perm new-perm
 431                                                            'rename name))
 432                        result))
 433              (push (list name (vc-git--state-code state)
 434                          (vc-git-create-extra-fileinfo old-perm new-perm))
 435                    result))))))
 436     (when result
 437       (setq result (nreverse result))
 438       (when files
 439         (dolist (entry result) (setq files (delete (car entry) files)))
 440         (unless files (setq next-stage nil))))
 441     (when (or result (not next-stage))
 442       (funcall update-function result next-stage))
 443     (when next-stage
 444       (vc-git-dir-status-goto-stage next-stage files update-function))))
 445
 446 (defun vc-git-dir-status-goto-stage (stage files update-function)
 447   (erase-buffer)
 448   (pcase stage
 449     (`update-index
 450      (if files
 451          (vc-git-command (current-buffer) 'async files "add" "--refresh" "--")
 452        (vc-git-command (current-buffer) 'async nil
 453                        "update-index" "--refresh")))
 454     (`ls-files-added
 455      (vc-git-command (current-buffer) 'async files
 456                      "ls-files" "-z" "-c" "-s" "--"))
 457     (`ls-files-up-to-date
 458      (vc-git-command (current-buffer) 'async files
 459                      "ls-files" "-z" "-c" "-s" "--"))
 460     (`ls-files-unknown
 461      (vc-git-command (current-buffer) 'async files
 462                      "ls-files" "-z" "-o" "--directory"
 463                      "--no-empty-directory" "--exclude-standard" "--"))
 464     (`ls-files-ignored
 465      (vc-git-command (current-buffer) 'async files
 466                      "ls-files" "-z" "-o" "-i" "--directory"
 467                      "--no-empty-directory" "--exclude-standard" "--"))
 468     ;; --relative added in Git 1.5.5.
 469     (`diff-index
 470      (vc-git-command (current-buffer) 'async files
 471                      "diff-index" "--relative" "-z" "-M" "HEAD" "--")))
 472   (vc-exec-after
 473    `(vc-git-after-dir-status-stage ',stage  ',files ',update-function)))
 474
 475 (defun vc-git-dir-status (_dir update-function)
 476   "Return a list of (FILE STATE EXTRA) entries for DIR."
 477   ;; Further things that would have to be fixed later:
 478   ;; - how to handle unregistered directories
 479   ;; - how to support vc-dir on a subdir of the project tree
 480   (vc-git-dir-status-goto-stage 'update-index nil update-function))
 481
 482 (defun vc-git-dir-status-files (_dir files _default-state update-function)
 483   "Return a list of (FILE STATE EXTRA) entries for FILES in DIR."
 484   (vc-git-dir-status-goto-stage 'update-index files update-function))
 485
 486 (defvar vc-git-stash-map
 487   (let ((map (make-sparse-keymap)))
 488     ;; Turn off vc-dir marking
 489     (define-key map [mouse-2] 'ignore)
 490
 491     (define-key map [down-mouse-3] 'vc-git-stash-menu)
 492     (define-key map "\C-k" 'vc-git-stash-delete-at-point)
 493     (define-key map "=" 'vc-git-stash-show-at-point)
 494     (define-key map "\C-m" 'vc-git-stash-show-at-point)
 495     (define-key map "A" 'vc-git-stash-apply-at-point)
 496     (define-key map "P" 'vc-git-stash-pop-at-point)
 497     (define-key map "S" 'vc-git-stash-snapshot)
 498     map))
 499
 500 (defvar vc-git-stash-menu-map
 501   (let ((map (make-sparse-keymap "Git Stash")))
 502     (define-key map [de]
 503       '(menu-item "Delete Stash" vc-git-stash-delete-at-point
 504                   :help "Delete the current stash"))
 505     (define-key map [ap]
 506       '(menu-item "Apply Stash" vc-git-stash-apply-at-point
 507                   :help "Apply the current stash and keep it in the stash list"))
 508     (define-key map [po]
 509       '(menu-item "Apply and Remove Stash (Pop)" vc-git-stash-pop-at-point
 510                   :help "Apply the current stash and remove it"))
 511     (define-key map [sh]
 512       '(menu-item "Show Stash" vc-git-stash-show-at-point
 513                   :help "Show the contents of the current stash"))
 514     map))
 515
 516 (defun vc-git-dir-extra-headers (_dir)
 517   (let ((str (with-output-to-string
 518                (with-current-buffer standard-output
 519                  (vc-git--out-ok "symbolic-ref" "HEAD"))))
 520         (stash (vc-git-stash-list))
 521         (stash-help-echo "Use M-x vc-git-stash to create stashes.")
 522         branch remote remote-url)
 523     (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str)
 524         (progn
 525           (setq branch (match-string 2 str))
 526           (setq remote
 527                 (with-output-to-string
 528                   (with-current-buffer standard-output
 529                     (vc-git--out-ok "config"
 530                                     (concat "branch." branch ".remote")))))
 531           (when (string-match "\\([^\n]+\\)" remote)
 532             (setq remote (match-string 1 remote)))
 533           (when remote
 534             (setq remote-url
 535                   (with-output-to-string
 536                     (with-current-buffer standard-output
 537                       (vc-git--out-ok "config"
 538                                       (concat "remote." remote ".url"))))))
 539           (when (string-match "\\([^\n]+\\)" remote-url)
 540             (setq remote-url (match-string 1 remote-url))))
 541       (setq branch "not (detached HEAD)"))
 542     ;; FIXME: maybe use a different face when nothing is stashed.
 543     (concat
 544      (propertize "Branch     : " 'face 'font-lock-type-face)
 545      (propertize branch
 546                  'face 'font-lock-variable-name-face)
 547      (when remote
 548        (concat
 549         "\n"
 550         (propertize "Remote     : " 'face 'font-lock-type-face)
 551         (propertize remote-url
 552                     'face 'font-lock-variable-name-face)))
 553      "\n"
 554      (if stash
 555        (concat
 556         (propertize "Stash      :\n" 'face 'font-lock-type-face
 557                     'help-echo stash-help-echo)
 558         (mapconcat
 559          (lambda (x)
 560            (propertize x
 561                        'face 'font-lock-variable-name-face
 562                        'mouse-face 'highlight
 563                        'help-echo "mouse-3: Show stash menu\nRET: Show stash\nA: Apply stash\nP: Apply and remove stash (pop)\nC-k: Delete stash"
 564                        'keymap vc-git-stash-map))
 565          stash "\n"))
 566        (concat
 567         (propertize "Stash      : " 'face 'font-lock-type-face
 568                     'help-echo stash-help-echo)
 569         (propertize "Nothing stashed"
 570                     'help-echo stash-help-echo
 571                     'face 'font-lock-variable-name-face))))))
 572
 573 (defun vc-git-branches ()
 574   "Return the existing branches, as a list of strings.
 575 The car of the list is the current branch."
 576   (with-temp-buffer
 577     (vc-git--call t "branch")
 578     (goto-char (point-min))
 579     (let (current-branch branches)
 580       (while (not (eobp))
 581         (when (looking-at "^\\([ *]\\) \\(.+\\)$")
 582           (if (string-equal (match-string 1) "*")
 583               (setq current-branch (match-string 2))
 584             (push (match-string 2) branches)))
 585         (forward-line 1))
 586       (cons current-branch (nreverse branches)))))
 587
 588 ;;; STATE-CHANGING FUNCTIONS
 589
 590 (defun vc-git-create-repo ()
 591   "Create a new Git repository."
 592   (vc-git-command nil 0 nil "init"))
 593
 594 (defun vc-git-register (files &optional _rev _comment)
 595   "Register FILES into the git version-control system."
 596   (let (flist dlist)
 597     (dolist (crt files)
 598       (if (file-directory-p crt)
 599           (push crt dlist)
 600         (push crt flist)))
 601     (when flist
 602       (vc-git-command nil 0 flist "update-index" "--add" "--"))
 603     (when dlist
 604       (vc-git-command nil 0 dlist "add"))))
 605
 606 (defalias 'vc-git-responsible-p 'vc-git-root)
 607
 608 (defun vc-git-unregister (file)
 609   (vc-git-command nil 0 file "rm" "-f" "--cached" "--"))
 610
 611 (declare-function log-edit-mode "log-edit" ())
 612 (declare-function log-edit-toggle-header "log-edit" (header value))
 613 (declare-function log-edit-extract-headers "log-edit" (headers string))
 614
 615 (defun vc-git-log-edit-toggle-signoff ()
 616   "Toggle whether to add the \"Signed-off-by\" line at the end of
 617 the commit message."
 618   (interactive)
 619   (log-edit-toggle-header "Sign-Off" "yes"))
 620
 621 (defun vc-git-log-edit-toggle-amend ()
 622   "Toggle whether this will amend the previous commit.
 623 If toggling on, also insert its message into the buffer."
 624   (interactive)
 625   (when (log-edit-toggle-header "Amend" "yes")
 626     (goto-char (point-max))
 627     (unless (bolp) (insert "\n"))
 628     (insert (with-output-to-string
 629               (vc-git-command
 630                standard-output 1 nil
 631                "log" "--max-count=1" "--pretty=format:%B" "HEAD")))))
 632
 633 (defvar vc-git-log-edit-mode-map
 634   (let ((map (make-sparse-keymap "Git-Log-Edit")))
 635     (define-key map "\C-c\C-s" 'vc-git-log-edit-toggle-signoff)
 636     (define-key map "\C-c\C-e" 'vc-git-log-edit-toggle-amend)
 637     map))
 638
 639 (define-derived-mode vc-git-log-edit-mode log-edit-mode "Log-Edit/git"
 640   "Major mode for editing Git log messages.
 641 It is based on `log-edit-mode', and has Git-specific extensions.")
 642
 643 (defun vc-git-checkin (files _rev comment)
 644   (let ((coding-system-for-write vc-git-commits-coding-system))
 645     (cl-flet ((boolean-arg-fn
 646                (argument)
 647                (lambda (value) (when (equal value "yes") (list argument)))))
 648       (apply 'vc-git-command nil 0 files
 649              (nconc (list "commit" "-m")
 650                     (log-edit-extract-headers
 651                      `(("Author" . "--author")
 652                        ("Date" . "--date")
 653                        ("Amend" . ,(boolean-arg-fn "--amend"))
 654                        ("Sign-Off" . ,(boolean-arg-fn "--signoff")))
 655                      comment)
 656                     (list "--only" "--"))))))
 657
 658 (defun vc-git-find-revision (file rev buffer)
 659   (let* (process-file-side-effects
 660          (coding-system-for-read 'binary)
 661          (coding-system-for-write 'binary)
 662          (fullname
 663           (let ((fn (vc-git--run-command-string
 664                      file "ls-files" "-z" "--full-name" "--")))
 665             ;; ls-files does not return anything when looking for a
 666             ;; revision of a file that has been renamed or removed.
 667             (if (string= fn "")
 668                 (file-relative-name file (vc-git-root default-directory))
 669               (substring fn 0 -1)))))
 670     (vc-git-command
 671      buffer 0
 672      nil
 673      "cat-file" "blob" (concat (if rev rev "HEAD") ":" fullname))))
 674
 675 (defun vc-git-checkout (file &optional _editable rev)
 676   (vc-git-command nil 0 file "checkout" (or rev "HEAD")))
 677
 678 (defun vc-git-revert (file &optional contents-done)
 679   "Revert FILE to the version stored in the git repository."
 680   (if contents-done
 681       (vc-git-command nil 0 file "update-index" "--")
 682     (vc-git-command nil 0 file "reset" "-q" "--")
 683     (vc-git-command nil nil file "checkout" "-q" "--")))
 684
 685 (defvar vc-git-error-regexp-alist
 686   '(("^ \\(.+\\) |" 1 nil nil 0))
 687   "Value of `compilation-error-regexp-alist' in *vc-git* buffers.")
 688
 689 (defun vc-git-pull (prompt)
 690   "Pull changes into the current Git branch.
 691 Normally, this runs \"git pull\".  If PROMPT is non-nil, prompt
 692 for the Git command to run."
 693   (let* ((root (vc-git-root default-directory))
 694          (buffer (format "*vc-git : %s*" (expand-file-name root)))
 695          (command "pull")
 696          (git-program vc-git-program)
 697          args)
 698     ;; If necessary, prompt for the exact command.
 699     (when prompt
 700       (setq args (split-string
 701                   (read-shell-command "Git pull command: "
 702                                       (format "%s pull" git-program)
 703                                       'vc-git-history)
 704                   " " t))
 705       (setq git-program (car  args)
 706             command     (cadr args)
 707             args        (cddr args)))
 708     (apply 'vc-do-async-command buffer root git-program command args)
 709     (with-current-buffer buffer (vc-exec-after '(vc-compilation-mode 'git)))
 710     (vc-set-async-update buffer)))
 711
 712 (defun vc-git-merge-branch ()
 713   "Merge changes into the current Git branch.
 714 This prompts for a branch to merge from."
 715   (let* ((root (vc-git-root default-directory))
 716          (buffer (format "*vc-git : %s*" (expand-file-name root)))
 717          (branches (cdr (vc-git-branches)))
 718          (merge-source
 719           (completing-read "Merge from branch: "
 720                            (if (or (member "FETCH_HEAD" branches)
 721                                    (not (file-readable-p
 722                                          (expand-file-name ".git/FETCH_HEAD"
 723                                                            root))))
 724                                branches
 725                              (cons "FETCH_HEAD" branches))
 726                            nil t)))
 727     (apply 'vc-do-async-command buffer root vc-git-program "merge"
 728            (list merge-source))
 729     (with-current-buffer buffer (vc-exec-after '(vc-compilation-mode 'git)))
 730     (vc-set-async-update buffer)))
 731
 732 ;;; HISTORY FUNCTIONS
 733
 734 (defun vc-git-print-log (files buffer &optional shortlog start-revision limit)
 735   "Get change log associated with FILES.
 736 Note that using SHORTLOG requires at least Git version 1.5.6,
 737 for the --graph option."
 738   (let ((coding-system-for-read vc-git-commits-coding-system))
 739     ;; `vc-do-command' creates the buffer, but we need it before running
 740     ;; the command.
 741     (vc-setup-buffer buffer)
 742     ;; If the buffer exists from a previous invocation it might be
 743     ;; read-only.
 744     (let ((inhibit-read-only t))
 745       (with-current-buffer
 746           buffer
 747         (apply 'vc-git-command buffer
 748                'async files
 749                (append
 750                 '("log" "--no-color")
 751                 (when shortlog
 752                   `("--graph" "--decorate" "--date=short"
 753                     ,(format "--pretty=tformat:%s"
 754                              (car vc-git-root-log-format))
 755                     "--abbrev-commit"))
 756                 (when limit (list "-n" (format "%s" limit)))
 757                 (when start-revision (list start-revision))
 758                 '("--")))))))
 759
 760 (defun vc-git-log-outgoing (buffer remote-location)
 761   (interactive)
 762   (vc-git-command
 763    buffer 0 nil
 764    "log"
 765    "--no-color" "--graph" "--decorate" "--date=short"
 766    (format "--pretty=tformat:%s" (car vc-git-root-log-format))
 767    "--abbrev-commit"
 768    (concat (if (string= remote-location "")
 769                "@{upstream}"
 770              remote-location)
 771            "..HEAD")))
 772
 773 (defun vc-git-log-incoming (buffer remote-location)
 774   (interactive)
 775   (vc-git-command nil 0 nil "fetch")
 776   (vc-git-command
 777    buffer 0 nil
 778    "log"
 779    "--no-color" "--graph" "--decorate" "--date=short"
 780    (format "--pretty=tformat:%s" (car vc-git-root-log-format))
 781    "--abbrev-commit"
 782    (concat "HEAD.." (if (string= remote-location "")
 783                         "@{upstream}"
 784                       remote-location))))
 785
 786 (defvar log-view-message-re)
 787 (defvar log-view-file-re)
 788 (defvar log-view-font-lock-keywords)
 789 (defvar log-view-per-file-logs)
 790 (defvar log-view-expanded-log-entry-function)
 791
 792 (define-derived-mode vc-git-log-view-mode log-view-mode "Git-Log-View"
 793   (require 'add-log) ;; We need the faces add-log.
 794   ;; Don't have file markers, so use impossible regexp.
 795   (set (make-local-variable 'log-view-file-re) "\\`a\\`")
 796   (set (make-local-variable 'log-view-per-file-logs) nil)
 797   (set (make-local-variable 'log-view-message-re)
 798        (if (not (eq vc-log-view-type 'long))
 799            (cadr vc-git-root-log-format)
 800          "^commit *\\([0-9a-z]+\\)"))
 801   ;; Allow expanding short log entries
 802   (when (eq vc-log-view-type 'short)
 803     (setq truncate-lines t)
 804     (set (make-local-variable 'log-view-expanded-log-entry-function)
 805          'vc-git-expanded-log-entry))
 806   (set (make-local-variable 'log-view-font-lock-keywords)
 807        (if (not (eq vc-log-view-type 'long))
 808            (list (cons (nth 1 vc-git-root-log-format)
 809                        (nth 2 vc-git-root-log-format)))
 810          (append
 811           `((,log-view-message-re (1 'change-log-acknowledgment)))
 812           ;; Handle the case:
 813           ;; user: foo@bar
 814           '(("^Author:[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 815              (1 'change-log-email))
 816             ;; Handle the case:
 817             ;; user: FirstName LastName <foo@bar>
 818             ("^Author:[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 819              (1 'change-log-name)
 820              (2 'change-log-email))
 821             ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)"
 822              (1 'change-log-name))
 823             ("^ +\\(?:\\(?:[Aa]cked\\|[Ss]igned-[Oo]ff\\)-[Bb]y:\\)[ \t]+\\([^<(]+?\\)[ \t]*[(<]\\([A-Za-z0-9_.+-]+@[A-Za-z0-9_.-]+\\)[>)]"
 824              (1 'change-log-name)
 825              (2 'change-log-email))
 826             ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)"
 827              (1 'change-log-acknowledgment)
 828              (2 'change-log-acknowledgment))
 829             ("^Date:   \\(.+\\)" (1 'change-log-date))
 830             ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message)))))))
 831
 832
 833 (defun vc-git-show-log-entry (revision)
 834   "Move to the log entry for REVISION.
 835 REVISION may have the form BRANCH, BRANCH~N,
 836 or BRANCH^ (where \"^\" can be repeated)."
 837   (goto-char (point-min))
 838   (prog1
 839       (when revision
 840         (search-forward
 841          (format "\ncommit %s" revision) nil t
 842          (cond ((string-match "~\\([0-9]\\)\\'" revision)
 843                 (1+ (string-to-number (match-string 1 revision))))
 844                ((string-match "\\^+\\'" revision)
 845                 (1+ (length (match-string 0 revision))))
 846                (t nil))))
 847     (beginning-of-line)))
 848
 849 (defun vc-git-expanded-log-entry (revision)
 850   (with-temp-buffer
 851     (apply 'vc-git-command t nil nil (list "log" revision "-1"))
 852     (goto-char (point-min))
 853     (unless (eobp)
 854       ;; Indent the expanded log entry.
 855       (indent-region (point-min) (point-max) 2)
 856       (buffer-string))))
 857
 858 (defun vc-git-diff (files &optional rev1 rev2 buffer)
 859   "Get a difference report using Git between two revisions of FILES."
 860   (let (process-file-side-effects)
 861     (apply #'vc-git-command (or buffer "*vc-diff*") 1 files
 862            (if (and rev1 rev2) "diff-tree" "diff-index")
 863            "--exit-code"
 864            (append (vc-switches 'git 'diff)
 865                    (list "-p" (or rev1 "HEAD") rev2 "--")))))
 866
 867 (defun vc-git-revision-table (_files)
 868   ;; What about `files'?!?  --Stef
 869   (let (process-file-side-effects
 870         (table (list "HEAD")))
 871     (with-temp-buffer
 872       (vc-git-command t nil nil "for-each-ref" "--format=%(refname)")
 873       (goto-char (point-min))
 874       (while (re-search-forward "^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$"
 875                                 nil t)
 876         (push (match-string 2) table)))
 877     table))
 878
 879 (defun vc-git-revision-completion-table (files)
 880   (letrec ((table (lazy-completion-table
 881                    table (lambda () (vc-git-revision-table files)))))
 882     table))
 883
 884 (defun vc-git-annotate-command (file buf &optional rev)
 885   (let ((name (file-relative-name file)))
 886     (vc-git-command buf 'async nil "blame" "--date=iso" "-C" "-C" rev "--" name)))
 887
 888 (declare-function vc-annotate-convert-time "vc-annotate" (time))
 889
 890 (defun vc-git-annotate-time ()
 891   (and (re-search-forward "[0-9a-f]+[^()]+(.* \\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) \\([-+0-9]+\\) +[0-9]+) " nil t)
 892        (vc-annotate-convert-time
 893         (apply #'encode-time (mapcar (lambda (match)
 894                                        (string-to-number (match-string match)))
 895                                      '(6 5 4 3 2 1 7))))))
 896
 897 (defun vc-git-annotate-extract-revision-at-line ()
 898   (save-excursion
 899     (move-beginning-of-line 1)
 900     (when (looking-at "\\([0-9a-f^][0-9a-f]+\\) \\(\\([^(]+\\) \\)?")
 901       (let ((revision (match-string-no-properties 1)))
 902         (if (match-beginning 2)
 903             (let ((fname (match-string-no-properties 3)))
 904               ;; Remove trailing whitespace from the file name.
 905               (when (string-match " +\\'" fname)
 906                 (setq fname (substring fname 0 (match-beginning 0))))
 907               (cons revision
 908                     (expand-file-name fname (vc-git-root default-directory))))
 909           revision)))))
 910
 911 ;;; TAG SYSTEM
 912
 913 (defun vc-git-create-tag (dir name branchp)
 914   (let ((default-directory dir))
 915     (and (vc-git-command nil 0 nil "update-index" "--refresh")
 916          (if branchp
 917              (vc-git-command nil 0 nil "checkout" "-b" name)
 918            (vc-git-command nil 0 nil "tag" name)))))
 919
 920 (defun vc-git-retrieve-tag (dir name _update)
 921   (let ((default-directory dir))
 922     (vc-git-command nil 0 nil "checkout" name)
 923     ;; FIXME: update buffers if `update' is true
 924     ))
 925
 926
 927 ;;; MISCELLANEOUS
 928
 929 (defun vc-git-previous-revision (file rev)
 930   "Git-specific version of `vc-previous-revision'."
 931   (if file
 932       (let* ((fname (file-relative-name file))
 933              (prev-rev (with-temp-buffer
 934                          (and
 935                           (vc-git--out-ok "rev-list" "-2" rev "--" fname)
 936                           (goto-char (point-max))
 937                           (bolp)
 938                           (zerop (forward-line -1))
 939                           (not (bobp))
 940                           (buffer-substring-no-properties
 941                            (point)
 942                            (1- (point-max)))))))
 943         (or (vc-git-symbolic-commit prev-rev) prev-rev))
 944     (with-temp-buffer
 945       (and
 946        (vc-git--out-ok "rev-parse" (concat rev "^"))
 947        (buffer-substring-no-properties (point-min) (+ (point-min) 40))))))
 948
 949 (defun vc-git-next-revision (file rev)
 950   "Git-specific version of `vc-next-revision'."
 951   (let* ((default-directory (file-name-directory
 952                              (expand-file-name file)))
 953          (file (file-name-nondirectory file))
 954          (current-rev
 955           (with-temp-buffer
 956             (and
 957              (vc-git--out-ok "rev-list" "-1" rev "--" file)
 958              (goto-char (point-max))
 959              (bolp)
 960              (zerop (forward-line -1))
 961              (bobp)
 962              (buffer-substring-no-properties
 963               (point)
 964               (1- (point-max))))))
 965          (next-rev
 966           (and current-rev
 967                (with-temp-buffer
 968                  (and
 969                   (vc-git--out-ok "rev-list" "HEAD" "--" file)
 970                   (goto-char (point-min))
 971                   (search-forward current-rev nil t)
 972                   (zerop (forward-line -1))
 973                   (buffer-substring-no-properties
 974                    (point)
 975                    (progn (forward-line 1) (1- (point)))))))))
 976     (or (vc-git-symbolic-commit next-rev) next-rev)))
 977
 978 (defun vc-git-delete-file (file)
 979   (vc-git-command nil 0 file "rm" "-f" "--"))
 980
 981 (defun vc-git-rename-file (old new)
 982   (vc-git-command nil 0 (list old new) "mv" "-f" "--"))
 983
 984 (defvar vc-git-extra-menu-map
 985   (let ((map (make-sparse-keymap)))
 986     (define-key map [git-grep]
 987       '(menu-item "Git grep..." vc-git-grep
 988                   :help "Run the `git grep' command"))
 989     (define-key map [git-sn]
 990       '(menu-item "Stash a Snapshot" vc-git-stash-snapshot
 991                   :help "Stash the current state of the tree and keep the current state"))
 992     (define-key map [git-st]
 993       '(menu-item "Create Stash..." vc-git-stash
 994                   :help "Stash away changes"))
 995     (define-key map [git-ss]
 996       '(menu-item "Show Stash..." vc-git-stash-show
 997                   :help "Show stash contents"))
 998     map))
 999
1000 (defun vc-git-extra-menu () vc-git-extra-menu-map)
1001
1002 (defun vc-git-extra-status-menu () vc-git-extra-menu-map)
1003
1004 (defun vc-git-root (file)
1005   (or (vc-file-getprop file 'git-root)
1006       (vc-file-setprop file 'git-root (vc-find-root file ".git"))))
1007
1008 ;; Derived from `lgrep'.
1009 (defun vc-git-grep (regexp &optional files dir)
1010   "Run git grep, searching for REGEXP in FILES in directory DIR.
1011 The search is limited to file names matching shell pattern FILES.
1012 FILES may use abbreviations defined in `grep-files-aliases', e.g.
1013 entering `ch' is equivalent to `*.[ch]'.
1014
1015 With \\[universal-argument] prefix, you can edit the constructed shell command line
1016 before it is executed.
1017 With two \\[universal-argument] prefixes, directly edit and run `grep-command'.
1018
1019 Collect output in a buffer.  While git grep runs asynchronously, you
1020 can use \\[next-error] (M-x next-error), or \\<grep-mode-map>\\[compile-goto-error] \
1021 in the grep output buffer,
1022 to go to the lines where grep found matches.
1023
1024 This command shares argument histories with \\[rgrep] and \\[grep]."
1025   (interactive
1026    (progn
1027      (grep-compute-defaults)
1028      (cond
1029       ((equal current-prefix-arg '(16))
1030        (list (read-from-minibuffer "Run: " "git grep"
1031                                    nil nil 'grep-history)
1032              nil))
1033       (t (let* ((regexp (grep-read-regexp))
1034                 (files (grep-read-files regexp))
1035                 (dir (read-directory-name "In directory: "
1036                                           nil default-directory t)))
1037            (list regexp files dir))))))
1038   (require 'grep)
1039   (when (and (stringp regexp) (> (length regexp) 0))
1040     (let ((command regexp))
1041       (if (null files)
1042           (if (string= command "git grep")
1043               (setq command nil))
1044         (setq dir (file-name-as-directory (expand-file-name dir)))
1045         (setq command
1046               (grep-expand-template "git grep -n -e <R> -- <F>"
1047                                     regexp files))
1048         (when command
1049           (if (equal current-prefix-arg '(4))
1050               (setq command
1051                     (read-from-minibuffer "Confirm: "
1052                                           command nil nil 'grep-history))
1053             (add-to-history 'grep-history command))))
1054       (when command
1055         (let ((default-directory dir)
1056               (compilation-environment (cons "PAGER=" compilation-environment)))
1057           ;; Setting process-setup-function makes exit-message-function work
1058           ;; even when async processes aren't supported.
1059           (compilation-start command 'grep-mode))
1060         (if (eq next-error-last-buffer (current-buffer))
1061             (setq default-directory dir))))))
1062
1063 (defun vc-git-stash (name)
1064   "Create a stash."
1065   (interactive "sStash name: ")
1066   (let ((root (vc-git-root default-directory)))
1067     (when root
1068       (vc-git--call nil "stash" "save" name)
1069       (vc-resynch-buffer root t t))))
1070
1071 (defun vc-git-stash-show (name)
1072   "Show the contents of stash NAME."
1073   (interactive "sStash name: ")
1074   (vc-setup-buffer "*vc-git-stash*")
1075   (vc-git-command "*vc-git-stash*" 'async nil "stash" "show" "-p" name)
1076   (set-buffer "*vc-git-stash*")
1077   (diff-mode)
1078   (setq buffer-read-only t)
1079   (pop-to-buffer (current-buffer)))
1080
1081 (defun vc-git-stash-apply (name)
1082   "Apply stash NAME."
1083   (interactive "sApply stash: ")
1084   (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" name)
1085   (vc-resynch-buffer (vc-git-root default-directory) t t))
1086
1087 (defun vc-git-stash-pop (name)
1088   "Pop stash NAME."
1089   (interactive "sPop stash: ")
1090   (vc-git-command "*vc-git-stash*" 0 nil "stash" "pop" "-q" name)
1091   (vc-resynch-buffer (vc-git-root default-directory) t t))
1092
1093 (defun vc-git-stash-snapshot ()
1094   "Create a stash with the current tree state."
1095   (interactive)
1096   (vc-git--call nil "stash" "save"
1097                 (let ((ct (current-time)))
1098                   (concat
1099                    (format-time-string "Snapshot on %Y-%m-%d" ct)
1100                    (format-time-string " at %H:%M" ct))))
1101   (vc-git-command "*vc-git-stash*" 0 nil "stash" "apply" "-q" "stash@{0}")
1102   (vc-resynch-buffer (vc-git-root default-directory) t t))
1103
1104 (defun vc-git-stash-list ()
1105   (delete
1106    ""
1107    (split-string
1108     (replace-regexp-in-string
1109      "^stash@" "             " (vc-git--run-command-string nil "stash" "list"))
1110     "\n")))
1111
1112 (defun vc-git-stash-get-at-point (point)
1113   (save-excursion
1114     (goto-char point)
1115     (beginning-of-line)
1116     (if (looking-at "^ +\\({[0-9]+}\\):")
1117         (match-string 1)
1118       (error "Cannot find stash at point"))))
1119
1120 (defun vc-git-stash-delete-at-point ()
1121   (interactive)
1122   (let ((stash (vc-git-stash-get-at-point (point))))
1123     (when (y-or-n-p (format "Remove stash %s ? " stash))
1124       (vc-git--run-command-string nil "stash" "drop" (format "stash@%s" stash))
1125       (vc-dir-refresh))))
1126
1127 (defun vc-git-stash-show-at-point ()
1128   (interactive)
1129   (vc-git-stash-show (format "stash@%s" (vc-git-stash-get-at-point (point)))))
1130
1131 (defun vc-git-stash-apply-at-point ()
1132   (interactive)
1133   (vc-git-stash-apply (format "stash@%s" (vc-git-stash-get-at-point (point)))))
1134
1135 (defun vc-git-stash-pop-at-point ()
1136   (interactive)
1137   (vc-git-stash-pop (format "stash@%s" (vc-git-stash-get-at-point (point)))))
1138
1139 (defun vc-git-stash-menu (e)
1140   (interactive "e")
1141   (vc-dir-at-event e (popup-menu vc-git-stash-menu-map e)))
1142
1143 \f
1144 ;;; Internal commands
1145
1146 (defun vc-git-command (buffer okstatus file-or-list &rest flags)
1147   "A wrapper around `vc-do-command' for use in vc-git.el.
1148 The difference to vc-do-command is that this function always invokes
1149 `vc-git-program'."
1150   (apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program
1151          file-or-list (cons "--no-pager" flags)))
1152
1153 (defun vc-git--empty-db-p ()
1154   "Check if the git db is empty (no commit done yet)."
1155   (let (process-file-side-effects)
1156     (not (eq 0 (vc-git--call nil "rev-parse" "--verify" "HEAD")))))
1157
1158 (defun vc-git--call (buffer command &rest args)
1159   ;; We don't need to care the arguments.  If there is a file name, it
1160   ;; is always a relative one.  This works also for remote
1161   ;; directories.  We enable `inhibit-null-byte-detection', otherwise
1162   ;; Tramp's eol conversion might be confused.
1163   (let ((inhibit-null-byte-detection t)
1164         (process-environment (cons "PAGER=" process-environment)))
1165     (apply 'process-file vc-git-program nil buffer nil command args)))
1166
1167 (defun vc-git--out-ok (command &rest args)
1168   (zerop (apply 'vc-git--call '(t nil) command args)))
1169
1170 (defun vc-git--run-command-string (file &rest args)
1171   "Run a git command on FILE and return its output as string.
1172 FILE can be nil."
1173   (let* ((ok t)
1174          (str (with-output-to-string
1175                 (with-current-buffer standard-output
1176                   (unless (apply 'vc-git--out-ok
1177                                  (if file
1178                                      (append args (list (file-relative-name
1179                                                          file)))
1180                                    args))
1181                     (setq ok nil))))))
1182     (and ok str)))
1183
1184 (defun vc-git-symbolic-commit (commit)
1185   "Translate COMMIT string into symbolic form.
1186 Returns nil if not possible."
1187   (and commit
1188        (let ((name (with-temp-buffer
1189                      (and
1190                       (vc-git--out-ok "name-rev" "--name-only" commit)
1191                       (goto-char (point-min))
1192                       (= (forward-line 2) 1)
1193                       (bolp)
1194                       (buffer-substring-no-properties (point-min)
1195                                                       (1- (point-max)))))))
1196          (and name (not (string= name "undefined")) name))))
1197
1198 (provide 'vc-git)
1199
1200 ;;; vc-git.el ends here