Permalink
Fetching contributors…
Cannot retrieve contributors at this time
7761 lines (7038 sloc) 319 KB
;;; egg.el --- Emacs Got Git - Emacs interface to Git
;; Copyright (C) 2008 Linh Dang
;; Copyright (C) 2008 Marius Vollmer
;; Copyright (C) 2009 Tim Moore
;; Copyright (C) 2010 Alexander Prusov
;; Copyright (C) 2011-2016 byplayer
;;
;; Author: Bogolisk <bogolisk@gmail.com>
;; Created: 19 Aug 2008
;; Version: 1.1.0
;; Keywords: git, version control, release management
;;
;; Special Thanks to
;; Antoine Levitt, Bogolisk,
;; Christian Köstlin
;; Max Mikhanosha
;; Aleksandar Simic
;; Maksim Golubev
;; Felix S Klock II
;;
;; Egg is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; Egg is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
;; License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary
;;; This is my fork of Marius's excellent magit. his work is at:
;;; http://zagadka.vm.bytemark.co.uk/magit
;;;
;;; This is my fork of bogolisk egg . his work is at
;; http://github.com/bogolisk/egg
;;
;; ssh and github: please use key authentication since egg doesn't
;; handle login/passwd prompt
;;
;; gpg and tag : please add "use-agent" option in your gpg.conf
;; since egg doesn't handle passphrase prompt.
;;;
;; Options
;; If you want to auto-update egg-status on file save,
;; you set follow value on your .emacs.
;; (setq egg-auto-update t)
;;
;; Set to nonnil for egg-status to switch to the status buffer in the same window.
;; (setq egg-switch-to-buffer t)
;;
;; If you want to change prefix of lunch egg,
;; you set follow value on your .emacs.
;; (custom-set-variables
;; '(egg-mode-key-prefix "C-c v"))
(eval-when-compile (require 'cl))
(require 'egg-custom)
(require 'egg-base)
(require 'egg-const)
(require 'egg-git)
(require 'electric)
(require 'ediff)
(require 'ffap)
(require 'diff-mode)
(require 'rx)
(defconst egg-version "1.1.1")
(defconst egg-basic-map
(let ((map (make-sparse-keymap "Egg:Basic")))
(set-keymap-parent map egg-section-map)
(define-key map (kbd "C-c C-s") 'egg-status)
(define-key map (kbd "s") 'egg-status)
(define-key map (kbd "l") 'egg-log)
(define-key map (kbd "L") 'egg-log-buffer-reflog-ref)
(define-key map (kbd "/") 'egg-search-changes)
(define-key map (kbd "c") 'egg-commit-log-edit)
map)
"Keymap for a basic egg buffer.
\\{egg-basic-map}")
(defconst egg-file-index-map
(let ((map (make-sparse-keymap "Egg:FileIndex")))
(set-keymap-parent map egg-basic-map)
map)
"Keymap for an egg buffer show the index version of a file.
\\{egg-file-index-map}")
(defvar egg-global-mode-name nil)
(defvar egg-global-mode nil)
(defun egg-set-global-mode (&optional string)
(interactive)
(when (egg-is-in-git)
(when (boundp 'vc-mode)
(set 'vc-mode nil))
(set (make-local-variable 'egg-global-mode) t)
(set (make-local-variable 'egg-global-mode-name)
(if string (concat " " string)))
;; (setq egg-global-mode-name
;; (intern (concat "egg-" (egg-git-dir) "-HEAD")))
(or (assq 'egg-global-mode minor-mode-alist)
(push '(egg-global-mode egg-global-mode-name) minor-mode-alist))))
;;(cl-macroexpand '(egg-text blah 'egg-text-3))
(defun egg-show-branch (branch)
(interactive (list (egg-head-at-point)))
(let* ((info (and (stringp branch)
(egg-git-to-string-list "for-each-ref"
"--format=%(refname:short) %(refname) %(upstream:short)"
(concat "refs/heads/" branch))))
(name (nth 0 info))
(full (nth 1 info))
(upstream (nth 2 info)))
(when (stringp name)
(message "local-branch:%s full-name:%s upstream:%s"
(egg-text name 'bold)
(egg-text full 'bold)
(if upstream (egg-text upstream 'bold) "none")))))
(defvar egg-atag-info-buffer (get-buffer-create "*tag-info*"))
(defun egg-show-atag (tag)
(interactive (list (egg-tag-at-point)))
(let ((dir (egg-work-tree-dir))
(buf egg-atag-info-buffer)
(new-buf-name (concat "*tag@" (egg-repo-name) ":" tag "*"))
(inhibit-read-only t)
target-type sig-beg sig-end verify pos)
(with-current-buffer buf
(setq default-directory dir)
(setq target-type (egg-git-to-string "for-each-ref" "--format=%(objecttype)"
(concat "refs/tags/" tag)))
(unless (equal target-type "tag")
(error "Not an annotated tag: %s" tag))
(unless (string-equal (buffer-name) new-buf-name)
(rename-buffer new-buf-name))
(erase-buffer)
(unless (egg--git t "show" "-s" tag)
(error "Failed to show tag %s" tag))
(save-match-data
(goto-char (point-min))
(re-search-forward "^tag ")
(put-text-property (match-end 0) (line-end-position) 'face 'egg-branch)
(re-search-forward "^Tagger:\\s-+")
(put-text-property (match-end 0) (line-end-position) 'face 'egg-text-2)
(re-search-forward "^Date:\\s-+")
(put-text-property (match-end 0) (line-end-position) 'face 'egg-text-2)
(setq pos (line-end-position))
(when (re-search-forward "-----BEGIN PGP SIGNATURE-----" nil t)
(setq sig-beg (match-beginning 0))
(re-search-forward "-----END PGP SIGNATURE-----\n")
(setq sig-end (match-end 0))
(goto-char sig-beg)
(delete-region sig-beg sig-end)
(with-temp-buffer
(egg--git t "tag" "-v" tag)
(goto-char (point-min))
(re-search-forward "^gpg:")
(setq verify (buffer-substring-no-properties (match-beginning 0)
(point-max))))
(insert verify "\n"))
(goto-char pos)
(re-search-forward "^\\(commit\\|gpg:\\)")
(put-text-property pos (match-beginning 0) 'face 'egg-text-1)
(re-search-forward "^Author:\\s-+")
(put-text-property (match-end 0) (line-end-position) 'face 'egg-text-2)
(re-search-forward "^Date:\\s-+")
(put-text-property (match-end 0) (line-end-position) 'face 'egg-text-2)
(put-text-property (line-end-position) (point-max) 'face 'egg-text-1))
(set-buffer-modified-p nil))
(pop-to-buffer buf)))
(defun egg-show-remote-branch (branch)
(interactive (list (egg-remote-at-point)))
(let* ((info (and (stringp branch)
(egg-git-to-string-list "for-each-ref"
"--format=%(refname:short) %(refname)"
(concat "refs/remotes/" branch))))
(name (nth 0 info))
(full (nth 1 info))
(site (and (stringp name) (egg-rbranch-to-remote name)))
(url (and site (egg-git-to-string "ls-remote" "--get-url" site))))
(when (stringp name)
(message "remote-tracking-branch:%s full-name:%s site:%s"
(egg-text name 'bold)
(egg-text full 'bold)
(egg-text url 'bold)))))
(defun egg-call-next-action (action &optional ignored-action only-action)
(when (and action (symbolp action))
(let ((cmd (plist-get '(log egg-log
status egg-status
stash egg-status
commit egg-commit-log-edit
reflog egg-reflog)
action))
(current-prefix-arg nil))
(when (and (commandp cmd) ;; cmd is a valid command
;; if only-action is specified, then only take
;; action if it's the same as only-action
(or (and only-action (eq only-action action))
;; if only-action is not specified, then
;; take the action if it's not ignored.
(and (null only-action)
(not (if (symbolp ignored-action)
(eq action ignored-action)
(memq action ignored-action))))))
(call-interactively cmd)))))
(defsubst egg-tooltip-func ()
(if egg-enable-tooltip 'egg-buffer-help-echo))
(defun egg-read-tracked-filename (prompt &optional default no-match-ok)
(concat (egg-work-tree-dir)
(completing-read prompt #'egg-do-completion
#'egg-get-match-files-substring
(not no-match-ok) default)))
(defun egg-find-tracked-file (file-name)
"Open a file tracked by git."
(interactive (list (egg-read-tracked-filename "Find tracked file: ")))
(switch-to-buffer (find-file-noselect file-name)))
(defun egg-pretty-head-string (&optional state)
"Pretty description of HEAD. if STATE was not nil then use it
as repo state instead of re-read from disc."
(let* ((state (or state (egg-repo-state)))
(branch (plist-get state :branch))
(merge-heads (plist-get state :merge-heads))
(rebase-head (plist-get state :rebase-head))
(squash-head (plist-get state :squash-head))
(rebase-upstream (plist-get state :rebase-upstream))
(sha1 (plist-get state :sha1)))
(cond ((and branch merge-heads)
(concat "Merging to " branch " from: "
(mapconcat 'identity merge-heads ",")))
(merge-heads
(concat "Merging to " (egg-pretty-short-rev sha1) " from: "
(mapconcat 'identity merge-heads ",")))
((and branch squash-head)
(concat "Squashed " squash-head " onto " branch))
(squash-head
(concat "Squashed " squash-head " onto " (egg-pretty-short-rev sha1)))
((and rebase-head rebase-upstream)
(format "Rebasing %s onto %s" rebase-head rebase-upstream))
(branch branch)
(t (concat "Detached HEAD: " (egg-describe-rev sha1))))))
(defsubst egg-pretty-head-name (&optional state)
"Pretty name for HEAD. if STATE was not nil then use it
as repo state instead of re-read from disc."
(let* ((state (or state (egg-repo-state)))
(branch (plist-get state :branch)))
(or branch (egg-pretty-short-rev (plist-get state :sha1)))))
(defun egg--async-create-signed-commit-handler (buffer-to-update)
(goto-char (point-min))
(re-search-forward "EGG-GIT-OUTPUT:\n" nil t)
(if (not (match-end 0))
(message "something wrong with git-commit's output!")
(let* ((proc egg-async-process)
(ret-code (process-exit-status proc))
res)
(goto-char (match-end 0))
(save-restriction
(narrow-to-region (point) (point-max))
(setq res (egg--do-show-output
"GIT-COMMIT-GPG"
(egg--do-handle-exit (cons ret-code (current-buffer))
#'egg--git-pp-commit-output
buffer-to-update)))
(when (plist-get res :success)
(setq res (nconc (list :next-action 'status) res)))
(egg--buffer-handle-result res t)))))
(defsubst egg-buffer-do-amend-no-edit (&rest args)
(egg--buffer-handle-result (egg--git-amend-no-edit-cmd t) t))
(defun egg--buffer-do-create-tag (name rev stdin &optional short-msg force ignored-action)
(let ((args (list name rev))
(check-name (egg-git-to-string "name-rev" name))
res)
(cond (stdin (setq args (nconc (list "-F" "-") args)))
(short-msg (setq args (nconc (list "-m" short-msg))))
(t nil))
(setq force (egg--git-tag-check-name name force))
(when force (setq args (cons "-f" args)))
(when (or stdin short-msg) (setq args (cons "-a" args)))
(setq res (egg--git-tag-cmd (egg-get-log-buffer) stdin args))
;;; useless???
(when (plist-get res :success)
(setq res (nconc (list :next-action 'log) res)))
(egg--buffer-handle-result res t ignored-action)))
;;(setenv "GPG_AGENT_INFO" "/tmp/gpg-SbJxGl/S.gpg-agent:28016:1")
;;(getenv "GPG_AGENT_INFO")
(defun egg--async-create-signed-tag-handler (buffer-to-update name rev)
(goto-char (point-min))
(re-search-forward "EGG-GIT-OUTPUT:\n" nil t)
(if (not (match-end 0))
(message "something wrong with git-tag's output!")
(let* ((proc egg-async-process)
(ret-code (process-exit-status proc))
res)
(goto-char (match-end 0))
(save-restriction
(narrow-to-region (point) (point-max))
(setq res (egg--do-show-output
"GIT-TAG-GPG"
(egg--do-handle-exit (cons ret-code (current-buffer))
#'egg--git-tag-cmd-pp
buffer-to-update)))
(when (plist-get res :success)
(setq res (nconc (list :next-action 'log) res)))
(egg--buffer-handle-result res t)))))
(defun egg--async-create-signed-tag-cmd (buffer-to-update msg name rev &optional gpg-uid force)
(let ((force (egg--git-tag-check-name name force))
(args (list "-m" msg name rev)))
(when force (setq args (cons "-f" args)))
(setq args (if (stringp gpg-uid) (nconc (list "-u" gpg-uid) args) (cons "-s" args)))
(egg-async-1-args (list #'egg--async-create-signed-tag-handler buffer-to-update name rev)
(cons "tag" args))))
(defsubst egg-log-buffer-do-tag-commit (name rev force &optional msg)
(egg--buffer-do-create-tag name rev nil msg force 'log))
(defsubst egg-status-buffer-do-tag-HEAD (name force &optional msg)
(egg--buffer-do-create-tag name "HEAD" nil msg force 'status))
(defsubst egg-edit-buffer-do-create-tag (name rev beg end force)
(egg--buffer-do-create-tag name rev (cons beg end) nil force))
(defun egg--buffer-handle-result (result &optional take-next-action ignored-action only-action)
"Handle the structure returned by the egg--git-xxxxx-cmd functions.
RESULT is the returned value of those functions. Proceed to the next logical action
if TAKE-NEXT-ACTION is non-nil unless the next action is IGNORED-ACTION.
if ONLY-ACTION is non-nil then only perform the next action if it's the same
as ONLY-ACTION.
See documentation of `egg--git-action-cmd-doc' for structure of RESULT."
(let ((ok (plist-get result :success))
(next-action (plist-get result :next-action)))
(egg-revert-visited-files (plist-get result :files))
(when (and ok take-next-action)
(egg-call-next-action next-action ignored-action only-action))
ok))
(defun egg--buffer-handle-result-with-commit (result commit-args
&optional take-next-action
ignored-action only-action)
"Handle the structure returned by the egg--git-xxxxx-cmd functions.
RESULT is the returned value of those functions. Proceed to the next logical action
if TAKE-NEXT-ACTION is non-nil unless the next action is IGNORED-ACTION.
if ONLY-ACTION is non-nil then only perform the next action if it's the same
as ONLY-ACTION.
See documentation of `egg--git-action-cmd-doc' for structure of RESULT."
(let ((ok (plist-get result :success))
(next-action (plist-get result :next-action)))
(egg-revert-visited-files (plist-get result :files))
(when (and ok take-next-action)
(if (eq next-action 'commit)
(apply #'egg-commit-log-edit commit-args)
(egg-call-next-action next-action ignored-action only-action)))
ok))
(defsubst egg-log-buffer-handle-result (result)
"Handle the RESULT returned by egg--git-xxxxx-cmd functions.
This function should be used in the log buffer only.
See documentation of `egg--git-action-cmd-doc' for structure of RESULT."
(egg--buffer-handle-result result t 'log))
(defsubst egg-status-buffer-handle-result (result)
"Handle the RESULT returned by egg--git-xxxxx-cmd functions.
This function should be used in the status buffer only.
See documentation of `egg--git-action-cmd-doc' for structure of RESULT."
(egg--buffer-handle-result result t 'status))
(defsubst egg-stash-buffer-handle-result (result)
"Handle the RESULT returned by egg--git-xxxxx-cmd functions.
This function should be used in the stash buffer only.
See documentation of `egg--git-action-cmd-doc' for structure of RESULT."
(egg--buffer-handle-result result t 'stash))
(defsubst egg-file-buffer-handle-result (result)
"Handle the RESULT returned by egg--git-xxxxx-cmd functions.
This function should be used in a file visiting buffer only.
See documentation of `egg--git-action-cmd-doc' for structure of RESULT."
;; for file buffer, we only take commit action
(egg--buffer-handle-result result t nil 'commit))
(defsubst egg-buffer-do-create-branch (name rev force track ignored-action)
"Create a new branch synchronously when inside an egg special buffer.
NAME is the name of the new branch. REV is the starting point of the branch.
If force is non-nil, then force the creation of new branch even if a branch
NAME already existed. Branch NAME will bet set up to track REV if REV was
a branch and track was non-nil. Take the next logical action unless it's
IGNORED-ACTION."
(egg--buffer-handle-result
(egg--git-branch-cmd (egg-get-log-buffer)
(nconc (if force (list "-f"))
(if track (list "--track"))
(list name rev))) t ignored-action))
(defsubst egg-log-buffer-do-co-rev (rev &rest args)
"Checkout REV using ARGS as arguments when in the log buffer."
(egg-log-buffer-handle-result (egg--git-co-rev-cmd-args t rev args)))
(defsubst egg-status-buffer-do-co-rev (rev &rest args)
"Checkout REV using ARGS as arguments when in the status buffer."
(egg-status-buffer-handle-result (egg--git-co-rev-cmd-args t rev args)))
;;;========================================================
;;; Blame utils
;;;========================================================
(defconst egg-blame-map
(let ((map (make-sparse-keymap "Egg:Blame")))
(define-key map (kbd "l") 'egg-blame-locate-commit)
(define-key map (kbd "RET") 'egg-blame-locate-commit)
(define-key map (kbd "q") 'egg-file-toggle-blame-mode)
(define-key map (kbd "n") 'egg-buffer-cmd-navigate-next)
(define-key map (kbd "p") 'egg-buffer-cmd-navigate-prev)
map)
"Keymap for an annotated section.\\{egg-blame-map}")
(defun egg-parse-git-blame (target-buf blame-buf &optional ov-attributes)
"Parse blame-info in buffer BLAME-BUF and decorate TARGET-BUF buffer.
OV-ATTRIBUTES are the extra decorations for each blame chunk."
(save-match-data
(let ((blank (egg-text " " 'egg-blame))
(nl (egg-text "\n" 'egg-blame))
(commit-hash (make-hash-table :test 'equal :size 577))
commit commit-info old-line new-line num old-file subject author
info ov beg end blame)
(with-current-buffer blame-buf
(goto-char (point-min))
;; search for a ful commit info
(while (re-search-forward (rx line-start
(group (= 40 hex-digit)) " "
(group (1+ digit)) " "
(group (1+ digit)) " "
(group (1+ digit))
line-end)
nil t)
(setq commit (match-string-no-properties 1)
old-line (string-to-number
(match-string-no-properties 2))
new-line (string-to-number
(match-string-no-properties 3))
num (string-to-number
(match-string-no-properties 4)))
;; was this commit already seen (and stored in the hash)?
(setq commit-info (gethash commit commit-hash))
;; Nope, this is the 1st time, the full commit-info follow.
(unless commit-info
(re-search-forward "^author \\(.+\\)$")
(setq author (match-string-no-properties 1))
(re-search-forward "^summary \\(.+\\)$")
(setq subject (match-string-no-properties 1))
(re-search-forward "^filename \\(.+\\)$")
(setq old-file (match-string-no-properties 1))
(setq commit-info (nconc
(list :sha1 commit :author author
:subject subject :file old-file)
ov-attributes))
;; save it in the hash
(puthash commit commit-info commit-hash))
;; add the current blame-block into the list INFO.
(setq info (cons (list old-line new-line num commit-info)
info))))
;; now do from beginning
(setq info (nreverse info))
(with-current-buffer target-buf
;; for every blame chunk
(dolist (chunk info)
(setq commit-info (nth 3 chunk)
old-line (nth 0 chunk)
new-line (nth 1 chunk)
num (nth 2 chunk)
commit (plist-get commit-info :sha1)
author (plist-get commit-info :author)
subject (plist-get commit-info :subject))
(goto-char (point-min))
(forward-line (1- new-line))
(setq beg (line-beginning-position)
end (save-excursion
(forward-line num)
(line-beginning-position)))
;; mark the blame chunk
(put-text-property beg end :blame chunk)
(put-text-property beg end :navigation commit)
;; make an overlay with blame info as 'before-string
;; on the current chunk.
(setq ov (make-overlay beg end))
(overlay-put ov :blame chunk)
(setq blame (concat
(egg-text (substring-no-properties commit 0 8)
'egg-blame)
blank
(egg-text (format "%-20s" author)
'egg-blame-culprit)
blank
(egg-text subject 'egg-blame-subject)
blank nl))
(overlay-put ov 'before-string blame)
(overlay-put ov 'local-map egg-blame-map))))))
(defsubst egg-file-buffer-blame-off (buffer)
(save-excursion
(save-restriction
(with-current-buffer buffer
(widen)
(mapc (lambda (ov)
(if (overlay-get ov :blame)
(delete-overlay ov)))
(overlays-in (point-min) (point-max)))))))
(defun egg-file-buffer-blame-on (buffer &rest ov-attributes)
(egg-file-buffer-blame-off buffer)
(save-excursion
(with-current-buffer buffer
(save-restriction
(with-temp-buffer
(when (egg--git t "blame" "-w" "-M" "-C" "--porcelain" "--"
(file-name-nondirectory
(buffer-file-name buffer)))
(egg-parse-git-blame buffer (current-buffer)
ov-attributes)))))))
(defun egg-blame-locate-commit (pos &optional all)
"Jump to a commit in the branch history from an annotated blame section.
With prefix argument, the history of all refs is used."
(interactive "d\nP")
(let ((overlays (overlays-at pos))
sha1)
(dolist (ov overlays)
(if (overlay-get ov :blame)
(setq sha1 (plist-get (nth 3 (overlay-get ov :blame)) :sha1))))
(if sha1
(egg-do-locate-commit sha1))))
;;;========================================================
;;; Diff/Hunk
;;;========================================================
(defun egg-mouse-do-command (event cmd)
(let* ((window (posn-window (event-end event)))
(buffer (and window (window-buffer window)))
(position (posn-point (event-end event))))
(when (bufferp buffer)
(save-window-excursion
(save-excursion
(select-window window)
(with-current-buffer buffer
(goto-char position)
(call-interactively cmd)))))))
(defun egg-mouse-hide-show-cmd (event)
(interactive "e")
(egg-mouse-do-command event 'egg-section-cmd-toggle-hide-show))
(defun list-nav ()
(interactive)
(message "nav: %c:%s-%c:%s"
(preceding-char)
(get-text-property (1- (point)) :navigation)
(following-char)
(get-text-property (point) :navigation)))
(defsubst egg-decorate-diff-header (beg end line-beg line-end)
(put-text-property line-beg (1+ beg)
'display
(egg-text
(concat "\n"
(buffer-substring-no-properties beg
(1+ beg)))
'egg-diff-file-header))
(put-text-property (1+ beg) end 'face 'egg-diff-file-header)
(put-text-property (1+ beg) end 'help-echo (egg-tooltip-func)))
(defsubst egg-decorate-cc-diff-header (beg end line-beg line-end)
(put-text-property line-beg (1+ beg)
'display
(egg-text
(concat "\n"
(buffer-substring-no-properties beg
(1+ beg)))
'egg-unmerged-diff-file-header))
(put-text-property (1+ beg) end 'face 'egg-unmerged-diff-file-header)
(put-text-property (1+ beg) end 'help-echo (egg-tooltip-func)))
(defsubst egg-decorate-diff-index-line (beg end line-beg line-end)
(put-text-property line-beg (1+ line-end) 'display ""))
(defsubst egg-decorate-hunk-header (beg end line-beg line-end)
(put-text-property beg end 'face 'egg-diff-hunk-header)
(put-text-property end line-end 'face 'egg-diff-none)
(put-text-property beg end 'help-echo (egg-tooltip-func)))
(defvar egg-internal-buffer-obarray nil)
(defsubst egg-make-navigation (parent child)
"Make a symbolic and unique navigation id.
return a symbol PARENT-CHILD from an internal obarray."
(unless (vectorp egg-internal-buffer-obarray)
(error "Arrg! egg-internal-buffer-obarray is not an obarray!"))
(intern (format "%s-%s" parent child) egg-internal-buffer-obarray))
(defsubst egg-do-compute-navigation (section pos)
"Come up with a symbolic and unique navigation id for
section SECTION at position POS."
(egg-make-navigation (get-text-property pos :navigation)
(if (consp section)
(car section)
section)))
(defun egg-compute-navigation (ignored-1 section pos ignored-2)
"Come up with a symbolic and unique navigation id for
section SECTION at position POS."
(egg-do-compute-navigation section pos))
(defun egg-delimit-section (sect-type section beg end
&optional inv-beg
keymap navigation)
"Mark section for navigation and add local/context keymap.
SECT-TYPE is the type of the section (usually a :symbol).
SECTION is the name of the section (usually a string). BEG and
END are limits of the section. INV-BEG is the position after the
position that would remain visible when the section is hidden.
KEYMAP is the local/context keymap for the section.
NAVIGATION is the navigation id of the section. NAVIGATION can also
a function to call to compute the navigation id of the section."
(let ((nav (cond ((and (not (eq navigation 'file))
(functionp navigation))
(funcall navigation sect-type section beg end))
((null navigation) beg)
(t navigation))))
(put-text-property beg end :sect-type sect-type)
(put-text-property beg end sect-type section)
(put-text-property beg end :navigation nav)
(when (keymapp keymap)
(put-text-property beg end 'keymap keymap))
(when (integer-or-marker-p inv-beg)
(let ((current-inv (get-text-property inv-beg 'invisible)))
(add-to-list 'current-inv nav t)
(put-text-property inv-beg (1- end) 'invisible current-inv)))))
(defsubst egg-make-hunk-info (name beg end diff)
"Build a hunk info NAME from BEG to END based on DIFF.
Hunk info contains name and posistions of the hunk. Positions are offsets
from DIFF because it can the whole diff can be pushed around inside
the buffer.
The fourth element of hunk info is NIL and is a placeholder for
HUNK-RANGES list to be placed there by `egg-calculate-hunk-ranges'
"
(let ((b (nth 1 diff)))
(list name (- beg b) (- end b) nil)))
(defsubst egg-make-diff-info (name beg end head-end)
"Build a diff info NAME from BEG to END. HEAD-END is the end position
of the diff header.
Diff info contains name and posistions of the diff. The beginning position
is stored as a marker and the others are offset from the beginning posistion
because the whole diff can be pushed around inside the buffer."
(let ((b (make-marker))
info)
(set-marker b beg)
;; no insertion indo the diff
(set-marker-insertion-type b t)
;; all other posistions are offsets from B.
(setq info (list name b (- end beg) (- head-end beg)))
(save-match-data
(save-excursion
(goto-char beg)
(if (re-search-forward "new file mode" head-end t)
(setq info (nconc info (list 'newfile))))))
info))
(defun egg-decorate-diff-sequence (args)
"Decorate a sequence of deltas. ARGS is a plist containing the
positions of the sequence as well as the decorations.
:begin :end :diff-map :hunk-map :cc-diff-map :cc-hunk-map
:conflict-map :src-prefix :dst-prefix
"
(let* ((beg (plist-get args :begin))
(end (plist-get args :end))
(diff-map (plist-get args :diff-map))
(hunk-map (plist-get args :hunk-map))
(cc-diff-map (plist-get args :cc-diff-map))
(cc-hunk-map (plist-get args :cc-hunk-map))
(conflict-map (plist-get args :conflict-map))
(a (plist-get args :src-prefix))
(b (plist-get args :dst-prefix))
;; the sub match id of the regexp below
(diff-no 1)
(cc-diff-no 2)
(hunk-no 3)
(cc-hunk-no 4)
(src-no 5)
(dst-no 6)
(index-no 7)
(conf-beg-no 8)
(conf-div-no 9)
(conf-end-no 10)
(cc-del-no 11)
(cc-add-no 12)
(del-no 13)
(add-no 14)
(none-no 15)
(regexp
(concat "^\\(?:"
"diff --git " a ".+ " b "\\(.+\\)\\|" ;1 diff header
"diff --cc \\(.+\\)\\|" ;2 cc-diff header
"\\(@@ .+@@\\).*\\|" ;3 hunk
"\\(@@@ .+@@@\\).*\\|" ;4 cc-hunk
"--- " a "\\(.+\\)\\|" ;5 src
"\\+\\+\\+ " b "\\(.+\\)\\|" ;6 dst
"index \\(.+\\)\\|" ;7 index
"\\+\\+<<<<<<< \\(.+\\)\\(?::.+\\)?\\|";8 conflict start
"\\(\\+\\+=======\\)\\|" ;9 conflict div
"\\+\\+>>>>>>> \\(.+\\)\\(?::.+\\)?\\|";10 conflict end
"\\( -.*\\)\\|" ;11 cc-del
"\\( \\+.*\\)\\|" ;12 cc-add
"\\(-.*\\)\\|" ;13 del
"\\(\\+.*\\)\\|" ;14 add
"\\( .*\\)" ;15 none
"\\)$"))
;; where the hunk end?
(hunk-end-re "^\\(?:diff \\|@@\\|\\* \\)")
;; where the diff end?
(diff-end-re "^\\(?:diff \\|\\* \\)")
sub-beg sub-end head-end m-b-0 m-e-0 m-b-x m-e-x
last-diff last-cc current-delta-is tmp pos)
(save-match-data
(save-excursion
(goto-char beg)
(while (re-search-forward regexp end t)
(setq sub-beg (match-beginning 0)
m-b-0 sub-beg
m-e-0 (match-end 0))
(cond ((or (match-beginning del-no)
(and (match-beginning cc-del-no) (eq current-delta-is 'cc-diff))) ;; del
(put-text-property m-b-0 m-e-0 'face 'egg-diff-del))
((or (match-beginning add-no)
(and (match-beginning cc-add-no) (eq current-delta-is 'cc-diff))) ;; add
(put-text-property m-b-0 m-e-0 'face 'egg-diff-add))
((match-beginning none-no) ;; unchanged
(put-text-property m-b-0 m-e-0 'face 'egg-diff-none))
((match-beginning dst-no) ;; +++ b/file
(setq m-b-x (match-beginning dst-no)
m-e-x (match-end dst-no))
(put-text-property m-b-0 m-b-x 'face 'egg-diff-add)
(put-text-property m-b-x m-e-x 'face 'egg-diff-none))
((match-beginning src-no) ;; --- a/file
(setq m-b-x (match-beginning src-no)
m-e-x (match-end src-no))
(put-text-property m-b-0 m-b-x 'face 'egg-diff-del)
(put-text-property m-b-x m-e-x 'face 'egg-diff-none))
((match-beginning conf-beg-no) ;;++<<<<<<<
(setq m-b-x (match-beginning conf-beg-no)
m-e-x (match-end conf-beg-no)
tmp (match-string-no-properties conf-beg-no))
(put-text-property m-b-0 m-b-x 'face 'egg-diff-conflict)
(put-text-property m-b-x m-e-x 'face 'egg-branch-mono)
(put-text-property m-e-x m-e-0 'face 'egg-diff-none)
(setq pos (egg-safe-search "^++=======" end))
(add-text-properties m-b-0 pos (list :conflict-side 'ours
:conflict-head tmp))
;; mark the whole conflict section
(setq sub-end (egg-safe-search "^++>>>>>>>.+\n" end nil nil t))
(egg-delimit-section :conflict (cons sub-beg sub-end) sub-beg sub-end
(+ m-b-0 9) conflict-map 'egg-compute-navigation))
((match-beginning conf-end-no) ;;++>>>>>>>
(setq m-b-x (match-beginning conf-end-no)
m-e-x (match-end conf-end-no)
tmp (match-string-no-properties conf-end-no))
;; just decorate, no mark.
;; the section was already mark when the conf-beg-no
;; matched.
(setq pos (egg-safe-search "^++=======" beg nil t t))
(add-text-properties pos (1+ m-e-0) (list :conflict-side 'theirs
:conflict-head tmp))
(put-text-property m-b-0 m-b-x 'face 'egg-diff-conflict)
(put-text-property m-b-x m-e-x 'face 'egg-branch-mono)
(put-text-property m-e-x m-e-0 'face 'egg-diff-none))
((match-beginning conf-div-no) ;;++=======
;; just decorate, no mark.
;; the section was already mark when the conf-beg-no
;; matched.
(put-text-property m-b-0 m-e-0 'face 'egg-diff-conflict))
((match-beginning hunk-no) ;; hunk @@
(setq m-b-x (match-beginning hunk-no)
m-e-x (match-end hunk-no)
;; find the end of the hunk section
sub-end (or (egg-safe-search hunk-end-re end)
end))
;; decorate the header
(egg-decorate-hunk-header m-b-x m-e-x m-b-0 m-e-0)
;; mark the whole hunk based on the last diff header
(egg-delimit-section
:hunk (egg-make-hunk-info
(match-string-no-properties hunk-no)
sub-beg sub-end last-diff)
sub-beg sub-end m-e-0 hunk-map
'egg-compute-navigation))
((match-beginning cc-hunk-no) ;; cc-hunk
(setq m-b-x (match-beginning cc-hunk-no)
m-e-x (match-end cc-hunk-no)
;; find the end of the hunk section
sub-end (or (egg-safe-search hunk-end-re end)
end))
;; decorate the header
(egg-decorate-hunk-header m-b-x m-e-x m-b-0 m-e-0)
;; mark the whole hunk based on the last cc-diff header
(egg-delimit-section
:hunk (egg-make-hunk-info
(match-string-no-properties cc-hunk-no)
sub-beg sub-end last-cc)
sub-beg sub-end m-e-0 cc-hunk-map
'egg-compute-navigation))
((match-beginning diff-no) ;; diff
(setq m-b-x (match-beginning diff-no)
m-e-x (match-end diff-no)
sub-end (or (egg-safe-search diff-end-re end) end)
;; find the end of the header
head-end (or (egg-safe-search "^\\(@@\\|diff\\)" end) end))
;; decorate the header
(egg-decorate-diff-header m-b-x m-e-x m-b-0 m-e-0)
;; mark the whole diff
(egg-delimit-section
:diff (setq last-diff
(egg-make-diff-info
(match-string-no-properties diff-no)
sub-beg sub-end head-end))
sub-beg sub-end m-e-0 diff-map 'egg-compute-navigation)
(put-text-property (- sub-end 2) sub-end 'intangible t)
(setq current-delta-is 'diff))
((match-beginning cc-diff-no) ;; cc-diff
(setq m-b-x (match-beginning cc-diff-no)
m-e-x (match-end cc-diff-no)
sub-end (or (egg-safe-search diff-end-re end) end)
;; find the end of the header
head-end (or (egg-safe-search "^\\(@@@\\|diff\\)" end) end))
;; decorate the header
(egg-decorate-cc-diff-header m-b-x m-e-x m-b-0 m-e-0)
;; mark the whole diff
(egg-delimit-section
:diff (setq last-cc
(egg-make-diff-info
(match-string-no-properties cc-diff-no)
sub-beg sub-end head-end))
sub-beg sub-end m-e-0 cc-diff-map
'egg-compute-navigation)
(put-text-property (- sub-end 2) sub-end 'intangible t)
(setq current-delta-is 'cc-diff))
((match-beginning index-no) ;; index
(setq m-b-x (match-beginning index-no)
m-e-x (match-end index-no))
(egg-decorate-diff-index-line m-b-x m-e-x m-b-0 m-e-0))
) ;; cond
) ;; while
) ;; save-excursion
) ;;; save -match-data
nil))
(defun egg-decorate-diff-section (&rest args)
"Decorate a section containing a sequence of diffs.
See `egg-decorate-diff-sequence'."
(let ((beg (plist-get args :begin))
(end (plist-get args :end))
(a (or (plist-get args :src-prefix) "a/"))
(b (or (plist-get args :dst-prefix) "b/"))
(a-rev (plist-get args :src-revision))
(b-rev (plist-get args :dst-revision)))
(when (stringp a-rev)
(put-text-property beg end :src-revision a-rev))
(when (stringp b-rev)
(put-text-property beg end :dst-revision b-rev))
(egg-decorate-diff-sequence
(nconc (list :src-prefix a :dst-prefix b) args))))
(defsubst egg-hunk-info-at (pos)
"Rebuild the hunk info at POS.
Hunk info are relative offsets. This function compute the
physical offsets. The hunk-line may be NIL if this is not status
or commit buffer and `egg-calculate-hunk-ranges' was
not called"
(let* ((diff-info (get-text-property pos :diff))
(head-beg (nth 1 diff-info))
(hunk-info (get-text-property pos :hunk))
(hunk-beg (and hunk-info (+ (nth 1 hunk-info) head-beg)))
(hunk-end (and hunk-info (+ (nth 2 hunk-info) head-beg)))
(hunk-ranges (and hunk-info (nth 3 hunk-info))))
(and hunk-info
(list (car diff-info) (car hunk-info) hunk-beg hunk-end hunk-ranges))))
(defun egg-diff-section-cmd-visit-file (file)
"Visit file FILE."
(interactive (list (car (get-text-property (point) :diff))))
(find-file file))
(defun egg-staged-diff-section-cmd-visit-index (file &optional use-wdir-file)
"Visit the index of FILE.
With C-u prefix, visit the work-tree's file instead."
(interactive (list (car (get-text-property (point) :diff))
current-prefix-arg))
(if use-wdir-file
(find-file file)
(egg-buffer-pop-to-file file ":0")))
(defun egg-staged-diff-section-cmd-visit-index-other-window (file &optional use-wdir-file)
(interactive (list (car (get-text-property (point) :diff))
current-prefix-arg))
(if use-wdir-file
(find-file-other-window file)
(egg-buffer-pop-to-file file ":0" t)))
(defun egg-staged-hunk-cmd-visit-index-other-window (use-wdir-file file hunk-header hunk-beg &rest ignored)
(interactive (cons current-prefix-arg (egg-hunk-info-at (point))))
(egg-buffer-pop-to-file file
(unless use-wdir-file ":0")
t
use-wdir-file
(egg-hunk-compute-line-no hunk-header hunk-beg)))
(defun egg-staged-hunk-cmd-visit-index (use-wdir-file file hunk-header hunk-beg &rest ignored)
(interactive (cons current-prefix-arg (egg-hunk-info-at (point))))
(egg-buffer-pop-to-file file
(unless use-wdir-file ":0")
nil
use-wdir-file
(egg-hunk-compute-line-no hunk-header hunk-beg)))
(defun egg-diff-section-cmd-visit-file-other-window (file)
"Visit file FILE in other window."
(interactive (list (car (get-text-property (point) :diff))))
(find-file-other-window file))
(defun egg-unmerged-section-cmd-ediff3 (file)
"Run ediff3 to resolve merge conflicts in FILE."
(interactive (list (car (get-text-property (point) :diff))))
(egg-resolve-merge-with-ediff file))
(defun egg-unstaged-section-cmd-ediff (file)
"Compare FILE and its staged copy using ediff."
(interactive (list (car (get-text-property (point) :diff))))
(egg--ediff-file-revs file nil nil ":0" "INDEX"))
(defun egg-staged-section-cmd-ediff3 (file &optional ediff2)
"Compare the staged copy of FILE and the version in HEAD using ediff."
(interactive (list (car (get-text-property (point) :diff)) current-prefix-arg))
(if ediff2
(egg--ediff-file-revs file ":0" "INDEX" (egg-branch-or-HEAD) nil)
(egg--ediff-file-revs file nil nil ":0" "INDEX" (egg-branch-or-HEAD) nil)))
(defvar egg-diff-buffer-info nil
"Data for the diff buffer.
This is built by `egg-build-diff-info'")
(defun egg-diff-section-cmd-ediff (file pos)
"Ediff src and dest versions of FILE based on the diff at POS."
(interactive (list (car (get-text-property (point) :diff))
(point)))
(let ((commit (get-text-property pos :commit))
(diff-info egg-diff-buffer-info))
(cond ((stringp commit)
(egg--commit-do-ediff-file-revs (egg-pretty-short-rev commit) file))
((consp diff-info)
(egg--diff-do-ediff-file-revs diff-info file)))))
(defun egg-hunk-compute-line-no (hunk-header hunk-beg &optional hunk-ranges)
"Calculate the effective line number in the original file based
on the position of point in a hunk. HUNK-HEADER is the header and
HUNK-BEG is the starting position of the current hunk."
(let ((limit (line-end-position))
(line
(or
(when hunk-ranges
;; 3rd element of real range
(third (third hunk-ranges)))
(string-to-number
(nth 2 (save-match-data
(split-string hunk-header "[ @,\+,-]+" t))))))
(adjust 0))
(save-excursion
(goto-char hunk-beg)
(forward-line 1)
(end-of-line)
(while (and (< (point) limit)
(re-search-forward "^\\(?:\\+\\| \\).*" limit t))
(setq adjust (1+ adjust))))
(+ line adjust)))
(defun egg-hunk-section-cmd-visit-file (file hunk-header hunk-beg hunk-end
hunk-ranges &rest ignored)
"Visit FILE and goto the current line of the hunk."
(interactive (egg-hunk-info-at (point)))
(let ((line (egg-hunk-compute-line-no hunk-header hunk-beg hunk-ranges)))
(find-file file)
(goto-char (point-min))
(forward-line (1- line))))
(defun egg-hunk-section-cmd-visit-file-other-window (file hunk-header hunk-beg hunk-end
hunk-ranges &rest ignored)
"Visit FILE in other-window and goto the current line of the hunk."
(interactive (egg-hunk-info-at (point)))
(let ((line (egg-hunk-compute-line-no hunk-header hunk-beg hunk-ranges)))
(find-file-other-window file)
(goto-char (point-min))
(forward-line (1- line))))
(defun egg-unmerged-conflict-checkout-side (pos)
"Checkout one side of the conflict at POS."
(interactive "d")
(let* ((side (or (get-text-property pos :conflict-side) "theirs"))
(head (or (get-text-property pos :conflict-head) "ours"))
(file (car (get-text-property pos :diff))))
(unless (memq :unmerged (assoc file egg-status-buffer-changed-files-status))
(error "Not an unmerged file: %s" file))
(when (y-or-n-p (format "use %s's contents for unmerged file %s? " head file))
(when (egg-status-buffer-handle-result
(egg--git-co-files-cmd (current-buffer) file (concat "--" (symbol-name side))))
(when (y-or-n-p (format "stage %s? " file))
(egg-status-buffer-handle-result (egg--git-add-cmd (current-buffer) file)))))))
(defun egg-unmerged-conflict-take-side (pos)
"Interactive resolve conflict at POS."
(interactive "d")
(let* ((hunk-info (egg-hunk-info-at pos))
(file (and hunk-info (car hunk-info)))
(hunk-header (and hunk-info (nth 1 hunk-info)))
(hunk-beg (and hunk-info (nth 2 hunk-info)))
(hunk-end (and hunk-info (nth 3 hunk-info)))
(hunk-ranges (and hunk-info (nth 4 hunk-info)))
(line (and hunk-info (egg-hunk-compute-line-no hunk-header hunk-beg hunk-ranges)))
(side (get-text-property pos :conflict-side))
our-head their-head resolution)
(save-window-excursion
(save-excursion
(with-current-buffer (find-file-noselect file)
(select-window (display-buffer (current-buffer)))
(let (conf-beg conf-end ours-beg ours-end theirs-beg theirs-end
ours theirs conflict bg)
(goto-char (point-min))
(forward-line (1- line))
(if (eq side 'theirs)
(progn
(unless (re-search-backward "^<<<<<<< \\(.+\\)\n" nil t)
(error "Failed searching for <<<<<<<"))
(setq our-head (match-string-no-properties 1))
(setq conf-beg (copy-marker (match-beginning 0) nil))
(setq ours-beg (match-end 0))
(unless (re-search-forward "^=======\n" nil t)
(error "Failed searching for ======="))
(setq ours-end (match-beginning 0))
(setq theirs-beg (match-end 0))
(unless (re-search-forward "^>>>>>>> \\(.+\\)\n")
(error "Failed searching for >>>>>>>"))
(setq their-head (match-string-no-properties 1))
(setq theirs-end (match-beginning 0))
(setq conf-end (copy-marker (match-end 0) t)))
(unless (re-search-forward "^>>>>>>> \\(.+\\)\n")
(error "Failed searching for >>>>>>>"))
(setq their-head (match-string-no-properties 1))
(setq theirs-end (match-beginning 0))
(setq conf-end (copy-marker (match-end 0) t))
(unless (re-search-backward "^=======\n" nil t)
(error "Failed searching for ======="))
(setq ours-end (match-beginning 0))
(setq theirs-beg (match-end 0))
(unless (re-search-backward "^<<<<<<< \\(.+\\)\n" nil t)
(error "Failed searching for <<<<<<<"))
(setq our-head (match-string-no-properties 1))
(setq ours-beg (match-end 0))
(setq conf-beg (copy-marker (match-beginning 0) nil)))
(setq ours (buffer-substring-no-properties ours-beg ours-end))
(setq theirs (buffer-substring-no-properties theirs-beg theirs-end))
(setq conflict (buffer-substring-no-properties conf-beg conf-end))
(goto-char conf-beg)
(delete-region conf-beg conf-end)
(insert (if (eq side 'theirs) theirs ours))
(setq bg (make-overlay conf-beg conf-end nil nil t))
(overlay-put bg 'face 'egg-add-bg)
(setq resolution
(if (y-or-n-p (format "keep %s's delta? "
(if (eq side 'theirs) their-head our-head)))
side
(goto-char conf-beg)
(delete-region conf-beg conf-end)
(insert (if (eq side 'theirs) ours theirs))
(setq bg (move-overlay bg conf-beg conf-end))
(if (y-or-n-p (format "keep %s's delta? "
(if (eq side 'theirs) our-head their-head)))
(if (eq side 'theirs) 'ours 'theirs)
nil)))
(if resolution
(basic-save-buffer)
(goto-char conf-beg)
(delete-region conf-beg conf-end)
(insert conflict)
(set-buffer-modified-p nil))
(delete-overlay bg)))))
(when resolution
(egg-buffer-cmd-refresh)
;; (when (egg-git-ok nil "diff" "--cc" "--quiet" file)
;; (when (y-or-n-p (format "no more conflict in %s, stage %s? " file file))
;; (egg-status-buffer-handle-result (egg--git-add-cmd (current-buffer) file))))
)))
(defun egg-hunk-compute-replacement-text (hunk-info)
(let ((file (nth 0 hunk-info))
(b-beg (nth 2 hunk-info))
(b-end (nth 3 hunk-info))
(ranges (nth 4 hunk-info))
range
new-1st-line new-num-lines
old-1st-line old-num-lines
hunk-text new-text old-text
old-ranges new-ranges
start-c current-prefix current-range)
(setq range (nth 1 ranges))
(setq old-1st-line (nth 0 range)
old-num-lines (nth 1 range)
new-1st-line (nth 2 range)
new-num-lines (nth 3 range))
(setq hunk-text (buffer-substring-no-properties
(save-excursion
(goto-char b-beg)
(forward-line 1)
(point))
b-end))
(with-temp-buffer
(erase-buffer)
(insert hunk-text)
(goto-char (point-min))
(flush-lines "^\\+")
(goto-char (point-min))
(while (not (eobp))
(delete-char 1)
(forward-line 1))
(setq old-text (buffer-string))
(erase-buffer)
(insert hunk-text)
(goto-char (point-min))
(flush-lines "^-")
(goto-char (point-min))
(while (not (eobp))
(delete-char 1)
(forward-line 1))
(setq new-text (buffer-string))
(erase-buffer)
(insert hunk-text)
(goto-char (point-min))
(setq current-prefix (char-after))
(while (not (eobp))
(setq start-c (char-after))
(delete-char 1)
(unless (= start-c current-prefix)
(cond ((eq current-prefix ?+)
(setcdr current-range (1- (point)))
(push current-range new-ranges))
((eq current-prefix ?-)
(setcdr current-range (1- (point)))
(push current-range old-ranges)))
(setq current-range (list (1- (point))))
(setq current-prefix start-c))
(forward-line 1))
(unless (eq current-prefix ? )
(cond ((eq current-prefix ?+)
(setcdr current-range (1- (point)))
(push current-range new-ranges))
((eq current-range ?-)
(setcdr current-range (1- (point)))
(push current-range old-ranges))))
(setq hunk-text (buffer-string)))
(list file
(list old-1st-line old-num-lines old-text)
(list new-1st-line new-num-lines new-text)
(list old-ranges new-ranges hunk-text))))
(defun egg-section-cmd-toggle-hide-show (nav)
"Toggle the hidden state of the current section."
(interactive (list (get-text-property (point) :navigation)))
;; emacs's bug? caused by tooltip
(if (eq buffer-invisibility-spec t)
(setq buffer-invisibility-spec nil))
(if (assoc nav buffer-invisibility-spec)
(remove-from-invisibility-spec (cons nav t))
(add-to-invisibility-spec (cons nav t)))
(force-window-update (current-buffer)))
(defun egg-section-cmd-toggle-hide-show-children (pos sect-type)
"Toggle the hidden state of the subsections of the current section."
(interactive (list (previous-single-property-change (1+ (point))
:navigation)
(get-text-property (point) :sect-type)))
(unless pos
(setq pos (point)))
(let ((end (next-single-property-change pos sect-type nil (point-max)))
child-pos child-nav
currently-hidden)
;; guess the current state
(setq child-pos (next-single-property-change pos :navigation nil end))
(when child-pos
(setq child-nav (get-text-property child-pos :navigation))
(setq currently-hidden (and child-nav
(assoc child-nav
buffer-invisibility-spec))))
(setq child-pos pos)
;; toggle every child
(while (< (setq child-pos (next-single-property-change child-pos :navigation nil end))
end)
(setq child-nav (get-text-property child-pos :navigation))
(if currently-hidden
(remove-from-invisibility-spec (cons child-nav t))
(add-to-invisibility-spec (cons child-nav t))))
(force-window-update (current-buffer))))
(defun egg-diff-section-patch-string (&optional pos)
"Build a file patch based on the diff section at POS."
(let* ((diff-info (get-text-property (or pos (point)) :diff))
(beg (nth 1 diff-info))
(end (+ (nth 2 diff-info) beg)))
(buffer-substring-no-properties beg end)))
(defun egg-hunk-section-patch-string (&optional pos reverse)
"Build a single hunk patch based on the delta hunk at POS."
(let* ((diff-info (get-text-property (or pos (point)) :diff))
(head-beg (nth 1 diff-info))
(head-end (+ (nth 3 diff-info) head-beg))
(hunk-info (get-text-property (or pos (point)) :hunk))
(hunk-beg (+ (nth 1 hunk-info) head-beg))
(hunk-end (+ (nth 2 hunk-info) head-beg)))
;; craete diff patch
(if (egg-use-region-p)
(egg-hunk-section-patch-region-string pos diff-info reverse)
(concat (buffer-substring-no-properties head-beg head-end)
(buffer-substring-no-properties hunk-beg hunk-end)))))
(defun egg-hunk-section-patch-region-string (pos diff-info reverse)
"Build a patch string usable as input for git apply.
The patch is built based on the hunk enclosing POS. DIFF-INFO
is the file-level diff information enclosing the hunk. Build a
reversed patch if REVERSE was non-nil."
(let* ((head-beg (nth 1 diff-info))
(head-end (+ (nth 3 diff-info) head-beg))
(hunk-info (get-text-property (or pos (point)) :hunk))
(hunk-beg (+ (nth 1 hunk-info) head-beg))
(hunk-end (+ (nth 2 hunk-info) head-beg))
(beg (region-beginning))
(end (region-end))
(hunk-buf (current-buffer)))
(with-temp-buffer
(let ((buf (current-buffer)))
(with-current-buffer hunk-buf
;; insert header
(egg-insert-string-buffer
(buffer-substring-no-properties head-beg head-end) buf)
(goto-char hunk-beg)
;; insert beginning of hunk
(egg-insert-current-line-buffer buf)
(forward-line)
(let ((copy-op (if reverse "+" "-")))
(while (< (point) hunk-end)
(if (and (<= beg (point)) (< (point) end))
(egg-insert-current-line-buffer buf)
(cond ((looking-at " ")
(egg-insert-current-line-buffer buf))
((looking-at copy-op)
(egg-insert-string-buffer
(concat
" "
(buffer-substring-no-properties
(+ (point) 1) (line-beginning-position 2))) buf))))
(forward-line))))
;; with current buffer `buf'
(diff-fixup-modifs (point-min) (point-max))
(buffer-string)))))
;;;========================================================
;;; Buffer
;;;========================================================
;; (defun egg-buffer-cmd-refresh ()
;; "Refresh the current egg special buffer."
;; (interactive)
;; (when (and (egg-git-dir)
;; (functionp egg-buffer-refresh-func))
;; (funcall egg-buffer-refresh-func (current-buffer))))
(defun egg-buffer-cmd-refresh ()
"Refresh the current egg special buffer."
(interactive)
(when (egg-git-dir)
(egg-refresh-buffer (current-buffer))))
(defun egg-buffer-cmd-next-block (nav-prop)
"Move to the next block indentified by text property NAV-PROP."
(goto-char (or (next-single-property-change (point) nav-prop)
(point))))
(defun egg-buffer-cmd-prev-block (nav-prop)
"Move to the previous block indentified by text property NAV-PROP."
(goto-char (previous-single-property-change (point) nav-prop
nil (point-min))))
(defun egg-buffer-cmd-navigate-next (&optional at-level)
"Move to the next section.
With C-u prefix, move to the next section of the same type."
(interactive "P")
(egg-buffer-cmd-next-block
(if (not at-level) :navigation
(or (get-text-property (point) :sect-type) :navigation))))
(defun egg-buffer-cmd-navigate-prev (&optional at-level)
"Move to the previous section.
With C-u prefix, move to the previous section of the same type."
(interactive "P")
(egg-buffer-cmd-prev-block
(if (not at-level) :navigation
(or (get-text-property (point) :sect-type) :navigation))))
(defun egg-get-buffer (fmt create)
"Get a special egg buffer. If buffer doesn't exist and CREATE was not nil then
creat the buffer. FMT is used to construct the buffer name. The name is built
as: (format FMT current-dir-name git-dir-full-path)."
(let* ((git-dir (egg-git-dir))
(dir (egg-work-tree-dir git-dir))
(dir-name (egg-repo-name git-dir))
(buf-name (format fmt dir-name git-dir))
(default-directory dir)
(buf (get-buffer buf-name)))
(unless (or (bufferp buf) (not create))
(setq buf (get-buffer-create buf-name)))
buf))
(defvar egg-orig-window-config nil)
(defun egg-quit-buffer (&optional win)
"Leave (and burry) an egg special buffer"
(interactive)
(let ((orig-win-cfg egg-orig-window-config)
(mode major-mode))
(quit-window (memq 'kill (cdr (assq mode egg-quit-window-actions))) win)
(if (and orig-win-cfg
(window-configuration-p orig-win-cfg)
(memq 'restore-windows (cdr (assq mode egg-quit-window-actions))))
(set-window-configuration orig-win-cfg))))
(defmacro define-egg-buffer (type name-fmt &rest body)
"Define an egg-special-file type."
(let* ((type-name (symbol-name type))
(get-buffer-sym (intern (concat "egg-get-" type-name "-buffer")))
(buffer-mode-sym (intern (concat "egg-" type-name "-buffer-mode")))
(buffer-mode-hook-sym (intern (concat "egg-" type-name "-buffer-mode-hook")))
(buffer-mode-map-sym (intern (concat "egg-" type-name "-buffer-mode-map")))
(update-buffer-no-create-sym (intern (concat "egg-update-" type-name "-buffer-no-create"))))
`(progn
(defun ,buffer-mode-sym ()
,@body
(set (make-local-variable 'egg-orig-window-config)
(current-window-configuration))
;; (message "buffer %s win-cfg %s" (buffer-name) egg-orig-window-config)
(set (make-local-variable 'egg-internal-buffer-obarray)
(make-vector 67 0)))
(defun ,get-buffer-sym (&optional create)
(let ((buf (egg-get-buffer ,name-fmt create)))
(when (bufferp buf)
(with-current-buffer buf
(unless (and (not create) (eq major-mode ',buffer-mode-sym))
(,buffer-mode-sym))))
buf))
,(unless (string-match ":" type-name)
`(progn
(defun ,update-buffer-no-create-sym ()
(let ((buf (,get-buffer-sym)))
(when (bufferp buf)
(egg-refresh-buffer buf))))
(add-hook 'egg-buffers-refresh-hook ',update-buffer-no-create-sym))))))
;; (cl-macroexpand '(define-egg-buffer diff "*diff-%s@egg:%s*"))
;; (cl-macroexpand ' (define-egg-buffer diff (buf) "*diff-%s@egg:%s*" (show-diff buf) ))
;;;========================================================
;;; Status Buffer
;;;========================================================
(defun egg-buffer-do-rebase (upstream-or-action &optional onto current-action)
"Perform rebase action from an egg special buffer.
See `egg-do-rebase-head'."
(let ((rebase-dir (plist-get (egg-repo-state :rebase-dir) :rebase-dir))
(git-dir (egg-git-dir))
res)
(if (stringp upstream-or-action)
(unless (egg-repo-clean)
(egg-status nil nil)
(error "Repo %s is not clean" git-dir))
(unless rebase-dir
(error "No rebase in progress in directory %s"
(egg-work-tree-dir git-dir))))
(egg-do-rebase-head upstream-or-action onto current-action)))
(defun egg-buffer-rebase-continue ()
"Continue the current rebase session."
(interactive)
(message "continue with current rebase")
(egg-buffer-do-rebase :continue nil
(cdr (assq major-mode '((egg-status-buffer-mode . status)
(egg-log-buffer-mode . log))))))
(defsubst egg-do-async-rebase-continue (callback closure &optional
action
exit-code)
"Continue the current rebase session asynchronously."
(let ((process-environment (copy-sequence process-environment))
(action (or action "--continue"))
(buffer (current-buffer))
proc)
(setenv "EDITOR" "\nplease commit in egg")
(setq proc (egg-async-1 (list callback closure) "rebase" action))
(process-put proc :orig-buffer buffer)
proc))
(defun egg-buffer-selective-rebase-action (action)
"Perform ACTION to continue the current rebase session.
The mode, sync or async, will depend on the nature of the current
rebase session."
(if (not (egg-interactive-rebase-in-progress))
(egg-buffer-do-rebase action nil
(cdr (assq major-mode '((egg-status-buffer-mode . status)
(egg-log-buffer-mode . log)))))
(setq action (cdr (assq action '((:skip . "--skip")
(:continue . "--continue")
(:abort . "--abort")))))
(with-egg-debug-buffer
(egg-do-async-rebase-continue
#'egg-handle-rebase-interactive-exit
(egg-pick-file-contents (concat (egg-git-rebase-dir) "head-name") "^.+$")
action))))
(defun egg-buffer-selective-rebase-continue ()
"Continue the current rebase session.
The mode, sync or async, will depend on the nature of the current
rebase session."
(interactive)
(message "continue with current rebase")
(egg-buffer-selective-rebase-action :continue))
(defun egg-buffer-selective-rebase-skip ()
"Skip the current commit and continue the current rebase session.
The mode, sync or async, will depend on the nature of the current
rebase session."
(interactive)
(message "skip rebase's current commit")
(egg-buffer-selective-rebase-action :skip))
(defun egg-buffer-rebase-abort ()
(interactive)
(message "abort current rebase")
(egg-buffer-do-rebase :abort nil
(cdr (assq major-mode '((egg-status-buffer-mode . status)
(egg-log-buffer-mode . log))))))
(defvar egg-status-buffer-changed-files-status nil)
(defvar egg-status-buffer-interactive-stash-info nil)
(defun egg-sb-setup-interactive-stash ()
(make-local-variable 'egg-status-buffer-interactive-stash-info)
(let ((dir (egg-work-tree-dir))
(stash-index-file (make-temp-name (concat (egg-git-dir) "/index.stash.")))
info base-commit index-commit index-tree
branch head-desc
worktree-unchanged index-unchanged)
(with-current-buffer "*i-stash-debug*"
(erase-buffer)
(setq default-directory dir)
(setq index-unchanged (egg-git-ok t "diff-index" "--exit-code" "--cached" "HEAD"
"--ignore-submodules"))
(setq worktree-unchanged (egg-git-ok t "diff-files" "--exit-code"
"--ignore-submodules"))
(when (and worktree-unchanged index-unchanged)
(error "nothing to stash"))
(unless (egg-git-ok t "update-index" "--refresh")
(error "git update-index failed!"))
(setq base-commit (egg-git-to-string "rev-parse" "--verify" "HEAD"))
(setq head-desc (egg-git-to-string "rev-list" "--oneline" "-n1" "HEAD" "--"))
(setq branch (or (egg-current-branch) "(no branch)"))
(setq index-tree (egg-git-to-string "write-tree"))
(unless index-tree
(error "git write-tree failed to write original index to database."))
(setq index-commit (egg-git-to-string "commit-tree" "-p" base-commit
"-m"
(format "index on %s: %s" branch head-desc)
index-tree))
(unless index-commit
(error "git commit-tree failed to create commit object for original index"))
(unless (egg-git-ok t "read-tree" (format "--index-output=%s" stash-index-file)
"HEAD")
(error "git read-tree failed read HEAD into stash index file %s"
stash-index-file))
(setq info (list :stash-index-file stash-index-file
:base-commit base-commit
:index-commit index-commit
:branch branch
:head-desc head-desc)))
(setq egg-status-buffer-interactive-stash-info info)
(egg-status nil t)
(set (make-local-variable 'egg--internal-index-file) stash-index-file)))
(defun egg-sb-istash-abort ()
(interactive)
(unless (consp egg-status-buffer-interactive-stash-info)
(error "Something wrong, no interactive stash session is in progress!"))
(let ((info egg-status-buffer-interactive-stash-info))
(setq egg--internal-index-file nil)
(delete-file (plist-get info :stash-index-file))
(egg-status nil t)))
(defun egg-sb-istash-go ()
(interactive)
(unless (consp egg-status-buffer-interactive-stash-info)
(error "Something wrong, no interactive stash session is in progress!"))
(let ((info egg-status-buffer-interactive-stash-info)
(msg (read-string "Sort message for this WiP: "))
(stash-ref-file (concat (egg-git-dir) "/refs/stash"))
worktree-commit workdir-tree old-stash patch res)
(setq workdir-tree (egg-git-to-string "write-tree"))
(setq msg (format "On %s: %s" (plist-get info :branch) msg))
(setq patch (egg-git-to-string "diff-tree" "HEAD" workdir-tree))
(unless (> (length patch) 1)
(error "No changes selected to stash!"))
(setq worktree-commit (egg-git-to-string "commit-tree"
"-p" (plist-get info :base-commit)
"-p" (plist-get info :index-commit)
"-m" msg workdir-tree))
(when (file-exists-p stash-ref-file)
(setq old-stash (egg-git-to-string "rev-parse" "--verify" "refs/stash"))
(egg--git "update-ref" "-d" "refs/stash" old-stash))
(write-region (point-min) (point-min) stash-ref-file t)
(unless (egg-git-ok "update-ref" "-m" msg "refs/stash" worktree-commit)
(error "Failed to stash WiP!"))
(setq egg--internal-index-file nil)
(delete-file (plist-get info :stash-index-file))
(setq egg-status-buffer-interactive-stash-info nil)
(if (y-or-n-p "Discard unstashed local changes? ")
(egg-sb-undo-wdir-back-to-HEAD t t 'status)
(egg-status-buffer-handle-result
(egg--git-apply-cmd (current-buffer) patch (list "--reverse"))))))
(defun egg-sb-interactive-stash-wip ()
(message "TBD"))
(defun egg-sb-insert-repo-section ()
"Insert the repo section into the status buffer."
(let* ((state (egg-repo-state))
(sha1 (plist-get state :sha1))
(beg (point))
(map egg-section-map)
(rebase-step (plist-get state :rebase-step))
(rebase-num (plist-get state :rebase-num))
(rebase-stopped-sha (plist-get state :rebase-stopped))
inv-beg help-beg help-inv-beg rebase-beg)
(unless (and sha1 state)
(error "Invalid repo state: sha1 = %s, state = %S"
sha1 state))
;; head, sha1 and git-dir
(insert (egg-text (egg-pretty-head-string state) 'egg-branch) "\n"
(egg-text sha1 'font-lock-string-face) "\n"
(egg-text (plist-get state :gitdir) 'font-lock-constant-face)
"\n")
;; invisibility start at the newline
(setq inv-beg (1- (point)))
(when egg-status-buffer-interactive-stash-info
;; Interactive stash info
(insert (egg-text "Interactive stashing in progress\n" 'egg-text-2)
(egg-text "s: Select/Unselect deltas for stashing\n" 'egg-text-1)))
(when rebase-step
;; Rebase info and keybindings
(insert (format "Rebase: commit %s of %s" rebase-step rebase-num))
(when rebase-stopped-sha
(insert " (" (egg-git-to-string "log" "--no-walk" "--pretty=%h:%s"
rebase-stopped-sha)
")"))
(insert "\n")
(setq map egg-status-buffer-rebase-map))
(when (memq :status egg-show-key-help-in-buffers)
;; Help
(insert "\n")
(setq help-beg (point))
(insert (egg-text "Help" 'egg-help-header-1) "\n")
(put-text-property help-beg (point) 'help-echo (egg-tooltip-func))
(setq help-inv-beg (1- (point)))
(insert egg-status-buffer-common-help-text)
(when (eq egg-status-buffer-rebase-map map)
(insert egg-status-buffer-rebase-help-text))
(insert egg-status-buffer-diff-help-text)
(insert egg-stash-help-text))
;; Mark the repo section
(egg-delimit-section :section 'repo beg (point) inv-beg map 'repo)
(when help-beg
;; Mark the help sub-section so it can be hidden
(egg-delimit-section :help 'help help-beg (point) help-inv-beg map
'egg-compute-navigation))
(put-text-property (- (point) 2) (point) 'intangible t)
(put-text-property beg (or help-beg (point))
'help-echo (egg-tooltip-func))))
(defun egg-ignore-pattern-from-string-at-point ()
"Add an ignore pattern based on the string at point."
(interactive)
(let ((string (egg-string-at-point))
(file (ffap-file-at-point))
dir pattern gitignore)
(setq pattern (read-string "ignore pattern: "
(if (string-match "\\.[^.]+\\'" string)
(match-string-no-properties 0 string)
string)))
(when (equal pattern "")
(error "Can't ignore empty string!"))
(setq dir (if (stringp file)
(file-name-directory (expand-file-name file))
default-directory))
(setq gitignore
(read-file-name (format "add pattern `%s' to: " pattern)
dir nil nil ".gitignore"))
(save-excursion
(with-current-buffer (find-file-noselect gitignore t t)
(goto-char (point-max))
(insert pattern "\n")
(save-buffer)
(kill-buffer (current-buffer))))
(egg-buffer-cmd-refresh)))
(defun egg-status-buffer-stage-untracked-file (&optional no-stage)
"add untracked file(s) to the repository
acts on a single file or on a region which contains the names of
untracked files. If NO-STAGE, then only create the index entries without
adding the contents."
(interactive "P")
(let ((files (if mark-active
(progn
(if (< (point) (mark))
(progn
(goto-char (line-beginning-position))
(exchange-point-and-mark)
(goto-char (line-end-position)))
(progn
(goto-char (line-end-position))
(exchange-point-and-mark)
(goto-char (line-beginning-position))))
(split-string
(buffer-substring-no-properties (point) (mark)) "\n" t))
(list (buffer-substring-no-properties
(line-beginning-position) (line-end-position)))))
args files-string)
(setq files (delete "" files))
(setq files (delete nil files))
(if (consp files)
(setq files-string (mapconcat 'identity files ", "))
(error "No file to stage!"))
(setq args (nconc (list "-v" "--") files))
(if no-stage
(setq args (cons "-N" args)))
(when (apply 'egg--git-add-cmd (current-buffer) args)
(message "%s %s to git." (if no-stage "registered" "added") files-string))))
(defun egg-sb-insert-untracked-section ()
"Insert the untracked files section into the status buffer."
(let ((beg (point)) inv-beg end)
(insert (egg-prepend "Untracked Files:" "\n\n"
'face 'egg-section-title
'help-echo (egg-tooltip-func))
"\n")
(setq inv-beg (1- (point)))
(egg--git t "ls-files" "--others" "--exclude-standard")
(setq end (point))
(egg-delimit-section :section 'untracked beg end
inv-beg egg-section-map 'untracked)
(put-text-property inv-beg end 'keymap egg-untracked-file-map)
(put-text-property (1+ inv-beg) end 'help-echo (egg-tooltip-func))
(put-text-property (- end 2) end 'intangible t)))
(defun egg-sb-buffer-show-stash (pos)
"Load the details of the stash at POS."
(interactive "d")
(let* ((next (next-single-property-change pos :diff))
(stash (and next (get-text-property next :stash))))
(unless (equal (get-text-property pos :stash) stash)
(egg-buffer-do-insert-stash pos))))
(defun egg-decorate-stash-list (start line-map section-prefix)
(let (stash-beg stash-end beg end msg-beg msg-end name msg)
(save-excursion
(goto-char start)
(while (re-search-forward "^\\(stash@{[0-9]+}\\): +\\(.+\\)$" nil t)
(setq beg (match-beginning 0)
stash-end (match-end 1)
msg-beg (match-beginning 2)
end (match-end 0))
(setq name (buffer-substring-no-properties beg stash-end)
msg (buffer-substring-no-properties msg-beg end))
;; entire line
(add-text-properties beg (1+ end)
(list :navigation (concat section-prefix name)
:stash name
'keymap line-map))
;; comment
(put-text-property beg stash-end 'face 'egg-stash-mono)
(put-text-property msg-beg end 'face 'egg-text-2)))))
(defun egg-sb-insert-stash-section ()
(let ((beg (point)) inv-beg stash-beg end)
(insert (egg-prepend "Stashed WIPs:" "\n\n"
'face 'egg-section-title
'help-echo (egg-tooltip-func))
"\n")
(setq inv-beg (1- (point)))
(setq stash-beg (point))
(egg-list-stash)
(setq end (point))
(egg-delimit-section :section 'stash beg end
inv-beg egg-section-map 'stash)
(egg-decorate-stash-list stash-beg egg-stash-map "stash-")
(put-text-property (- end 2) end 'intangible t)
;;(put-text-property (1+ inv-beg) end 'help-echo (egg-tooltip-func))
))
(defun egg-sb-decorate-unmerged-entries-in-section (beg end sect-type)
(save-excursion
(goto-char beg)
(let (status tmp path)
(save-match-data
(while (re-search-forward (rx line-start "* Unmerged path "
(group (1+ not-newline)) line-end)
end t)
(setq path (match-string-no-properties 1))
(setq tmp (propertize (concat "\n" (substring path 0 1))
'face 'egg-unmerged-diff-file-header))
(add-text-properties (match-beginning 0) (1+ (match-beginning 1))
(list 'display tmp 'intangible t))
(put-text-property (1+ (match-beginning 1)) (match-end 1)
'face 'egg-unmerged-diff-file-header)
(setq status (assoc path egg-status-buffer-changed-files-status))
(when status
(egg-delimit-section sect-type status
(match-beginning 0) (match-end 0) nil nil
#'egg-compute-navigation)
(put-text-property (match-beginning 0) (match-end 0)
'keymap (if (eq sect-type :merged)
egg-unmerged-index-file-map
egg-unmerged-wdir-file-map))
(setq tmp (buffer-substring-no-properties (match-end 0) (1+ (match-end 0))))
(setq tmp (concat (cond ((memq :we-deleted status) ": deleted by us")
((memq :they-deleted status) ": deleted by them")
((memq :both-deleted status) ": deleted by both")
((memq :both-modified status) ": modified by both, please resolve in worktree")
((memq :we-added status) ": added by us, please resolve in worktree")
((memq :they-added status) ": added by them, please resolve in worktree")
((memq :both-added status) ": added by both, please reolsve in worktree")
(t "")) tmp))
(put-text-property (match-end 0) (1+ (match-end 0)) 'display tmp)))))))
(defun egg-sb-insert-unstaged-section (title &rest extra-diff-options)
"Insert the unstaged changes section into the status buffer."
(let ((beg (point)) inv-beg diff-beg end path tmp status)
(insert (egg-prepend title "\n\n" 'face 'egg-section-title
'help-echo (egg-tooltip-func))
"\n")
(setq diff-beg (point))
(setq inv-beg (1- (point)))
(egg-git-ok-args t (append (if egg-status-buffer-interactive-stash-info
(list "diff" "--no-color" "-M" "-p"
"--src-prefix=WiP:/"
"--dst-prefix=Trash:/" )
(list "diff" "--no-color" "-M" "-p"
"--src-prefix=INDEX:/"
"--dst-prefix=WORKDIR:/" ))
egg-git-diff-options
extra-diff-options))
(setq end (point))
(egg-delimit-section :section 'unstaged beg (point)
inv-beg egg-section-map 'unstaged)
(if egg-status-buffer-interactive-stash-info
(egg-decorate-diff-section :begin diff-beg
:end (point)
:src-prefix "WiP:/"
:dst-prefix "Trash:/"
:diff-map egg-unstaged-diff-section-map
:hunk-map egg-unstaged-hunk-section-map)
;; this section might contains merge conflicts, thus cc-diff
(egg-decorate-diff-section :begin diff-beg
:end (point)
:src-prefix "INDEX:/"
:dst-prefix "WORKDIR:/"
:diff-map egg-unstaged-diff-section-map
:hunk-map egg-unstaged-hunk-section-map
:cc-diff-map egg-unmerged-diff-section-map
:cc-hunk-map egg-unmerged-hunk-section-map
:conflict-map egg-unmerged-conflict-map))
(egg-sb-decorate-unmerged-entries-in-section diff-beg end :unmerged)
(put-text-property (- end 2) end 'intangible t)))
(defun egg-sb-insert-staged-section (title &rest extra-diff-options)
"Insert the staged changes section into the status buffer."
(let ((beg (point)) inv-beg diff-beg end)
(insert (egg-prepend title "\n\n"
'face 'egg-section-title
'help-echo (egg-tooltip-func))
"\n")
(put-text-property (- beg 2) beg 'intangible t)
(setq diff-beg (point)
inv-beg (1- diff-beg))
(egg-git-ok-args t (append (if egg-status-buffer-interactive-stash-info
(list "diff" "--no-color" "--cached" "-M" "-p"
"--src-prefix=Base:/"
"--dst-prefix=WiP:/")
(list "diff" "--no-color" "--cached" "-M" "-p"
"--src-prefix=HEAD:/"
"--dst-prefix=INDEX:/"))
egg-git-diff-options
extra-diff-options))
(setq end (point))
(egg-delimit-section :section 'staged beg (point)
inv-beg egg-section-map 'staged)
;; this section never contains merge conflicts, thus no cc-diff
(if egg-status-buffer-interactive-stash-info
(egg-decorate-diff-section :begin diff-beg
:end (point)
:src-prefix "Base:/"
:dst-prefix "WiP:/"
:diff-map egg-staged-diff-section-map
:hunk-map egg-staged-hunk-section-map)
(egg-decorate-diff-section :begin diff-beg
:end (point)
:src-prefix "HEAD:/"
:dst-prefix "INDEX:/"
:diff-map egg-staged-diff-section-map
:hunk-map egg-staged-hunk-section-map))
(egg-sb-decorate-unmerged-entries-in-section diff-beg end :merged)
(put-text-property (- end 2) end 'intangible t)))
(defvar egg-hunk-ranges-cache nil
"A list of (FILENAME HUNK-RANGE-INFO ...)) for each file in the
buffer. Each HUNK-RANGE-INFO has the form of (SECTION BUFFER-RANGE REAL-RANGE SINGLE-RANGE)
SECTION is either 'staged or 'unstaged
Each RANGE is a list of four numbers (L1 S1 L2 S2) from the \"@@
-L1,S1 +L2,S2 @@\" hunk header.
Each of the three ranges have the following meaning:
* BUFFER-RANGE : The parsed number from the git hunk header in
the buffer. They change as hunks are staged or unstaged. In the
unstaged area, line numbers refer to actual working directory
file. In the staged area, line numbers refer to the INDEX copy
of the file, with all other staged hunks also applied
* REAL-RANGE : For the unstaged hunks, same as BUFFER-RANGE, but
for the staged hunks, its the line numbers are in relation to
working directory file, rather then INDEX + staged changes. This range
will stay constant if hunk is staged or unstaged, but may change
if new unstaged changes are added to what Egg buffer reflects.
* SINGLE-RANGE : This is a hunk range, artificially adjusted so
that line numbers are in relation to the INDEX, as if this hunk
was the only hunk staged.. This range will remain constant, when
hunks are staged, unstaged, or new unstaged hunks are introduced, as long
It may change only if user had extended the hunk by changing
more lines abutting it, so that the hunk is extended or
shrunken.
The only range that we really need, is SINGLE-RANGE, because it
is as close as we can get to unique hunk identifier, that will
remain constant in most circumstances.. But we need the other two
ranges in order to calculate the SINGLE-RANGE
For unstaged hunk, the SINGLE range is REAL-RANGE, adjusted for the total delta
of all staged and unstaged hunks before it
For staged hunk, the SINGLE range is BUFFER-RANGE adjusted for for the total
delta of staged hunks before it.
")
(defvar egg-section-visibility-info nil
"Info on invisibility of file and its hunks before stage or unstage.
Each member of this list is (FILE-OR-SECTION VISIBILITY UNSTAGED-VISIBILITY
LINE-NUMBERS)
* FILE-OR-SECTION : When string its a file, otherwise :NAVIGATION property
of the section
* VISIBILITY : One of the following values:
* :HIDDEN : File is hidden
* :VISIBLE : File is showing
* NIL : File is not present in the section (only for files)
* UNSTAGED-VISIBILITY : Only for files, same as VISIBILITY but
in unstaged section
* LINE-NUMBERS : Real line numbers of hidden hunks (only for files)
The reason we use line numbers and not hunk ids, is because under
git hunk ids will not be the same, if hunks that are before them
in the same file are unstaged")
(defvar egg-around-point-section-info nil
"The list of three elements (BEFORE-POINT AT-POINT
AFTER-POINT), that describe the previous, current and next
visible section of the egg status or diff buffer.
Each element is a list (FILE-OR-SECTION SECTION HUNK-LINE-NUMBER)
* FILE-OR-SECTION : When string its a file, otherwise value of
:navigation property of the section
* SECTION : The value of :section property
* HUNK-LINE-NUMBER : Real hunk line number in the unstaged file
This information is used to restore the point to a good place
after buffer is refreshed, for example if last hunk in a diff is
staged or unstaged, point will move to the next one or previous
if no next hunk existed, or to the section if it was last hunk in
the section.
")
(make-variable-buffer-local 'egg-hunk-ranges-cache)
(make-variable-buffer-local 'egg-section-visibility-info)
(make-variable-buffer-local 'egg-around-point-section-info)
(defun egg-get-hunk-range (pos)
"Return the 4 numbers from hunk header as list of integers"
(destructuring-bind (file hunk-header hunk-beg &rest ignore)
(egg-hunk-info-at pos)
(let* ((range-as-strings
(save-match-data
(split-string hunk-header "[ @,\+,-]+" t)))
(range
(mapcar 'string-to-number range-as-strings))
(len (length range)))
;; normalize hunk range, sorted in order of most frequent
(cond
;; Normal hunk
((= 4 len) range)
;; 3 way diff when merging, never seen >6
((= 6 len) (append (subseq range 0 2)
(subseq range 4 6)))
;; Adding sub-modules
((= 2 len) (append range range))
;; Adding symbolic links
((= 3 len) (append range (list (second range))))
;; Never seen this 5 line numbers hunk, treat as 4
((= 5 len) (subseq range 0 4))
;; Never seen 1 line number hunk
((= 1 len) (list (car range) (car range) (car range) (car range)))
;; never seen hunk header with no line numbers
((zerop len) (list 1 1 1 1))
;; more then 6 numbers
(t (warn "Weird hunk header %S" hunk-header)
;; treat as 6 line one
(append (subseq range 0 2)
(subseq range 4 6)))))))
(defun egg-ensure-hunk-ranges-cache ()
"Returns `egg-hunk-ranges-cache' re-creating it if its NIL."
(or egg-hunk-ranges-cache
(save-excursion
(let ((pos (point-min)) nav
last-file
list)
(while (setq pos (next-single-property-change (1+ pos) :navigation))
(let ((sect (get-text-property pos :section))
(type (get-text-property pos :sect-type))
(file (first (get-text-property pos :diff)))
(nav (get-text-property pos :navigation)))
(when (and nav file sect)
(when (and (eq type :hunk))
(when (not (equal last-file file))
(push (setq list (cons file nil)) egg-hunk-ranges-cache)
(setq last-file file))
(let* ((range (egg-get-hunk-range pos))
(elem (list sect range
(copy-sequence range)
(copy-sequence range)))
(hunk-info (get-text-property pos :hunk)))
(setcdr list (cons elem (cdr list)))
(setf (fourth hunk-info) elem))))))
egg-hunk-ranges-cache))))
(defun egg-unstaged-lines-delta-before-hunk (file line)
"Count how many lines any unstaged patches add before LINE line number"
(let ((cnt 0))
(dolist (elem (cdr (assoc file (egg-ensure-hunk-ranges-cache))))
(let ((sect (first elem))
(range (second elem))
(real-range (third elem))
(single-range (fourth elem)))
(when (eq sect 'unstaged)
(destructuring-bind (l1 s1 l2 &optional s2) range
(when (< l2 line)
;; Increment adjustment by how many lines were added
(incf cnt (- (or s2 s1) s1)))))))
cnt))
(defun egg-staged-lines-delta-before-hunk (file line)
"Count how many lines any staged patches add before LINE line number"
(let ((cnt 0))
(dolist (elem (cdr (assoc file (egg-ensure-hunk-ranges-cache))))
(let ((sect (first elem))
(range (second elem))
(real-range (third elem))
(single-range (fourth elem)))
(when (eq sect 'staged)
(destructuring-bind (l1 s1 l2 &optional s2) range
(when (< l2 line)
;; Increment adjustment by how many lines were added
(incf cnt (- (or s2 s1) s1)))))))
cnt))
(defun egg-calculate-hunk-ranges ()
"Calculate the correct line number in the real unstaged file,
of each hunk in the current buffer, and store in the fourth
element of the :hunk info"
;; Refresh it
(setq egg-hunk-ranges-cache nil)
(egg-ensure-hunk-ranges-cache)
;; First create correct real range, for all staged changes
(save-excursion
(let ((pos (point-min)) nav
last-file
list)
;; first do all staged
(while (setq pos (next-single-property-change (1+ pos) :navigation))
(when (eq (get-text-property pos :sect-type) :hunk)
(let* ((hunk-info (get-text-property pos :hunk))
(hunk-ranges (fourth hunk-info))
(file (first (get-text-property pos :diff))))
(when (eq (get-text-property pos :section) 'staged)
;; set real range
(let* ((real-range (third hunk-ranges))
(delta (egg-unstaged-lines-delta-before-hunk
file
(third real-range))))
;; (incf (first real-range) delta)
(incf (third real-range) delta))))))))
;; Now create correct single-range for both staged and unstaged changes
(save-excursion
(let ((pos (point-min)) nav
last-file
list)
(while (setq pos (next-single-property-change (1+ pos) :navigation))
(when (eq (get-text-property pos :sect-type) :hunk)
(let* ((hunk-info (get-text-property pos :hunk))
(file (first (get-text-property pos :diff)))
(hunk-ranges (fourth hunk-info))
(buffer-range (second hunk-ranges))
(real-range (third hunk-ranges))
(single-range (fourth hunk-ranges)))
(if (eq (get-text-property pos :section) 'unstaged)
(let* (
(delta-unstaged
(egg-unstaged-lines-delta-before-hunk
file
(third real-range)))
(delta-staged
(egg-staged-lines-delta-before-hunk
file
(- (third buffer-range)
delta-unstaged))))
(decf (first single-range) delta-staged)
(decf (third single-range) (+ delta-unstaged delta-staged)))
(let ((delta
(egg-staged-lines-delta-before-hunk
file (third buffer-range))))
;; (decf (first single-range) delta)
(decf (third single-range) delta)))))))))
(defun egg-hunk-real-line-number (&optional pos)
"Return hunks line number in the unstaged file"
(multiple-value-bind (file hunk-header hunk-beg hunk-end
ranges &rest ignored)
(egg-hunk-info-at (or pos (point)))
(or (when ranges (third (third ranges)))
(string-to-number
(nth 2 (save-match-data
(split-string hunk-header "[ @,\+,-]+" t)))))))
(defun egg-save-section-visibility ()
"Save the visibility status of each file, and each hunk in the
buffer into `egg-section-visibility-info'. Hunks are indexed by
their real file line number.
Also the the first section after the point in `my-egg-stage/unstage-point"
(setq egg-section-visibility-info nil)
(setq egg-around-point-section-info (list nil nil nil))
(let* ((pos (point-min)) nav
(nav-at-point (get-text-property (point) :navigation))
(nav-at-point-type (get-text-property (point) :sect-type))
(nav-at-point-sect (get-text-property (point) :section))
(nav-next
(let (nav (pos (next-single-property-change (point) :navigation)))
(while (and pos (or (invisible-p pos)
(eq nav-at-point
(get-text-property pos :navigation))
(not (eq nav-at-point-type
(get-text-property pos :sect-type)))
(and (not (eq nav-at-point-type :section))
(not (eq nav-at-point-sect
(get-text-property pos :section))))))
(setq pos (next-single-property-change pos :navigation)))
(and pos (get-text-property pos :navigation))))
(nav-prev
(let (nav (pos (previous-single-property-change (point) :navigation)))
(and pos (setq pos (line-beginning-position)))
(while (and pos
(or (invisible-p pos)
(eq nav-at-point
(get-text-property pos :navigation))
(not (eq nav-at-point-type
(get-text-property pos :sect-type)))
(and (not (eq nav-at-point-type :section))
(not (eq nav-at-point-sect
(get-text-property pos :section))))))
(setq pos (previous-single-property-change pos :navigation)))
(and pos (get-text-property pos :navigation)))))
(while (setq pos (next-single-property-change (min (1+ pos) (point-max)) :navigation))
(let* ((sect (get-text-property pos :section))
(type (get-text-property pos :sect-type))
(file (first (get-text-property pos :diff)))
(nav (get-text-property pos :navigation))
(hunk-ranges (fourth (get-text-property pos :hunk)))
(file-or-sect (or file nav)))
;; Save current section visibility
(when (and nav sect)
(let ((info
(or (assoc file-or-sect egg-section-visibility-info)
(first (push (list file-or-sect nil nil nil)
egg-section-visibility-info))))
(state (if (assoc nav buffer-invisibility-spec) :hidden :visible)))
(cond ((and (eq sect 'staged) (eq type :diff))
(setf (second info) state))
((and (eq sect 'unstaged) (eq type :diff))
(setf (third info) state))
((and (eq type :hunk))
(push (list hunk-ranges state)
(fourth info)))
((not (memq type '(:hunk :diff)))
;; some other section like help or entire staged/unstaged
(setf (second info) state)))))
;; Remember previous, current and next sections at point
(cond ((eq nav nav-prev)
(setf (first egg-around-point-section-info)
(list file-or-sect sect hunk-ranges)))
((eq nav nav-at-point)
(setf (second egg-around-point-section-info)
(list file-or-sect sect hunk-ranges)))
((eq nav nav-next)
(setf (third egg-around-point-section-info)
(list file-or-sect sect hunk-ranges))))))))
(defun egg-restore-section-visibility ()
"Restore the visibility of sections and hunks"
(let* ( ;; these are sections before refresh
(before-point (first egg-around-point-section-info))
(at-point (second egg-around-point-section-info))
(after-point (third egg-around-point-section-info))
restore-pt restore-before-pt restore-after-pt
at-point-section-same-p
(at-point-was-file-or-hunk-p (stringp (first at-point))))
(let ((pos (point-min)))
(while (setq pos (next-single-property-change (1+ pos) :navigation))
(let* ((sect (get-text-property pos :section))
(type (get-text-property pos :sect-type))
(file (first (get-text-property pos :diff)))
(nav (get-text-property pos :navigation))
(file-or-sect (or file nav))
(hunk-ranges (when (eq type :hunk)
(fourth (get-text-property pos :hunk)))))
(when (and nav file-or-sect)
(let ((info (assoc file-or-sect egg-section-visibility-info)))
(when info
(cond
((eq type :diff)
(let* ((was-present-here
(if (eq sect 'staged)
(second info)
(third info)))
(was-present-there
(if (eq sect 'staged)
(third info)
(second info)))
(was-invisible-here (eq :hidden was-present-here))
(was-invisible-there (eq :hidden was-present-there)))
;; only make invisible if it was invisible in that section before
;; or if it was not present, and opposite section was invisible
(when (and was-invisible-there
(or
was-invisible-here
(not was-present-here))
(not (assoc nav buffer-invisibility-spec)))
(add-to-invisibility-spec (cons nav t)))))
;; for hunks, unconditionally restore invisibility
((and (eq type :hunk))
(let* ((old-state
(egg-find-if
(lambda (elem)
(destructuring-bind (old-ranges old-state)
elem
(equal (fourth hunk-ranges)
(fourth old-ranges))))
(fourth info)))
(was-invisile (and old-state (eq (second old-state) :hidden)))
(is-invisible (assoc nav buffer-invisibility-spec)))
(cond ((and was-invisile (not is-invisible))
(add-to-invisibility-spec (cons nav t)))
;; below restores visibility, if it was visible before
;; so that moving folded hunk to staged, then unfolding it
;; and moving it back, moves it back unfolded
((and (not was-invisile) is-invisible)
(remove-from-invisibility-spec (cons nav t))))))))))
(when file-or-sect
(cond
;; when point was not on file or hunk, simply restore it
((and (not at-point-was-file-or-hunk-p)
(eq nav (first at-point)))
(setq restore-pt (save-excursion
(goto-char pos)
(line-beginning-position))))
;; when point was on hunk or file, see if its section had changed
((and at-point-was-file-or-hunk-p
(equal file-or-sect (first at-point))
(equal (fourth hunk-ranges)
(fourth (third at-point))))
(when (setq at-point-section-same-p (eq sect (second at-point)))
(setq restore-pt (save-excursion
(goto-char pos)
(line-beginning-position)))))
;; need these in case piece where point was had moved
((and (equal file-or-sect (first before-point))
(equal (fourth hunk-ranges)
(fourth (third before-point)))
(equal sect (second before-point)))
(setq restore-before-pt (save-excursion
(goto-char pos)
(let ((end
(1- (next-single-property-change
(point) :navigation nil
(1+ (point-max))))))
(unless
(save-excursion
(goto-char end)
(invisible-p (line-beginning-position)))
(goto-char end)))
;; TODO move back until visible
(line-beginning-position))))
((and (equal file-or-sect (first after-point))
(equal (fourth hunk-ranges)
(fourth (third after-point)))
(equal sect (second after-point)))
(setq restore-after-pt (save-excursion
(goto-char pos)
(line-beginning-position)))))))))
(cond (restore-pt
(goto-char restore-pt))
;; If point was at file/hunk, and there was one after
;; it (in the same section), then move point to it
((and at-point-was-file-or-hunk-p
(not at-point-section-same-p)
(stringp (first after-point))
restore-after-pt)
(goto-char restore-after-pt))
;; Otherwise if there was file/hunk before it
((and at-point-was-file-or-hunk-p
(not at-point-section-same-p)
(stringp (first before-point))
restore-before-pt)
(goto-char restore-before-pt))
;; Otherwise if point was on file/hunk, move point
;; to the section it was in
((and at-point-was-file-or-hunk-p
(setq restore-pt
(let ((pos (point-min)))
(while (and pos (not (eq (second at-point)
(get-text-property pos :section))))
(setq pos (next-single-property-change pos :section)))
pos)))
(goto-char restore-pt))
;; Should not happen (somehow file section had disappeared)
(t ;; (when at-point
;; (warn "Unable to find section %S that file %s was in"
;; (second at-point)
;; (first at-point)))
(if (setq restore-pt (or restore-before-pt restore-after-pt))
(goto-char restore-pt)
(goto-char (point-min)))))))
(defun egg-unmerged-file-del-action (pos)
(interactive "d")
(let* ((status (or (get-text-property pos :unmerged) (get-text-property pos :merged)))
(file (and status (car status))))
(unless (or (memq :we-deleted status) (memq :they-deleted status) (memq :both-deleted status))
(error "don't know how to handle status %S" status))
(if (y-or-n-p (format "delete file %s?" file))
(egg-status-buffer-handle-result (egg--git-rm-cmd (current-buffer) file))
(if (y-or-n-p (format "keep file %s alive?" file))
(egg-status-buffer-handle-result (egg--git-add-cmd (current-buffer) file))
(message "deleted file %s is still unmerged!" file)))))
(defun egg-unmerged-file-add-action (pos)
(interactive "d")
(let* ((status (or (get-text-property pos :unmerged) (get-text-property pos :merged)))
(file (and status (car status))))
(unless (or (memq :we-added status) (memq :they-added status) (memq :both-added status))
(error "don't know how to handle status %S" status))
(if (y-or-n-p (format "add file %s?" file))
(egg-status-buffer-handle-result (egg--git-add-cmd (current-buffer) file))
(if (y-or-n-p (format "delete file %s" file))
(egg-status-buffer-handle-result (egg--git-rm-cmd (current-buffer) file))
(message "added file %s is still unmerged!" file)))))
(defun egg-unmerged-file-checkout-action (pos)
(interactive "d")
(let* ((status (get-text-property pos :merged))
(file (and status (car status))))
(unless (memq :unmerged status)
(error "don't know how to handle status %S" status))
(when (y-or-n-p (format "undo all merge results in %s? " file))
(egg-status-buffer-handle-result (egg--git-co-files-cmd (current-buffer) file "-m")))))
(defun egg-unmerged-file-ediff-action (pos)
(interactive "d")
(let* ((status (or (get-text-property pos :unmerged) (get-text-property pos :merged)))
(file (and status (car status))))
(unless (memq :unmerged status)
(error "don't know how to handle status %S" status))
(egg-resolve-merge-with-ediff file)))
(defun egg-unmerged-wdir-file-next-action (pos)
(interactive "d")
(let* ((status (get-text-property pos :unmerged))
(file (and status (car status))))
(unless (memq :unmerged status)
(error "don't know how to handle status %S" status))
(cond ((or (memq :we-added status) (memq :they-added status) (memq :both-added status))
(egg-unmerged-file-add-action pos))
((or (memq :we-deleted status) (memq :they-deleted status) (memq :both-deleted status))
(egg-unmerged-file-del-action pos))
((memq :both-modified status)
(egg-unmerged-file-ediff-action pos))
(t (message "don't know how to handle status %S" status)))))
(defun egg-unmerged-index-file-next-action (pos)
(interactive "d")
(let* ((status (get-text-property pos :merged))
(file (and status (car status))))
(unless (memq :unmerged status)
(error "don't know how to handle status %S" status))
(cond ((or (memq :we-deleted status) (memq :they-deleted status) (memq :both-deleted status))
(egg-unmerged-file-del-action pos))
((memq :both-modified status)
(egg-unmerged-file-ediff-action pos))
(t (message "don't know how to handle status %S" status)))))
(defun egg-status-buffer-checkout-ref (&optional force name)
"Prompt a revision to checkout. Default is name."
(interactive (list current-prefix-arg (egg-ref-at-point)))
(setq name (egg-read-local-ref "checkout (branch or tag): " name))
(if force
(egg-status-buffer-do-co-rev name "-f")
(egg-status-buffer-do-co-rev name)))
(defun egg-buffer-hide-all (&optional show-all)
"Hide all sections in current special egg buffer."
(interactive "P")
(if show-all
(setq buffer-invisibility-spec nil) ;; show all
(let ((pos (point-min)) nav)
(while (setq pos (next-single-property-change (1+ pos) :navigation))
(setq nav (get-text-property pos :navigation))
(add-to-invisibility-spec (cons nav t)))))
(if (invoked-interactively-p)
(force-window-update (current-buffer))))
(defsubst egg-buffer-show-all ()
"UnHide all hidden sections in the current special egg buffer."
(interactive)
(setq buffer-invisibility-spec nil)
(if (invoked-interactively-p)
(force-window-update (current-buffer))))
(defsubst egg-buffer-hide-section-type (sect-type &optional beg end)
"Hide sections of SECT-TYPE in current special egg buffer."
(let ((pos (or beg (point-min)))
(end (or end (point-max)))
nav)
(while (and (setq pos (next-single-property-change (1+ pos) sect-type))
(< pos end))
(when (get-text-property pos sect-type)
(setq nav (get-text-property pos :navigation))
(add-to-invisibility-spec (cons nav t))))))
(defsubst egg-buffer-maybe-hide-all ()
"If requested, hide all sections in current special egg buffer.
See `egg-buffer-hide-sub-blocks-on-start'."
(let ((sect-type (cdr (assq major-mode
egg-buffer-hide-section-type-on-start))))
(cond ((memq major-mode egg-buffer-hide-sub-blocks-on-start)
(egg-buffer-hide-all))
((and sect-type (symbolp sect-type))
(egg-buffer-hide-section-type sect-type)))))
(defsubst egg-buffer-maybe-hide-help (help-nav &optional top-nav)
"If requested, hide the help section in the current special buffer.
See `egg-buffer-hide-help-on-start'."
(if (memq major-mode egg-buffer-hide-help-on-start)
(add-to-invisibility-spec
(cons (if (symbolp help-nav) help-nav
(egg-make-navigation top-nav help-nav))
t))))
(defun egg-status-buffer-redisplay (buf &optional init)
"(Re)Display the contents of the status buffer in BUF.
If INIT was not nil, then perform 1st-time initializations as well."
(with-current-buffer buf
(let ((inhibit-read-only t)
(state (egg-repo-state))
(win (get-buffer-window buf))
pos)
(set (make-local-variable 'egg-status-buffer-changed-files-status)
(egg--get-status-code))
;; Emacs tries to be too smart, if we erase and re-fill the buffer
;; that is currently being displayed in the other window,
;; it remembers it, and no matter where we move the point, it will
;; force it to be at (point-min). Making a buffer selected
;; while we erase and re-fill it, seems to fix this behavour
(save-selected-window
(when win
(select-window win t))
(egg-save-section-visibility)
(erase-buffer)
(dolist (sect egg-status-buffer-sections)
(cond ((eq sect 'repo) (egg-sb-insert-repo-section))
((eq sect 'unstaged)
(setq pos (point))
(egg-sb-insert-unstaged-section
(cond ((consp egg-status-buffer-interactive-stash-info) "To be Removed:")
((egg-is-merging state) "Unmerged Changes:")
(t "Unstaged Changes:"))))
((eq sect 'staged)
(egg-sb-insert-staged-section
(cond ((consp egg-status-buffer-interactive-stash-info) "To be Stashed:")
((egg-is-merging state) "Merged Changes:")
(t "Staged Changes:"))))
((eq sect 'untracked) (egg-sb-insert-untracked-section))
((eq sect 'stash) (egg-sb-insert-stash-section))))
(egg-calculate-hunk-ranges)
(if init
(progn
(egg-buffer-maybe-hide-all)
(egg-buffer-maybe-hide-help "help" 'repo))
(egg-restore-section-visibility))
(goto-char pos)
(goto-char (egg-previous-non-hidden (point)))
))))
(defun egg-internal-background (proc msg)
"Background job sentinel."
(let ((name (process-name proc)))
(cond ((string= msg "finished\n")
(message "EGG BACKGROUND: %s finished." name))
((string= msg "killed\n")
(message "EGG BACKGROUND: %s was killed." name))
((string-match "exited abnormally" msg)
(message "EGG BACKGROUND: %s failed." name))
(t (message "EGG BACKGROUND: %s is weird!" name)))))
(defun egg-internal-background-refresh-index (buffer-name)
(let ((buffer (get-buffer buffer-name))
proc)
(when (and buffer (buffer-live-p buffer))
(with-current-buffer buffer
(setq proc (start-process (format "refresh index in %s"
default-directory)
nil
egg-git-command "update-index"
"-q" "--really-refresh" "--unmerged"))
(set-process-sentinel proc #'egg-internal-background)))))
(defvar egg-internal-status-buffer-names-list nil)
(defvar egg-internal-background-jobs-timer nil)
(defun egg-internal-background-jobs-restart ()
(cancel-function-timers #'egg-status-buffer-background-job)
(setq egg-internal-background-jobs-timer
(run-with-idle-timer egg-background-idle-period t
#'egg-status-buffer-background-job)))
(defun egg-set-background-idle-period (var val)
(custom-set-default var val)
(egg-internal-background-jobs-restart))
(defcustom egg-background-idle-period 30
"How long emacs has been idle before we trigger background jobs."
:group 'egg
:set #'egg-set-background-idle-period
:type 'integer)
(defun egg-status-buffer-background-job ()
(when egg-refresh-index-in-backround
(mapcar #'egg-internal-background-refresh-index
egg-internal-status-buffer-names-list)))
(egg-internal-background-jobs-restart)
(define-egg-buffer status "*%s-status@%s*"
"Major mode to display the egg status buffer."
(kill-all-local-variables)
(setq buffer-read-only t)
(setq major-mode 'egg-status-buffer-mode
mode-name "Egg-Status"
mode-line-process ""
truncate-lines t)
(use-local-map egg-status-buffer-mode-map)
(set (make-local-variable 'egg-buffer-refresh-func)
'egg-status-buffer-redisplay)
(setq buffer-invisibility-spec nil)
(add-to-list 'egg-internal-status-buffer-names-list (buffer-name))
(run-mode-hooks 'egg-status-buffer-mode-hook))
;;; I'm here
(defun egg-status-make-section-menu (&optional name)
(let ((map (make-sparse-keymap name)))
(define-key map [f-stage] (list 'menu-item "Stage File"
'egg-diff-section-cmd-stage
:visible '(egg-diff-at-point)
:enable '(egg-point-in-section 'unstaged)))
(define-key map [f-unstage] (list 'menu-item "Unstage File"
'egg-diff-section-cmd-unstage
:visible '(egg-diff-at-point)
:enable '(egg-point-in-section 'staged)))
(define-key map [f-undo] (list 'menu-item "Undo File's Modifications"
'egg-diff-section-cmd-undo
:visible '(egg-diff-at-point)
:enable '(egg-point-in-section 'unstaged)))
(define-key map [h-stage] (list 'menu-item "Stage Hunk"
'egg-hunk-section-cmd-stage
:visible '(egg-hunk-at-point)
:enable '(egg-point-in-section 'unstaged)))
(define-key map [h-unstage] (list 'menu-item "Unstage Hunk"
'egg-hunk-section-cmd-unstage
:visible '(egg-hunk-at-point)
:enable '(egg-point-in-section 'staged)))
(define-key map [h-undo] (list 'menu-item "Undo Hunk"
'egg-hunk-section-cmd-undo
:visible '(egg-hunk-at-point)
:enable '(egg-point-in-section 'unstaged)))
(define-key map [sp9] '("--"))
(define-key map [prev] (list 'menu-item "Goto Prev Block"
'egg-buffer-cmd-navigate-prev
:enable '(egg-navigation-at-point)))
(define-key map [next] (list 'menu-item "Goto Next Block"
'egg-buffer-cmd-navigate-next
:enable '(egg-navigation-at-point)))
(define-key map [hs] (list 'menu-item "Hide/Show Current Block"
'egg-section-cmd-toggle-hide-show
:enable '(egg-navigation-at-point)))
(define-key map [hs-sub] (list 'menu-item "Hide/Show SubBlocks"
'egg-section-cmd-toggle-hide-show-children
:enable '(egg-navigation-at-point)))
(define-key map [sp8] '("--"))
(define-key map [goto-file] (list 'menu-item "Open File"
'egg-diff-section-cmd-visit-file-other-window
:visble '(and (egg-diff-at-point)
(not (egg-hunk-at-point)))))
(define-key map [goto-line] (list 'menu-item "Locate Line"
'egg-hunk-section-cmd-visit-file-other-window
:visible '(egg-hunk-at-point)))
(define-key map [ediff] (list 'menu-item "Ediff: WorkDir vs INDEX"
'egg-unstaged-section-cmd-ediff
:visible '(egg-diff-at-point)
:enable '(egg-point-in-section 'unstaged)))
(define-key map [ediff3] (list 'menu-item "Ediff3: WorkDir vs INDEX vs HEAD"
'egg-staged-section-cmd-ediff3
:visible '(egg-diff-at-point)
:enable '(egg-point-in-section 'staged)))
map))
(defconst egg-status-buffer-unstaged-diff-menu (egg-status-make-section-menu "Unstaged Delta"))
(defconst egg-status-buffer-unstaged-hunk-menu (egg-status-make-section-menu "Unstaged Hunk"))
(defconst egg-status-buffer-staged-diff-menu (egg-status-make-section-menu "Staged Delta"))
(defconst egg-status-buffer-staged-hunk-menu (egg-status-make-section-menu "Staged Hunk"))
(defconst egg-status-buffer-mode-delta-menu (egg-status-make-section-menu))
(defun egg-status-popup-delta-menu (event menu)
(let* ((keys (progn
(force-mode-line-update)
(x-popup-menu event menu)))
(cmd (and keys (lookup-key menu (apply 'vector keys)))))
(when (and cmd (commandp cmd))
(call-interactively cmd))))
(defun egg-status-popup-unstaged-diff-menu (event)
(interactive "e")
(egg-status-popup-delta-menu event egg-status-buffer-unstaged-diff-menu))
(defun egg-status-popup-staged-diff-menu (event)
(interactive "e")
(egg-status-popup-delta-menu event egg-status-buffer-staged-diff-menu))
(defun egg-status-popup-unstaged-hunk-menu (event)
(interactive "e")
(egg-status-popup-delta-menu event egg-status-buffer-unstaged-hunk-menu))
(defun egg-status-popup-staged-hunk-menu (event)
(interactive "e")
(egg-status-popup-delta-menu event egg-status-buffer-staged-hunk-menu))
(defconst egg-status-buffer-menu (make-sparse-keymap "Egg (Git)"))
(define-key egg-status-buffer-mode-map
[menu-bar egg-status-buffer-mode] (cons "Egg (Git)" egg-status-buffer-menu))
(let ((menu egg-status-buffer-menu))
(define-key menu [quit] '(menu-item "Close Status View" egg-quit-buffer))
(define-key menu [refresh] '(menu-item "Refresh Status View" egg-buffer-cmd-refresh))
(define-key menu [log] '(menu-item "Show Branch History" egg-log))
(define-key menu [sp3] '("--"))
(define-key menu [rb-skip] '(menu-item "Skip Rebase Session's Current Commit"
egg-buffer-selective-rebase-skip
:enable (egg-rebase-in-progress)))
(define-key menu [rb-abort] '(menu-item "Abort Rebase Session"
egg-buffer-rebase-abort
:enable (egg-rebase-in-progress)))
(define-key menu [rb-cont] '(menu-item "Resume Rebase Session"
egg-buffer-selective-rebase-continue
:enable (egg-rebase-in-progress)))
(define-key menu [sp2] '("--"))
(define-key menu [delta] (list 'menu-item "Delta"
egg-status-buffer-mode-delta-menu
:enable '(egg-diff-at-point)))
(define-key menu [commit] '(menu-item "Commit Staged Changes"
egg-commit-log-edit))
(define-key menu [stage] '(menu-item "Stage All Modifications"
egg-stage-all-files
:enable (egg-wdir-dirty)))
(define-key menu [unstage] '(menu-item "UnStage All Staged Modifications"
egg-unstage-all-files
:enable (egg-staged-changes)))
(define-key menu [stage-untracked] '(menu-item "Stage All Untracked Files"
egg-stage-untracked-files))
(define-key menu [sp1] '("--"))
(define-key menu [hide-all] '(menu-item "Hide All" egg-buffer-hide-all))
(define-key menu [show-all] '(menu-item "Show All" egg-buffer-show-all))
(define-key menu [hs] '(menu-item "Hide/Show Block"
egg-section-cmd-toggle-hide-show
:enable (egg-navigation-at-point)))
(define-key menu [hs-sub] '(menu-item "Hide/Show SubBlocks"
egg-section-cmd-toggle-hide-show-children
:enable (egg-navigation-at-point)))
(define-key menu [prev] '(menu-item "Goto Previous Block" egg-buffer-cmd-navigate-prev
:enable (egg-navigation-at-point)))
(define-key menu [next] '(menu-item "Goto Next Block" egg-buffer-cmd-navigate-next
:enable (egg-navigation-at-point))))
(defvar egg-switch-to-buffer nil
"Set to nonnil for egg-status to switch to the status buffer in the same window.")
(defun egg-status (called-interactively select &optional caller)
"Show the status of the current repo."
(interactive "p\nP")
(let* ((egg-internal-current-state
(egg-repo-state (if (invoked-interactively-p) :error-if-not-git)))
(buf (egg-get-status-buffer 'create))
(select (if called-interactively ;; only do this for commands
(if egg-cmd-select-special-buffer
(not select) ;; select by default (select=nil), C-u not select
select) ;; not select by default (select=nil), C-u select
select)))
(with-current-buffer buf
(egg-status-buffer-redisplay buf 'init))
(cond ((eq caller :sentinel) (pop-to-buffer buf))
(select (pop-to-buffer buf))
(egg-switch-to-buffer (switch-to-buffer buf))
(called-interactively (display-buffer buf))
(t (display-buffer buf)))))
;;;========================================================
;;; log message
;;;========================================================
(require 'derived)
(require 'ring)
(defvar egg-log-msg-ring (make-ring 32))
(defvar egg-log-msg-ring-idx nil)
(defvar egg-log-msg-closure nil
"Closure for be called when done composing a message.
It must be a local variable in the msg buffer. It's a list
in the form (func arg1 arg2 arg3...).
func should be a function expecting the following args:
PREFIX-LEVEL the prefix argument converted to a number.
BEG a marker for the beginning of the composed text.
END a marker for the end of the composed text.
NEXT-BEG is a marker for the beginnning the next section.
ARG1 ARG2 ARG3... are the items composing the closure
when the buffer was created.")
(defsubst egg-log-msg-func () (car egg-log-msg-closure))
(defsubst egg-log-msg-args () (cdr egg-log-msg-closure))
(defsubst egg-log-msg-prefix () (nth 0 (egg-log-msg-args)))
(defsubst egg-log-msg-gpg-uid () (nth 1 (egg-log-msg-args)))
(defsubst egg-log-msg-text-beg () (nth 2 (egg-log-msg-args)))
(defsubst egg-log-msg-text-end () (nth 3 (egg-log-msg-args)))
(defsubst egg-log-msg-next-beg () (nth 4 (egg-log-msg-args)))
(defsubst egg-log-msg-extras () (nthcdr 5 (egg-log-msg-args)))
(defsubst egg-log-msg-set-prefix (prefix) (setcar (egg-log-msg-args) prefix))
(defsubst egg-log-msg-set-gpg-uid (uid) (setcar (cdr (egg-log-msg-args)) uid))
(defsubst egg-log-msg-mk-closure-input (func &rest args)
(cons func args))
(defsubst egg-log-msg-mk-closure-from-input (input gpg-uid prefix beg end next)
(cons (car input) (nconc (list prefix gpg-uid beg end next) (cdr input))))
(defsubst egg-log-msg-apply-closure (prefix)
(egg-log-msg-set-prefix prefix)
(apply (egg-log-msg-func) (egg-log-msg-args)))
(define-derived-mode egg-log-msg-mode text-mode "Egg-LogMsg"
"Major mode for editing Git log message.\n\n
\{egg-log-msg-mode-map}."
(setq default-directory (egg-work-tree-dir))
(set (make-local-variable 'egg-log-msg-closure) nil)
(set (make-local-variable 'egg-log-msg-ring-idx) nil))
(define-key egg-log-msg-mode-map (kbd "C-c C-c") 'egg-log-msg-done)
(define-key egg-log-msg-mode-map (kbd "C-c C-k") 'egg-log-msg-cancel)
(define-key egg-log-msg-mode-map (kbd "C-c C-s") 'egg-log-msg-buffer-toggle-signed)
(define-key egg-log-msg-mode-map (kbd "M-p") 'egg-log-msg-older-text)
(define-key egg-log-msg-mode-map (kbd "M-n") 'egg-log-msg-newer-text)
(define-key egg-log-msg-mode-map (kbd "C-l") 'egg-buffer-cmd-refresh)
(defsubst egg-log-msg-commit (prefix gpg-uid text-beg text-end &rest ignored)
"Commit the index using the text between TEXT-BEG and TEXT-END as message.
PREFIX and IGNORED are ignored."
(egg-cleanup-n-commit-msg (if gpg-uid
#'egg--async-create-signed-commit-cmd
#'egg--git-commit-with-region-cmd)
text-beg text-end gpg-uid))
(defsubst egg-log-msg-amend-commit (prefix gpg-uid text-beg text-end &rest ignored)
"Amend the last commit with the index using the text between TEXT-BEG and TEXT-END
as message. PREFIX and IGNORED are ignored."
(egg-cleanup-n-commit-msg (if gpg-uid
#'egg--async-create-signed-commit-cmd
#'egg--git-commit-with-region-cmd)
text-beg text-end gpg-uid "--amend"))
(defun egg-log-msg-buffer-toggle-signed ()
"Toggle the to-be-gpg-signed state of the message being composed."
(interactive)
(let* ((gpg-uid (egg-log-msg-gpg-uid))
(new-uid (if gpg-uid
"None"
(read-string "Sign with gpg key uid: " (egg-user-name))))
(inhibit-read-only t))
(egg-log-msg-set-gpg-uid (if gpg-uid nil new-uid))
(save-excursion
(save-match-data
(goto-char (point-min))
(re-search-forward "^GPG-Signed by: \\(.+\\)$" (egg-log-msg-text-beg))
(replace-match (egg-text new-uid 'egg-text-2) nil t nil 1)
(set-buffer-modified-p nil)))))
(defun egg-log-msg-done (level)
"Take action with the composed message.
This usually means calling the lambda returned from (egg-log-msg-func)
with the appropriate arguments."
(interactive "p")
(widen)
(let* ((text-beg (egg-log-msg-text-beg))
(text-end (egg-log-msg-text-end))
(diff-beg (egg-log-msg-next-beg)))
(goto-char text-beg)
(if (save-excursion (re-search-forward "\\sw\\|\\-" text-end t))
(when (functionp (egg-log-msg-func))
(ring-insert egg-log-msg-ring
(buffer-substring-no-properties text-beg text-end))
(save-excursion (egg-log-msg-apply-closure level))
(let ((inhibit-read-only t)
(win (get-buffer-window (current-buffer))))
(erase-buffer)
(kill-buffer)))
(message "Please enter a log message!")
(ding))))
(defun egg-log-msg-cancel ()
"Cancel the current message editing."
(interactive)
(kill-buffer))
(defun egg-log-msg-hist-cycle (&optional forward)
"Cycle through message log history."
(let* ((len (ring-length egg-log-msg-ring))
(text-beg (egg-log-msg-text-beg))
(text-end (egg-log-msg-text-end)))
(cond ((<= len 0)
;; no history
(message "No previous log message.")
(ding))
;; don't accidentally throw away unsaved text
((and (null egg-log-msg-ring-idx)
(> text-end text-beg)
(not (y-or-n-p "throw away current text? "))))
;; do it
(t (delete-region text-beg text-end)
(setq egg-log-msg-ring-idx
(if (null egg-log-msg-ring-idx)
(if forward
;; 1st-time + fwd = oldest
(ring-minus1 0 len)
;; 1st-time + bwd = newest
0)
(if forward
;; newer
(ring-minus1 egg-log-msg-ring-idx len)
;; older
(ring-plus1 egg-log-msg-ring-idx len))))
(goto-char text-beg)
(insert (ring-ref egg-log-msg-ring egg-log-msg-ring-idx))))))
(defun egg-log-msg-older-text ()
"Cycle backward through comment history."
(interactive)
(egg-log-msg-hist-cycle))
(defun egg-log-msg-newer-text ()
"Cycle forward through comment history."
(interactive)
(egg-log-msg-hist-cycle t))
(defun egg-commit-log-buffer-show-diffs (buf &optional init diff-beg)
"Show the diff sections in the commit buffer.
See `egg-commit-buffer-sections'"
(with-current-buffer buf
(let* ((inhibit-read-only t)
(diff-beg (or diff-beg (egg-log-msg-next-beg)))
beg)
(egg-save-section-visibility)
(goto-char diff-beg)
(delete-region (point) (point-max))
(setq beg (point))
(dolist (sect egg-commit-buffer-sections)
(cond ((eq sect 'staged)
(egg-sb-insert-staged-section "Changes to Commit:" "--stat"))
((eq sect 'unstaged)
(egg-sb-insert-unstaged-section "Deferred Changes:"))
((eq sect 'untracked)
(egg-sb-insert-untracked-section))))
(egg-calculate-hunk-ranges)
(put-text-property beg (point) 'read-only t)
(put-text-property beg (point) 'front-sticky nil)
(if init (egg-buffer-maybe-hide-all))
(egg-restore-section-visibility)
(force-window-update buf))))
(define-egg-buffer commit "*%s-commit@%s*"
(egg-log-msg-mode)
(setq major-mode 'egg-commit-buffer-mode
mode-name "Egg-Commit"
mode-line-process ""
truncate-lines t)
(set (make-local-variable 'egg-buffer-refresh-func)
'egg-commit-log-buffer-show-diffs)
(setq buffer-invisibility-spec nil)
(run-mode-hooks 'egg-commit-buffer-mode-hook))
(defun egg-commit-log-edit (title-function
action-closure
insert-init-text-function &optional amend-no-msg)
"Open the commit buffer for composing a message.
With C-u prefix, the message will be use to amend the last commit.
With C-u C-u prefix, just amend the last commit with the old message.
For non interactive use:
TITLE-FUNCTION is either a string describing the text to compose or
a function return a string for the same purpose.
ACTION-CLOSURE is the input to build `egg-log-msg-closure'. It should
be the results of `egg-log-msg-mk-closure-from-input'.
INSERT-INIT-TEXT-FUNCTION is either a string or function returning a string
describing the initial text in the editing area.
if AMEND-NO-MSG is non-nil, the do nothing but amending the last commit
using git's default msg."
(interactive (let ((prefix (prefix-numeric-value current-prefix-arg)))
(cond ((> prefix 15) ;; C-u C-u
;; only set amend-no-msg
(list nil nil nil t))
((> prefix 3) ;; C-u
(list (concat
(egg-text "Amending " 'egg-text-3)
(egg-text (egg-pretty-head-name) 'egg-branch))
(egg-log-msg-mk-closure-input #'egg-log-msg-amend-commit)
(egg-commit-message "HEAD")))
(t ;; regular commit
(list (concat
(egg-text "Committing into " 'egg-text-3)
(egg-text (egg-pretty-head-name) 'egg-branch))
(egg-log-msg-mk-closure-input #'egg-log-msg-commit)
nil)))))
(if amend-no-msg
(egg-buffer-do-amend-no-edit)
(let* ((git-dir (egg-git-dir))
(default-directory (egg-work-tree-dir git-dir))
(buf (egg-get-commit-buffer 'create))
(state (egg-repo-state :name :email))
(head-info (egg-head))
(head (or (cdr head-info)
(format "Detached HEAD! (%s)" (car head-info))))
(inhibit-read-only inhibit-read-only)
text-beg text-end diff-beg)
(with-current-buffer buf
(setq inhibit-read-only t)
(erase-buffer)
(insert (cond ((functionp title-function)
(funcall title-function state))
((stringp title-function) title-function)
(t "Shit happens!"))
"\n"
(egg-text "Repository: " 'egg-text-1)
(egg-text git-dir 'font-lock-constant-face) "\n"
(egg-text "Committer: " 'egg-text-1)
(egg-text (plist-get state :name) 'egg-text-2) " "
(egg-text (concat "<" (plist-get state :email) ">") 'egg-text-2) "\n"
(egg-text "GPG-Signed by: " 'egg-text-1)
(egg-text "None" 'egg-text-2) "\n"
(egg-text "-- Commit Message (type `C-c C-c` when done or `C-c C-k` to cancel) -"
'font-lock-comment-face))
(put-text-property (point-min) (point) 'read-only t)
(put-text-property (point-min) (point) 'rear-sticky nil)
(insert "\n")
(setq text-beg (point-marker))
(set-marker-insertion-type text-beg nil)
(put-text-property (1- text-beg) text-beg :navigation 'commit-log-text)
(insert (egg-prop "\n------------------------ End of Commit Message ------------------------"
'read-only t 'front-sticky nil
'face 'font-lock-comment-face))
(setq diff-beg (point-marker))
(set-marker-insertion-type diff-beg nil)
(egg-commit-log-buffer-show-diffs buf 'init diff-beg)
(goto-char text-beg)
(cond ((functionp insert-init-text-function)
(funcall insert-init-text-function))
((stringp insert-init-text-function)
(insert insert-init-text-function)))
(setq text-end (point-marker))
(set-marker-insertion-type text-end t)
(set (make-local-variable 'egg-log-msg-closure)
(egg-log-msg-mk-closure-from-input action-closure
nil nil text-beg text-end diff-beg)))
(pop-to-buffer buf))))
;;;========================================================
;;; action
;;;========================================================
(defun egg-revert-visited-files (file-or-files)
"Revert the buffers of FILE-OR-FILES.
FILE-OR-FILES can be a string or a list of strings.
Each string should be a file name relative to the work tree."
(let* ((git-dir (egg-git-dir))
(default-directory (egg-work-tree-dir git-dir))
(files (if (listp file-or-files)
file-or-files
(list file-or-files))))
(mapcar (lambda (file)
(let ((buf (get-file-buffer file)))
(when (bufferp buf)
(with-current-buffer buf
(when (equal (egg-git-dir) git-dir)
(revert-buffer t t t))))))
files)))
(defun egg-revert-all-visited-files ()
(let* ((git-dir (egg-git-dir))
(default-directory (egg-work-tree-dir git-dir))
bufs files)
(setq files
(delq nil (mapcar (lambda (buf)
(with-current-buffer buf
(when (and (buffer-file-name buf)
(equal (egg-git-dir) git-dir))
(buffer-file-name buf))))
(buffer-list))))
(when (consp files)
(setq files (mapcar 'expand-file-name
(apply 'egg-git-to-lines "ls-files" files)))
(when (consp files)
(egg-revert-visited-files files)))))
(defun egg-hunk-section-apply-cmd (pos &rest args)
"Apply using git apply with ARGS as arguments.
The patch (input to git apply) will be built based on the hunk enclosing
POS."
(let ((patch (egg-hunk-section-patch-string pos (member "--reverse" args)))
(file (car (get-text-property pos :diff)))
res)
(unless (stringp file)
(error "No diff with file-name here!"))
(setq res (egg--git-apply-cmd t patch args))
(unless (member "--cached" args)
(egg-revert-visited-files (plist-get res :files)))
(plist-get res :success)))
(defun egg-show-applied-hunk-in-buffer (buf before after
hunk-text b-ranges a-ranges
question yes no)
(let ((inhibit-read-only t)
(before-1st-line (nth 0 before))
(before-num-lines (nth 1 before))
(before-text (nth 2 before))
(after-text (nth 2 after))
beg end bg answer)
(with-current-buffer buf
(goto-char (point-min))
(forward-line (1- before-1st-line))
(setq beg (point))
(setq end (save-excursion (forward-line before-num-lines) (point)))
(delete-region beg end)
(goto-char beg)
(insert hunk-text)
(setq end (point))
(dolist (range b-ranges)
(setq bg (make-overlay (+ (car range) beg) (+ (cdr range) beg) nil nil t))
(overlay-put bg 'face 'egg-del-bg)
(overlay-put bg 'evaporate t))
(dolist (range a-ranges)
(setq bg (make-overlay (+ (car range) beg) (+ (cdr range) beg) nil nil t))
(overlay-put bg 'face 'egg-add-bg)
(overlay-put bg 'evaporate t)))
(with-selected-window (display-buffer buf t)
(goto-char beg)
(recenter)
(setq answer (y-or-n-p question))
(bury-buffer buf))
(with-current-buffer buf
(goto-char beg)
(delete-region beg end)
(if answer
(cond ((eq yes :cleanup)
(set-buffer-modified-p nil))
((eq yes :kill)
(kill-buffer buf))
((eq yes :save)
(insert after-text)
(basic-save-buffer))
(t nil))
(cond ((eq no :cleanup)
(set-buffer-modified-p nil))
((eq no :kill)
(kill-buffer buf))
((eq no :restore)
(insert before-text)
(set-buffer-modified-p nil))
(t nil)))
answer)))
(defun egg-hunk-section-show-n-ask-staging (pos)
(let* ((hunk (egg-hunk-info-at pos))
(info (egg-hunk-compute-replacement-text hunk))
(file (car info))
(index (nth 1 info))
(worktree (nth 2 info))
(hunk-ranges-n-text (nth 3 info))
(hunk-text (nth 2 hunk-ranges-n-text))
(index-ranges (nth 0 hunk-ranges-n-text))
(worktree-ranges (nth 1 hunk-ranges-n-text))
(buf (egg-file-get-other-version file ":0" nil t)))
(if (egg-show-applied-hunk-in-buffer buf index worktree
hunk-text index-ranges worktree-ranges
(format "update Index's %s as shown? " file)
:kill :kill)
t
(message "Cancel staging %s's hunk %s" file (nth 1 hunk))
nil)))
(defun egg-hunk-section-show-n-ask-unstaging (pos)
(let* ((hunk (egg-hunk-info-at pos))
(info (egg-hunk-compute-replacement-text hunk))
(file (car info))
(head (nth 1 info))
(index (nth 2 info))
(hunk-ranges-n-text (nth 3 info))
(hunk-text (nth 2 hunk-ranges-n-text))
(head-ranges (nth 0 hunk-ranges-n-text))
(index-ranges (nth 1 hunk-ranges-n-text))
(buf (egg-file-get-other-version file ":0" nil t)))
(if (egg-show-applied-hunk-in-buffer buf index head
hunk-text index-ranges head-ranges
(format "restore Index's %s as shown? " file)
:kill :kill)
t
(message "Cancel unstaging %s's hunk %s" file (nth 1 hunk))
nil)))
(defun egg-sb-relocate-hunk (hunk-info)
(let* ((file (nth 0 hunk-info))
(ranges (nth 4 hunk-info))
(before-type (nth 0 ranges))
(type (cond ((eq before-type 'staged) 'unstaged)
((eq before-type 'unstaged) 'staged)
(t before-type)))
(range (nth 3 ranges))
(pos (point-min))
hunk found)
(while (and (not found)
(setq pos (next-single-property-change (1+ pos) :hunk)))
(when (and (setq hunk (egg-hunk-info-at pos))
(equal (car hunk) file)
(equal (car (nth 4 hunk)) type)
(equal (nth 3 (nth 4 hunk)) range))
(setq found pos)))
(unless (or found (eq type before-type))
(setq type before-type)
(setq pos (point-min))
(while (and (not found)
(setq pos (next-single-property-change (1+ pos) :hunk)))
(when (and (setq hunk (egg-hunk-info-at pos))
(equal (car hunk) file)
(equal (car (nth 4 hunk)) type)
(equal (nth 3 (nth 4 hunk)) range))
(setq found pos))))
(when found
(goto-char found))))
(defmacro with-current-hunk (pos &rest body)
"remember the hunk at POS, eval BODY then relocate the moved hunk."
(declare (indent 1) (debug t))
(let ((hunk-info (make-symbol "hunk-info")))
`(let ((,hunk-info (egg-hunk-info-at ,pos)))
,@body
(egg-sb-relocate-hunk ,hunk-info))))
(defun egg-hunk-section-cmd-stage (pos)
"Add the hunk enclosing POS to the index."
(interactive "d")
(when (or (not egg-confirm-staging)
(egg-hunk-section-show-n-ask-staging pos))
(with-current-hunk pos
(egg-hunk-section-apply-cmd pos "--cached"))))
(defun egg-hunk-section-cmd-unstage (pos)
"Remove the hunk enclosing POS from the index."
(interactive "d")
(when (or (not egg-confirm-staging)
(egg-hunk-section-show-n-ask-unstaging pos))
(with-current-hunk pos
(egg-hunk-section-apply-cmd pos "--cached" "--reverse"))))
(defun egg-hunk-section-show-n-undo (pos)
(let* ((hunk (egg-hunk-info-at pos))
(info (egg-hunk-compute-replacement-text hunk))
(file (car info))
(new (nth 2 info))
(old (nth 1 info))
(hunk-ranges-n-text (nth 3 info))
(buf (find-file-noselect file)) bg res)
(if (egg-show-applied-hunk-in-buffer buf new old
(nth 2 hunk-ranges-n-text)
(nth 1 hunk-ranges-n-text)
(nth 0 hunk-ranges-n-text)
(format "restore %s's text as shown? " file)
:save :restore)
(egg-refresh-buffer (current-buffer))
(message "Cancel undo %s's hunk %s!" file (nth 1 hunk)))))
(defun egg-sb-relocate-diff-file (diff-info)
(let ((file (car diff-info))
(marker (nth 1 diff-info))
(pos (point-min))
diff found)
(while (and (not found)
(setq pos (next-single-property-change (1+ pos) :diff)))
(when (and (setq diff (get-text-property pos :diff))
(equal (car diff) file))
(setq found (nth 1 diff))))
(when found
(goto-char found))))
(defmacro with-current-diff (pos &rest body)
"remember the diff at POS, eval BODY then relocate the moved diff."
(declare (indent 1) (debug t))
(let ((diff-info (make-symbol "diff-info")))
`(let ((,diff-info (get-text-property ,pos :diff)))
,@body
(egg-sb-relocate-diff-file ,diff-info))))
(defun egg-hunk-section-cmd-undo (pos)
"Remove the file's modification described by the hunk enclosing POS."
(interactive "d")
(cond ((null egg-confirm-undo)
(egg-hunk-section-apply-cmd pos "-p1" "--reverse"))
((or (eq egg-confirm-undo 'prompt)
;; only status buffer can do "show-n-undo"
;; fallback to prompt
(not (eq major-mode 'egg-status-buffer-mode)))
(if (y-or-n-p "irreversibly remove the hunk under cursor? ")
(egg-hunk-section-apply-cmd pos "-p1" "--reverse")
(message "Too chicken to proceed with undo operation!")))
((eq egg-confirm-undo 'show)
(egg-hunk-section-show-n-undo pos))))
(defun egg-diff-section-cmd-stage (pos)
"Update the index with the file at POS.
If the file was delete in the workdir then remove it from the index."
(interactive "d")
(let ((file (car (get-text-property pos :diff))))
(cond ((not (stringp file))
(error "No diff with file-name here!"))
((file-exists-p file)
;; add file to index, nothing change in wdir
;; diff and status buffers must be updated
;; just update them all
(with-current-diff pos
(egg--git-add-cmd t "-v" file)))
(t ;; file is deleted, update the index
(egg--git-rm-cmd t file)))))
(defun egg-diff-section-cmd-unstage (pos)
"For the file at POS, revert its stage in the index to original.
If the file was a newly created file, it will be removed from the index.
If the file was added after a merge resolution, it will reverted back to
conflicted state. Otherwise, its stage will be reset to HEAD."
(interactive "d")
(let ((is-merging (egg-is-merging (egg-repo-state)))
(diff-info (get-text-property pos :diff))
file newfile)
(setq newfile (memq 'newfile diff-info)
file (car diff-info))
(cond (newfile (egg--git-rm-cmd t "--cached" file))
(is-merging (with-current-diff pos
(egg--git-co-files-cmd t file "-m")))
(t (with-current-diff pos
(egg--git-reset-files-cmd t nil file))))))
(defun egg-diff-section-cmd-undo (pos)
"For the file at POS, remove its differences vs the source revision.
Usually, this command revert the file to its staged state in the index. However,
in a diff special egg buffer, it can change the file's contents to the one of
the source revision."
(interactive "d")
(unless (or (not egg-confirm-undo)
(y-or-n-p "irreversibly remove the delta under cursor? "))
(error "Too chicken to proceed with undo operation!"))
(let ((file (car (or (get-text-property pos :diff)
(error "No diff with file-name here!"))))
(src-rev (get-text-property pos :src-revision)))
(egg-revert-visited-files
(plist-get (cond ((stringp src-rev)
(egg--git-co-files-cmd t file src-rev))
((consp src-rev)
(egg--git-co-files-cmd
t file (egg-git-to-string "merge-base"
(car src-rev) (cdr src-rev))))
(t (egg--git-co-files-cmd t file)))
:files))))
(defun egg-diff-section-cmd-revert-to-head (pos)
"Revert the file and its slot in the index to its state in HEAD."
(interactive "d")
(let ((file (car (or (get-text-property pos :diff)
(error "No diff with file-name here!")))))
(unless (or (not egg-confirm-undo)
(y-or-n-p (format "irreversibly revert %s to HEAD? " file)))
(error "Too chicken to proceed with reset operation!"))
(egg-revert-visited-files
(plist-get (egg--git-co-files-cmd t file "HEAD") :files))))
(defun egg-file-stage-current-file ()
"Add the current's file contents into the index."
(interactive)
(let* ((short-file (file-name-nondirectory (buffer-file-name)))
(egg--do-no-output-message (format "staged %s's modifications" short-file)))
(egg-file-buffer-handle-result (egg--git-add-cmd (egg-get-status-buffer) "-v"
(buffer-file-name)))))
(defun egg-stage-all-files ()
"Stage all tracked files in the repository."
(interactive)
(let ((default-directory (egg-work-tree-dir))
(egg--do-no-output-message "staged all tracked files's modifications"))
(egg-file-buffer-handle-result (egg--git-add-cmd (egg-get-status-buffer) "-v" "-u"))))
(defsubst egg-log-buffer-do-move-head (reset-mode rev)
(egg-buffer-do-move-head reset-mode rev 'log))
(defsubst egg-status-buffer-do-move-head (reset-mode rev)
(egg-buffer-do-move-head reset-mode rev 'status))
(defun egg-unstage-all-files ()
"Unstage all files in the index."
(interactive)
(let ((default-directory (egg-work-tree-dir)))
(when (egg-status-buffer-do-move-head "--mixed" "HEAD")
(message "unstaged all modfications in INDEX"))))
(defun egg-sb-undo-wdir-back-to-index (really-do-it take-next-action ignored-action)
"When in the status buffer, reset the work-tree to the state in the index.
When called interactively, do nothing unless REALLY-DO-IT is non-nil.
Take the next logical action if TAKE-NEXT-ACTION is non-nil unless the
next action is IGNORED-ACTION."
(interactive (list (or current-prefix-arg
(y-or-n-p "throw away all unstaged modifications? "))
t nil))
(when really-do-it
(let ((default-directory (egg-work-tree-dir))
(egg--do-no-output-message "reverted work-dir to INDEX"))
(egg-status-buffer-do-co-rev :0 "-f" "-a"))))
(defun egg-sb-undo-wdir-back-to-HEAD (really-do-it take-next-action ignored-action)
"When in the status buffer, reset the work-tree and the index to HEAD.
When called interactively, do nothing unless REALLY-DO-IT is non-nil.
Take the next logical action if TAKE-NEXT-ACTION is non-nil unless the
next action is IGNORED-ACTION."
(interactive (list (y-or-n-p "throw away all (staged and unstaged) modifications? ")))
(when really-do-it
(let ((default-directory (egg-work-tree-dir)))
(egg-status-buffer-do-move-head "--hard" "HEAD"))))
(defun egg-status-buffer-undo-wdir (harder)
"When in the status buffer, throw away local modifications in the work-tree.
if HARDER is non-nil (prefixed with C-u), reset the work-tree to its state
in HEAD. Otherwise, reset the work-tree to its staged state in the index."
(interactive "P")
(funcall (if harder
#'egg-sb-undo-wdir-back-to-HEAD
#'egg-sb-undo-wdir-back-to-index)
(y-or-n-p (format "throw away ALL %s modifications? "
(if harder "(staged AND unstaged)" "unstaged")))
t 'status))
(defun egg-stage-untracked-files ()
"Add all untracked files to the index."
(interactive)
(let ((default-directory (egg-work-tree-dir))
(egg--do-git-quiet t))
(when (egg--git-add-cmd t "-v" ".")
(message "staged all untracked files"))))
(defun egg-buffer-do-move-head (reset-mode rev &optional ignored-action)
"Move (reset) HEAD to REV using RESET-MODE.
REV should be a valid git rev (branch, tag, commit,...)
RESET-MODE should be a valid reset option such as --hard.
The command usually takes the next action recommended by the results, but
if the next action is IGNORED-ACTION then it won't be taken."
(let* ((egg--do-no-output-message
(format "detached %s and re-attached on %s"
(egg-branch-or-HEAD) rev))
(res (egg--git-reset-cmd t reset-mode rev)))
(egg--buffer-handle-result res t ignored-action)
(plist-get res :success)))
(defun egg-buffer-do-merge-to-head (rev &optional merge-mode-flag msg ignored-action)
"Merge REV to HEAD.
REV should be a valid git rev (branch, tag, commit,...)
MERGE-MODE should be a valid reset option such as --ff-only.
MSG will be used for the merge commit.
Thecommand usually take the next action recommended by the results, but
if the next action is IGNORED-ACTION then it won't be taken."
(let ((msg (or msg (concat "merging in " rev)))
merge-cmd-ok res modified-files options
need-commit force-commit-to-status line fix-line-func)
(setq modified-files (egg-git-to-lines "diff" "--name-only" rev))
(cond ((equal merge-mode-flag "--commit")
(setq options egg-git-merge-strategy-options)
(setq need-commit t)
(setq merge-mode-flag "--no-commit")
(setq fix-line-func
(lambda (merge-res)
(let (line)
(when (and (plist-get merge-res :success)
(setq line (plist-get merge-res :line)))
(save-match-data
(when (string-match "stopped before committing as requested" line)
(setq line
"Auto-merge went well, please prepare the merge message")
(plist-put merge-res :line line)))))
merge-res)))
((member merge-mode-flag '("--no-commit" "--squash"))
(setq options egg-git-merge-strategy-options)
(setq force-commit-to-status t)))
(setq res (nconc (egg--git-merge-cmd-args 'all fix-line-func
(append (cons merge-mode-flag options)
(list "--log" rev)))
(list :files modified-files)))
(if need-commit
(egg--buffer-handle-result-with-commit
res (list (concat (egg-text "Merge in: " 'egg-text-3)
(egg-text rev 'egg-branch))
(egg-log-msg-mk-closure-input #'egg-log-msg-commit)
msg)
t ignored-action)
(when (and (eq (plist-get res :next-action) 'commit)
force-commit-to-status)
(plist-put res :next-action 'status))
(egg--buffer-handle-result res t ignored-action))))
(defsubst egg-log-buffer-do-merge-to-head (rev &optional merge-mode-flag)
"Merge REV to HEAD when the log special buffer.
see `egg-buffer-do-merge-to-head'."
(egg-buffer-do-merge-to-head rev merge-mode-flag nil 'log))
(defun egg-do-rebase-head (upstream-or-action &optional onto current-action)
"Rebase HEAD based on UPSTREAM-OR-ACTION.
If UPSTREAM-OR-ACTION is a string then it used as upstream for the rebase operation.
If ONTO is non-nil, then rebase HEAD onto ONTO using UPSTREAM-OR-ACTION as upstream.
If UPSTREAM-OR-ACTION is one of: :abort, :skip and :continue then
perform the indicated rebase action."
(let ((pre-merge (egg-get-current-sha1))
cmd-res modified-files feed-back old-choices)
(with-egg-debug-buffer
(unless (eq upstream-or-action :abort) ;; keep for debugging
(erase-buffer))
(setq cmd-res
(cond ((and (stringp onto) (stringp upstream-or-action))
(egg--git-rebase-merge-cmd-args
t nil (append egg-git-merge-strategy-options
(list "-m" "--onto" onto upstream-or-action))))
((eq upstream-or-action :abort)
(egg--git-rebase-merge-cmd t nil "--abort"))
((eq upstream-or-action :skip)
(egg--git-rebase-merge-cmd t nil "--skip"))
((eq upstream-or-action :continue)
(egg--git-rebase-merge-cmd t nil "--continue"))
((stringp upstream-or-action)
(egg--git-rebase-merge-cmd-args
t nil (append egg-git-merge-strategy-options
(list "-m" upstream-or-action))))))
(setq modified-files (egg-git-to-lines "diff" "--name-only" pre-merge))
(when (consp cmd-res) (plist-put cmd-res :files modified-files))
(egg--buffer-handle-result cmd-res t current-action))))
;;;========================================================
;;; diff-mode
;;;========================================================
(defconst egg-diff-buffer-mode-map
(let ((map (make-sparse-keymap "Egg:DiffBuffer")))
(set-keymap-parent map egg-buffer-mode-map)
(define-key map "G" 'egg-diff-buffer-run-command)
(define-key map "s" 'egg-status)
(define-key map "l" 'egg-log)
(define-key map "/" 'egg-search-changes)
(define-key map "C-c C-/" 'egg-search-changes-all)
map)
"\\{egg-diff-buffer-mode-map}")
(defun egg-diff-buffer-run-command ()
"Re-run the command that create the buffer."
(interactive)
(call-interactively (or (plist-get egg-diff-buffer-info :command)
#'egg-buffer-cmd-refresh)))
(defun egg-buffer-ask-pickaxe-mode (pickaxe-action search-code &optional default-term)
(let* ((key-type-alist '((?s "string" identity)
(?r "posix regex" (lambda (s) (list s :regexp)))
(?l "line matching regex" (lambda (s) (list s