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   (save-excursion
 572     (when (stgit-goto-patch patchsym)
 573       (move-to-column 1)
 574       (let ((inhibit-read-only t))
 575         (insert-and-inherit ?*)
 576         (delete-char 1)))))
 577
 578 (defun stgit-remove-mark (patchsym)
 579   "Unmark the patch PATCHSYM."
 580   (setq stgit-marked-patches (delq patchsym stgit-marked-patches))
 581   (save-excursion
 582     (when (stgit-goto-patch patchsym)
 583       (move-to-column 1)
 584       (let ((inhibit-read-only t))
 585         (insert-and-inherit ? )
 586         (delete-char 1)))))
 587
 588 (defun stgit-clear-marks ()
 589   "Unmark all patches."
 590   (setq stgit-marked-patches '()))
 591
 592 (defun stgit-patch-at-point (&optional cause-error)
 593   (get-text-property (point) 'patch-data))
 594
 595 (defun stgit-patch-name-at-point (&optional cause-error)
 596   "Return the patch name on the current line as a symbol.
 597 If CAUSE-ERROR is not nil, signal an error if none found."
 598   (let ((patch (stgit-patch-at-point)))
 599     (cond (patch
 600            (stgit-patch-name patch))
 601           (cause-error
 602            (error "No patch on this line")))))
 603
 604 (defun stgit-patched-file-at-point (&optional both-files)
 605   "Returns a cons of the patchsym and file name at point. For
 606 copies and renames, return the new file if the patch is either
 607 applied. If BOTH-FILES is non-nil, return a cons of the old and
 608 the new file names instead of just one name."
 609   (let ((patchsym (get-text-property (point) 'stgit-file-patchsym))
 610         (file     (get-text-property (point) 'stgit-file)))
 611     (cond ((not patchsym) nil)
 612           (file (cons patchsym file))
 613           (both-files
 614            (cons patchsym (cons (get-text-property (point) 'stgit-old-file)
 615                                 (get-text-property (point) 'stgit-new-file))))
 616           (t
 617            (let ((file-sym (save-excursion
 618                              (stgit-previous-patch)
 619                              (unless (eq (stgit-patch-name-at-point)
 620                                          patchsym)
 621                                (error "Cannot find the %s patch" patchsym))
 622                              (beginning-of-line)
 623                              (if (= (char-after) ?-)
 624                                  'stgit-old-file
 625                                'stgit-new-file))))
 626              (cons patchsym (get-text-property (point) file-sym)))))))
 627
 628 (defun stgit-patches-marked-or-at-point ()
 629   "Return the symbols of the marked patches, or the patch on the current line."
 630   (if stgit-marked-patches
 631       stgit-marked-patches
 632     (let ((patch (stgit-patch-name-at-point)))
 633       (if patch
 634           (list patch)
 635         '()))))
 636
 637 (defun stgit-goto-patch (patchsym)
 638   "Move point to the line containing patch PATCHSYM.
 639 If that patch cannot be found, return nil."
 640   (let ((p (text-property-any (point-min) (point-max)
 641                               'stgit-patchsym patchsym)))
 642     (when p
 643       (goto-char p)
 644       (move-to-column goal-column))))
 645
 646 (defun stgit-init ()
 647   "Run stg init."
 648   (interactive)
 649   (stgit-capture-output nil
 650     (stgit-run "init"))
 651   (stgit-reload))
 652
 653 (defun stgit-mark ()
 654   "Mark the patch under point."
 655   (interactive)
 656   (let ((patch (stgit-patch-name-at-point t)))
 657     (stgit-add-mark patch))
 658   (stgit-next-patch))
 659
 660 (defun stgit-unmark-up ()
 661   "Remove mark from the patch on the previous line."
 662   (interactive)
 663   (stgit-previous-patch)
 664   (stgit-remove-mark (stgit-patch-name-at-point t)))
 665
 666 (defun stgit-unmark-down ()
 667   "Remove mark from the patch on the current line."
 668   (interactive)
 669   (stgit-remove-mark (stgit-patch-name-at-point t))
 670   (stgit-next-patch))
 671
 672 (defun stgit-rename (name)
 673   "Rename the patch under point to NAME."
 674   (interactive (list (read-string "Patch name: "
 675                                   (symbol-name (stgit-patch-name-at-point t)))))
 676   (let ((old-patchsym (stgit-patch-name-at-point t)))
 677     (stgit-capture-output nil
 678       (stgit-run "rename" old-patchsym name))
 679     (let ((name-sym (intern name)))
 680       (when (memq old-patchsym stgit-expanded-patches)
 681         (setq stgit-expanded-patches
 682             (cons name-sym (delq old-patchsym stgit-expanded-patches))))
 683       (when (memq old-patchsym stgit-marked-patches)
 684         (setq stgit-marked-patches
 685             (cons name-sym (delq old-patchsym stgit-marked-patches))))
 686       (stgit-reload)
 687       (stgit-goto-patch name-sym))))
 688
 689 (defun stgit-repair ()
 690   "Run stg repair."
 691   (interactive)
 692   (stgit-capture-output nil
 693     (stgit-run "repair"))
 694   (stgit-reload))
 695
 696 (defun stgit-available-branches ()
 697   "Returns a list of the available stg branches"
 698   (let ((output (with-output-to-string
 699                   (stgit-run "branch" "--list")))
 700         (start 0)
 701         result)
 702     (while (string-match "^>?\\s-+s\\s-+\\(\\S-+\\)" output start)
 703       (setq result (cons (match-string 1 output) result))
 704       (setq start (match-end 0)))
 705     result))
 706
 707 (defun stgit-branch (branch)
 708   "Switch to branch BRANCH."
 709   (interactive (list (completing-read "Switch to branch: "
 710                                       (stgit-available-branches))))
 711   (stgit-capture-output nil (stgit-run "branch" "--" branch))
 712   (stgit-reload))
 713
 714 (defun stgit-commit (count)
 715   "Run stg commit on COUNT commits.
 716 Interactively, the prefix argument is used as COUNT."
 717   (interactive "p")
 718   (stgit-capture-output nil (stgit-run "commit" "-n" count))
 719   (stgit-reload))
 720
 721 (defun stgit-uncommit (count)
 722   "Run stg uncommit on COUNT commits.
 723 Interactively, the prefix argument is used as COUNT."
 724   (interactive "p")
 725   (stgit-capture-output nil (stgit-run "uncommit" "-n" count))
 726   (stgit-reload))
 727
 728 (defun stgit-push-next (npatches)
 729   "Push the first unapplied patch.
 730 With numeric prefix argument, push that many patches."
 731   (interactive "p")
 732   (stgit-capture-output nil (stgit-run "push" "-n" npatches))
 733   (stgit-reload)
 734   (stgit-refresh-git-status))
 735
 736 (defun stgit-pop-next (npatches)
 737   "Pop the topmost applied patch.
 738 With numeric prefix argument, pop that many patches."
 739   (interactive "p")
 740   (stgit-capture-output nil (stgit-run "pop" "-n" npatches))
 741   (stgit-reload)
 742   (stgit-refresh-git-status))
 743
 744 (defun stgit-applied-at-point ()
 745   "Is the patch on the current line applied?"
 746   (save-excursion
 747     (beginning-of-line)
 748     (looking-at "[>+]")))
 749
 750 (defun stgit-push-or-pop ()
 751   "Push or pop the patch on the current line."
 752   (interactive)
 753   (let ((patchsym (stgit-patch-name-at-point t))
 754         (applied (stgit-applied-at-point)))
 755     (stgit-capture-output nil
 756       (stgit-run (if applied "pop" "push") patchsym))
 757     (stgit-reload)))
 758
 759 (defun stgit-goto ()
 760   "Go to the patch on the current line."
 761   (interactive)
 762   (let ((patchsym (stgit-patch-name-at-point t)))
 763     (stgit-capture-output nil
 764       (stgit-run "goto" patchsym))
 765     (stgit-reload)))
 766
 767 (defun stgit-id (patchsym)
 768   "Return the git commit id for PATCHSYM.
 769 If PATCHSYM is a keyword, returns PATCHSYM unmodified."
 770   (if (keywordp patchsym)
 771       patchsym
 772     (let ((result (with-output-to-string
 773                     (stgit-run-silent "id" patchsym))))
 774       (unless (string-match "^\\([0-9A-Fa-f]\\{40\\}\\)$" result)
 775         (error "Cannot find commit id for %s" patchsym))
 776       (match-string 1 result))))
 777
 778 (defun stgit-show ()
 779   "Show the patch on the current line."
 780   (interactive)
 781   (stgit-capture-output "*StGit patch*"
 782     (case (get-text-property (point) 'entry-type)
 783       ('file
 784        (let ((patchsym (stgit-patch-name-at-point))
 785              (patched-file (stgit-patched-file-at-point t)))
 786          (let ((id (stgit-id (car patched-file))))
 787            (if (consp (cdr patched-file))
 788                ;; two files (copy or rename)
 789                (stgit-run-git "diff" "-C" "-C" (concat id "^") id "--"
 790                               (cadr patched-file) (cddr patched-file))
 791              ;; just one file
 792              (stgit-run-git "diff" (concat id "^") id "--"
 793                             (cdr patched-file))))))
 794       ('patch
 795        (stgit-run "show" "-O" "--patch-with-stat" "-O" "-M"
 796                   (stgit-patch-name-at-point)))
 797       (t
 798        (error "No patch or file at point")))
 799     (with-current-buffer standard-output
 800       (goto-char (point-min))
 801       (diff-mode))))
 802
 803 (defun stgit-edit ()
 804   "Edit the patch on the current line."
 805   (interactive)
 806   (let ((patchsym (stgit-patch-name-at-point t))
 807         (edit-buf (get-buffer-create "*StGit edit*"))
 808         (dir default-directory))
 809     (log-edit 'stgit-confirm-edit t nil edit-buf)
 810     (set (make-local-variable 'stgit-edit-patchsym) patchsym)
 811     (setq default-directory dir)
 812     (let ((standard-output edit-buf))
 813       (stgit-run-silent "edit" "--save-template=-" patchsym))))
 814
 815 (defun stgit-confirm-edit ()
 816   (interactive)
 817   (let ((file (make-temp-file "stgit-edit-")))
 818     (write-region (point-min) (point-max) file)
 819     (stgit-capture-output nil
 820       (stgit-run "edit" "-f" file stgit-edit-patchsym))
 821     (with-current-buffer log-edit-parent-buffer
 822       (stgit-reload))))
 823
 824 (defun stgit-new (add-sign)
 825   "Create a new patch.
 826 With a prefix argument, include a \"Signed-off-by:\" line at the
 827 end of the patch."
 828   (interactive "P")
 829   (let ((edit-buf (get-buffer-create "*StGit edit*"))
 830         (dir default-directory))
 831     (log-edit 'stgit-confirm-new t nil edit-buf)
 832     (setq default-directory dir)
 833     (when add-sign
 834       (save-excursion
 835         (let ((standard-output (current-buffer)))
 836           (stgit-run-silent "new" "--sign" "--save-template=-"))))))
 837
 838 (defun stgit-confirm-new ()
 839   (interactive)
 840   (let ((file (make-temp-file "stgit-edit-")))
 841     (write-region (point-min) (point-max) file)
 842     (stgit-capture-output nil
 843       (stgit-run "new" "-f" file))
 844     (with-current-buffer log-edit-parent-buffer
 845       (stgit-reload))))
 846
 847 (defun stgit-create-patch-name (description)
 848   "Create a patch name from a long description"
 849   (let ((patch ""))
 850     (while (> (length description) 0)
 851       (cond ((string-match "\\`[a-zA-Z_-]+" description)
 852              (setq patch (downcase (concat patch
 853                                            (match-string 0 description))))
 854              (setq description (substring description (match-end 0))))
 855             ((string-match "\\` +" description)
 856              (setq patch (concat patch "-"))
 857              (setq description (substring description (match-end 0))))
 858             ((string-match "\\`[^a-zA-Z_-]+" description)
 859              (setq description (substring description (match-end 0))))))
 860     (cond ((= (length patch) 0)
 861            "patch")
 862           ((> (length patch) 20)
 863            (substring patch 0 20))
 864           (t patch))))
 865
 866 (defun stgit-delete (patchsyms &optional spill-p)
 867   "Delete the patches in PATCHSYMS.
 868 Interactively, delete the marked patches, or the patch at point.
 869
 870 With a prefix argument, or SPILL-P, spill the patch contents to
 871 the work tree and index."
 872   (interactive (list (stgit-patches-marked-or-at-point)
 873                      current-prefix-arg))
 874   (unless patchsyms
 875     (error "No patches to delete"))
 876   (let ((npatches (length patchsyms)))
 877     (when (yes-or-no-p (format "Really delete %d patch%s%s? "
 878                                npatches
 879                                (if (= 1 npatches) "" "es")
 880                                (if spill-p
 881                                    " (spilling contents to index)"
 882                                  "")))
 883       (let ((args (if spill-p
 884                       (cons "--spill" patchsyms)
 885                     patchsyms)))
 886         (stgit-capture-output nil
 887           (apply 'stgit-run "delete" args))
 888         (stgit-reload)))))
 889
 890 (defun stgit-move-patches-target ()
 891   "Return the patchsym indicating a target patch for
 892 `stgit-move-patches'.
 893
 894 This is either the patch at point, or one of :top and :bottom, if
 895 the point is after or before the applied patches."
 896
 897   (let ((patchsym (stgit-patch-name-at-point)))
 898     (cond (patchsym patchsym)
 899           ((save-excursion (re-search-backward "^>" nil t)) :top)
 900           (t :bottom))))
 901
 902 (defun stgit-sort-patches (patchsyms)
 903   "Returns the list of patches in PATCHSYMS sorted according to
 904 their position in the patch series, bottommost first.
 905
 906 PATCHSYMS may not contain duplicate entries."
 907   (let (sorted-patchsyms
 908         (series (with-output-to-string
 909                   (with-current-buffer standard-output
 910                     (stgit-run-silent "series" "--noprefix"))))
 911         start)
 912     (while (string-match "^\\(.+\\)" series start)
 913       (let ((patchsym (intern (match-string 1 series))))
 914         (when (memq patchsym patchsyms)
 915           (setq sorted-patchsyms (cons patchsym sorted-patchsyms))))
 916       (setq start (match-end 0)))
 917     (setq sorted-patchsyms (nreverse sorted-patchsyms))
 918
 919     (unless (= (length patchsyms) (length sorted-patchsyms))
 920       (error "Internal error"))
 921
 922     sorted-patchsyms))
 923
 924 (defun stgit-move-patches (patchsyms target-patch)
 925   "Move the patches in PATCHSYMS to below TARGET-PATCH.
 926 If TARGET-PATCH is :bottom or :top, move the patches to the
 927 bottom or top of the stack, respectively.
 928
 929 Interactively, move the marked patches to where the point is."
 930   (interactive (list stgit-marked-patches
 931                      (stgit-move-patches-target)))
 932   (unless patchsyms
 933     (error "Need at least one patch to move"))
 934
 935   (unless target-patch
 936     (error "Point not at a patch"))
 937
 938   (if (eq target-patch :top)
 939       (stgit-capture-output nil
 940         (apply 'stgit-run "float" patchsyms))
 941
 942     ;; need to have patchsyms sorted by position in the stack
 943     (let ((sorted-patchsyms (stgit-sort-patches patchsyms)))
 944       (while sorted-patchsyms
 945         (setq sorted-patchsyms
 946               (and (stgit-capture-output nil
 947                      (if (eq target-patch :bottom)
 948                          (stgit-run "sink" "--" (car sorted-patchsyms))
 949                        (stgit-run "sink" "--to" target-patch "--"
 950                                   (car sorted-patchsyms))))
 951                    (cdr sorted-patchsyms))))))
 952   (stgit-reload))
 953
 954 (defun stgit-squash (patchsyms)
 955   "Squash the patches in PATCHSYMS.
 956 Interactively, squash the marked patches.
 957
 958 Unless there are any conflicts, the patches will be merged into
 959 one patch, which will occupy the same spot in the series as the
 960 deepest patch had before the squash."
 961   (interactive (list stgit-marked-patches))
 962   (when (< (length patchsyms) 2)
 963     (error "Need at least two patches to squash"))
 964   (let ((stgit-buffer (current-buffer))
 965         (edit-buf (get-buffer-create "*StGit edit*"))
 966         (dir default-directory)
 967         (sorted-patchsyms (stgit-sort-patches patchsyms)))
 968     (log-edit 'stgit-confirm-squash t nil edit-buf)
 969     (set (make-local-variable 'stgit-patchsyms) sorted-patchsyms)
 970     (setq default-directory dir)
 971     (let ((result (let ((standard-output edit-buf))
 972                     (apply 'stgit-run-silent "squash"
 973                            "--save-template=-" sorted-patchsyms))))
 974
 975       ;; stg squash may have reordered the patches or caused conflicts
 976       (with-current-buffer stgit-buffer
 977         (stgit-reload))
 978
 979       (unless (eq 0 result)
 980         (fundamental-mode)
 981         (rename-buffer "*StGit error*")
 982         (resize-temp-buffer-window)
 983         (switch-to-buffer-other-window stgit-buffer)
 984         (error "stg squash failed")))))
 985
 986 (defun stgit-confirm-squash ()
 987   (interactive)
 988   (let ((file (make-temp-file "stgit-edit-")))
 989     (write-region (point-min) (point-max) file)
 990     (stgit-capture-output nil
 991       (apply 'stgit-run "squash" "-f" file stgit-patchsyms))
 992     (with-current-buffer log-edit-parent-buffer
 993       (stgit-clear-marks)
 994       ;; Go to first marked patch and stay there
 995       (goto-char (point-min))
 996       (re-search-forward (concat "^[>+-]\\*") nil t)
 997       (move-to-column goal-column)
 998       (let ((pos (point)))
 999         (stgit-reload)
1000         (goto-char pos)))))
1001
1002 (defun stgit-help ()
1003   "Display help for the StGit mode."
1004   (interactive)
1005   (describe-function 'stgit-mode))
1006
1007 (defun stgit-undo (&optional arg)
1008   "Run stg undo.
1009 With prefix argument, run it with the --hard flag."
1010   (interactive "P")
1011   (stgit-capture-output nil
1012     (if arg
1013         (stgit-run "undo" "--hard")
1014       (stgit-run "undo")))
1015   (stgit-reload))
1016
1017 (defun stgit-refresh (&optional arg)
1018   "Run stg refresh.
1019 With prefix argument, refresh the marked patch or the patch under point."
1020   (interactive "P")
1021   (let ((patchargs (if arg
1022                        (let ((patches (stgit-patches-marked-or-at-point)))
1023                          (cond ((null patches)
1024                                 (error "No patch to update"))
1025                                ((> (length patches) 1)
1026                                 (error "Too many patches selected"))
1027                                (t
1028                                 (cons "-p" patches))))
1029                      nil)))
1030     (stgit-capture-output nil
1031       (apply 'stgit-run "refresh" patchargs))
1032     (stgit-refresh-git-status))
1033   (stgit-reload))
1034
1035 (provide 'stgit)