Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
9343 lines (8403 sloc) 379 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-12 byplayer
;;
;; Author: Bogolisk <bogolisk@gmail.com>
;; Created: 19 Aug 2008
;; Version: 1.0.2
;; Keywords: git, version control, release management
;;
;; Special Thanks to
;; Antoine Levitt, Bogolisk,
;; Christian Köstlin
;; Max Mikhanosha
;; Aleksandar Simic
;;
;; 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"))
(require 'cl)
(require 'electric)
(require 'ediff)
(require 'ffap)
(require 'diff-mode)
(defconst egg-version "1.0.2")
(defgroup egg nil
"Controlling Git from Emacs."
:prefix "egg-"
:group 'tools)
(defgroup egg-faces nil
"Colourful Faces for Egg."
:group 'egg)
(defface egg-header
'((t :weight bold :inherit variable-pitch :height 1.1))
"Face for generic headers.
Many Egg faces inherit from this one by default."
:group 'egg-faces)
(defface egg-text-base
'((((class color) (background light))
:foreground "navy" :inherit variable-pitch)
(((class color) (background dark))
:foreground "SteelBlue" :inherit variable-pitch)
(t))
"Face for description text."
:group 'egg-faces)
(defface egg-text-1
'((t :inherit egg-text-base))
"Face for description text."
:group 'egg-faces)
(defface egg-text-help
'((t :inherit egg-text-base :height 0.8))
"Face for help text."
:group 'egg-faces)
(defface egg-help-header-1
'((t :inherit egg-text-base :weight bold))
"Face for help text."
:group 'egg-faces)
(defface egg-help-header-2
'((((class color) (background light))
:foreground "Black" :inherit egg-text-1 :height 0.9)
(((class color) (background dark))
:foreground "LightSteelBlue" :inherit egg-text-1 :height 0.9)
(t :inherit egg-text-1))
"Face for help text."
:group 'egg-faces)
(defface egg-text-2
'((t :inherit egg-text-base :height 1.1))
"Face for description text."
:group 'egg-faces)
(defface egg-text-3
'((t :inherit egg-text-base :height 1.2))
"Face for description text."
:group 'egg-faces)
(defface egg-text-4
'((t :inherit egg-text-base :height 1.4))
"Face for description text."
:group 'egg-faces)
(defface egg-electrict-choice
'((((class color) (background light))
:foreground "Blue" :inherit egg-text-1 :weight bold)
(((class color) (background dark))
:foreground "Cyan" :inherit egg-text-1 :weight bold)
(t))
"Face for description text."
:group 'egg-faces)
(defface egg-section-title
'((((class color) (background light))
:foreground "DarkGoldenrod" :inherit egg-header :height 1.1)
(((class color) (background dark))
:foreground "PaleGreen" :inherit egg-header :height 1.1)
(t :weight bold))
"Face for generic header lines.
Many Egg faces inherit from this one by default."
:group 'egg-faces)
(defface egg-branch
'((((class color) (background light))
:foreground "SkyBlue" :inherit egg-header :height 1.1)
(((class color) (background dark))
:foreground "Yellow" :inherit egg-header :height 1.1)
(t :weight bold))
"Face for the current branch."
:group 'egg-faces)
(defface egg-log-buffer-mark
'((((class color) (background light))
:foreground "black" :inherit bold)
(((class color) (background dark))
:foreground "orchid1" :inherit bold)
(t :weight bold))
"Face to mark commit line in log-buffer."
:group 'egg-faces)
(defface egg-branch-mono
'((((class color) (background light))
:foreground "SkyBlue" :inherit bold)
(((class color) (background dark))
:foreground "Yellow" :inherit bold)
(t :weight bold))
"Face for a branch."
:group 'egg-faces)
(defface egg-tag-mono
'((((class color) (background light))
:foreground "GoldenRod" :inherit bold)
(((class color) (background dark))
:foreground "SkyBlue" :inherit bold)
(t :weight bold))
"Face for a tag."
:group 'egg-faces)
(defface egg-an-tag-mono
'((((class color) (background light))
:foreground "DarkGoldenRod" :inherit bold)
(((class color) (background dark))
:foreground "LightGreen" :inherit bold)
(t :weight bold))
"Face for an annotated branch."
:group 'egg-faces)
(defface egg-stash-mono
'((((class color) (background light))
:foreground "DarkGoldenRod" :inherit bold)
(((class color) (background dark))
:foreground "LightGreen" :inherit bold)
(t :weight bold))
"Face for a stash identifier."
:group 'egg-faces)
(defface egg-reflog-mono
'((((class color) (background light))
:foreground "gray70" :inherit egg-stash-mono)
(((class color) (background dark))
:foreground "gray30" :inherit egg-stash-mono)
(t :weight bold))
"Face for a reflog identifier."
:group 'egg-faces)
(defface egg-remote-mono
'((((class color) (background light))
:foreground "Orchid" :inherit bold)
(((class color) (background dark))
:foreground "DarkSalmon" :inherit bold)
(t :weight bold))
"Face for a remote."
:group 'egg-faces)
(defface egg-term
'((((class color) (background light))
:foreground "SkyBlue" :inherit bold)
(((class color) (background dark))
:foreground "Yellow" :inherit bold)
(t :weight bold))
"Face for an important term."
:group 'egg-faces)
(defface egg-help-key
'((t :inherit egg-term :height 0.9))
"Hilight Face in help text."
:group 'egg-faces)
(defface egg-warning
'((((class color) (background light))
:foreground "Red" :inherit bold)
(((class color) (background dark))
:foreground "Orange" :inherit bold)
(t :weight bold))
"Face for a warning."
:group 'egg-faces)
(defface egg-diff-file-header
'((((class color) (background light))
:foreground "SlateBlue" :inherit egg-header)
(((class color) (background dark))
:foreground "LightSlateBlue" :inherit egg-header)
(t :weight bold))
"Face for diff file headers."
:group 'egg-faces)
(defface egg-unmerged-diff-file-header
'((((class color) (background light))
:foreground "Red" :inherit egg-diff-file-header)
(((class color) (background dark))
:foreground "Orange" :inherit egg-diff-file-header)
(t :weight bold))
"Face for unmerged diff file headers."
:group 'egg-faces)
(defface egg-diff-hunk-header
'((((class color) (background light))
:background "grey85")
(((class color) (background dark))
:background "grey45"))
"Face for diff hunk headers."
:group 'egg-faces)
(defface egg-diff-add
'((((class color) (background light))
:foreground "blue1")
(((class color) (background dark))
:foreground "ForestGreen"))
"Face for lines in a diff that have been added."
:group 'egg-faces)
(defface egg-add-bg
'((((class color) (background light))
:background "medium sea green")
(((class color) (background dark))
:background "#375243"))
"Background Face for lines in a diff that have been added."
:group 'egg-faces)
(defface egg-del-bg
'((((class color) (background light))
:background "indian red")
(((class color) (background dark))
:background "IndianRed4"))
"Background Face for lines in a diff that have been deleted."
:group 'egg-faces)
(defface egg-diff-none
'((((class color) (background light))
:foreground "grey50")
(((class color) (background dark))
:foreground "grey70"))
"Face for lines in a diff that are unchanged."
:group 'egg-faces)
(defface egg-diff-del
'((((class color) (background light))
:foreground "red")
(((class color) (background dark))
:foreground "OrangeRed"))
"Face for lines in a diff that have been deleted."
:group 'egg-faces)
(defface egg-diff-conflict
'((((class color) (background light))
:foreground "Blue")
(((class color) (background dark))
:foreground "Orange"))
"Face for lines in a diff that have been deleted."
:group 'egg-faces)
(defface egg-graph
'((((class color) (background light))
:foreground "grey90")
(((class color) (background dark))
:foreground "grey30"))
"Face for graph."
:group 'egg-faces)
(defface egg-blame
'((((class color) (background light))
:background: "grey85" :foreground "black")
(((class color) (background dark))
:background "grey15" :foreground "white")
(t :inherit region))
"Face for blame header."
:group 'egg-faces)
(defface egg-blame-culprit
'((((class color) (background light))
:inherit egg-text-2 :background "grey85" :foreground "grey35")
(((class color) (background dark))
:inherit egg-text-2 :background "grey15" :foreground "grey60")
(t :inherit egg-blame))
"Face for blame culprit."
:group 'egg-faces)
(defface egg-blame-subject
'((((class color) (background light))
:inherit egg-blame-culprit :foreground "black")
(((class color) (background dark))
:inherit egg-blame-culprit :foreground "white")
(t :inherit egg-blame))
"Face for blame tag line."
:group 'egg-faces)
(defface egg-log-HEAD
'((t (:inherit region)))
"Face to highlight HEAD in the log buffer."
:group 'egg-faces)
(defface egg-log-HEAD-name
'((t (:inherit (egg-log-HEAD egg-branch-mono))))
"Face to highlight HEAD in the log buffer."
:group 'egg-faces)
(defcustom egg-buffer-hide-sub-blocks-on-start nil
"Initially hide all sub-blocks."
:group 'egg
:type '(set (const :tag "Status Buffer" egg-status-buffer-mode)
(const :tag "Log Buffer" egg-log-buffer-mode)
(const :tag "File Log Buffer" egg-file-log-buffer-mode)
(const :tag "Diff Buffer" egg-diff-buffer-mode)
(const :tag "Commit Buffer" egg-commit-buffer-mode)))
(defcustom egg-buffer-hide-section-type-on-start nil
"Initially hide sections of the selected type."
:group 'egg
:type '(set (cons :tag "Status Buffer"
(const :tag "Hide Blocks of type"
egg-status-buffer-mode)
(radio (const :tag "Section" :section)
(const :tag "File" :diff)
(const :tag "Hunk" :hunk)))
(cons :tag "Commit Log Buffer"
(const :tag "Hide Blocks of type"
egg-commit-buffer-mode)
(radio (const :tag "Section" :section)
(const :tag "File" :diff)
(const :tag "Hunk" :hunk)))
(cons :tag "Diff Buffer"
(const :tag "Hide Blocks of type"
egg-diff-buffer-mode)
(radio (const :tag "File" :diff)
(const :tag "Hunk" :hunk)))))
(defcustom egg-buffer-hide-help-on-start nil
"Initially hide keybindings help."
:group 'egg
:type '(set (const :tag "Status Buffer" egg-status-buffer-mode)
(const :tag "Log Buffer" egg-log-buffer-mode)
(const :tag "File Log Buffer" egg-file-log-buffer-mode)
(const :tag "Diff Buffer" egg-diff-buffer-mode)
(const :tag "Commit Buffer" egg-commit-buffer-mode)))
(defcustom egg-log-HEAD-max-len 1000
"Maximum number of entries when showing the history of HEAD."
:group 'egg
:type 'integer)
(defcustom egg-log-all-max-len 10000
"Maximum number of entries when showing the history of HEAD."
:group 'egg
:type 'integer)
(defcustom egg-max-reflogs 10
"Maximum number of reflogs displayed in the log buffer."
:group 'egg
:type 'integer)
(defcustom egg-confirm-next-action t
"Always prompt for confirmation while guessing the next logical action ."
:group 'egg
:type 'boolean)
(defcustom egg-confirm-undo t
"Always prompt for confirmation before removing delta from workdir."
:group 'egg
:type 'boolean)
(defcustom egg-status-buffer-sections '(repo unstaged staged untracked)
"Sections to be listed in the status buffer and their order."
:group 'egg
:type '(repeat (choice (const :tag "Repository Info" repo)
(const :tag "Unstaged Changes Section" unstaged)
(const :tag "Staged Changes Section" staged)
(const :tag "Untracked/Unignored Files" untracked))))
(defcustom egg-commit-buffer-sections '(staged unstaged untracked)
"Sections to be listed in the status buffer and their order."
:group 'egg
:type '(repeat (choice (const :tag "Unstaged Changes Section" unstaged)
(const :tag "Staged Changes Section" staged)
(const :tag "Untracked/Unignored Files" untracked))))
(defcustom egg-refresh-index-in-backround nil
"Whether to refresh the index in the background when emacs is idle."
:group 'egg
:type 'boolean)
(defcustom egg-enable-tooltip nil
"Whether to activate useful tooltips, showing the local keymap at the point."
:group 'egg
:type 'boolean)
(defcustom egg-git-rebase-subdir "rebase-merge"
"Name of the rebase's workdir.
Different versions of git have different names for this subdir."
:group 'egg
:type '(choice (const ".dotest-merge")
(const "rebase-merge")
string))
(defcustom egg-show-key-help-in-buffers
'(:log :status :diff :file-log :reflog :query :stash)
"Display keybinding help in egg special buffers."
:group 'egg
:type '(set (const :tag "Status Buffer" :status)
(const :tag "Log Buffer" :log)
(const :tag "File Log Buffer" :file-log)
(const :tag "RefLog Buffer" :reflog)
(const :tag "Diff Buffer" :diff)
(const :tag "Commit Buffer" :commit)
(const :tag "Search Buffer" :query)
(const :tag "Stash Buffer" :stash)))
(define-widget 'egg-quit-window-actions-set 'lazy
"Custom Type for quit-window actions."
:offset 4
:format "%v"
:type '(set :tag "Actions"
(const :tag "Kill Buffer" kill)
(const :tag "Restore Windows" restore-windows)))
(defcustom egg-quit-window-actions nil
"Actions to perform upon quitting an egg special buffer."
:group 'egg
:type '(set (cons :format "%v" (const :tag "Status Buffer" egg-status-buffer-mode)
egg-quit-window-actions-set)
(cons :format "%v" (const :tag "Log (History) Buffer" egg-log-buffer-mode)
egg-quit-window-actions-set)
(cons :format "%v" (const :tag "Commit Log Buffer" egg-commit-buffer-mode)
egg-quit-window-actions-set)
(cons :format "%v" (const :tag "Diff Buffer" egg-diff-buffer-mode)
egg-quit-window-actions-set)
(cons :format "%v" (const :tag "File Log (History) Buffer" egg-file-log-buffer-mode)
egg-quit-window-actions-set)))
(defcustom egg-git-command "git"
"Name or full-path to the git command.
Set this to the appropriate string in the case where `git' is not the
desirable way to invoke GIT."
:group 'egg
:type 'string)
(defcustom egg-cmd-select-special-buffer nil
"If true, then select the special window invoked by the command.
Instead of just displaying it. Commands like egg-status, unless prefixed
with C-u, only display the special buffer but not selecting it. When
this option is true, invert the meaning of the prefix. I.e. the command
will select the window unless prefixed with C-u."
:group 'egg
:type 'boolean)
(defcustom egg-git-diff-options
'("--patience" "--ignore-space-at-eol")
"Extra options for git diff."
:group 'egg
:type '(set :tag "Extra Diff Options"
(radio :tag "Algorithm"
(const :tag "Patience" "--patience")
(const :tag "Historgram" "--histogram")
(const :tag "Minimal" "--minimal"))
(radio :tag "White Space"
(const :tag "Ignore Space at End-of-Line"
"--ignore-space-at-eol")
(const :tag "Ignore Space Changes"
"--ignore-space-change")
(const :tag "Ignore All Space"
"--ignore-all-space"))))
(defcustom egg-git-diff-file-options-alist
'((c-mode "--patience" "--ignore-all-space")
(emacs-lisp-mode "--patience" "--ignore-all-space")
(text-mode "--histogram")
(makefile-mode "--patience" "--ignore-space-at-eol"))
"Extra options for when show diff of a file matching a major mode."
:group 'egg
:type '(repeat (cons :tag "File Diff"
(choice :tag "Mode"
(const :tag "C" c-mode)
(const :tag "C++" c++-mode)
(const :tag "Java" java-mode)
(const :tag "Text" text-mode)
(const :tag "ELisp" emacs-lisp-mode)
(const :tag "Lisp" lisp-mode)
(const :tag "Makefile" makefile-mode)
(const :tag "Python" python-mode)
(const :tag "Perl" perl-mode)
(symbol :tag "Other"))
(set :tag "Extra Options"
(radio :tag "Algorithm"
(const :tag "Patience" "--patience")
(const :tag "Historgram" "--histogram")
(const :tag "Minimal" "--minimal"))
(radio :tag "White Space"
(const :tag "Ignore Space at End-of-Line"
"--ignore-space-at-eol")
(const :tag "Ignore Space Changes"
"--ignore-space-change")
(const :tag "Ignore All Space"
"--ignore-all-space"))))
))
(defcustom egg-dummy-option nil
"Foo bar"
:group 'egg
:type '(set (const :bold) (const :italic)))
(defvar egg-gpg-agent-info nil)
(defun egg-gpg-agent-info (&optional action-if-not-set)
(or egg-gpg-agent-info
(setq egg-gpg-agent-info
(let* ((file (and (file-readable-p "~/.gpg-agent-info")
(expand-file-name "~/.gpg-agent-info")))
(info (and file (egg-pick-file-contents
file "^GPG_AGENT_INFO=\\(.+\\)$" 1)))
(env (getenv "GPG_AGENT_INFO"))
(info-list (and (stringp info) (save-match-data
(split-string info ":" t))))
(socket (and info-list (car info-list)))
(agent-pid (and info-list (string-to-number (nth 1 info-list))))
(agent-attr (and agent-pid (process-attributes agent-pid)))
(agent-cmdline (and agent-attr (cdr (assq 'args agent-attr))))
agent-info)
(setq agent-info
(if (stringp env)
env ;; trust the environment
(when (and info
(file-exists-p socket)
(= (aref (nth 8 (file-attributes socket)) 0) ?s)
agent-attr
(save-match-data
(string-match "gpg-agent" agent-cmdline)))
info)))
(when (and (not env) agent-info)
(cond ((eq action-if-not-set 'set)
(setenv "GPG_AGENT_INFO" agent-info))
((stringp action-if-not-set)
(if (y-or-n-p (format action-if-not-set agent-info))
(setenv "GPG_AGENT_INFO" agent-info)
(setq agent-info nil)))
((null action-if-not-set)
;; cancel everything!!!
(setq agent-info nil))
(t (error "What happened? (action-if-not-set = %s)"
action-if-not-set))))
agent-info))))
;;;========================================================
;;; simple routines
;;;========================================================
(defsubst egg-unquote-posix-regexp (string)
(while (string-match "\\\\[\\|()]" string)
(setq string (concat (substring string 0 (match-beginning 0))
(substring string (1+ (match-beginning 0))))))
string)
(defmacro invoked-interactively-p ()
"wrapper for checking if the function was invoked interactively,
works around the deprecation of 'interactive-p' after Emacs 23.2"
(if (> emacs-major-version 23)
'(called-interactively-p 'interactive)
(if (> emacs-minor-version 2)
'(called-interactively-p 'interactive)
'(interactive-p))))
(defmacro with-egg-debug-buffer (&rest body)
"Evaluate BODY there like `progn' in the egg's debug buffer.
See also `with-temp-file' and `with-output-to-string'."
(declare (indent 0) (debug t))
(let ((egg-debug-buffer (make-symbol "egg-debug-buffer"))
(egg-debug-dir (make-symbol "egg-debug-dir")))
`(let ((,egg-debug-dir (egg-work-tree-dir))
(,egg-debug-buffer (get-buffer-create (concat "*egg-debug:" (egg-git-dir) "*"))))
(with-current-buffer ,egg-debug-buffer
(setq default-directory ,egg-debug-dir)
(unwind-protect
(progn ,@body)
)))))
(defmacro with-egg-async-buffer (&rest body)
"Evaluate BODY there like `progn' in the egg's async buffer.
See also `with-temp-file' and `with-output-to-string'."
(declare (indent 0) (debug t))
(let ((egg-async-buffer (make-symbol "egg-async-buffer"))
(egg-async-dir (make-symbol "egg-async-dir")))
`(let ((,egg-async-dir (egg-work-tree-dir))
(,egg-async-buffer (get-buffer-create (concat "*egg-async:" (egg-git-dir) "*"))))
;; FIXME: kill-buffer can change current-buffer in some odd cases.
(with-current-buffer ,egg-async-buffer
(setq default-directory ,egg-async-dir)
(unwind-protect
(progn ,@body)
)))))
;; (cl-macroexpand '(with-egg-debug-buffer (do-something)))
;; (let* ((egg-debug-dir (egg-work-tree-dir))
;; (egg-debug-buffer (get-buffer-create (concat "*egg-debug:" (egg-git-dir) "*"))))
;; (with-current-buffer egg-debug-buffer
;; (setq default-directory egg-debug-dir)
;; (unwind-protect
;; (progn (do-something))
;; (and (buffer-name egg-debug-buffer)
;; (kill-buffer egg-debug-buffer)))))
(defmacro egg-text (text face)
"Format TEXT with face FACE at compile-time or run-time."
(cond ((stringp text)
(propertize text 'face (if (symbolp face) face
(nth 1 face))))
((null text)
`(propertize "<internal-bug>" 'face ,face))
(t `(propertize ,text 'face ,face))))
;;(cl-macroexpand '(egg-text blah 'egg-text-3))
(defmacro egg-prop (text &rest prop)
"Propertize TEXT with properties list PROP at compile-time or run-time."
(if (stringp text)
(apply 'propertize text
(mapcar (lambda (sym)
(if (consp sym)
(nth 1 sym)
sym))
prop))
`(propertize ,text ,@prop)))
(defsubst egg-string-at-point () (current-word t))
;;(defalias 'egg-string-at-point 'ffap-string-at-point)
(defalias 'egg-find-file-at-point 'find-file-at-point)
(defsubst egg-goto-line (line)
(goto-char (point-min))
(forward-line (1- line)))
(defsubst egg-prepend (str prefix &rest other-properties)
"Make STR appear to have prefix PREFIX.
If OTHER-PROPERTIES was non-nil, apply it to STR."
(setq prefix (concat prefix (substring str 0 1)))
(setq str (apply 'propertize str other-properties))
(put-text-property 0 1 'display prefix str)
str)
(defsubst egg-commit-contents (rev)
"Retrieve the raw-contents of the commit REV."
(with-temp-buffer
(call-process egg-git-command nil t nil "cat-file" "commit" rev)
(buffer-string)))
(defsubst egg-commit-message (rev)
"Retrieve the commit message of REV."
(save-match-data
(with-temp-buffer
(call-process egg-git-command nil t nil "cat-file" "commit" rev)
(goto-char (point-min))
(re-search-forward "^\n")
(buffer-substring-no-properties (match-end 0) (point-max)))))
(defun egg-commit-subject (rev)
"Retrieve the commit subject of REV."
(save-match-data
(with-temp-buffer
(call-process egg-git-command nil t nil "cat-file" "commit" rev)
(goto-char (point-min))
(re-search-forward "^\n")
(buffer-substring-no-properties (match-end 0)
(if (or (re-search-forward "\n\n" nil t)
(re-search-forward "\n" nil t))
(match-beginning 0)
(point-max))))))
(defsubst egg-cmd-to-string-1 (program args)
"Execute PROGRAM and return its output as a string.
ARGS is a list of arguments to pass to PROGRAM."
(with-temp-buffer
(if (= (apply 'call-process program nil t nil args) 0)
(buffer-substring-no-properties
(point-min) (if (> (point-max) (point-min))
(1- (point-max)) (point-max))))))
(defsubst egg-cmd-to-string (program &rest args)
"Execute PROGRAM and return its output as a string.
ARGS is a list of arguments to pass to PROGRAM."
(egg-cmd-to-string-1 program args))
(defsubst egg-git-to-string (&rest args)
"run GIT wih ARGS and return the output as a string."
(egg-cmd-to-string-1 egg-git-command args))
(defsubst egg-cmd-ok (program buffer &rest args)
"run PROGRAM with ARGS and insert output into BUFFER at point.
return the t if the exit-code was 0. if BUFFER was t then
current-buffer would be used."
(= (apply 'call-process program nil buffer nil args) 0))
(defsubst egg-git-ok (buffer &rest args)
"run GIT with ARGS and insert output into BUFFER at point.
return the t if the exit-code was 0. if BUFFER was t then
current-buffer would be used."
(= (apply 'call-process egg-git-command nil buffer nil args) 0))
(defsubst egg-git-ok-args (buffer args)
"run GIT with ARGS and insert output into BUFFER at point.
return the t if the exit-code was 0. if BUFFER was t then
current-buffer would be used."
(= (apply 'call-process egg-git-command nil buffer nil args) 0))
(defun egg-git-show-file-args (buffer file rev args)
(let* ((mode (assoc-default file auto-mode-alist 'string-match))
(extras (and mode (assoc-default mode egg-git-diff-file-options-alist 'eq))))
(egg-git-ok-args buffer (append (list "--no-pager" "show")
extras
args
(list rev "--" file)))))
(defsubst egg-git-show-file (buffer file rev &rest args)
(egg-git-show-file-args buffer file rev args))
(defsubst egg-git-region-ok (start end &rest args)
"run GIT with ARGS and insert output into current buffer at point.
return the t if the exit-code was 0. The text between START and END
is used as input to GIT."
(= (apply 'call-process-region start end egg-git-command t t nil args) 0))
(defsubst egg-wdir-clean () (egg-git-ok nil "diff" "--quiet"))
(defsubst egg-file-updated (file)
(egg-git-ok nil "diff" "--quiet" "--" file))
(defsubst egg-file-committed (file)
(egg-git-ok nil "diff" "--quiet" "HEAD" "--" file))
(defsubst egg-file-index-empty (file)
(egg-git-ok nil "diff" "--quiet" "--cached" "--" file))
(defsubst egg-index-empty () (egg-git-ok nil "diff" "--cached" "--quiet"))
(defsubst egg-has-stashed-wip ()
(egg-git-ok nil "rev-parse" "--verify" "-q" "stash@{0}"))
(defsubst egg-git-to-lines (&rest args)
"run GIT with ARGS.
Return the output lines as a list of strings."
(save-match-data
(split-string (or (egg-cmd-to-string-1 egg-git-command args) "")
"[\n]+" t)))
(defun egg-git-lines-matching (re idx &rest args)
"run GIT with ARGS.
Return the output lines as a list of strings."
(with-temp-buffer
(when (= (apply 'call-process egg-git-command nil t nil args) 0)
(let (lines)
(save-match-data
(goto-char (point-min))
(while (re-search-forward re nil t)
(setq lines (cons (match-string-no-properties idx) lines)))
lines)))))
(defun egg-git-lines-matching-stdin (stdin re idx &rest args)
"run GIT with ARGS.
Return the output lines as a list of strings."
(with-temp-buffer
(let (lines pos)
(insert stdin)
(setq pos (point-max))
(when (= (apply 'call-process-region (point-min) (point-max)
egg-git-command nil t nil args) 0)
(save-match-data
(goto-char pos)
(while (re-search-forward re nil t)
(setq lines (cons (match-string-no-properties idx) lines)))
lines)))))
(defun egg-git-lines-matching-multi (re indices &rest args)
"run GIT with ARGS.
Return the output lines as a list of strings."
(with-temp-buffer
(when (= (apply 'call-process egg-git-command nil t nil args) 0)
(let (lines matches)
(save-match-data
(goto-char (point-min))
(while (re-search-forward re nil t)
(setq matches nil)
(dolist (idx indices)
(when (match-beginning idx)
(setq matches
(cons (cons idx (match-string-no-properties idx))
matches))))
(setq lines (cons matches lines)))
lines)))))
(defsubst egg-file-git-name (file)
"return the repo-relative name of FILE."
(car (egg-git-to-lines "ls-files" "--full-name" "--" file)))
(defsubst egg-buf-git-name (&optional buf)
"return the repo-relative name of the file visited by BUF.
if BUF was nil then use current-buffer"
(egg-file-git-name (file-truename (buffer-file-name buf))))
(defsubst egg-files-git-name (files)
"return the repo-relative name for each file in the list of files FILES."
(delete-dups
(apply 'egg-git-to-lines "ls-files" "--full-name" "--" files)))
(defsubst egg-unmerged-files ()
"return a list of repo-relative names for each unmerged files."
(save-match-data
(delete-dups
(mapcar 'car
(mapcar 'last
(mapcar
'split-string
(egg-git-to-lines "ls-files" "--full-name" "-u")))))))
(defsubst egg-local-branches ()
"Get a list of local branches. E.g. (\"master\", \"wip1\")."
(egg-git-to-lines "rev-parse" "--symbolic" "--branches"))
(defsubst egg-local-refs ()
"Get a list of local refs. E.g. (\"master\", \"wip1\")."
(egg-git-to-lines "rev-parse" "--symbolic" "--branches" "--tags"))
(defun egg-remote-branches (&optional raw)
"Get a list of remote branches. E.g. (\"origin/master\", \"joe/fork1\")."
(let ((lst (egg-git-to-lines "rev-parse" "--symbolic" "--remotes")))
(if raw lst
(mapcar (lambda (full-name)
(let ((tmp (save-match-data (split-string full-name "/"))))
(cons (cadr tmp) (car tmp))))
lst))))
(defun egg-upstream (branch)
(and (egg-git-ok nil "config" (concat "branch." branch ".merge"))
(let ((upstream (egg-git-to-string "name-rev" "--name-only"
(concat branch "@{upstream}"))))
(if (and (> (length upstream) 8)
(string-equal (substring upstream 0 8) "remotes/"))
(substring upstream 8)
upstream))))
(defsubst egg-rbranch-to-remote (rbranch)
"Return the remote name in the remote-branch RBRANCH.
E.g: `foo' in `foo/bar'"
(and (stringp rbranch)
(> (length rbranch) 0)
(directory-file-name (file-name-directory rbranch))))
(defsubst egg-rbranch-name (rbranch)
"Return the ref name in the remote-branch RBRANCH.
E.g: `bar' in `foo/bar'"
(and (stringp rbranch)
(> (length rbranch) 0)
(file-name-nondirectory rbranch)))
(defsubst egg-short-ref (full-ref)
"Return the short ref name of the full ref name FULL-REF.
like `my_tag' in `refs/tags/my_tag'."
(and (stringp full-ref)
(> (length full-ref) 0)
(file-name-nondirectory full-ref)))
(defsubst egg-file-as-string-raw (file-name)
(with-temp-buffer
(insert-file-contents-literally file-name)
(buffer-string)))
(defsubst egg-file-as-string (file-name)
"return the contents of file FILE-NAME as a string."
(with-temp-buffer
(insert-file-contents-literally file-name)
(buffer-substring-no-properties
(point-min) (if (> (point-max) (point-min))
(1- (point-max)) (point-max)))))
(defun egg-pick-file-contents (file-name regexp &rest indices)
"Pick a string out of the contents of the file FILE-NAME.
This function searches for and return the 1st match of REGEXP on the
contents of the file. If indices was not nil, then return the first
successful submatch in the order in INDICES."
(with-temp-buffer
(insert-file-contents-literally file-name)
(goto-char (point-min))
(when (re-search-forward regexp nil t)
(if (null indices)
(match-string-no-properties 0)
(dolist (idx indices)
(if (match-beginning idx)
(return (match-string-no-properties idx))))))))
(defun egg-pick-file-records (file-name start-re end-re)
"Return a list of strings from the contents of the file FILE-NAME.
START-RE is the regexp to match the beginning of a record.
END-RE is the regexp to match the end of a record."
(with-temp-buffer
(insert-file-contents-literally file-name)
(goto-char (point-min))
(let ((beg (point-min))
(end (point-max))
lst)
(save-match-data
(while (and (> end beg)
(not (eobp))
(re-search-forward start-re nil t))
(setq beg (match-beginning 0))
(when (re-search-forward end-re nil t)
(setq end (match-beginning 0))
(if (> end beg)
(setq lst (cons (buffer-substring-no-properties
beg (match-beginning 0))
lst)))
(goto-char end))))
lst)))
(defsubst egg-is-in-git ()
"is the default-directory in a git repo."
(= (call-process egg-git-command nil nil nil "rev-parse" "--git-dir") 0))
(defsubst egg-is-dir-in-git (dir)
"is DIR in a git repo."
(let ((default-directory dir)) (egg-is-in-git)))
(defsubst egg-name-rev (rev)
"get the symbolic name of REV."
(egg-git-to-string "name-rev" "--always" "--name-only" rev))
(defsubst egg-describe-rev (rev)
"get the long symbolic name of REV."
(egg-git-to-string "describe" "--always" "--tags" rev))
(defsubst egg-sha1 (rev)
"get the SHA1 of REV."
(egg-git-to-string "rev-parse" (concat rev "~0")))
(defun egg-read-git-dir ()
"call GIT to read the git directory of default-directory."
(let* ((dotgit-parent (locate-dominating-file default-directory ".git"))
(dotgit (and dotgit-parent (concat dotgit-parent "/.git")))
(dir (or (and dotgit (file-directory-p dotgit) dotgit)
(egg-git-to-string "rev-parse" "--git-dir")))
(work-tree dotgit-parent))
(when (stringp dir)
(setq dir (expand-file-name dir))
(when (stringp work-tree)
(setq work-tree (expand-file-name work-tree))
(put-text-property 0 (length dir) :work-tree work-tree dir))
dir)))
(defvar egg-git-dir nil)
(defun egg-git-dir (&optional error-if-not-git)
"return the (pre-read) git-dir of default-directory"
(if (and (local-variable-p 'egg-git-dir) egg-git-dir)
egg-git-dir
(set (make-local-variable 'egg-git-dir)
(or (egg-read-git-dir)
(and error-if-not-git
(or (kill-local-variable 'egg-git-dir) t)
(error "Not in a git repository: %s" default-directory))))
;; first time, no status yet.
;; this directory's specific var will be updated by
;; egg-set-mode-info
(set (intern (concat "egg-" egg-git-dir "-HEAD")) " Egg")
egg-git-dir))
(defsubst egg-work-tree-dir (&optional git-dir)
(unless git-dir (setq git-dir (egg-git-dir)))
(or (get-text-property 0 :work-tree git-dir)
(file-name-directory git-dir)))
(defsubst egg-repo-name (&optional git-dir)
(let* ((dir (or git-dir (egg-git-dir)))
(work-tree-dir (egg-work-tree-dir dir)))
(when (stringp work-tree-dir)
(file-name-nondirectory (directory-file-name work-tree-dir)))))
(defsubst egg-buf-git-dir (buffer)
"return the (pre-read) git-dir of BUFFER."
(with-current-buffer buffer
(egg-git-dir)))
(defun egg-HEAD ()
"return HEAD. Either a symbolic ref or a sha1."
(let* ((git-dir (egg-git-dir)))
(if git-dir
(egg-pick-file-contents (concat git-dir "/HEAD")
"^ref: refs/heads/\\(.+\\)\\|^\\([0-9a-f]+\\)" 1 2))))
(defsubst egg-get-symbolic-HEAD (&optional file)
;; get the symbolic name of HEAD
(setq file (or file (concat (egg-git-dir) "/HEAD")))
(egg-pick-file-contents file
"^ref: refs/heads/\\(.+\\)"
1))
(defsubst egg-get-full-symbolic-HEAD (&optional file)
;; get the symbolic full name of HEAD
(setq file (or file (concat (egg-git-dir) "/HEAD")))
(egg-pick-file-contents file
"^ref: \\(refs/heads/.+\\)"
1))
(defsubst egg-get-current-sha1 ()
(or (egg-git-to-string "rev-parse" "--verify" "-q" "HEAD")
"0000000000000000000000000000000000000000"))
(defun egg-commit-at-point (&optional pos object)
(interactive "d")
(get-text-property (or pos (point)) :commit object))
(defun egg-ref-at-point (&optional pos type object)
(interactive "d")
(let ((ref (get-text-property (or pos (point)) :ref object)))
(when ref
(if type
(and (if (consp type)
(memq (cdr ref) type)
(eq (cdr ref) type))
(car ref))
(car ref)))))
(defsubst egg-ref-at (pos &optional object)
(egg-ref-at-point pos nil object))
(defsubst egg-head-at-point (&optional pos object)
(interactive "d")
(egg-ref-at-point pos :head object))
(defsubst egg-head-at (pos)
(egg-ref-at-point pos '(:remote :head)))
(defsubst egg-tag-at-point (&optional pos object)
(interactive "d")
(egg-ref-at-point pos :tag object))
(defsubst egg-remote-at-point (&optional pos object)
(interactive "d")
(egg-ref-at-point pos :remote object))
(defsubst egg-references-at-point (&optional pos object)
(interactive "d")
(get-text-property (or pos (point)) :references object))
(defsubst egg-ref-or-commit-at (pos &optional object)
(or (egg-ref-at-point pos object) (egg-commit-at-point pos object)))
(defsubst egg-commit-at (pos &optional object)
(egg-commit-at-point pos object))
(defsubst egg-rsite-at (pos &optional object)
(egg-rbranch-to-remote (egg-remote-at-point pos object)))
(defsubst egg-delta-file-at (pos &optional object)
(car (get-text-property pos :diff object)))
(defsubst egg-delta-hunk-at (pos &optional object)
(car (get-text-property pos :hunk object)))
(defsubst egg-set-mode-info (state)
"Set the mode-line string for buffers visiting files in the current repo.
The string is built based on the current state STATE."
(set (intern (concat "egg-" egg-git-dir "-HEAD"))
(format " Git:%s" (cond ((plist-get state :rebase-dir)
"(rebasing)")
((plist-get state :merge-heads)
"(merging)")
((plist-get state :branch)
(plist-get state :branch))
(t "(detached)")))))
(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-stash
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)))))
(defun egg-all-refs ()
"Get a list of all refs."
(append (egg-git-to-lines "rev-parse" "--symbolic"
"--branches" "--tags" "--remotes")
(delq nil
(mapcar
(lambda (head)
(if (file-exists-p (concat (egg-git-dir) "/" head))
head))
'("HEAD" "ORIG_HEAD")))))
(defun egg-ref-type-alist ()
"Build an alist of (REF-NAME . :type) cells."
(mapcar (lambda (ref-desc)
(cons (cdr (assq 5 ref-desc))
(cond ((assq 2 ref-desc) :head)
((assq 3 ref-desc) :tag)
((assq 4 ref-desc) :remote))))
(egg-git-lines-matching-multi
"^.+ \\(refs/\\(?:\\(heads\\)\\|\\(tags\\)\\|\\(remotes\\)\\)/\\(\\([^/\n]+/\\)?[^/\n]+\\)\\)$"
;; 1: full-name
;; 2: head
;; 3: tag
;; 4: remote
;; 5: name
;; 6: remote-host
'(1 2 3 4 5 6) "show-ref")))
(defsubst egg-tooltip-func ()
(if egg-enable-tooltip 'egg-buffer-help-echo))
(defun egg-full-ref-decorated-alist (head-properties
tag-properties
atag-properties
remote-ref-properties
remote-site-properties
&optional head-properties-HEAD)
"Build an alist of (ref . :type) cells.
A ref string of a head will be decorated with HEAD-PROPERTIES. A
ref string of a tag will be decorated with TAG-PROPERTIES or
ATAG-PROPERTIES. A ref string of a remote will be formatted with
REMOTE-REF-PROPERTIES and REMOTE-SITE-PROPERTIES."
(let ((refs-desc-list
(egg-git-lines-matching-multi
"^.+ \\(refs/\\(?:\\(heads\\)\\|\\(tags\\)\\|\\(remotes\\)\\)/\\(\\([^/\n]+/\\)?[^/\n{}]+\\)\\)\\(\\^{}\\)?$"
;; 1: full-name
;; 2: head
;; 3: tag
;; 4: remote
;; 5: name
;; 6: remote-host
;; 7: is annotated tag
'(1 2 3 4 5 6 7) "show-ref" "-d"))
(symbolic-HEAD (egg-get-symbolic-HEAD))
annotated-tags)
;; remove the annotated tags from the list
(setq refs-desc-list
(delq nil
(mapcar (lambda (desc)
(if (not (assq 7 desc))
;; not an annotated tag
desc
(setq annotated-tags
(cons (cdr (assq 1 desc))
annotated-tags))
nil))
refs-desc-list)))
;; decorate the ref alist
(mapcar (lambda (desc)
(let ((full-name (cdr (assq 1 desc)))
(name (cdr (assq 5 desc)))
(remote (cdr (assq 6 desc))))
(cond ((assq 2 desc)
;; head
(cons full-name
(apply 'propertize name
:full-name full-name
:ref (cons name :head)
(if (and head-properties-HEAD
(string-equal name
symbolic-HEAD))
head-properties-HEAD
head-properties))))
((assq 3 desc)
;; tag
(cons full-name
(apply 'propertize name
:full-name full-name
:ref (cons name :tag)
(if (member full-name annotated-tags)
atag-properties
tag-properties))))
((assq 4 desc)
;; remote
(cons full-name
(concat
(if (stringp remote)
(apply 'propertize remote
:ref (cons name :remote)
remote-site-properties)
;; svn has no remote name
"")
(apply 'propertize (substring name (length remote))
:full-name full-name
:ref (cons name :remote)
remote-ref-properties)))))))
refs-desc-list)))
(defun egg-get-all-refs (prefix)
(egg-git-to-lines "for-each-ref" "--format=%(refname:short)"
(format "refs/heads/%s*" prefix)
(format "refs/tags/%s*" prefix)
(format "refs/remotes/%s*/*" prefix)
(format "refs/remotes/%s*" prefix)))
(defun egg-get-local-refs (prefix)
(egg-git-to-lines "for-each-ref" "--format=%(refname:short)"
(format "refs/heads/%s*" prefix)
(format "refs/tags/%s*" prefix)))
(defun egg-complete-get-all-refs (prefix &optional matches)
(if matches
(try-completion prefix matches)
(egg-get-all-refs prefix)))
(defun egg-complete-get-local-refs (prefix &optional matches)
(if matches
(try-completion prefix matches)
(egg-get-local-refs prefix)))
(defun egg-get-match-files-substring (sub &optional matches)
(if matches
(try-completion sub (mapcar #'file-name-nondirectory matches))
(let ((default-directory (egg-work-tree-dir))
files name-matched-files full-match)
(setq files (egg-git-to-lines "--no-pager" "ls-files"
(concat sub "*")
(concat "*/" sub "*")))
(dolist (file files)
(if (string-equal file sub)
(setq full-match file))
(if (string-equal (file-name-nondirectory file) sub)
(add-to-list 'name-matched-files file)))
(or (and full-match (list full-match))
name-matched-files
files))))
(defun egg-do-completion (string &optional func all)
"Do ref name completion"
(let* ((matches (funcall func string))
(single (= (length matches) 1))
(perfect (and single (equal (car matches) string)))
prefix)
(if all matches
(when matches
(setq prefix (funcall func string matches)))
(cond ((null matches) nil)
(perfect t)
(single (car matches))
((stringp prefix) prefix)
((null prefix) nil)
(t string)))))
(defsubst egg-read-ref (prompt &optional default no-match-ok)
(completing-read prompt #'egg-do-completion #'egg-complete-get-all-refs (not no-match-ok) default))
(defsubst egg-read-local-ref (prompt &optional default no-match-ok)
(completing-read prompt #'egg-do-completion #'egg-complete-get-local-refs (not no-match-ok) default))
(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)
(interactive (list (egg-read-tracked-filename "Find tracked file: ")))
(switch-to-buffer (find-file-noselect file-name)))
(defun egg-complete-rev (string &optional ignored all)
"Do revision completion"
(save-match-data
(cond ((string-match "\\`:[0-3]*" string) ;; stages
(funcall (if all 'all-completions 'try-completion)
string '(":0" ":1" ":2" ":3")))
;; rev^, rev~10 etc.
((string-match "[\\^~][\\^~0-9]*\\'" string)
;; check with rev-parse
(if (egg-git-ok nil "rev-parse" string)
;; rev-parse ok
(if all
;; fixme: how to do a full expansion?
(list string)
;; match
string)))
;; normal rev name
(t (let ((matches
;; match all types of refs
(egg-git-to-lines "for-each-ref" "--format=%(refname)"
(concat "refs/*/" string "*")
(concat "refs/*/" string "*/*")))
prefix)
;; get the short name
;; with 1.6.x: for-each-ref" "--format=%(refname=short)
(setq matches
(mapcar (lambda (long)
(string-match
"\\`refs/\\(?:heads\\|tags\\|remotes\\)/\\(.+\\)\\'"
long)
(match-string-no-properties 1 long))
matches))
;; do the completion
(setq prefix
(funcall (if all 'all-completions 'try-completion)
string
(nconc (directory-files (egg-git-dir)
nil "HEAD")
matches)))
(cond (all prefix)
((stringp prefix) prefix)
((null prefix) nil)
(t string)))))))
(defsubst egg-get-rebase-apply-state (rebase-dir)
"Build a plist of rebase info of REBASE-DIR.
this is for rebase -m variant."
(let ((patch-files (directory-files rebase-dir nil "\\`[0-9]+\\'")))
(list :rebase-dir rebase-dir
:rebase-head (egg-name-rev (egg-file-as-string (concat rebase-dir "head-name")))
:rebase-upstream
(egg-describe-rev (egg-file-as-string (concat rebase-dir "onto")))
:rebase-step (string-to-number (car patch-files))
:rebase-num (string-to-number (car (nreverse patch-files))))))
(defsubst egg-get-rebase-merge-state (rebase-dir)
"Build a plist of rebase info of REBASE-DIR.
this is for rebase -m variant."
(list :rebase-dir rebase-dir
:rebase-head
(egg-name-rev (egg-file-as-string (concat rebase-dir "head-name")))
:rebase-upstream
(egg-describe-rev (egg-file-as-string (concat rebase-dir "onto_name")))
:rebase-step ;; string-to-number?
(egg-file-as-string (concat rebase-dir "msgnum"))
:rebase-num ;; string-to-number?
(egg-file-as-string (concat rebase-dir "end"))))
(defsubst egg-get-rebase-interactive-state (rebase-dir)
"Build a plist of rebase info of REBASE-DIR.
this is for rebase -i variant."
(list :rebase-dir rebase-dir
:rebase-head
(egg-name-rev (egg-file-as-string (concat rebase-dir "head-name")))
:rebase-upstream
(egg-describe-rev (egg-file-as-string (concat rebase-dir "onto")))
:rebase-num
(length
(egg-pick-file-records (concat rebase-dir "git-rebase-todo.backup")
"^[pes]" "$"))
:rebase-step
(if (file-exists-p (concat rebase-dir "done"))
(length (egg-pick-file-records (concat rebase-dir "done")
"^[pes]" "$"))
0)
:rebase-stopped
(if (file-exists-p (concat rebase-dir "stopped-sha"))
(egg-pick-file-contents (concat rebase-dir "stopped-sha") "^[0-9a-f]+$"))
:rebase-cherry
(if (file-exists-p (concat rebase-dir "done"))
(car (egg-pick-file-records
(concat rebase-dir "done")
"^[pes]" "$")))))
(defsubst egg-git-rebase-dir (&optional git-dir)
(concat (or git-dir (egg-git-dir)) "/" egg-git-rebase-subdir "/"))
(defsubst egg-rebase-author-info (rebase-dir)
"Retrieve an alist of commit environment variables of the current
cherry in REBASE-DIR."
(mapcar (lambda (lst)
;; chop the ' '
(setcar (cdr lst) (substring (cadr lst) 1 -1))
lst)
(mapcar (lambda (line)
;; name-value split
(save-match-data (split-string line "=" t)))
;; grab the GIT_xxx=yyy
(egg-pick-file-records (concat rebase-dir "author-script")
"^GIT_\\(.+\\)" "$"))))
(defsubst egg-interactive-rebase-in-progress ()
"Is an interactive rebase in progress in the current repo?"
(file-exists-p (concat (egg-git-dir) "/" egg-git-rebase-subdir
"/interactive") ))
(defvar egg-internal-current-state nil)
(defun egg-get-repo-state (&optional extras)
"Retrieve current repo's state as a plist.
The properties:
:gitdir :head :branch :sha1 :merge-heads :rebase-dir :rebase-head
:rebase-upstream :rebase-step :rebase-num :rebase-cherry
EXTRAS contains the extra properties to retrieve: :staged :unstaged
if EXTRAS contains :error-if-not-git then error-out if not a git repo.
"
(let* ((git-dir (egg-git-dir (memq :error-if-not-git extras)))
(head-file (concat git-dir "/HEAD"))
(merge-file (concat git-dir "/MERGE_HEAD"))
(branch (egg-get-symbolic-HEAD head-file))
(branch-full-name (egg-get-full-symbolic-HEAD head-file))
(sha1 (egg-get-current-sha1))
(merge-heads
(mapcar 'egg-name-rev
(if (file-readable-p merge-file)
(egg-pick-file-records merge-file "^" "$"))))
(rebase-apply (if (file-directory-p (concat git-dir "/rebase-apply"))
(concat git-dir "/rebase-apply/")))
(rebase-dir
(or rebase-apply
(if (file-directory-p (concat git-dir "/" egg-git-rebase-subdir))
(concat git-dir "/" egg-git-rebase-subdir "/"))))
(is-rebase-interactive
(and (not rebase-apply)
(file-exists-p (concat rebase-dir "interactive"))))
(rebase-state
(if rebase-apply
(egg-get-rebase-apply-state rebase-dir)
(when rebase-dir
(if is-rebase-interactive
(egg-get-rebase-interactive-state rebase-dir)
(egg-get-rebase-merge-state rebase-dir)))))
(state (nconc (list :gitdir git-dir
:head branch-full-name
:branch branch
:sha1 sha1
:merge-heads merge-heads)
rebase-state))
files)
(dolist (req extras)
(cond ((eq req :unstaged)
(setq files (egg-git-to-lines "diff" "--name-only"))
(setq state (nconc (list :unstaged files) state))
(when (and files (stringp (car files)))
(setq state (nconc (list :unmerged (egg-unmerged-files))
state))))
((eq req :staged)
(setq state
(nconc (list :staged (egg-git-to-lines "diff" "--cached" "--name-only"))
state)))
((eq req :name)
(setq state
(nconc (list :name (egg-git-to-string "config" "user.name")) state)))
((eq req :email)
(setq state
(nconc (list :email (egg-git-to-string "config" "user.email")) state)))))
;; update mode-line
(egg-set-mode-info state)
state))
(defun egg-repo-state (&rest args)
"return the cached repo state or re-read it.
if ARGS contained :force then ignore the cached state."
(if (or (null egg-internal-current-state) ;; not cached
(memq :force args) ;; forced
(memq nil ;; cached copy has no extra reqs
(mapcar (lambda (req)
(memq req egg-internal-current-state))
args)))
(egg-get-repo-state args)
egg-internal-current-state))
(defsubst egg-repo-clean (&optional state)
"Whether the current repos is clean base on the current repo state.
use STATE as repo state if it was not nil. Otherwise re-read the repo state."
(unless state
(setq state (egg-repo-state :staged :unstaged)))
(and
(null (plist-get state :rebase-num))
(null (plist-get state :merge-heads))
(not (if (memq :unstaged state)
(plist-get state :unstaged)
(egg-wdir-clean)))
(not (if (memq :staged state)
(plist-get state :staged)
(egg-index-empty)))))
(defun egg-wdir-dirty () (plist-get (egg-repo-state :unstaged) :unstaged))
(defun egg-staged-changes () (plist-get (egg-repo-state :staged) :staged))
(defsubst egg-current-branch (&optional state)
"The current symbolic value of HEAD. i.e. name of a branch. if STATE
was not nil then use it as repo state instead of re-read from disc."
(plist-get (or state (egg-repo-state)) :branch))
(defsubst egg-short-sha1 (&optional sha1)
(egg-git-to-string "rev-parse" "--short" (or sha1 (egg-current-sha1))))
(defsubst egg-current-sha1 (&optional state)
"The immutable sha1 of HEAD. if STATE was not nil then use it
as repo state instead of re-read from disc."
(plist-get (or state (egg-repo-state)) :sha1))
(defsubst egg-user-name (&optional state)
"The configured user name."
(plist-get (or state (egg-repo-state :name)) :name))
(defsubst egg-user-email (&optional state)
"The configured email."
(plist-get (or state (egg-repo-state :email)) :email))
(defsubst egg-head (&optional state)
"a cons cell (branch . sha1) of HEAD. if STATE was not nil then use it
as repo state instead of re-read from disc."
(if (egg-git-dir)
(let ((state (or state (egg-repo-state))))
(cons (egg-current-sha1 state)
(egg-current-branch state)))))
(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))
(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-name-rev sha1) " from: "
(mapconcat 'identity merge-heads ",")))
((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-describe-rev (plist-get state :sha1)))))
(defsubst egg-branch-or-HEAD () (or (egg-get-symbolic-HEAD) "HEAD"))
(defsubst egg-config-section-raw (type &optional name)
(egg-pick-file-contents (concat (egg-git-dir) "/config")
(concat "^"
(if name
(format "\\[%s \"%s\"\\]" type name)
(format "\\[%s\\]" type))
"\n"
"\\(\\(?:\t.+\n\\)+\\)")
1))
(defsubst egg-config-section (type &optional name)
(save-match-data
(mapcar
(lambda (line)
(split-string line "[ =]+" t))
(split-string (or (egg-config-section-raw type name) "")
"[\t\n]+" t))))
(defun egg-config-get-all (called-interactively file type)
(interactive "p\nfFilename: \nsType: ")
(let (res)
(setq res
(save-match-data
(mapcar (lambda (rec)
(let ((key (car rec))
(infos (cdr rec)))
(cons (progn (string-match "\"\\(.+\\)\"" key)
(match-string-no-properties 1 key))
(mapcar (lambda (attr)
(split-string attr "[ =]+" t))
infos))))
(mapcar (lambda (str)
(split-string str "[\t\n]+" t))
(egg-pick-file-records file
(concat "^\\[" type " \"")
"^\\[\\|\\'")))))
(if called-interactively
(message "%S" res))
res))
(defsubst egg-config-get-all-branches ()
(egg-config-get-all nil (concat (egg-git-dir) "/config") "branch"))
(defsubst egg-config-get-all-remotes ()
(egg-config-get-all nil (concat (egg-git-dir) "/config") "remote"))
(defsubst egg-config-get-all-remote-names ()
(mapcar 'car (egg-config-get-all-remotes)))
(defsubst egg-config-get (type attr &optional name)
(and (egg-git-dir)
(cadr (assoc attr (egg-config-section type name)))))
(defun egg-tracking-target (branch &optional mode)
(let ((remote (egg-config-get "branch" "remote" branch))
(rbranch (egg-config-get "branch" "merge" branch)))
(when (stringp rbranch)
(setq rbranch (egg-rbranch-name rbranch))
(cond ((null mode) (concat remote "/" rbranch))
((eq :name-only mode) rbranch)
(t (cons rbranch remote))))))
(defsubst egg-read-rev (prompt &optional default)
"Query user for a revision using PROMPT. DEFAULT is the default value."
(completing-read prompt 'egg-complete-rev nil nil default))
(defsubst egg-read-remote (prompt &optional default)
"Query user for a remote using PROMPT. DEFAULT is the default value."
(completing-read prompt (egg-config-get-all-remote-names) nil t default))
;;;========================================================
;;; Async Git process
;;;========================================================
(defsubst egg-async-process ()
(with-egg-async-buffer
(let ((proc (get-buffer-process (current-buffer))))
(if (and (processp proc) ;; is a process
(not (eq (process-status proc) 'exit)) ;; not finised
(= (process-exit-status proc) 0)) ;; still running
proc))))
(defun egg-async-do (exit-code func-args args)
"Run GIT asynchronously with ARGS.
if EXIT code is an exit-code from GIT other than zero but considered
success."
(let ((inhibit-read-only inhibit-read-only)
(accepted-msg (and (integerp exit-code)
(format "exited abnormally with code %d"
exit-code)))
proc)
(with-egg-async-buffer
(setq proc (get-buffer-process (current-buffer)))
(when (and (processp proc) ;; is a process
(not (eq (process-status proc) 'exit)) ;; not finised
(= (process-exit-status proc) 0)) ;; still running
(error "EGG: %s is already running!" (process-command proc)))
(setq inhibit-read-only t)
(erase-buffer)
(widen)
(goto-char (point-max))
(insert "EGG-GIT-CMD:\n")
(insert (format "%S\n" args))
(insert "EGG-GIT-OUTPUT:\n")
(setq proc (apply 'start-process "egg-git" (current-buffer) egg-git-command args))
(setq mode-line-process " git")
(when (and (consp func-args) (functionp (car func-args)))
(process-put proc :callback-func (car func-args))
(process-put proc :callback-args (cdr func-args)))
(when (stringp accepted-msg)
(process-put proc :accepted-msg accepted-msg)
(process-put proc :accepted-code exit-code))
(process-put proc :cmds (cons egg-git-command args))
(set-process-sentinel proc #'egg-process-sentinel))
proc))
(defsubst egg-async-0 (func-args &rest args)
(egg-async-do nil func-args args))
(defsubst egg-async-1 (func-args &rest args)
(egg-async-do 1 func-args args))
(defsubst egg-async-0-args (func-args args)
(egg-async-do 0 func-args args))
(defsubst egg-async-1-args (func-args args)
(egg-async-do 1 func-args args))
(defvar egg-async-process nil)
(defvar egg-async-cmds nil)
(defvar egg-async-exit-msg nil)
(defun egg-process-sentinel (proc msg)
(let ((exit-code (process-get proc :accepted-code))
(accepted-msg (process-get proc :accepted-msg))
(callback-func (process-get proc :callback-func))
(callback-args (process-get proc :callback-args))
(cmds (process-get proc :cmds)))
(cond ((string= msg "finished\n")
(message "EGG: git finished."))
((string= msg "killed\n")
(message "EGG: git was killed."))
((and accepted-msg (string-match accepted-msg msg))
(message "EGG: git exited with code: %d." exit-code))
((string-match "exited abnormally" msg)
(message "EGG: git failed."))
(t (message "EGG: git is weird!")))
(with-current-buffer (process-buffer proc)
(setq mode-line-process nil)
(widen)
(egg-cmd-log-whole-buffer (current-buffer))
(goto-char (point-max))
(re-search-backward "^EGG-GIT-CMD:" nil t)
;; Narrow to the last command
(narrow-to-region (point) (point-max))
(if (functionp callback-func)
(let ((egg-async-process proc)
(egg-async-cmds cmds)
(egg-async-exit-msg msg))
(apply callback-func callback-args))))))
;;;========================================================
;;; New: internal command
;;;========================================================
(defvar egg--ediffing-temp-buffers nil)
(defun egg--add-ediffing-temp-buffers (&rest buffers)
(dolist (buf buffers)
(when (buffer-live-p buf)
(add-to-list 'egg--ediffing-temp-buffers buf))))
(defun egg--kill-ediffing-temp-buffers ()
(let ((lst egg--ediffing-temp-buffers))
(setq egg--ediffing-temp-buffers nil)
(message "kill ediffing buffers: job-name=%s buffers=%S" ediff-job-name lst)
(dolist (buf lst)
(when (buffer-live-p buf)
(message "egg killing buffer: %s" (if (bufferp buf) (buffer-name buf) buf))
(bury-buffer buf)
(kill-buffer buf)))))
(defsubst egg--do-output (&optional erase)
"Get the output buffer for synchronous commands.
erase the buffer's contents if ERASE was non-nil."
(let ((buffer (get-buffer-create (concat " *egg-output:" (egg-git-dir) "*")))
(default-directory default-directory))
(with-current-buffer buffer
(setq default-directory (egg-work-tree-dir))
(widen)
(if erase (erase-buffer)))
buffer))
(defmacro with-egg--do-buffer (&rest body)
"Evaluate BODY there like `progn' in the egg--do-output buffer.
See also `with-temp-file' and `with-output-to-string'."
(declare (indent 0) (debug t))
`(with-current-buffer (egg--do-output)
(setq default-directory (egg-work-tree-dir))
(unwind-protect
(progn ,@body)
)))
(defmacro with-clean-egg--do-buffer (&rest body)
"Evaluate BODY there like `progn' in the egg--do-output buffer.
See also `with-temp-file' and `with-output-to-string'."
(declare (indent 0) (debug t))
`(with-current-buffer (egg--do-output t)
(setq default-directory (egg-work-tree-dir))
(unwind-protect
(progn ,@body)
)))
(defun egg--do (stdin program args)
"Run PROGRAM with ARGS synchronously using STDIN as starndard input.
ARGS should be a list of arguments for PROGRAM."
(let ((buf (current-buffer)) ret)
(egg-cmd-log "RUN:" program " " (mapconcat 'identity args " ")
(if stdin " <REGION\n" "\n"))
(with-clean-egg--do-buffer
(cond ((stringp stdin)
(insert stdin))
((consp stdin)
(insert-buffer-substring buf (car stdin) (cdr stdin)))
(t nil))
(setq ret (if stdin
(apply 'call-process-region (point-min) (point-max)
program t t nil args)
(apply 'call-process program nil t nil args)))
(egg-cmd-log-whole-buffer (current-buffer))
(egg-cmd-log (format "RET:%d\n" ret))
(cons ret (current-buffer)))))
(defun egg--do-git (stdin cmd args)
"Run git command CMD with ARGS synchronously, using STDIN as starndard input.
ARGS should be a list of arguments for the git command CMD."
(egg--do stdin "git" (cons cmd args)))
(defun egg--do-handle-exit (exit-info post-proc-func &optional buffer-to-update)
"Handle the exit code and the output of a synchronous action.
EXIT-INFO is the results of the action in form of a pair (return-code . output-buffer).
POST-PROC-FUNC shall be a function which will be call with 1 argument: the return-code
of the action. It shall be called in the output buffer of the action.
This function returns the returned value of POST-PROC-FUNC.
EXIT-INFO should be the return value of `egg--do-git' or `egg--do'."
(let ((ret (car exit-info))
(buf (cdr exit-info))
beg end pp-results)
(with-current-buffer buf
(setq beg (point-min))
(setq end (point-max))
;; even if the buffer is empty, post-proc-func must
;; still be done to process the ret-code
(when (functionp post-proc-func)
(goto-char (point-min))
(setq pp-results (funcall post-proc-func ret))))
(cond ((bufferp buffer-to-update)
(egg-refresh-buffer buffer-to-update))
((memq buffer-to-update '(t all))
(egg-run-buffers-update-hook))
(t nil))
(if (memq :success pp-results)
pp-results
(nconc (list :success (= ret 0)) pp-results) ;; default result
)))
(defvar egg--do-git-quiet nil) ;; don't show git's output
(defvar egg--do-no-output-message nil)
(defun egg--do-show-output (cmd-name output-info)
"Show the output of a synchronous git command as feed-back for the emacs command.
CMD-NAME is the name of the git command such as: merge or checkout. OUTPUT-INFO is
generally the returned value of `egg--do-handle-exit'. OUTPUT-INFO will also be
used as the returned value of this function."
(let ((ok (plist-get output-info :success))
(line (plist-get output-info :line))
(no-output-message (or egg--do-no-output-message "*no output*"))
prefix)
(setq prefix (concat (if (stringp cmd-name) cmd-name "GIT")
(if ok "> " ":ERROR> ")))
(unless (and egg--do-git-quiet ok)
(message (if (stringp line)
(concat prefix line)
(concat "EGG: " no-output-message))))
(unless ok (ding))
output-info))
(defun egg--do-git-action (cmd buffer-to-update post-proc-func args)
"Run git command CMD with arguments list ARGS.
Show the output of CMD as feedback of the emacs command.
Update the buffer BUFFER-TO-UPDATE and use POST-PROC-FUNC as the
output processing function for `egg--do-handle-exit'."
(egg--do-show-output (concat "GIT-" (upcase cmd))
(egg--do-handle-exit (egg--do-git nil cmd args)
post-proc-func buffer-to-update)))
(defun egg--do-git-action-stdin (cmd stdin buffer-to-update post-proc-func args)
"Run git command CMD with arguments list ARGS and STDIN as standard input.
Show the output of CMD as feedback of the emacs command.
Update the buffer BUFFER-TO-UPDATE and use POST-PROC-FUNC as the
output processing function for `egg--do-handle-exit'."
(egg--do-show-output (concat "GIT-" (upcase cmd))
(egg--do-handle-exit (egg--do-git stdin cmd args)
post-proc-func buffer-to-update)))
(defconst egg--bad-git-output-regex
(concat (regexp-opt '("Cannot" "cannot" "Couldn't" "couldn't" "Could not" "could not"
"Failed" "failed" "incompatible" "Incompatible" "invalid" "Invalid"
"not allowed" "rejected" "Unable" "unable" "internal error"
"mutually exclusive" "does not" "do not" "did not" "is not" "needs a"
"No such" "no such" "No changes" "Too many" "too many"
"Nothing" "nothing" "Abort" "abort" "Malformed" "malformed"
"unresolved" "Unresolved" "Corrupt" "corrupt" "empty"
"does not make sense" "only with" "only one" "only allowed"
"skipped" "Skipped" "bad" "Bad" "doesn't"
"too big" "Too big" "too many" "Too many"
"not a valid" "Not a valid" "already exist" "ignored by" "is beyond"
"Not"
) t)
"\\|\\(?:No.+found\\)\\|\\(?:[On]nly.+can be used\\)"))
(defconst egg--fatal-git-output-regex "^fatal")
(defun egg--git-pp-grab-line-no (line-no &rest extras)
"Grab the line LINE-NO in the current buffer.
Return it in a form usable for `egg--do-show-output'."
(let* ((lines (delete "" (save-match-data
(split-string (buffer-string) "\n"))))
(line (cond ((< line-no 0) (nth (- -1 line-no) (nreverse lines)))
((> line-no 0) (nth (1- line-no) lines))
(t nil))))
(when (stringp line)
(nconc (list :line line) extras))))
(defun egg--git-pp-grab-line-matching (regex &optional replacement &rest extras)
"If REGEX matched a line in the current buffer, return it in a form suitable
for `egg--do-show-output'. If REPLACEMENT was provided, use it in the returned
structure instead of the matching line."
(let ((matched-line
(when (stringp regex)
(save-match-data
(goto-char (point-min))
(when (re-search-forward regex nil t)
(goto-char (match-beginning 0))
(buffer-substring-no-properties
(line-beginning-position)
(line-end-position)))))))
(when (stringp matched-line)
(nconc (list :line (if (stringp replacement) replacement matched-line))
extras))))
(defsubst egg--git-pp-grab-1st-line-matching (regex-list &optional replacement &rest extras)
"Try maching the lines in the current buffer against each regex in REGEX-LIST
until one matched. Return the line in a form suitable for `egg--do-show-output'.
If REPLACEMENT was provided, use it in the returned structure instead of
the matching line."
(let ((r-list regex-list)
re found)
(while (and (not found) r-list)
(setq re (car r-list)
r-list (cdr r-list))
(setq found (apply 'egg--git-pp-grab-line-matching re replacement extras)))
found))
(defun egg--git-pp-fatal-output (&optional pre-regexes post-regexes)
(or
(egg--git-pp-grab-1st-line-matching
(nconc (if (stringp pre-regexes) (list pre-regexes) pre-regexes)
(list egg--bad-git-output-regex egg--fatal-git-output-regex)
(if (stringp post-regexes) (list post-regexes) post-regexes)))
(egg--git-pp-grab-line-no -1)))
(defsubst egg--git-pp-fatal-result (&optional pre-regexes post-regexes)
(nconc (list :success nil)
(egg--git-pp-fatal-output pre-regexes post-regexes)))
(defun egg--git-pp-generic (ret-code accepted-codes ok-regex bad-regex
&optional line-no)
"Simple post-processing function for synchronous git actions.
return a suitable structure for `egg--do-show-output'. if RET-CODE was 0
then the action is considered a success. The line matching OK-REGEX would
be also return in the structure. OK-REGEX can also be a list of regexes.
If no line matched OK-REGEX and LINE-NO was provided, then return the line
LINE-NO in the result structure. If RET-CODE wasn't 0, then use BAD-REGEX
instead of OK-REGEX.
This simple function might be use as the POST-PROC-FUNC argument of the
`egg--do-handle-exit' function."
(if (memq ret-code accepted-codes)
(if (consp ok-regex)
(egg--git-pp-grab-1st-line-matching ok-regex nil :success t)
(egg--git-pp-grab-line-matching ok-regex nil :success t))
(or (if (consp bad-regex)
(egg--git-pp-grab-1st-line-matching bad-regex)
(egg--git-pp-grab-line-matching bad-regex))
(egg--git-pp-grab-line-no (or line-no -1)))))
(defconst egg--git-action-cmd-doc nil
"The `egg--git-xxxxx-cmd' functions perform git command synchronously.
The returned value is a plist where the results of the action are indexed
by the :aaaaa symbols
:success (t or nil) the success of the action from egg's p-o-v.
:line the selected line from the git command's output to display
to the user as the feedback of the emacs command. Sometimes
egg fabricates this line.
:files the files in the worktree which might be changed by the
git command and their buffers should be reverted.
:next-action (a symbol) the next logical action for egg to do.")
(defun egg--git-push-cmd (buffer-to-update &rest args)
"Peform a synchronous action using the git push command using ARGS as arguments.
Update BUFFER-TO-UPDATE if needed.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(egg--do-git-action
"push" buffer-to-update
(lambda (ret-code)
(egg--git-pp-generic ret-code '(0) " -> \\|Everything up-to-date\\|deleted"
'("rejected" "\\<not\\>")))
args))
(defun egg--git-push-cmd-test (from to repo)
(interactive "sPush: \nsOnTo: \nsAt:")
(egg--git-push-cmd nil repo (concat from ":" to)))
(defun egg--git-pp-reset-output (ret-code reset-mode)
"Post-processing function for the output the git reset command in the current buffer.
RET-CODE is the return code of the git process and RESET-MODE would be one
of: --hard, --keep, --soft, --mixed. --merge is currently not supported.
Return a structure suitable for `egg--do-show-output'."
(if (/= ret-code 0)
(egg--git-pp-fatal-output "Entry.not uptodate")
(cond ((string-equal "--hard" reset-mode)
(egg--git-pp-grab-line-matching "^HEAD is now at" nil
:next-action 'log :success t))
((string-equal "--keep" reset-mode)
(egg--git-pp-grab-line-no -1 :next-action 'status :success t))
((string-equal "--soft" reset-mode)
(egg--git-pp-grab-line-no -1 :next-action 'status :success t))
((string-equal "--mixed" reset-mode)
(egg--git-pp-grab-line-matching "Unstaged changes after reset"
"there are unstaged changes after reset"
:next-action 'status :success t)))))
(defun egg--git-reset-cmd (buffer-to-update reset-mode rev)
"Peform a synchronous action using the git reset command.
Update BUFFER-TO-UPDATE if needed. RESET mode is a one of: --hard, --keep, --mixed
and --soft (--merge is currently unsupported.). HEAD will be resetted to REV.
The relevent line from the output of the underlying git command will be display
as feedback of emacs command.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(let ((pre-reset (egg-get-current-sha1))
;; will be changed, if "--keep"
(rev-vs-head (egg-git-to-lines "diff" "--name-only" "HEAD" rev))
;; will be changed, if "--hard"
(rev-vs-wdir (egg-git-to-lines "diff" "--name-only" rev))
files res)
(setq res (egg--do-git-action
"reset" buffer-to-update
`(lambda (ret-code)
(egg--git-pp-reset-output ret-code ,reset-mode))
(list reset-mode rev)))
(if (plist-get res :success)
(cond ((equal reset-mode "--hard")
(nconc res (list :files rev-vs-wdir)))
((member reset-mode '("--keep" "--merge"))
(nconc res (list :files rev-vs-head)))
(t res))
res)))
(defun egg--git-reset-cmd-test (mode rev)
(interactive "sreset mode:\nsrev:")
(egg--git-reset-cmd t mode rev))
(defun egg--git-reset-files-cmd (buffer-to-update rev &rest files)
"Peform a synchronous action using the git reset command on paths FILES.
Update BUFFER-TO-UPDATE if needed. FILES will be resetted to REV in the index.
The relevent line from the output of the underlying git command will be displayed
as feedback of emacs command.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(egg--do-git-action
"reset" buffer-to-update
(lambda (ret-code)
(cond ((= ret-code 0) (list :success t :next-action 'status))
((= ret-code 1)
(egg--git-pp-grab-line-matching "Unstaged changes after reset:"
"there are unstaged changes after reset"
:next-action 'status :success t))
((> ret-code 1) (egg--git-pp-fatal-result))))
(nconc (list (or rev "HEAD") "--") files)))
(defun egg--git-co-files-cmd (buffer-to-update file-or-files &rest args)
"Peform a synchronous action using the git checkout command on FILE-OR-FILES.
Update BUFFER-TO-UPDATE if needed. ARGS will be passed to the git command as
arguments. FILE-OR-FILES will be updated to REV in the index as well as the work
tree. The relevent line from the output of the underlying git command will be
displayed as feedback of emacs command.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(let* ((files (if (consp file-or-files) file-or-files (list file-or-files)))
(args (append args (cons "--" files)))
(res (egg--do-git-action
"checkout" buffer-to-update
(lambda (ret-code)
(if (= ret-code 0)
(list :success t :next-action 'status)
(egg--git-pp-fatal-result "yet to be born")))
args)))
(if (plist-get res :success)
(nconc res (list :files files))
res)))
(defun egg--git-co-rev-cmd-args (buffer-to-update rev args)
"Peform a synchronous action using git to checkout REV to the worktree.
ARGS will be used as arguments. Update BUFFER-TO-UPDATE if
needed. The relevent line from the output of the underlying git
command will be displayed as feedback of emacs command."
(let (files cmd res)
(if (eq :0 rev)
(setq files ;; index vs wdir
(egg-git-to-lines "diff" "--name-only")
cmd "checkout-index")
;; will change if switch rev
(setq files (egg-git-to-lines "diff" "--name-only" rev "HEAD")
cmd "checkout"
args (append args (list rev))))
(setq res
(egg--do-git-action
cmd buffer-to-update
(lambda (ret-code)
(if (= ret-code 0)
(or (egg--git-pp-grab-line-matching
(regexp-opt '("Already on" "HEAD is now at"
"Switched to branch" "Switched to a new branch"
"Reset branch")) nil
:next-action 'status :success t)
(egg--git-pp-grab-line-no -1 :next-action 'status :success t))
(or
(egg--git-pp-grab-line-matching "untracked working tree files would be overwritten"
"untracked file(s) would be overwritten"
:next-action 'status)
(egg--git-pp-fatal-result "Please, commit your changes"))))
args))
(if (plist-get res :success)
(nconc res (list :files files))
res)))
(defsubst egg--git-co-rev-cmd (buffer-to-update rev &rest args)
"Peform a synchronous action using git to checkout REV to the worktree.
ARGS will be used as arguments. Update BUFFER-TO-UPDATE if
needed. The relevent line from the output of the underlying git
command will be displayed as feedback of emacs command.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(egg--git-co-rev-cmd-args buffer-to-update rev args))
(defun egg--git-merge-cmd (buffer-to-update &rest args)
"Peform the git merge command synchronously with ARGS as arguments.
Update BUFFER-TO-UPDATE if needed. The relevant line from the
output of the underlying git command will be displayed as
feedback of emacs command.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(egg--do-git-action
"merge" buffer-to-update
(lambda (ret-code)
(cond ((= ret-code 0)
(or (egg--git-pp-grab-line-matching "stopped before committing as requested"
nil :next-action 'status :success t)
(egg--git-pp-grab-line-matching
(regexp-opt '("merge went well" "Already up-to-date"
"file changed" "files changed"
"insertions" "deletions"))
nil :success t :next-action 'log)
(egg--git-pp-grab-line-no -1 :success t :next-action 'status)))
((= ret-code 1)
(or (egg--git-pp-grab-line-matching "fix conflicts and then commit"
nil :next-action 'status :success t)
(egg--git-pp-grab-line-matching
"untracked working tree files would be overwritten by merge"
"untracked files would be overwritten, please rename them before merging"
:next-action 'status)
(egg--git-pp-grab-line-matching
"commit your changes or stash them before you can merge"
nil :next-action 'status)
(egg--git-pp-grab-line-no -1)))
(t (egg--git-pp-fatal-result))))
args))
(defun egg--git-merge-cmd-test (ff-only from)
(interactive "P\nsMerge: ")
(if ff-only
(egg--git-merge-cmd t "-v" "--ff-only" from)
(egg--git-merge-cmd t "-v" from)))
(defun egg--git-add-cmd (buffer-to-update &rest args)
"Run git add command synchronously with ARGS as arguments.
Update BUFFER-TO-UPDATE as needed.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(egg--do-git-action
"add" buffer-to-update
(lambda (ret-code)
(if (= ret-code 0)
(or (egg--git-pp-grab-line-matching "nothing added" nil :success t)
(egg--git-pp-grab-line-matching "^add " "index updated"
:next-action 'status :success t)
(egg--git-pp-grab-line-no -1 :success t))
(egg--git-pp-fatal-result)))
args))
(defun egg--git-rm-cmd (buffer-to-update &rest args)
"Run the git rm command synchronously with ARGS as arguments.
Update BUFFER-TO-UPDATE as needed.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(egg--do-git-action
"rm" buffer-to-update
(lambda (ret-code)
(if (= ret-code 0)
(nconc (list :success t)
(let (files)
(goto-char (point-min))
(while (re-search-forward "^rm '\\(.+\\)'$" nil t)
(add-to-list 'files (match-string-no-properties 1)))
(when (consp files)
(list :files files :next-action 'status))))
(egg--git-pp-fatal-result "has staged content different from both"
(regexp-opt '("did not match" "not removing")))))
args))
(defun egg--git-branch-cmd (buffer-to-update args)
"Run the git branch command synchronously with ARGS as arguments.
Update BUFFER-TO-UPDATE as needed.
See documentation of `egg--git-action-cmd-doc' for the return structure." (egg--do-git-action
"branch" buffer-to-update
(lambda (ret-code)
(if (= ret-code 0)
(egg--git-pp-grab-line-no -1 :success t)
(egg--git-pp-fatal-result (regexp-opt '("No commit" "no commit"
"No such" "no such" "is not fully")))))
args))
(defconst egg--git-stash-error-regex
"unimplemented\\|\\([dD]o \\|[Cc]ould \\|[Cc]an\\)not\\|No \\(changes\\|stash found\\)\\|Too many\\|is not\\|unable\\|Conflicts in index\\|No branch name\\|^fatal")
(defun egg--git-stash-save-cmd (buffer-to-update &rest args)
"Run the git stash save command synchronously with ARGS as arguments.
Update BUFFER-TO-UPDATE as needed.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(let ((files (egg-git-to-lines "diff" "--name-only" "HEAD"))
res)
(setq res
(egg--do-git-action
"stash" buffer-to-update
(lambda (ret-code)
(if (= ret-code 0)
(or (egg--git-pp-grab-1st-line-matching
'("Saved working directory" "HEAD is now at") nil
:next-action 'stash :success t)
(egg--git-pp-grab-line-no -1 :next-action 'stash :success t))
(egg--git-pp-fatal-result)))
(cons "save" args)))
(when (plist-get res :success)
(setq res (nconc res (list :files files))))
res))
(defun egg--git-stash-unstash-cmd (buffer-to-update cmd &optional args)
"Run a git stash CMD command synchronously with ARGS as arguments.
CMD should be pop, apply or branch.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(unless (egg-has-stashed-wip)
(error "no WIP was stashed!"))
(let ((files (egg-git-to-lines "diff" "--name-only" "stash@{0}"))
(cmd (or cmd "pop"))
res)
(setq res
(egg--do-git-action
"stash" buffer-to-update
(lambda (ret-code)
(if (= ret-code 0)
(or (egg--git-pp-grab-line-matching "Dropped refs/stash" nil
:next-action 'status :success t)
(egg--git-pp-grab-line-no -1 :next-action 'status :success t))
(or (egg--git-pp-grab-line-matching "^CONFLICT" nil
:next-action 'status :success t)
(egg--git-pp-grab-line-matching
"following files would be overwritten"
"stashed wip conflicts with local modifications, please commit first"
:next-action 'status)
(egg--git-pp-fatal-result))))
(cons cmd args)))
(when (plist-get res :success)
(setq res (nconc res (list :files files))))
res))
(defun egg--git-cherry-pick-pp (ret-code rev not-commit-yet)
(cond ((= ret-code 0)
(or (egg--git-pp-grab-line-matching
(regexp-opt '("file changed" "files changed"
"insertions" "deletions"))
nil :success t :next-action (if not-commit-yet 'commit 'log))
(if not-commit-yet
(if (egg-git-ok nil "diff" "--quiet" "--cached")
;; cherry pick produced empty index
(list :success t
:line (or (egg--git-pp-grab-line-no -1)
(format "cherry '%s' evaporated!!!" (egg-sha1 rev))))
(list :success t :next-action 'commit
:line (or (egg--git-pp-grab-line-no -1)
(format "cherry '%s' picked, ready to be committed"
(egg-sha1 rev)))))
(list :success t :next-action 'log
:line (or (egg--git-pp-grab-line-no -1)
(format "'%s' applied cleanly" (egg-sha1 rev)))))))
((= ret-code 1)
(or
(egg--git-pp-grab-line-matching
(regexp-opt '("cherry-pick is now empty" "nothing to commit"))
nil :success t)
(egg--git-pp-grab-line-matching "after resolving the conflicts"
"please resolve conflicts"
:next-action 'status :success t)
(egg--git-pp-grab-line-matching "error: could not apply" nil
:next-action 'status)
(egg--git-pp-grab-line-no -1)))
(t (egg--git-pp-fatal-result))))
(defun egg--git-cherry-pick-cmd (buffer-to-update rev &rest args)
"Run the git cherry-pick command synchronously with ARGS as arguments.
REV is the commit to be picked.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(let ((files (egg-git-to-lines "diff" "--name-only" rev))
(no-commit (and (member "--no-commit" args) t))
res)
(setq res
(egg--do-git-action
"cherry-pick"
buffer-to-update
`(lambda (ret-code)
(egg--git-cherry-pick-pp ret-code ,rev ,no-commit))
(nconc args (list rev))))
(when (plist-get res :success)
(nconc res (list :files files)))
res))
(defun egg--git-cherry-pick-cmd-test (rev option)
(interactive
(list (egg-read-rev "cherry pick rev: "
(or (egg-ref-at-point) (egg-commit-at-point) (egg-string-at-point)))
(read-string "cherry pick option: " "--no-commit")))
(egg--buffer-handle-result (egg--git-cherry-pick-cmd t rev option) t))
(defun egg--git-apply-cmd (buffer-to-update patch &optional args)
"Run the git apply command with PATCH as input and ARGS as arguments.
Update BUFFER-TO-UPDATE as needed.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(let ((files (egg-git-lines-matching-stdin patch "^[0-9]+\t[0-9]+\t\\(.+\\)$" 1
"apply" "--numstat" "-"))
res)
(setq res
(egg--do-git-action-stdin
"apply" patch
buffer-to-update
(lambda (ret-code)
(cond ((= ret-code 0)
(or (egg--git-pp-grab-line-matching "Applied patch.+cleanly"
"patch applied cleanly"
:success t :next-action 'commit)
(egg--git-pp-grab-line-no -1 :success t :next-action 'status)))
((= ret-code 1)
(or (egg--git-pp-grab-line-matching "Fall back to three-way merge"
"Patch produced conflicts"
:success t :next-action 'status)
(egg--git-pp-grab-1st-line-matching
'("Apply patch to.+with conflicts"
"error:.+patch does not apply"
"patch failed:"))
(egg--git-pp-grab-line-no -1)))
(t (egg--git-pp-fatal-result))))
(append args (list "-v" "-"))))
(when (plist-get res :success)
(nconc res (list :files files)))
res))
(defun egg--git-apply-cmd-test (file)
(interactive "fpatch file: ")
(with-temp-buffer
(insert-file-contents-literally file)
(egg--git-apply-cmd nil (buffer-string) '("-3"))
(egg-status nil nil)))
(defun egg--git-pp-commit-output (ret-code)
(cond ((= ret-code 0)
(or (egg--git-pp-grab-line-matching "files? changed" nil
:success t :next-action 'status)
(egg--git-pp-grab-line-no -1 :success t :next-action 'status)))
((= ret-code 1)
(or (egg--git-pp-grab-1st-line-matching '("^nothing" "^Abort") nil
:success t)
(egg--git-pp-grab-line-no -1)))
(t (egg--git-pp-fatal-result (regexp-opt '("empty message" "nothing to amend"))
"[Oo]nly one.+ can be used"))))
(defun egg--git-commit-with-region-cmd (buffer-to-update beg end gpg-uid &rest args)
(egg--do-git-action-stdin "commit"
(cons beg end) buffer-to-update
#'egg--git-pp-commit-output
(append args (cond ((eq gpg-uid t) (list "-v" "-S" "-F" "-"))
((stringp gpg-uid) (list "-v"
(concat "--gpg-sign=" gpg-uid)
"-F" "-"))
(t (list "-v" "-F" "-"))))))
(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)) commit
(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)))))
(defun egg--async-create-signed-commit-cmd (buffer-to-update beg end gpg-uid &rest extras)
(let ((args (list "-v" (if (stringp gpg-uid)
(concat "--gpg-sign=" gpg-uid)
"-S")
"-m" (buffer-substring-no-properties beg end))))
(setq args (nconc args extras))
(egg-async-1-args (list #'egg--async-create-signed-commit-handler buffer-to-update)
(cons "commit" args))))
(defsubst egg-do-commit-with-region (beg end gpg-uid)
(funcall (if gpg-uid
#'egg--async-create-signed-commit-cmd
#'egg--git-commit-with-region-cmd)
t beg end gpg-uid))
(defsubst egg-do-amend-with-region (beg end gpg-uid)
(funcall (if gpg-uid
#'egg--async-create-signed-commit-cmd
#'egg--git-commit-with-region-cmd)
t beg end gpg-uid "--amend"))
(defun egg--git-amend-no-edit-cmd (buffer-to-update &rest args)
(egg--do-git-action
"commit" buffer-to-update #'egg--git-pp-commit-output
(nconc (list "--amend" "--no-edit") args)))
(defsubst egg-buffer-do-amend-no-edit (&rest args)
(egg--buffer-handle-result (egg--git-amend-no-edit-cmd t) t))
(defun egg--git-revert-pp (ret-code rev not-commit-yet)
(cond ((= ret-code 0)
(or (egg--git-pp-grab-line-matching
(regexp-opt '("file changed" "files changed"
"insertions" "deletions"))
nil :success t :next-action (if not-commit-yet 'commit 'log))
(if not-commit-yet
(if (egg-git-ok nil "diff" "--quiet" "--cached")
;; revert produced empty index
(list :success t
:line (or (egg--git-pp-grab-line-no -1)
(format "successfully reverted '%s', but resulted in no changes"
(egg-sha1 rev))))
(list :success t :next-action 'commit
:line (or (egg--git-pp-grab-line-no -1)
(format "reverted '%s', ready to commit"
(egg-sha1 rev)))))
(list :success t :next-action 'log
:line (or (egg--git-pp-grab-line-no -1)
(format "rev '%s' reverted" (egg-sha1 rev)))))))
((= ret-code 1)
(or
(egg--git-pp-grab-line-matching "after resolving the conflicts"
"revert produced conflicts, please resolve"
:next-action 'status :success t)
(egg--git-pp-grab-line-matching "error: could not revert" nil
:next-action 'status)
(egg--git-pp-grab-line-no -1)))
(t (egg--git-pp-fatal-result))))
(defun egg--git-revert-cmd (buffer-to-update rev use-default-msg)
"Run the git revert command synchronously with ARGS as arguments.
REV is the commit to be picked.
See documentation of `egg--git-action-cmd-doc' for the return structure."
(let ((files (egg-git-to-lines "diff" "--name-only" rev))
(not-commit-yet (null use-default-msg))
res)
(setq res
(egg--do-git-action
"revert"
buffer-to-update
`(lambda (ret-code)
(egg--git-revert-pp ret-code ,rev ,not-commit-yet))
(list (if use-default-msg "--no-edit" "--no-commit") rev)))
(when (plist-get res :success)
(nconc res (list :files files)))
res))
(defun egg--git-tag-cmd-pp (ret-code)
(cond ((= ret-code 0)
(or (egg--git-pp-grab-1st-line-matching
'("Deleted tag" "Updated tag" "Good signature from"
"^user: ") nil :next-action 'log :success t)
(egg--git-pp-grab-line-no -1 :next-action 'log :success t)))
((= ret-code 1)
(or (egg--git-pp-grab-1st-line-matching '("no signature found" "^error:"))
(egg--git-pp-grab-line-no -1)))
(t ;; 128
(egg--git-pp-fatal-result
"gpg: skipped\\|^gpg: \\|empty.+object\\|bad object\\|[Nn]o tag"))))
(defun egg--git-tag-cmd (buffer-to-update stdin &optional args)
(if stdin
(egg--do-git-action-stdin "tag" stdin buffer-to-update #'egg--git-tag-cmd-pp args)
(egg--do-git-action "tag" buffer-to-update #'egg--git-tag-cmd-pp args)))
(defun egg--git-tag-check-name (name &optional force ambiguity-ok)
(let ((check-name (egg-git-to-string "name-rev" name)))
(setq check-name (save-match-data (split-string check-name " " t)))
(cond ((and (equal (nth 0 check-name) "Could")
(equal (nth 1 check-name) "not"))
nil) ;; ok, no collision
((and (equal (nth 0 check-name) name)
(not (equal (nth 1 check-name) name))
;; collision with existing tag
(or force
(y-or-n-p (format "a tag %s already exists, force move? " name)))))
((and (equal (nth 0 check-name) name)
(equal (nth 1 check-name) name)
;; collison with heads
(unless ambiguity-ok
(error "Refuse to introduce ambiguity: a branch head %s alread exist! bailed out!"
name))
nil)))))
(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 "^\\([0-9a-f]\\{40\\}\\) \\([0-9]+\\) \\([0-9]+\\) \\([0-9]+\\)$" 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-ok 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))
(defconst egg-hide-show-map
(let ((map (make-sparse-keymap "Egg:HideShow")))
(define-key map (kbd "h") 'egg-section-cmd-toggle-hide-show)
(define-key map (kbd "H") 'egg-section-cmd-toggle-hide-show-children)
(define-key map [mouse-2] 'egg-mouse-hide-show-cmd)
map)
"Keymap for a section than can be hidden/shown.\\{egg-hide-show-map}")
(defconst egg-section-map
(let ((map (make-sparse-keymap "Egg:Section")))
(set-keymap-parent map egg-hide-show-map)
(define-key map (kbd "n") 'egg-buffer-cmd-navigate-next)
(define-key map (kbd "p") 'egg-buffer-cmd-navigate-prev)
map)
"Keymap for a section in sequence that can be navigated back and forth.
\\{egg-section-map}")
(defconst egg-diff-section-map
(let ((map (make-sparse-keymap "Egg:Diff")))
(set-keymap-parent map egg-section-map)
(define-key map (kbd "RET") 'egg-diff-section-cmd-visit-file-other-window)
(define-key map (kbd "f") 'egg-diff-section-cmd-visit-file)
(define-key map (kbd "=") 'egg-diff-section-cmd-ediff)
map)
"Keymap for a diff section in sequence of deltas.
\\{egg-diff-section-map}")
(defconst egg-staged-diff-section-map
(let ((map (make-sparse-keymap "Egg:StagedDiff")))
(set-keymap-parent map egg-diff-section-map)
(define-key map (kbd "=") 'egg-staged-section-cmd-ediff3)
(define-key map (kbd "s") 'egg-diff-section-cmd-unstage)
(define-key map (kbd "DEL") 'egg-diff-section-cmd-revert-to-head)
(define-key map [C-down-mouse-2] 'egg-status-popup-staged-diff-menu)
(define-key map [C-mouse-2] 'egg-status-popup-staged-diff-menu)
map)
"Keymap for a diff section in sequence of staged deltas.
\\{egg-staged-diff-section-map}")
(defconst egg-wdir-diff-section-map
(let ((map (make-sparse-keymap "Egg:WdirDiff")))
(set-keymap-parent map egg-diff-section-map)
(define-key map (kbd "u") 'egg-diff-section-cmd-undo)
map)
"Keymap for a diff section in sequence of deltas between the workdir and
the index. \\{egg-wdir-diff-section-map}")
(defconst egg-unstaged-diff-section-map
(let ((map (make-sparse-keymap "Egg:UnstagedDiff")))
(set-keymap-parent map egg-wdir-diff-section-map)
(define-key map (kbd "=") 'egg-unstaged-section-cmd-ediff)
(define-key map (kbd "s") 'egg-diff-section-cmd-stage)
(define-key map (kbd "DEL") 'egg-diff-section-cmd-revert-to-head)
(define-key map [C-down-mouse-2] 'egg-status-popup-unstaged-diff-menu)
(define-key map [C-mouse-2] 'egg-status-popup-unstaged-diff-menu)
map)
"Keymap for a diff section in sequence of unstaged deltas.
\\{egg-unstaged-diff-section-map}")
(defconst egg-unmerged-diff-section-map
(let ((map (make-sparse-keymap "Egg:UnmergedDiff")))
(set-keymap-parent map egg-unstaged-diff-section-map)
(define-key map (kbd "=") 'egg-unmerged-section-cmd-ediff3)
map)
"Keymap for a diff section in sequence of unmerged deltas.
\\{egg-unmerged-diff-section-map}")
(defconst egg-hunk-section-map
(let ((map (make-sparse-keymap "Egg:Hunk")))
(set-keymap-parent map egg-section-map)
(define-key map (kbd "RET") 'egg-hunk-section-cmd-visit-file-other-window)
(define-key map (kbd "=") 'egg-diff-section-cmd-ediff)
(define-key map (kbd "f") 'egg-hunk-section-cmd-visit-file)
map)
"Keymap for a hunk in a diff section. \\{egg-hunk-section-map}")
(defconst egg-staged-hunk-section-map
(let ((map (make-sparse-keymap "Egg:StagedHunk")))
(set-keymap-parent map egg-hunk-section-map)
(define-key map (kbd "=") 'egg-staged-section-cmd-ediff3)
(define-key map (kbd "s") 'egg-hunk-section-cmd-unstage)
(define-key map [C-down-mouse-2] 'egg-status-popup-staged-hunk-menu)
(define-key map [C-mouse-2] 'egg-status-popup-staged-hunk-menu)
map)
"Keymap for a hunk in a staged diff section.
\\{egg-staged-hunk-section-map}")
(defconst egg-wdir-hunk-section-map
(let ((map (make-sparse-keymap "Egg:WdirHunk")))
(set-keymap-parent map egg-hunk-section-map)
(define-key map (kbd "u") 'egg-hunk-section-cmd-undo)
map)
"Keymap for a hunk in a diff section between the workdir and the index.
\\{egg-wdir-hunk-section-map}")
(defconst egg-unstaged-hunk-section-map
(let ((map (make-sparse-keymap "Egg:UnstagedHunk")))
(set-keymap-parent map egg-wdir-hunk-section-map)
(define-key map (kbd "=") 'egg-unstaged-section-cmd-ediff)
(define-key map (kbd "s") 'egg-hunk-section-cmd-stage)
(define-key map [C-down-mouse-2] 'egg-status-popup-unstaged-hunk-menu)
(define-key map [C-mouse-2] 'egg-status-popup-unstaged-hunk-menu)
map)
"Keymap for a hunk in a unstaged diff section.
\\{egg-unstaged-hunk-section-map}")
(defconst egg-unmerged-hunk-section-map
(let ((map (make-sparse-keymap "Egg:UnmergedHunk")))
;; no hunking staging in unmerged file
(set-keymap-parent map egg-wdir-hunk-section-map)
(define-key map (kbd "=") 'egg-unmerged-section-cmd-ediff3)
map)
"Keymap for a hunk in a unmerged diff section.
\\{egg-unmerged-hunk-section-map}")
(defun list-tp ()
(interactive)
(message "tp: %S" (text-properties-at (point))))
(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-navigation-at-point ()
(get-text-property (point) :navigation))
(defsubst egg-invisible-spec-at-point ()
(get-text-property (point) 'invisible))
(defsubst egg-hunk-at-point ()
(get-text-property (point) :hunk))
(defsubst egg-diff-at-point ()
(get-text-property (point) :diff))
(defsubst egg-point-in-section (section-id)
(eq (get-text-property (point) :section) section-id))
(defsubst egg-safe-search (re limit &optional no)
(save-excursion
(save-match-data
(and (re-search-forward re limit t)
(match-beginning (or no 0))))))
(defsubst egg-safe-search-pickup (re &optional limit no)
(save-excursion
(save-match-data
(and (re-search-forward re limit t)
(match-string-no-properties (or no 0))))))
(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 (1- line-beg) beg 'display " -- ")
(put-text-property beg end 'face 'egg-diff-none))
(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)
(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))
(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)
;; mark the whole conflict section
(setq sub-end (egg-safe-search "^++>>>>>>>.+$" end))
(put-text-property m-b-0 sub-end 'keymap
conflict-map))
((match-beginning conf-end-no)
(setq m-b-x (match-beginning conf-end-no)
m-e-x (match-end conf-end-no))
;; just decorate, no mark.
;; the section was already mark when the conf-beg-no
;; matched.
(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 "^@@" 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)
(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 "^@@@" 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)
(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-b-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))))
(defun egg-diff-section-cmd-visit-file (file)
"Visit file FILE."
(interactive (list (car (get-text-property (point) :diff))))
(find-file file))
(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))))
(find-file file)
(egg-resolve-merge-with-ediff))
(defun egg-unstaged-section-cmd-ediff (file)
"Compare FILE and its staged copy using ediff."
(interactive (list (car (get-text-property (point) :diff))))
(find-file file)
(egg-file-do-ediff ":0" "INDEX"))
(defun egg-staged-section-cmd-ediff3 (file)
"Compare the staged copy of FILE and the version in HEAD using ediff."
(interactive (list (car (get-text-property (point) :diff))))
(find-file file)
(egg-file-do-ediff ":0" "INDEX" "HEAD"))
(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)
src src-name dst)
(find-file file)
(cond (commit
(setq src (egg-describe-rev (concat commit "^"))
dst (egg-describe-rev commit)))
((setq src (plist-get diff-info :src-revision))
(when (consp src)
(setq src (egg-git-to-string "merge-base" (car src) (cdr src))))
(setq src (egg-describe-rev src)))
((setq src (and diff-info ":0"))
(setq src-name "INDEX")))
(unless src (error "Ooops!"))
(egg-file-do-ediff src src-name dst nil 'ediff2)))
(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)
(if (< (point) limit)
(while (re-search-forward "^\\(?:\\+\\| \\).*" limit t)
(setq adjust (1+ adjust)))))
(+ line adjust)))
(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 (+ (nth 1 hunk-info) head-beg))
(hunk-end (+ (nth 2 hunk-info) head-beg))
(hunk-ranges (nth 3 hunk-info)))
(list (car diff-info) (car hunk-info) hunk-beg hunk-end hunk-ranges)))
(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-section-cmd-toggle-hide-show (nav)
"Toggle the hidden state of the current navigation section of type NAV."
(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 navigation section at POS."
(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-use-region-p ()
(if (fboundp 'use-region-p)
(use-region-p)
(and transient-mark-mode mark-active)))
(defun egg-insert-current-line-buffer (buf)
(egg-insert-string-buffer (egg-current-line-string) buf))
(defun egg-current-line-string ()
(buffer-substring-no-properties
(line-beginning-position) (line-beginning-position 2)))
(defun egg-insert-string-buffer (string buf)
(with-current-buffer buf
(insert string)))
(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
;;;========================================================
(defvar egg-buffer-refresh-func nil)
(defvar egg-buffer-async-cmd-refresh-func nil)
(defvar egg-internal-update-index-timer nil)
(defsubst egg-buffer-async-do (accepted-code &rest args)
"Run git asynchronously and refresh the current buffer on exit.
exit code ACCEPTED-CODE is considered a success."
(egg-async-do accepted-code
(cons (or egg-buffer-async-cmd-refresh-func
egg-buffer-refresh-func)
(list (current-buffer)))
args))
(defsubst egg-run-buffers-update-hook (&optional newly-read-state)
"Update all egg special buffers."
(let ((egg-internal-current-state
(or newly-read-state (egg-get-repo-state))))
(run-hooks 'egg-buffers-refresh-hook)))
(defun egg-refresh-buffer (buffer)
(when (and (bufferp buffer) (buffer-live-p buffer))
(with-current-buffer buffer
(when (and (egg-git-dir)
(functionp egg-buffer-refresh-func))
(let ((line (count-lines (point-min) (point)))
(column (current-column))
(anchor (get-text-property (point) :navigation))
(offset (egg-section-relative-pos (point)))
(win-anchor-off-line-col-alist
(mapcar (lambda (win)
(let* ((win-pos (window-point win))
(win-anchor (get-text-property win-pos :navigation))
(win-off (egg-section-relative-pos win-pos))
(win-line (count-lines (point-min) win-pos))
(win-col (save-excursion
(goto-char win-pos)
(current-column))))
(list win win-anchor win-off win-line win-col)))
(get-buffer-window-list))))
(funcall egg-buffer-refresh-func (current-buffer))
(if anchor
(egg-buffer-goto-section anchor)
(egg-goto-line line)
(goto-char (+ (line-beginning-position) column)))
(dolist (win-anchor-off-line-col win-anchor-off-line-col-alist)
(let ((win (nth 0 win-anchor-off-line-col))
(anchor (nth 1 win-anchor-off-line-col))
(offset (nth 2 win-anchor-off-line-col))
(line (nth 3 win-anchor-off-line-col))
(col (nth 4 win-anchor-off-line-col)))
(with-selected-window win
(if anchor
(egg-buffer-goto-section anchor offset)
(egg-goto-line line)
(goto-char (+ (line-beginning-position) column)))))))))))
(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-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."
(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."
(interactive "P")
(egg-buffer-cmd-prev-block
(if (not at-level) :navigation
(or (get-text-property (point) :sect-type) :navigation))))
(defconst egg-buffer-mode-map
(let ((map (make-sparse-keymap "Egg:Buffer")))
(define-key map (kbd "q") 'egg-quit-buffer)
(define-key map (kbd "g") 'egg-buffer-cmd-refresh)
(define-key map (kbd "G") 'egg-buffer-cmd-refresh)
(define-key map (kbd "n") 'egg-buffer-cmd-navigate-next)
(define-key map (kbd "p") 'egg-buffer-cmd-navigate-prev)
(define-key map (kbd "C-c C-h") 'egg-buffer-hide-all)
map)
"Common map for an egg special buffer.\\{egg-buffer-mode-map}" )
(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)