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