lisp/vc-git.el

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