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