mdw@git.distorted.org.uk Git - stgit/blob - contrib/stgit.el

   1 ;; stgit.el: An emacs mode for StGit
   2 ;;
   3 ;; Copyright (C) 2007 David Kågedal <davidk@lysator.liu.se>
   4 ;;
   5 ;; To install: put this file on the load-path and place the following
   6 ;; in your .emacs file:
   7 ;;
   8 ;;    (require 'stgit)
   9 ;;
  10 ;; To start: `M-x stgit'
  11
  12 (require 'git nil t)
  13 (require 'cl)
  14
  15 (defun stgit (dir)
  16   "Manage StGit patches for the tree in DIR."
  17   (interactive "DDirectory: \n")
  18   (switch-to-stgit-buffer (git-get-top-dir dir))
  19   (stgit-reload))
  20
  21 (unless (fboundp 'git-get-top-dir)
  22   (defun git-get-top-dir (dir)
  23     "Retrieve the top-level directory of a git tree."
  24     (let ((cdup (with-output-to-string
  25                   (with-current-buffer standard-output
  26                     (cd dir)
  27                     (unless (eq 0 (call-process "git" nil t nil
  28                                                 "rev-parse" "--show-cdup"))
  29                       (error "Cannot find top-level git tree for %s" dir))))))
  30       (expand-file-name (concat (file-name-as-directory dir)
  31                                 (car (split-string cdup "\n")))))))
  32
  33 (defun stgit-refresh-git-status (&optional dir)
  34   "If it exists, refresh the `git-status' buffer belonging to
  35 directory DIR or `default-directory'"
  36   (when (and (fboundp 'git-find-status-buffer)
  37              (fboundp 'git-refresh-status))
  38     (let* ((top-dir (git-get-top-dir (or dir default-directory)))
  39            (git-status-buffer (and top-dir (git-find-status-buffer top-dir))))
  40       (when git-status-buffer
  41         (with-current-buffer git-status-buffer
  42           (git-refresh-status))))))
  43
  44 (defun switch-to-stgit-buffer (dir)
  45   "Switch to a (possibly new) buffer displaying StGit patches for DIR."
  46   (setq dir (file-name-as-directory dir))
  47   (let ((buffers (buffer-list)))
  48     (while (and buffers
  49                 (not (with-current-buffer (car buffers)
  50                        (and (eq major-mode 'stgit-mode)
  51                             (string= default-directory dir)))))
  52       (setq buffers (cdr buffers)))
  53     (switch-to-buffer (if buffers
  54                           (car buffers)
  55                         (create-stgit-buffer dir)))))
  56
  57 (defun create-stgit-buffer (dir)
  58   "Create a buffer for showing StGit patches.
  59 Argument DIR is the repository path."
  60   (let ((buf (create-file-buffer (concat dir "*stgit*")))
  61         (inhibit-read-only t))
  62     (with-current-buffer buf
  63       (setq default-directory dir)
  64       (stgit-mode)
  65       (setq buffer-read-only t))
  66     buf))
  67
  68 (defmacro stgit-capture-output (name &rest body)
  69   "Capture StGit output and, if there was any output, show it in a window
  70 at the end.
  71 Returns nil if there was no output."
  72   (declare (debug ([&or stringp null] body))
  73            (indent 1))
  74   `(let ((output-buf (get-buffer-create ,(or name "*StGit output*")))
  75          (stgit-dir default-directory)
  76          (inhibit-read-only t))
  77      (with-current-buffer output-buf
  78        (erase-buffer)
  79        (setq default-directory stgit-dir)
  80        (setq buffer-read-only t))
  81      (let ((standard-output output-buf))
  82        ,@body)
  83      (with-current-buffer output-buf
  84        (set-buffer-modified-p nil)
  85        (setq buffer-read-only t)
  86        (if (< (point-min) (point-max))
  87            (display-buffer output-buf t)))))
  88
  89 (defun stgit-make-run-args (args)
  90   "Return a copy of ARGS with its elements converted to strings."
  91   (mapcar (lambda (x)
  92             ;; don't use (format "%s" ...) to limit type errors
  93             (cond ((stringp x) x)
  94                   ((integerp x) (number-to-string x))
  95                   ((symbolp x) (symbol-name x))
  96                   (t
  97                    (error "Bad element in stgit-make-run-args args: %S" x))))
  98           args))
  99
 100 (defun stgit-run-silent (&rest args)
 101   (setq args (stgit-make-run-args args))
 102   (apply 'call-process "stg" nil standard-output nil args))
 103
 104 (defun stgit-run (&rest args)
 105   (setq args (stgit-make-run-args args))
 106   (let ((msgcmd (mapconcat #'identity args " ")))
 107     (message "Running stg %s..." msgcmd)
 108     (apply 'call-process "stg" nil standard-output nil args)
 109     (message "Running stg %s...done" msgcmd)))
 110
 111 (defun stgit-run-git (&rest args)
 112   (setq args (stgit-make-run-args args))
 113   (let ((msgcmd (mapconcat #'identity args " ")))
 114     (message "Running git %s..." msgcmd)
 115     (apply 'call-process "git" nil standard-output nil args)
 116     (message "Running git %s...done" msgcmd)))
 117
 118 (defun stgit-run-git-silent (&rest args)
 119   (setq args (stgit-make-run-args args))
 120   (apply 'call-process "git" nil standard-output nil args))
 121
 122 (defun stgit-reload ()
 123   "Update the contents of the StGit buffer."
 124   (interactive)
 125   (let ((inhibit-read-only t)
 126         (curline (line-number-at-pos))
 127         (curpatch (stgit-patch-at-point)))
 128     (erase-buffer)
 129     (insert "Branch: ")
 130     (stgit-run-silent "branch")
 131     (stgit-run-silent "series" "--description" "--empty")
 132     (stgit-rescan)
 133     (if curpatch
 134         (stgit-goto-patch curpatch)
 135       (goto-line curline)))
 136   (stgit-refresh-git-status))
 137
 138 (defgroup stgit nil
 139   "A user interface for the StGit patch maintenance tool."
 140   :group 'tools)
 141
 142 (defface stgit-description-face
 143   '((((background dark)) (:foreground "tan"))
 144     (((background light)) (:foreground "dark red")))
 145   "The face used for StGit descriptions"
 146   :group 'stgit)
 147
 148 (defface stgit-top-patch-face
 149   '((((background dark)) (:weight bold :foreground "yellow"))
 150     (((background light)) (:weight bold :foreground "purple"))
 151     (t (:weight bold)))
 152   "The face used for the top patch names"
 153   :group 'stgit)
 154
 155 (defface stgit-applied-patch-face
 156   '((((background dark)) (:foreground "light yellow"))
 157     (((background light)) (:foreground "purple"))
 158     (t ()))
 159   "The face used for applied patch names"
 160   :group 'stgit)
 161
 162 (defface stgit-unapplied-patch-face
 163   '((((background dark)) (:foreground "gray80"))
 164     (((background light)) (:foreground "orchid"))
 165     (t ()))
 166   "The face used for unapplied patch names"
 167   :group 'stgit)
 168
 169 (defface stgit-modified-file-face
 170   '((((class color) (background light)) (:foreground "purple"))
 171     (((class color) (background dark)) (:foreground "salmon")))
 172   "StGit mode face used for modified file status"
 173   :group 'stgit)
 174
 175 (defface stgit-unmerged-file-face
 176   '((((class color) (background light)) (:foreground "red" :bold t))
 177     (((class color) (background dark)) (:foreground "red" :bold t)))
 178   "StGit mode face used for unmerged file status"
 179   :group 'stgit)
 180
 181 (defface stgit-unknown-file-face
 182   '((((class color) (background light)) (:foreground "goldenrod" :bold t))
 183     (((class color) (background dark)) (:foreground "goldenrod" :bold t)))
 184   "StGit mode face used for unknown file status"
 185   :group 'stgit)
 186
 187 (defface stgit-file-permission-face
 188   '((((class color) (background light)) (:foreground "green" :bold t))
 189     (((class color) (background dark)) (:foreground "green" :bold t)))
 190   "StGit mode face used for permission changes."
 191   :group 'stgit)
 192
 193 (defcustom stgit-expand-find-copies-harder
 194   nil
 195   "Try harder to find copied files when listing patches.
 196
 197 When not nil, runs git diff-tree with the --find-copies-harder
 198 flag, which reduces performance."
 199   :type 'boolean
 200   :group 'stgit)
 201
 202 (defconst stgit-file-status-code-strings
 203   (mapcar (lambda (arg)
 204             (cons (car arg)
 205                   (propertize (cadr arg) 'face (car (cddr arg)))))
 206           '((add         "Added"       stgit-modified-file-face)
 207             (copy        "Copied"      stgit-modified-file-face)
 208             (delete      "Deleted"     stgit-modified-file-face)
 209             (modify      "Modified"    stgit-modified-file-face)
 210             (rename      "Renamed"     stgit-modified-file-face)
 211             (mode-change "Mode change" stgit-modified-file-face)
 212             (unmerged    "Unmerged"    stgit-unmerged-file-face)
 213             (unknown     "Unknown"     stgit-unknown-file-face)))
 214   "Alist of code symbols to description strings")
 215
 216 (defun stgit-file-status-code-as-string (code)
 217   "Return stgit status code as string"
 218   (let ((str (assq (if (consp code) (car code) code)
 219                    stgit-file-status-code-strings)))
 220     (when str
 221       (format "%-11s  "
 222               (if (and str (consp code) (/= (cdr code) 100))
 223                   (format "%s %s" (cdr str)
 224                           (propertize (format "%d%%" (cdr code))
 225                                       'face 'stgit-description-face))
 226                 (cdr str))))))
 227
 228 (defun stgit-file-status-code (str &optional score)
 229   "Return stgit status code from git status string"
 230   (let ((code (assoc str '(("A" . add)
 231                            ("C" . copy)
 232                            ("D" . delete)
 233                            ("M" . modify)
 234                            ("R" . rename)
 235                            ("T" . mode-change)
 236                            ("U" . unmerged)
 237                            ("X" . unknown)))))
 238     (setq code (if code (cdr code) 'unknown))
 239     (when (stringp score)
 240       (if (> (length score) 0)
 241           (setq score (string-to-number score))
 242         (setq score nil)))
 243     (if score (cons code score) code)))
 244
 245 (defconst stgit-file-type-strings
 246   '((#o100 . "file")
 247     (#o120 . "symlink")
 248     (#o160 . "subproject"))
 249   "Alist of names of file types")
 250
 251 (defun stgit-file-type-string (type)
 252   "Return string describing file type TYPE (the high bits of file permission).
 253 Cf. `stgit-file-type-strings' and `stgit-file-type-change-string'."
 254   (let ((type-str (assoc type stgit-file-type-strings)))
 255     (or (and type-str (cdr type-str))
 256         (format "unknown type %o" type))))
 257
 258 (defun stgit-file-type-change-string (old-perm new-perm)
 259   "Return string describing file type change from OLD-PERM to NEW-PERM.
 260 Cf. `stgit-file-type-string'."
 261   (let ((old-type (lsh old-perm -9))
 262         (new-type (lsh new-perm -9)))
 263     (cond ((= old-type new-type) "")
 264           ((zerop new-type) "")
 265           ((zerop old-type)
 266            (if (= new-type #o100)
 267                ""
 268              (format "   (%s)" (stgit-file-type-string new-type))))
 269           (t (format "   (%s -> %s)"
 270                      (stgit-file-type-string old-type)
 271                      (stgit-file-type-string new-type))))))
 272
 273 (defun stgit-file-mode-change-string (old-perm new-perm)
 274   "Return string describing file mode change from OLD-PERM to NEW-PERM.
 275 Cf. `stgit-file-type-change-string'."
 276   (setq old-perm (logand old-perm #o777)
 277         new-perm (logand new-perm #o777))
 278   (if (or (= old-perm new-perm)
 279           (zerop old-perm)
 280           (zerop new-perm))
 281       ""
 282     (let* ((modified       (logxor old-perm new-perm))
 283            (not-x-modified (logand (logxor old-perm new-perm) #o666)))
 284       (cond ((zerop modified) "")
 285             ((and (zerop not-x-modified)
 286                   (or (and (eq #o111 (logand old-perm #o111))
 287                            (propertize "-x" 'face 'stgit-file-permission-face))
 288                       (and (eq #o111 (logand new-perm #o111))
 289                            (propertize "+x" 'face
 290                                        'stgit-file-permission-face)))))
 291             (t (concat (propertize (format "%o" old-perm)
 292                                    'face 'stgit-file-permission-face)
 293                        (propertize " -> "
 294                                    'face 'stgit-description-face)
 295                        (propertize (format "%o" new-perm)
 296                                    'face 'stgit-file-permission-face)))))))
 297
 298 (defun stgit-expand-patch (patchsym)
 299   "Expand (show modification of) the patch with name PATCHSYM (a
 300 symbol) at point.
 301 `stgit-expand-find-copies-harder' controls how hard to try to
 302 find copied files."
 303   (save-excursion
 304     (forward-line)
 305     (let* ((start (point))
 306            (result (with-output-to-string
 307                      (stgit-run-git "diff-tree" "-r" "-z"
 308                                     (if stgit-expand-find-copies-harder
 309                                         "--find-copies-harder"
 310                                       "-C")
 311                                     (stgit-id patchsym)))))
 312       (let (mstart)
 313         (while (string-match "\0:\\([0-7]+\\) \\([0-7]+\\) [0-9A-Fa-f]\\{40\\} [0-9A-Fa-f]\\{40\\} \\(\\([CR]\\)\\([0-9]*\\)\0\\([^\0]*\\)\0\\([^\0]*\\)\\|\\([ABD-QS-Z]\\)\0\\([^\0]*\\)\\)"
 314                              result mstart)
 315           (let ((copy-or-rename (match-string 4 result))
 316                 (old-perm       (read (format "#o%s" (match-string 1 result))))
 317                 (new-perm       (read (format "#o%s" (match-string 2 result))))
 318                 (line-start (point))
 319                 status
 320                 change
 321                 (properties '(entry-type file)))
 322             (insert "    ")
 323             (if copy-or-rename
 324                 (let ((cr-score       (match-string 5 result))
 325                       (cr-from-file   (match-string 6 result))
 326                       (cr-to-file     (match-string 7 result)))
 327                   (setq status (stgit-file-status-code copy-or-rename
 328                                                        cr-score)
 329                         properties (list* 'stgit-old-file cr-from-file
 330                                           'stgit-new-file cr-to-file
 331                                           properties)
 332                         change (concat
 333                                 cr-from-file
 334                                 (propertize " -> "
 335                                             'face 'stgit-description-face)
 336                                 cr-to-file)))
 337               (setq status (stgit-file-status-code (match-string 8 result))
 338                     properties (list* 'stgit-file (match-string 9 result)
 339                                       properties)
 340                     change (match-string 9 result)))
 341
 342             (let ((mode-change (stgit-file-mode-change-string old-perm
 343                                                               new-perm)))
 344               (insert (format "%-12s" (stgit-file-status-code-as-string
 345                                        status))
 346                       mode-change
 347                       (if (> (length mode-change) 0) " " "")
 348                       change
 349                       (propertize (stgit-file-type-change-string old-perm
 350                                                                  new-perm)
 351                                   'face 'stgit-description-face)
 352                       ?\n))
 353             (add-text-properties line-start (point) properties))
 354           (setq mstart (match-end 0))))
 355       (when (= start (point))
 356         (insert "    <no files>\n"))
 357       (put-text-property start (point) 'stgit-file-patchsym patchsym))))
 358
 359 (defun stgit-collapse-patch (patchsym)
 360   "Collapse the patch with name PATCHSYM after the line at point."
 361   (save-excursion
 362     (forward-line)
 363     (let ((start (point)))
 364       (while (eq (get-text-property (point) 'stgit-file-patchsym) patchsym)
 365         (forward-line))
 366       (delete-region start (point)))))
 367
 368 (defun stgit-rescan ()
 369   "Rescan the status buffer."
 370   (save-excursion
 371     (let ((marked ())
 372           found-any)
 373       (goto-char (point-min))
 374       (while (not (eobp))
 375         (cond ((looking-at "Branch: \\(.*\\)")
 376                (put-text-property (match-beginning 1) (match-end 1)
 377                                   'face 'bold))
 378               ((looking-at "\\([0 ]\\)\\([>+-]\\)\\( \\)\\([^ ]+\\) *[|#] \\(.*\\)")
 379                (setq found-any t)
 380                (let ((empty (match-string 1))
 381                      (state (match-string 2))
 382                      (patchsym (intern (match-string 4))))
 383                  (put-text-property
 384                   (match-beginning 4) (match-end 4) 'face
 385                   (cond ((string= state ">") 'stgit-top-patch-face)
 386                         ((string= state "+") 'stgit-applied-patch-face)
 387                         ((string= state "-") 'stgit-unapplied-patch-face)))
 388                  (put-text-property (match-beginning 5) (match-end 5)
 389                                     'face 'stgit-description-face)
 390                  (when (memq patchsym stgit-marked-patches)
 391                    (save-excursion
 392                      (replace-match "*" nil nil nil 3))
 393                    (setq marked (cons patchsym marked)))
 394                  (add-text-properties (match-beginning 0) (match-end 0)
 395                                       (list 'stgit-patchsym patchsym
 396                                             'entry-type 'patch))
 397                  (when (memq patchsym stgit-expanded-patches)
 398                    (stgit-expand-patch patchsym))
 399                  (when (equal "0" empty)
 400                    (save-excursion
 401                      (goto-char (match-beginning 5))
 402                      (insert "(empty) ")))
 403                  (delete-char 1)
 404                  ))
 405               ((or (looking-at "stg series: Branch \".*\" not initialised")
 406                    (looking-at "stg series: .*: branch not initialized"))
 407                (setq found-any t)
 408                (forward-line 1)
 409                (insert "Run M-x stgit-init to initialise")))
 410         (forward-line 1))
 411       (setq stgit-marked-patches (nreverse marked))
 412       (unless found-any
 413         (insert "\n  "
 414                 (propertize "no patches in series"
 415                             'face 'stgit-description-face))))))
 416
 417 (defun stgit-select-file ()
 418   (let ((patched-file (stgit-patched-file-at-point)))
 419     (unless patched-file
 420       (error "No patch or file on the current line"))
 421     (let ((filename (expand-file-name (cdr patched-file))))
 422       (unless (file-exists-p filename)
 423         (error "File does not exist"))
 424       (find-file filename))))
 425
 426 (defun stgit-select-patch ()
 427   (let ((inhibit-read-only t)
 428         (curpatch (stgit-patch-at-point)))
 429     (if (memq curpatch stgit-expanded-patches)
 430         (save-excursion
 431           (setq stgit-expanded-patches (delq curpatch stgit-expanded-patches))
 432           (stgit-collapse-patch curpatch))
 433       (progn
 434         (setq stgit-expanded-patches (cons curpatch stgit-expanded-patches))
 435         (stgit-expand-patch curpatch)))))
 436
 437 (defun stgit-select ()
 438   "Expand or collapse the current entry"
 439   (interactive)
 440   (case (get-text-property (point) 'entry-type)
 441     ('patch
 442      (stgit-select-patch))
 443     ('file
 444      (stgit-select-file))
 445     (t
 446      (error "No patch or file on line"))))
 447
 448 (defun stgit-find-file-other-window ()
 449   "Open file at point in other window"
 450   (interactive)
 451   (let ((patched-file (stgit-patched-file-at-point)))
 452     (unless patched-file
 453       (error "No file on the current line"))
 454     (let ((filename (expand-file-name (cdr patched-file))))
 455       (unless (file-exists-p filename)
 456         (error "File does not exist"))
 457       (find-file-other-window filename))))
 458
 459 (defun stgit-quit ()
 460   "Hide the stgit buffer."
 461   (interactive)
 462   (bury-buffer))
 463
 464 (defun stgit-git-status ()
 465   "Show status using `git-status'."
 466   (interactive)
 467   (unless (fboundp 'git-status)
 468     (error "The stgit-git-status command requires git-status"))
 469   (let ((dir default-directory))
 470     (save-selected-window
 471       (pop-to-buffer nil)
 472       (git-status dir))))
 473
 474 (defun stgit-goal-column ()
 475   "Return goal column for the current line"
 476   (case (get-text-property (point) 'entry-type)
 477     ('patch 2)
 478     ('file 4)
 479     (t 0)))
 480
 481 (defun stgit-next-line (&optional arg)
 482   "Move cursor vertically down ARG lines"
 483   (interactive "p")
 484   (next-line arg)
 485   (move-to-column (stgit-goal-column)))
 486
 487 (defun stgit-previous-line (&optional arg)
 488   "Move cursor vertically up ARG lines"
 489   (interactive "p")
 490   (previous-line arg)
 491   (move-to-column (stgit-goal-column)))
 492
 493 (defun stgit-next-patch (&optional arg)
 494   "Move cursor down ARG patches"
 495   (interactive "p")
 496   (unless arg
 497     (setq arg 1))
 498   (if (< arg 0)
 499       (stgit-previous-patch (- arg))
 500     (while (not (zerop arg))
 501       (setq arg (1- arg))
 502       (while (progn (stgit-next-line)
 503                     (not (stgit-patch-at-point)))))))
 504
 505 (defun stgit-previous-patch (&optional arg)
 506   "Move cursor up ARG patches"
 507   (interactive "p")
 508   (unless arg
 509     (setq arg 1))
 510   (if (< arg 0)
 511       (stgit-next-patch (- arg))
 512     (while (not (zerop arg))
 513       (setq arg (1- arg))
 514       (while (progn (stgit-previous-line)
 515                     (not (stgit-patch-at-point)))))))
 516
 517 (defvar stgit-mode-hook nil
 518   "Run after `stgit-mode' is setup.")
 519
 520 (defvar stgit-mode-map nil
 521   "Keymap for StGit major mode.")
 522
 523 (unless stgit-mode-map
 524   (setq stgit-mode-map (make-keymap))
 525   (suppress-keymap stgit-mode-map)
 526   (mapc (lambda (arg) (define-key stgit-mode-map (car arg) (cdr arg)))
 527         '((" " .        stgit-mark)
 528           ("m" .        stgit-mark)
 529           ("\d" .       stgit-unmark-up)
 530           ("u" .        stgit-unmark-down)
 531           ("?" .        stgit-help)
 532           ("h" .        stgit-help)
 533           ("\C-p" .     stgit-previous-line)
 534           ("\C-n" .     stgit-next-line)
 535           ([up] .       stgit-previous-line)
 536           ([down] .     stgit-next-line)
 537           ("p" .        stgit-previous-patch)
 538           ("n" .        stgit-next-patch)
 539           ("\M-{" .     stgit-previous-patch)
 540           ("\M-}" .     stgit-next-patch)
 541           ("s" .        stgit-git-status)
 542           ("g" .        stgit-reload)
 543           ("r" .        stgit-refresh)
 544           ("\C-c\C-r" . stgit-rename)
 545           ("e" .        stgit-edit)
 546           ("M" .        stgit-move-patches)
 547           ("S" .        stgit-squash)
 548           ("N" .        stgit-new)
 549           ("R" .        stgit-repair)
 550           ("C" .        stgit-commit)
 551           ("U" .        stgit-uncommit)
 552           ("\r" .       stgit-select)
 553           ("o" .        stgit-find-file-other-window)
 554           (">" .        stgit-push-next)
 555           ("<" .        stgit-pop-next)
 556           ("P" .        stgit-push-or-pop)
 557           ("G" .        stgit-goto)
 558           ("=" .        stgit-show)
 559           ("D" .        stgit-delete)
 560           ([(control ?/)] . stgit-undo)
 561           ("\C-_" .     stgit-undo)
 562           ("B" .        stgit-branch)
 563           ("q" .        stgit-quit))))
 564
 565 (defun stgit-mode ()
 566   "Major mode for interacting with StGit.
 567 Commands:
 568 \\{stgit-mode-map}"
 569   (kill-all-local-variables)
 570   (buffer-disable-undo)
 571   (setq mode-name "StGit"
 572         major-mode 'stgit-mode
 573         goal-column 2)
 574   (use-local-map stgit-mode-map)
 575   (set (make-local-variable 'list-buffers-directory) default-directory)
 576   (set (make-local-variable 'stgit-marked-patches) nil)
 577   (set (make-local-variable 'stgit-expanded-patches) nil)
 578   (set-variable 'truncate-lines 't)
 579   (run-hooks 'stgit-mode-hook))
 580
 581 (defun stgit-add-mark (patchsym)
 582   "Mark the patch PATCHSYM."
 583   (setq stgit-marked-patches (cons patchsym stgit-marked-patches))
 584   (save-excursion
 585     (when (stgit-goto-patch patchsym)
 586       (move-to-column 1)
 587       (let ((inhibit-read-only t))
 588         (insert-and-inherit ?*)
 589         (delete-char 1)))))
 590
 591 (defun stgit-remove-mark (patchsym)
 592   "Unmark the patch PATCHSYM."
 593   (setq stgit-marked-patches (delq patchsym stgit-marked-patches))
 594   (save-excursion
 595     (when (stgit-goto-patch patchsym)
 596       (move-to-column 1)
 597       (let ((inhibit-read-only t))
 598         (insert-and-inherit ? )
 599         (delete-char 1)))))
 600
 601 (defun stgit-clear-marks ()
 602   "Unmark all patches."
 603   (setq stgit-marked-patches '()))
 604
 605 (defun stgit-patch-at-point (&optional cause-error)
 606   "Return the patch name on the current line as a symbol.
 607 If CAUSE-ERROR is not nil, signal an error if none found."
 608   (case (get-text-property (point) 'entry-type)
 609     ('patch (get-text-property (point) 'stgit-patchsym))
 610     (t (if cause-error
 611            (error "No patch on this line")
 612          nil))))
 613
 614 (defun stgit-patched-file-at-point (&optional both-files)
 615   "Returns a cons of the patchsym and file name at point. For
 616 copies and renames, return the new file if the patch is either
 617 applied. If BOTH-FILES is non-nil, return a cons of the old and
 618 the new file names instead of just one name."
 619   (let ((patchsym (get-text-property (point) 'stgit-file-patchsym))
 620         (file     (get-text-property (point) 'stgit-file)))
 621     (cond ((not patchsym) nil)
 622           (file (cons patchsym file))
 623           (both-files
 624            (cons patchsym (cons (get-text-property (point) 'stgit-old-file)
 625                                 (get-text-property (point) 'stgit-new-file))))
 626           (t
 627            (let ((file-sym (save-excursion
 628                              (stgit-previous-patch)
 629                              (unless (eq (stgit-patch-at-point)
 630                                          patchsym)
 631                                (error "Cannot find the %s patch" patchsym))
 632                              (beginning-of-line)
 633                              (if (= (char-after) ?-)
 634                                  'stgit-old-file
 635                                'stgit-new-file))))
 636              (cons patchsym (get-text-property (point) file-sym)))))))
 637
 638 (defun stgit-patches-marked-or-at-point ()
 639   "Return the symbols of the marked patches, or the patch on the current line."
 640   (if stgit-marked-patches
 641       stgit-marked-patches
 642     (let ((patch (stgit-patch-at-point)))
 643       (if patch
 644           (list patch)
 645         '()))))
 646
 647 (defun stgit-goto-patch (patchsym)
 648   "Move point to the line containing patch PATCHSYM.
 649 If that patch cannot be found, return nil."
 650   (let ((p (text-property-any (point-min) (point-max)
 651                               'stgit-patchsym patchsym)))
 652     (when p
 653       (goto-char p)
 654       (move-to-column goal-column))))
 655
 656 (defun stgit-init ()
 657   "Run stg init."
 658   (interactive)
 659   (stgit-capture-output nil
 660     (stgit-run "init"))
 661   (stgit-reload))
 662
 663 (defun stgit-mark ()
 664   "Mark the patch under point."
 665   (interactive)
 666   (let ((patch (stgit-patch-at-point t)))
 667     (stgit-add-mark patch))
 668   (stgit-next-patch))
 669
 670 (defun stgit-unmark-up ()
 671   "Remove mark from the patch on the previous line."
 672   (interactive)
 673   (stgit-previous-patch)
 674   (stgit-remove-mark (stgit-patch-at-point t)))
 675
 676 (defun stgit-unmark-down ()
 677   "Remove mark from the patch on the current line."
 678   (interactive)
 679   (stgit-remove-mark (stgit-patch-at-point t))
 680   (stgit-next-patch))
 681
 682 (defun stgit-rename (name)
 683   "Rename the patch under point to NAME."
 684   (interactive (list (read-string "Patch name: "
 685                                   (symbol-name (stgit-patch-at-point t)))))
 686   (let ((old-patchsym (stgit-patch-at-point t)))
 687     (stgit-capture-output nil
 688       (stgit-run "rename" old-patchsym name))
 689     (let ((name-sym (intern name)))
 690       (when (memq old-patchsym stgit-expanded-patches)
 691         (setq stgit-expanded-patches
 692             (cons name-sym (delq old-patchsym stgit-expanded-patches))))
 693       (when (memq old-patchsym stgit-marked-patches)
 694         (setq stgit-marked-patches
 695             (cons name-sym (delq old-patchsym stgit-marked-patches))))
 696       (stgit-reload)
 697       (stgit-goto-patch name-sym))))
 698
 699 (defun stgit-repair ()
 700   "Run stg repair."
 701   (interactive)
 702   (stgit-capture-output nil
 703     (stgit-run "repair"))
 704   (stgit-reload))
 705
 706 (defun stgit-available-branches ()
 707   "Returns a list of the available stg branches"
 708   (let ((output (with-output-to-string
 709                   (stgit-run "branch" "--list")))
 710         (start 0)
 711         result)
 712     (while (string-match "^>?\\s-+s\\s-+\\(\\S-+\\)" output start)
 713       (setq result (cons (match-string 1 output) result))
 714       (setq start (match-end 0)))
 715     result))
 716
 717 (defun stgit-branch (branch)
 718   "Switch to branch BRANCH."
 719   (interactive (list (completing-read "Switch to branch: "
 720                                       (stgit-available-branches))))
 721   (stgit-capture-output nil (stgit-run "branch" "--" branch))
 722   (stgit-reload))
 723
 724 (defun stgit-commit (count)
 725   "Run stg commit on COUNT commits.
 726 Interactively, the prefix argument is used as COUNT."
 727   (interactive "p")
 728   (stgit-capture-output nil (stgit-run "commit" "-n" count))
 729   (stgit-reload))
 730
 731 (defun stgit-uncommit (count)
 732   "Run stg uncommit on COUNT commits.
 733 Interactively, the prefix argument is used as COUNT."
 734   (interactive "p")
 735   (stgit-capture-output nil (stgit-run "uncommit" "-n" count))
 736   (stgit-reload))
 737
 738 (defun stgit-push-next (npatches)
 739   "Push the first unapplied patch.
 740 With numeric prefix argument, push that many patches."
 741   (interactive "p")
 742   (stgit-capture-output nil (stgit-run "push" "-n" npatches))
 743   (stgit-reload)
 744   (stgit-refresh-git-status))
 745
 746 (defun stgit-pop-next (npatches)
 747   "Pop the topmost applied patch.
 748 With numeric prefix argument, pop that many patches."
 749   (interactive "p")
 750   (stgit-capture-output nil (stgit-run "pop" "-n" npatches))
 751   (stgit-reload)
 752   (stgit-refresh-git-status))
 753
 754 (defun stgit-applied-at-point ()
 755   "Is the patch on the current line applied?"
 756   (save-excursion
 757     (beginning-of-line)
 758     (looking-at "[>+]")))
 759
 760 (defun stgit-push-or-pop ()
 761   "Push or pop the patch on the current line."
 762   (interactive)
 763   (let ((patchsym (stgit-patch-at-point t))
 764         (applied (stgit-applied-at-point)))
 765     (stgit-capture-output nil
 766       (stgit-run (if applied "pop" "push") patchsym))
 767     (stgit-reload)))
 768
 769 (defun stgit-goto ()
 770   "Go to the patch on the current line."
 771   (interactive)
 772   (let ((patchsym (stgit-patch-at-point t)))
 773     (stgit-capture-output nil
 774       (stgit-run "goto" patchsym))
 775     (stgit-reload)))
 776
 777 (defun stgit-id (patchsym)
 778   "Return the git commit id for PATCHSYM.
 779 If PATCHSYM is a keyword, returns PATCHSYM unmodified."
 780   (if (keywordp patchsym)
 781       patchsym
 782     (let ((result (with-output-to-string
 783                     (stgit-run-silent "id" patchsym))))
 784       (unless (string-match "^\\([0-9A-Fa-f]\\{40\\}\\)$" result)
 785         (error "Cannot find commit id for %s" patchsym))
 786       (match-string 1 result))))
 787
 788 (defun stgit-show ()
 789   "Show the patch on the current line."
 790   (interactive)
 791   (stgit-capture-output "*StGit patch*"
 792     (case (get-text-property (point) 'entry-type)
 793       ('file
 794        (let ((patchsym (stgit-patch-at-point))
 795              (patched-file (stgit-patched-file-at-point t)))
 796          (let ((id (stgit-id (car patched-file))))
 797            (if (consp (cdr patched-file))
 798                ;; two files (copy or rename)
 799                (stgit-run-git "diff" "-C" "-C" (concat id "^") id "--"
 800                               (cadr patched-file) (cddr patched-file))
 801              ;; just one file
 802              (stgit-run-git "diff" (concat id "^") id "--"
 803                             (cdr patched-file))))))
 804       ('patch
 805        (stgit-run "show" "-O" "--patch-with-stat" "-O" "-M" (stgit-patch-at-point)))
 806       (t
 807        (error "No patch or file at point")))
 808     (with-current-buffer standard-output
 809       (goto-char (point-min))
 810       (diff-mode))))
 811
 812 (defun stgit-edit ()
 813   "Edit the patch on the current line."
 814   (interactive)
 815   (let ((patchsym (stgit-patch-at-point t))
 816         (edit-buf (get-buffer-create "*StGit edit*"))
 817         (dir default-directory))
 818     (log-edit 'stgit-confirm-edit t nil edit-buf)
 819     (set (make-local-variable 'stgit-edit-patchsym) patchsym)
 820     (setq default-directory dir)
 821     (let ((standard-output edit-buf))
 822       (stgit-run-silent "edit" "--save-template=-" patchsym))))
 823
 824 (defun stgit-confirm-edit ()
 825   (interactive)
 826   (let ((file (make-temp-file "stgit-edit-")))
 827     (write-region (point-min) (point-max) file)
 828     (stgit-capture-output nil
 829       (stgit-run "edit" "-f" file stgit-edit-patchsym))
 830     (with-current-buffer log-edit-parent-buffer
 831       (stgit-reload))))
 832
 833 (defun stgit-new (add-sign)
 834   "Create a new patch.
 835 With a prefix argument, include a \"Signed-off-by:\" line at the
 836 end of the patch."
 837   (interactive "P")
 838   (let ((edit-buf (get-buffer-create "*StGit edit*"))
 839         (dir default-directory))
 840     (log-edit 'stgit-confirm-new t nil edit-buf)
 841     (setq default-directory dir)
 842     (when add-sign
 843       (save-excursion
 844         (let ((standard-output (current-buffer)))
 845           (stgit-run-silent "new" "--sign" "--save-template=-"))))))
 846
 847 (defun stgit-confirm-new ()
 848   (interactive)
 849   (let ((file (make-temp-file "stgit-edit-")))
 850     (write-region (point-min) (point-max) file)
 851     (stgit-capture-output nil
 852       (stgit-run "new" "-f" file))
 853     (with-current-buffer log-edit-parent-buffer
 854       (stgit-reload))))
 855
 856 (defun stgit-create-patch-name (description)
 857   "Create a patch name from a long description"
 858   (let ((patch ""))
 859     (while (> (length description) 0)
 860       (cond ((string-match "\\`[a-zA-Z_-]+" description)
 861              (setq patch (downcase (concat patch
 862                                            (match-string 0 description))))
 863              (setq description (substring description (match-end 0))))
 864             ((string-match "\\` +" description)
 865              (setq patch (concat patch "-"))
 866              (setq description (substring description (match-end 0))))
 867             ((string-match "\\`[^a-zA-Z_-]+" description)
 868              (setq description (substring description (match-end 0))))))
 869     (cond ((= (length patch) 0)
 870            "patch")
 871           ((> (length patch) 20)
 872            (substring patch 0 20))
 873           (t patch))))
 874
 875 (defun stgit-delete (patchsyms &optional spill-p)
 876   "Delete the patches in PATCHSYMS.
 877 Interactively, delete the marked patches, or the patch at point.
 878
 879 With a prefix argument, or SPILL-P, spill the patch contents to
 880 the work tree and index."
 881   (interactive (list (stgit-patches-marked-or-at-point)
 882                      current-prefix-arg))
 883   (unless patchsyms
 884     (error "No patches to delete"))
 885   (let ((npatches (length patchsyms)))
 886     (when (yes-or-no-p (format "Really delete %d patch%s%s? "
 887                                npatches
 888                                (if (= 1 npatches) "" "es")
 889                                (if spill-p
 890                                    " (spilling contents to index)"
 891                                  "")))
 892       (let ((args (if spill-p
 893                       (cons "--spill" patchsyms)
 894                     patchsyms)))
 895         (stgit-capture-output nil
 896           (apply 'stgit-run "delete" args))
 897         (stgit-reload)))))
 898
 899 (defun stgit-move-patches-target ()
 900   "Return the patchsym indicating a target patch for
 901 `stgit-move-patches'.
 902
 903 This is either the patch at point, or one of :top and :bottom, if
 904 the point is after or before the applied patches."
 905
 906   (let ((patchsym (stgit-patch-at-point)))
 907     (cond (patchsym patchsym)
 908           ((save-excursion (re-search-backward "^>" nil t)) :top)
 909           (t :bottom))))
 910
 911 (defun stgit-sort-patches (patchsyms)
 912   "Returns the list of patches in PATCHSYMS sorted according to
 913 their position in the patch series, bottommost first.
 914
 915 PATCHSYMS may not contain duplicate entries."
 916   (let (sorted-patchsyms
 917         (series (with-output-to-string
 918                   (with-current-buffer standard-output
 919                     (stgit-run-silent "series" "--noprefix"))))
 920         start)
 921     (while (string-match "^\\(.+\\)" series start)
 922       (let ((patchsym (intern (match-string 1 series))))
 923         (when (memq patchsym patchsyms)
 924           (setq sorted-patchsyms (cons patchsym sorted-patchsyms))))
 925       (setq start (match-end 0)))
 926     (setq sorted-patchsyms (nreverse sorted-patchsyms))
 927
 928     (unless (= (length patchsyms) (length sorted-patchsyms))
 929       (error "Internal error"))
 930
 931     sorted-patchsyms))
 932
 933 (defun stgit-move-patches (patchsyms target-patch)
 934   "Move the patches in PATCHSYMS to below TARGET-PATCH.
 935 If TARGET-PATCH is :bottom or :top, move the patches to the
 936 bottom or top of the stack, respectively.
 937
 938 Interactively, move the marked patches to where the point is."
 939   (interactive (list stgit-marked-patches
 940                      (stgit-move-patches-target)))
 941   (unless patchsyms
 942     (error "Need at least one patch to move"))
 943
 944   (unless target-patch
 945     (error "Point not at a patch"))
 946
 947   (if (eq target-patch :top)
 948       (stgit-capture-output nil
 949         (apply 'stgit-run "float" patchsyms))
 950
 951     ;; need to have patchsyms sorted by position in the stack
 952     (let ((sorted-patchsyms (stgit-sort-patches patchsyms)))
 953       (while sorted-patchsyms
 954         (setq sorted-patchsyms
 955               (and (stgit-capture-output nil
 956                      (if (eq target-patch :bottom)
 957                          (stgit-run "sink" "--" (car sorted-patchsyms))
 958                        (stgit-run "sink" "--to" target-patch "--"
 959                                   (car sorted-patchsyms))))
 960                    (cdr sorted-patchsyms))))))
 961   (stgit-reload))
 962
 963 (defun stgit-squash (patchsyms)
 964   "Squash the patches in PATCHSYMS.
 965 Interactively, squash the marked patches.
 966
 967 Unless there are any conflicts, the patches will be merged into
 968 one patch, which will occupy the same spot in the series as the
 969 deepest patch had before the squash."
 970   (interactive (list stgit-marked-patches))
 971   (when (< (length patchsyms) 2)
 972     (error "Need at least two patches to squash"))
 973   (let ((stgit-buffer (current-buffer))
 974         (edit-buf (get-buffer-create "*StGit edit*"))
 975         (dir default-directory)
 976         (sorted-patchsyms (stgit-sort-patches patchsyms)))
 977     (log-edit 'stgit-confirm-squash t nil edit-buf)
 978     (set (make-local-variable 'stgit-patchsyms) sorted-patchsyms)
 979     (setq default-directory dir)
 980     (let ((result (let ((standard-output edit-buf))
 981                     (apply 'stgit-run-silent "squash"
 982                            "--save-template=-" sorted-patchsyms))))
 983
 984       ;; stg squash may have reordered the patches or caused conflicts
 985       (with-current-buffer stgit-buffer
 986         (stgit-reload))
 987
 988       (unless (eq 0 result)
 989         (fundamental-mode)
 990         (rename-buffer "*StGit error*")
 991         (resize-temp-buffer-window)
 992         (switch-to-buffer-other-window stgit-buffer)
 993         (error "stg squash failed")))))
 994
 995 (defun stgit-confirm-squash ()
 996   (interactive)
 997   (let ((file (make-temp-file "stgit-edit-")))
 998     (write-region (point-min) (point-max) file)
 999     (stgit-capture-output nil
1000       (apply 'stgit-run "squash" "-f" file stgit-patchsyms))
1001     (with-current-buffer log-edit-parent-buffer
1002       (stgit-clear-marks)
1003       ;; Go to first marked patch and stay there
1004       (goto-char (point-min))
1005       (re-search-forward (concat "^[>+-]\\*") nil t)
1006       (move-to-column goal-column)
1007       (let ((pos (point)))
1008         (stgit-reload)
1009         (goto-char pos)))))
1010
1011 (defun stgit-help ()
1012   "Display help for the StGit mode."
1013   (interactive)
1014   (describe-function 'stgit-mode))
1015
1016 (defun stgit-undo (&optional arg)
1017   "Run stg undo.
1018 With prefix argument, run it with the --hard flag."
1019   (interactive "P")
1020   (stgit-capture-output nil
1021     (if arg
1022         (stgit-run "undo" "--hard")
1023       (stgit-run "undo")))
1024   (stgit-reload))
1025
1026 (defun stgit-refresh (&optional arg)
1027   "Run stg refresh.
1028 With prefix argument, refresh the marked patch or the patch under point."
1029   (interactive "P")
1030   (let ((patchargs (if arg
1031                        (let ((patches (stgit-patches-marked-or-at-point)))
1032                          (cond ((null patches)
1033                                 (error "No patch to update"))
1034                                ((> (length patches) 1)
1035                                 (error "Too many patches selected"))
1036                                (t
1037                                 (cons "-p" patches))))
1038                      nil)))
1039     (stgit-capture-output nil
1040       (apply 'stgit-run "refresh" patchargs))
1041     (stgit-refresh-git-status))
1042   (stgit-reload))
1043
1044 (provide 'stgit)