diff options
Diffstat (limited to 'elpa/evil-20220510.2302/evil-common.el')
| -rw-r--r-- | elpa/evil-20220510.2302/evil-common.el | 4073 |
1 files changed, 4073 insertions, 0 deletions
diff --git a/elpa/evil-20220510.2302/evil-common.el b/elpa/evil-20220510.2302/evil-common.el new file mode 100644 index 0000000..6b9f694 --- /dev/null +++ b/elpa/evil-20220510.2302/evil-common.el @@ -0,0 +1,4073 @@ +;;; evil-common.el --- Common functions and utilities -*- lexical-binding: t -*- +;; Author: Vegard Øye <vegard_oye at hotmail.com> +;; Maintainer: Vegard Øye <vegard_oye at hotmail.com> + +;; Version: 1.15.0 + +;; +;; This file is NOT part of GNU Emacs. + +;;; License: + +;; This file is part of Evil. +;; +;; Evil 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 of the License, or +;; (at your option) any later version. +;; +;; Evil 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 Evil. If not, see <http://www.gnu.org/licenses/>. + +(require 'evil-vars) +(require 'evil-digraphs) +(require 'rect) +(require 'thingatpt) +(require 'cl-lib) +(require 'calc) + +;;; Code: + +(declare-function evil-visual-state-p "evil-states") +(declare-function evil-visual-restore "evil-states") +(declare-function evil-motion-state "evil-states") +(declare-function evil-ex-p "evil-ex") +(declare-function evil-set-jump "evil-jumps") + +(condition-case nil + (require 'windmove) + (error + (message "evil: Could not load `windmove', \ +window commands not available.") + nil)) + +;;; Compatibility with different Emacs versions + +;; x-set-selection and x-get-selection have been deprecated since 25.1 +;; by gui-set-selection and gui-get-selection +(defalias 'evil-get-selection + (if (fboundp 'gui-get-selection) 'gui-get-selection 'x-get-selection)) +(defalias 'evil-set-selection + (if (fboundp 'gui-set-selection) 'gui-set-selection 'x-set-selection)) + +(defmacro evil-called-interactively-p () + "Wrapper for `called-interactively-p'. +In older versions of Emacs, `called-interactively-p' takes +no arguments. In Emacs 23.2 and newer, it takes one argument." + (called-interactively-p 'any)) +(make-obsolete 'evil-called-interactively-p + "please use (called-interactively-p 'any) instead." + "Git commit 222b791") + +;; macro helper +(eval-and-compile + (defun evil-unquote (exp) + "Return EXP unquoted." + (while (eq (car-safe exp) 'quote) + (setq exp (cadr exp))) + exp)) + +(defun evil-delay (condition form hook &optional append local name) + "Execute FORM when CONDITION becomes true, checking with HOOK. +NAME specifies the name of the entry added to HOOK. If APPEND is +non-nil, the entry is appended to the hook. If LOCAL is non-nil, +the buffer-local value of HOOK is modified." + (if (and (not (booleanp condition)) (eval condition)) + (eval form) + (let* ((name (or name (format "evil-delay-form-in-%s" hook))) + (fun (make-symbol name)) + (condition (or condition t))) + (fset fun `(lambda (&rest args) + (when ,condition + (remove-hook ',hook #',fun ',local) + ,form))) + (put fun 'permanent-local-hook t) + (add-hook hook fun append local)))) +(put 'evil-delay 'lisp-indent-function 2) + +;;; List functions + +(defmacro evil--add-to-alist (list-var &rest elements) + "Add the assocation of KEY and VAL to the value of LIST-VAR. +If the list already contains an entry for KEY, update that entry; +otherwise add at the end of the list. + +\(fn LIST-VAR KEY VAL &rest ELEMENTS)" + (when (eq (car-safe list-var) 'quote) + (setq list-var (cadr list-var))) + `(progn + ,@(if (version< emacs-version "26") + ;; TODO: Remove this path when support for Emacs 25 is dropped + (cl-loop for (key val) on elements by #'cddr + collect `(let* ((key ,key) + (val ,val) + (cell (assoc key ,list-var))) + (if cell + (setcdr cell val) + (push (cons key val) ,list-var)))) + (cl-loop for (key val) on elements by #'cddr + collect `(setf (alist-get ,key ,list-var nil nil #'equal) ,val))) + ,list-var)) + +(defun evil-add-to-alist (list-var key val &rest elements) + "Add the assocation of KEY and VAL to the value of LIST-VAR. +If the list already contains an entry for KEY, update that entry; +otherwise add at the end of the list." + (let ((tail (symbol-value list-var))) + (while (and tail (not (equal (car-safe (car-safe tail)) key))) + (setq tail (cdr tail))) + (if tail + (setcar tail (cons key val)) + (set list-var (append (symbol-value list-var) + (list (cons key val))))) + (if elements + (with-no-warnings + (apply #'evil-add-to-alist list-var elements)) + (symbol-value list-var)))) + +(make-obsolete 'evil-add-to-alist + "use `evil--add-to-alist' instead. You may need to recompile code with evil macros." + "1.13.1") + +;; custom version of `delete-if' +(defun evil-filter-list (predicate list &optional pointer) + "Delete by side-effect all items satisfying PREDICATE in LIST. +Stop when reaching POINTER. If the first item satisfies PREDICATE, +there is no way to remove it by side-effect; therefore, write +\(setq foo (evil-filter-list 'predicate foo)) to be sure of +changing the value of `foo'." + (let ((tail list) elt head) + (while (and tail (not (eq tail pointer))) + (setq elt (car tail)) + (cond + ((funcall predicate elt) + (setq tail (cdr tail)) + (if head + (setcdr head tail) + (setq list tail))) + (t + (setq head tail + tail (cdr tail))))) + list)) + +(defun evil-member-if (predicate list &optional pointer) + "Find the first item satisfying PREDICATE in LIST. +Stop when reaching POINTER, which should point at a link +in the list." + (let (elt) + (catch 'done + (while (and (consp list) (not (eq list pointer))) + (setq elt (car list)) + (if (funcall predicate elt) + (throw 'done elt) + (setq list (cdr list))))))) + +(defun evil-member-recursive-if (predicate tree) + "Find the first item satisfying PREDICATE in TREE." + (cond + ((funcall predicate tree) + tree) + ((listp tree) + (catch 'done + (dolist (elt tree) + (when (setq elt (evil-member-recursive-if predicate elt)) + (throw 'done elt))))))) + +(defun evil-concat-lists (&rest sequences) + "Concatenate lists, removing duplicates. +Elements are compared with `eq'." + (let (result) + (dolist (sequence sequences) + (dolist (elt sequence) + (push elt result))) + (nreverse (cl-remove-duplicates result :test #'eq)))) + +(defun evil-concat-alists (&rest sequences) + "Concatenate association lists, removing duplicates. +An alist is a list of cons cells (KEY . VALUE) where each key +may occur only once. Later values overwrite earlier values." + (let (result) + (dolist (sequence sequences) + (dolist (elt sequence) + (setq result (assq-delete-all (car-safe elt) result)) + (push elt result))) + (nreverse result))) + +(defun evil-concat-plists (&rest sequences) + "Concatenate property lists, removing duplicates. +A property list is a list (:KEYWORD1 VALUE1 :KEYWORD2 VALUE2...) +where each keyword may occur only once. Later values overwrite +earlier values." + (let (result) + (dolist (sequence sequences result) + (while sequence + (setq result + (plist-put result (pop sequence) (pop sequence))))))) + +(defun evil-concat-keymap-alists (&rest sequences) + "Concatenate keymap association lists, removing duplicates. +A keymap alist is a list of cons cells (VAR . MAP) where each keymap +may occur only once, but where the variables may be repeated +\(e.g., (VAR . MAP1) (VAR . MAP2) is allowed). The order matters, +with the highest priority keymaps being listed first." + (let (result) + (dolist (sequence sequences) + (dolist (elt sequence) + (unless (rassq (cdr-safe elt) result) + (push elt result)))) + (nreverse result))) + +(defun evil-plist-delete (prop plist) + "Delete by side effect the property PROP from PLIST. +If PROP is the first property in PLIST, there is no way +to remove it by side-effect; therefore, write +\(setq foo (evil-plist-delete :prop foo)) to be sure of +changing the value of `foo'." + (let ((tail plist) elt head) + (while tail + (setq elt (car tail)) + (cond + ((eq elt prop) + (setq tail (cdr (cdr tail))) + (if head + (setcdr (cdr head) tail) + (setq plist tail))) + (t + (setq head tail + tail (cdr (cdr tail)))))) + plist)) + +(defun evil-get-property (alist key &optional prop) + "Return property PROP for KEY in ALIST. +ALIST is an association list with entries of the form +\(KEY . PLIST), where PLIST is a property list. +If PROP is nil, return all properties for KEY. +If KEY is t, return an association list of keys +and their PROP values." + (cond + ((null prop) + (cdr (assq key alist))) + ((eq key t) + (let (result val) + (dolist (entry alist result) + (setq key (car entry) + val (cdr entry)) + (when (plist-member val prop) + (setq val (plist-get val prop)) + (push (cons key val) result))))) + (t + (plist-get (cdr (assq key alist)) prop)))) + +(defun evil-put-property (alist-var key prop val &rest properties) + "Set PROP to VAL for KEY in ALIST-VAR. +ALIST-VAR points to an association list with entries of the form +\(KEY . PLIST), where PLIST is a property list storing PROP and VAL." + (set alist-var + (let* ((alist (symbol-value alist-var)) + (plist (cdr (assq key alist)))) + (setq plist (plist-put plist prop val)) + (when properties + (setq plist (evil-concat-plists plist properties) + val (car (last properties)))) + (setq alist (assq-delete-all key alist)) + (push (cons key plist) alist))) + val) + +(defun evil-state-property (state prop &optional value) + "Return the value of property PROP for STATE. +PROP is a keyword as used by `evil-define-state'. +STATE is the state's symbolic name. +If VALUE is non-nil and the value is a variable, +return the value of that variable." + (let ((val (evil-get-property evil-state-properties state prop))) + (if (and value (symbolp val) (boundp val)) + (symbol-value val) + val))) + +(defmacro evil-swap (this that &rest vars) + "Swap the values of variables THIS and THAT. +If three or more arguments are given, the values are rotated. +E.g., (evil-swap A B C) sets A to B, B to C, and C to A." + `(progn + (setq ,this (prog1 ,that + (setq ,that ,this))) + ,@(when vars + `((evil-swap ,that ,@vars))))) + +(defmacro evil-sort (min max &rest vars) + "Place the smallest value in MIN and the largest in MAX. +If three or more arguments are given, place the smallest +value in the first argument and the largest in the last, +sorting in between." + (let ((sorted (make-symbol "sortvar"))) + `(let ((,sorted (sort (list ,min ,max ,@vars) '<))) + (setq ,min (pop ,sorted) + ,max (pop ,sorted) + ,@(apply #'append + (mapcar #'(lambda (var) + (list var `(pop ,sorted))) + vars)))))) + +(defun evil-vector-to-string (vector) + "Turns vector into a string, changing <escape> to '\\e'" + (mapconcat (lambda (c) + (if (equal c 'escape) + "\e" + (make-string 1 c))) + vector + "")) + +;;; Command properties + +(defmacro evil-define-command (command &rest body) + "Define a command COMMAND. + +\(fn COMMAND (ARGS...) DOC [[KEY VALUE]...] BODY...)" + (declare (indent defun) + (doc-string 3) + (debug (&define name + [&optional lambda-list] + [&optional stringp] + [&rest keywordp sexp] + [&optional ("interactive" [&rest form])] + def-body))) + (let ((interactive '(interactive)) + arg args doc doc-form key keys) + ;; collect arguments + (when (listp (car-safe body)) + (setq args (pop body))) + ;; collect docstring + (when (> (length body) 1) + (if (eq (car-safe (car-safe body)) 'format) + (setq doc-form (pop body)) + (when (stringp (car-safe body)) + (setq doc (pop body))))) + ;; collect keywords + (setq keys (plist-put keys :repeat t)) + (while (keywordp (car-safe body)) + (setq key (pop body) + arg (pop body)) + (unless nil ; TODO: add keyword check + (setq keys (plist-put keys key arg)))) + ;; collect `interactive' form + (when (and body (consp (car body)) + (eq (car (car body)) 'interactive)) + (let* ((iform (pop body)) + (result (apply #'evil-interactive-form (cdr iform))) + (form (car result)) + (attrs (cdr result))) + (setq interactive `(interactive ,form) + keys (evil-concat-plists keys attrs)))) + `(progn + ;; the compiler does not recognize `defun' inside `let' + ,(when (and command body) + `(defun ,command ,args + ,@(when doc `(,doc)) + ,interactive + (ignore ,@(cl-set-difference args '(&optional &rest))) + ,@body)) + ,(when (and command doc-form) + `(put ',command 'function-documentation ,doc-form)) + ;; set command properties for symbol or lambda function + (let ((func ',(if (and (null command) body) + `(lambda ,args + ,interactive + ,@body) + command))) + (apply #'evil-set-command-properties func ',keys) + func)))) + +;; If no Evil properties are defined for the command, several parts of +;; Evil apply certain default rules; e.g., the repeat system decides +;; whether the command is repeatable by monitoring buffer changes. +(defun evil-has-command-property-p (command property) + "Whether COMMAND has Evil PROPERTY. +See also `evil-has-command-properties-p'." + (plist-member (evil-get-command-properties command) property)) + +(defun evil-has-command-properties-p (command) + "Whether Evil properties are defined for COMMAND. +See also `evil-has-command-property-p'." + (and (evil-get-command-properties command) t)) + +(defun evil-get-command-property (command property &optional default) + "Return the value of Evil PROPERTY of COMMAND. +If the command does not have the property, return DEFAULT. +See also `evil-get-command-properties'." + (if (evil-has-command-property-p command property) + (evil-get-property evil-command-properties command property) + default)) + +(defun evil-get-command-properties (command) + "Return all Evil properties of COMMAND. +See also `evil-get-command-property'." + (evil-get-property evil-command-properties command)) + +(defun evil-set-command-property (command property value) + "Set PROPERTY to VALUE for COMMAND. +To set multiple properties at once, see +`evil-set-command-properties' and `evil-add-command-properties'." + (evil-put-property 'evil-command-properties command property value)) +(defalias 'evil-put-command-property 'evil-set-command-property) + +(defun evil-add-command-properties (command &rest properties) + "Add PROPERTIES to COMMAND. +PROPERTIES should be a property list. +To replace all properties at once, use `evil-set-command-properties'." + (apply #'evil-put-property + 'evil-command-properties command properties)) + +(defun evil-set-command-properties (command &rest properties) + "Replace all of COMMAND's properties with PROPERTIES. +PROPERTIES should be a property list. +This erases all previous properties; to only add properties, +use `evil-set-command-property'." + (setq evil-command-properties + (assq-delete-all command evil-command-properties)) + (when properties + (apply #'evil-add-command-properties command properties))) + +(defun evil-remove-command-properties (command &rest properties) + "Remove PROPERTIES from COMMAND. +PROPERTIES should be a list of properties (:PROP1 :PROP2 ...). +If PROPERTIES is the empty list, all properties are removed." + (let (plist) + (when properties + (setq plist (evil-get-command-properties command)) + (dolist (property properties) + (setq plist (evil-plist-delete property plist)))) + (apply #'evil-set-command-properties command plist))) + +(defun evil-yank-handler (&optional motion) + "Return the yank handler for MOTION. +MOTION defaults to the current motion." + (setq motion (or motion evil-this-motion)) + (evil-get-command-property motion :yank-handler)) + +(defun evil-declare-motion (command) + "Declare COMMAND to be a movement function. +This ensures that it behaves correctly in visual state." + (evil-add-command-properties command :keep-visual t :repeat 'motion)) + +(defun evil-declare-repeat (command) + "Declare COMMAND to be repeatable." + (evil-add-command-properties command :repeat t)) + +(defun evil-declare-not-repeat (command) + "Declare COMMAND to be nonrepeatable." + (evil-add-command-properties command :repeat nil)) + +(defun evil-declare-ignore-repeat (command) + "Declare COMMAND to be nonrepeatable." + (evil-add-command-properties command :repeat 'ignore)) + +(defun evil-declare-change-repeat (command) + "Declare COMMAND to be repeatable by buffer changes rather than +keystrokes." + (evil-add-command-properties command :repeat 'change)) + +(defun evil-declare-insert-at-point-repeat (command) + "Declare COMMAND to be repeatable by buffer changes." + (evil-add-command-properties command :repeat 'insert-at-point)) + +(defun evil-declare-abort-repeat (command) + "Declare COMMAND to be nonrepeatable." + (evil-add-command-properties command :repeat 'abort)) + +(defun evil-delimited-arguments (string &optional num) + "Parse STRING as a sequence of delimited arguments. +Returns a list of NUM strings, or as many arguments as +the string contains. The first non-blank character is +taken to be the delimiter. If some arguments are missing +from STRING, the resulting list is padded with nil values. +Two delimiters following directly after each other gives +an empty string." + (save-match-data + (let ((string (or string "")) + (count (or num -1)) (idx 0) + argument delim match result) + (when (string-match "^[[:space:]]*\\([^[:space:]]\\)" string) + (setq delim (match-string 1 string) + argument (format "%s\\(\\(?:[\\].\\|[^%s]\\)*\\)" + (regexp-quote delim) + delim)) + (while (and (/= count 0) (string-match argument string idx)) + (setq match (match-string 1 string) + idx (match-end 1) + count (1- count)) + (when (= count 0) + (unless (save-match-data + (string-match + (format "%s[[:space:]]*$" delim) string idx)) + (setq match (substring string (match-beginning 1))))) + (unless (and (zerop (length match)) + (zerop (length (substring string idx)))) + (push match result)))) + (when (and num (< (length result) num)) + (dotimes (_ (- num (length result))) + (push nil result))) + (nreverse result)))) + +(defun evil-concat-charsets (&rest sets) + "Concatenate character sets. +A character set is the part between [ and ] in a regular expression. +If any character set is complemented, the result is also complemented." + (let ((bracket "") (complement "") (hyphen "") result) + (save-match-data + (dolist (set sets) + (when (string-match-p "^\\^" set) + (setq set (substring set 1) + complement "^")) + (when (string-match-p "^]" set) + (setq set (substring set 1) + bracket "]")) + (when (string-match-p "^-" set) + (setq set (substring set 1) + hyphen "-")) + (setq result (concat result set))) + (format "%s%s%s%s" complement bracket hyphen result)))) + +;;; Key sequences + +(defun evil-keypress-parser (&optional input) + "Read from keyboard or INPUT and build a command description. +Returns (CMD COUNT), where COUNT is the numeric prefix argument. +Both COUNT and CMD may be nil." + (let (count negative) + (when input (setq unread-command-events (append input unread-command-events))) + (catch 'done + (while t + (let ((seq (read-key-sequence ""))) + (when seq + (let ((cmd (key-binding seq))) + (cond + ((null cmd) (throw 'done (list nil nil))) + ((arrayp cmd) ; keyboard macro, recursive call + (let ((cmd (evil-keypress-parser cmd))) + (throw 'done + (list (car cmd) + (if (or count (cadr cmd)) + (list (car cmd) (* (or count 1) + (or (cadr cmd) 1)))))))) + ((or (eq cmd #'digit-argument) + (and (equal seq "0") + count)) + (let* ((event (aref seq (- (length seq) 1))) + (char (or (when (characterp event) event) + (when (symbolp event) + (get event 'ascii-character)))) + (digit (if (or (characterp char) (integerp char)) + (- (logand char ?\177) ?0)))) + (setq count (+ (* 10 (or count 0)) digit)))) + ((eq cmd #'negative-argument) + (setq negative (not negative))) + (t + (throw 'done (list cmd + (and count + (* count + (if negative -1 1)))))))))))))) + +(defun evil-read-key (&optional prompt) + "Read a key from the keyboard. +Translates it according to the input method." + (let ((old-global-map (current-global-map)) + (new-global-map (make-sparse-keymap)) + (overriding-terminal-local-map nil) + (overriding-local-map evil-read-key-map) + seq char cmd) + (unwind-protect + (condition-case nil + (progn + (define-key new-global-map [menu-bar] + (lookup-key global-map [menu-bar])) + (define-key new-global-map [tab-bar] + (lookup-key global-map [tab-bar])) + (define-key new-global-map [tool-bar] + (lookup-key global-map [tool-bar])) + (setq new-global-map + (append new-global-map + (list (make-char-table 'display-table + 'self-insert-command)))) + (use-global-map new-global-map) + (setq seq (read-key-sequence prompt nil t) + char (aref seq 0) + cmd (key-binding seq)) + (while (arrayp cmd) + (setq char (aref cmd 0) + cmd (key-binding cmd))) + (cond + ((eq cmd 'self-insert-command) + char) + (cmd + (call-interactively cmd)) + (t + (user-error "No replacement character typed")))) + (quit + (when (fboundp 'evil-repeat-abort) + (evil-repeat-abort)) + (signal 'quit nil))) + (use-global-map old-global-map)))) + +(defun evil-read-quoted-char () + "Command that calls `read-quoted-char'. +This command can be used wherever `read-quoted-char' is required +as a command. Its main use is in the `evil-read-key-map'." + (interactive) + (read-quoted-char)) + +(defun evil-read-digraph-char-with-overlay (overlay) + "Read two chars, displaying the first in OVERLAY, replacing `?'. +Return the digraph from `evil-digraph', else return second char." + (interactive) + (let (char1 char2 string) + (unwind-protect + (progn + (overlay-put overlay 'invisible t) + ;; create overlay prompt + (setq string (propertize "?" + 'face 'minibuffer-prompt + 'cursor 1)) + (overlay-put overlay 'after-string string) + (setq char1 (read-key)) + (setq string (propertize (string char1) + 'face 'minibuffer-prompt + 'cursor 1)) + (overlay-put overlay 'after-string string) + (setq char2 (read-key))) + (delete-overlay overlay)) + (or (evil-digraph (list char1 char2)) + ;; use the last character if undefined + char2))) + +(defun evil-read-digraph-char (&optional hide-chars) + "Read two keys from keyboard forming a digraph. +This function creates an overlay at (point), hiding the next +HIDE-CHARS characters. HIDE-CHARS defaults to 1." + (interactive) + (let ((overlay (make-overlay (point) + (min (point-max) + (+ (or hide-chars 1) + (point)))))) + (evil-read-digraph-char-with-overlay overlay))) + +(defun evil-read-motion (&optional motion count type modifier) + "Read a MOTION, motion COUNT and motion TYPE from the keyboard. +The type may be overridden with MODIFIER, which may be a type +or a Visual selection as defined by `evil-define-visual-selection'. +Return a list (MOTION COUNT [TYPE])." + (let (command prefix) + (setq evil-this-type-modified nil) + (unless motion + (while (progn + (setq command (evil-keypress-parser) + motion (pop command) + prefix (pop command)) + (when prefix + (if count + (setq count (string-to-number + (concat (number-to-string count) + (number-to-string prefix)))) + (setq count prefix))) + ;; if the command is a type modifier, read more + (when (rassq motion evil-visual-alist) + (setq modifier + (or modifier + (car (rassq motion evil-visual-alist)))))))) + (when modifier + (setq type (or type (evil-type motion 'exclusive))) + (cond + ((eq modifier 'char) + ;; TODO: this behavior could be less hard-coded + (if (eq type 'exclusive) + (setq type 'inclusive) + (setq type 'exclusive))) + (t + (setq type modifier))) + (setq evil-this-type-modified type)) + (list motion count type))) + +(defun evil-mouse-events-p (keys) + "Returns non-nil iff KEYS contains a mouse event." + (catch 'done + (dotimes (i (length keys)) + (when (or (and (fboundp 'mouse-event-p) + (mouse-event-p (aref keys i))) + (mouse-movement-p (aref keys i))) + (throw 'done t))) + nil)) + +(defun evil-extract-count (keys) + "Splits the key-sequence KEYS into prefix-argument and the rest. +Returns the list (PREFIX CMD SEQ REST), where PREFIX is the +prefix count, CMD the command to be executed, SEQ the subsequence +calling CMD, and REST is all remaining events in the +key-sequence. PREFIX and REST may be nil if they do not exist. +If a command is bound to some keyboard macro, it is expanded +recursively." + (catch 'done + (let* ((len (length keys)) + (beg 0) + (end 1) + (found-prefix nil)) + (while (and (<= end len)) + (let* ((seq (substring keys beg end)) + (cmd (key-binding seq))) + (cond + ((memq cmd '(undefined nil)) + (user-error "No command bound to %s" seq)) + ((arrayp cmd) ; keyboard macro, replace command with macro + (setq keys (vconcat (substring keys 0 beg) + cmd + (substring keys end)) + end (1+ beg) + len (length keys))) + ((functionp cmd) + (if (or (memq cmd '(digit-argument negative-argument)) + (and found-prefix + (equal (vconcat seq) (vector ?0)))) + ;; skip those commands + (setq found-prefix t ; found at least one prefix argument + beg end + end (1+ end)) + ;; a real command, finish + (throw 'done + (list (unless (zerop beg) + (string-to-number + (concat (substring keys 0 beg)))) + cmd + seq + (when (< end len) + (substring keys end)))))) + (t ; append a further event + (setq end (1+ end)))))) + (user-error "Key sequence contains no complete binding")))) + +(defun evil-extract-append (file-or-append) + "Return an (APPEND . FILENAME) pair based on FILE-OR-APPEND. +FILE-OR-APPEND should either be a filename or a \">> FILE\" +directive. APPEND will be t if FILE-OR-APPEND is an append +directive and nil otherwise. FILENAME will be the extracted +filename." + (if (and (stringp file-or-append) + (string-match "\\(>> *\\)" file-or-append)) + (cons t (substring file-or-append(match-end 1))) + (cons nil file-or-append))) + +(defun evil-set-keymap-prompt (map prompt) + "Set the prompt-string of MAP to PROMPT." + (delq (keymap-prompt map) map) + (when prompt + (setcdr map (cons prompt (cdr map))))) + +(defun evil-lookup-key (map key) + "Returns non-nil value if KEY is bound in MAP." + (let ((definition (lookup-key map key))) + (if (numberp definition) ; in-band error + nil + definition))) + +;;; Display + +(defun evil-set-cursor (specs) + "Change the cursor's apperance according to SPECS. +SPECS may be a cursor type as per `cursor-type', a color +string as passed to `set-cursor-color', a zero-argument +function for changing the cursor, or a list of the above." + (unless (and (not (functionp specs)) + (listp specs) + (null (cdr-safe (last specs)))) + (setq specs (list specs))) + (dolist (spec specs) + (cond + ((functionp spec) + (condition-case nil + (funcall spec) + (error nil))) + ((stringp spec) + (evil-set-cursor-color spec)) + (t + (setq cursor-type spec))))) + +(defun evil-set-cursor-color (color) + "Set the cursor color to COLOR." + (unless (equal (frame-parameter nil 'cursor-color) color) + ;; `set-cursor-color' forces a redisplay, so only + ;; call it when the color actually changes + (set-cursor-color color))) + +(defun evil-refresh-cursor (&optional state buffer) + "Refresh the cursor for STATE in BUFFER. +BUFFER defaults to the current buffer. If STATE is nil the +cursor type is either `evil-force-cursor' or the current state." + (when (and (boundp 'evil-local-mode) evil-local-mode) + (let* ((state (or state evil-force-cursor evil-state 'normal)) + (default (or evil-default-cursor t)) + (cursor (evil-state-property state :cursor t)) + (color (or (and (stringp cursor) cursor) + (and (listp cursor) + (evil-member-if #'stringp cursor)) + (frame-parameter nil 'cursor-color)))) + (with-current-buffer (or buffer (current-buffer)) + ;; if both STATE and `evil-default-cursor' + ;; specify a color, don't set it twice + (when (and color (listp default)) + (setq default (evil-filter-list #'stringp default))) + (evil-set-cursor default) + (evil-set-cursor cursor))))) + +(defmacro evil-save-cursor (&rest body) + "Save the current cursor; execute BODY; restore the cursor." + (declare (indent defun) + (debug t)) + `(let ((cursor cursor-type) + (color (frame-parameter (selected-frame) 'cursor-color)) + (inhibit-quit t)) + (unwind-protect + (progn ,@body) + (evil-set-cursor cursor) + (evil-set-cursor color)))) + +(defun evil-echo (string &rest args) + "Display an unlogged message in the echo area. +That is, the message is not logged in the *Messages* buffer. +\(To log the message, just use `message'.)" + (unless evil-no-display + (let (message-log-max) + (apply #'message string args)))) + +(defun evil-echo-area-save () + "Save the current echo area in `evil-echo-area-message'." + (setq evil-echo-area-message (current-message))) + +(defun evil-echo-area-restore () + "Restore the echo area from `evil-echo-area-message'. +Does not restore if `evil-write-echo-area' is non-nil." + (unless evil-write-echo-area + (if evil-echo-area-message + (message "%s" evil-echo-area-message) + (message nil))) + (setq evil-echo-area-message nil + evil-write-echo-area nil)) + +;; toggleable version of `with-temp-message' +(defmacro evil-save-echo-area (&rest body) + "Save the echo area; execute BODY; restore the echo area. +Intermittent messages are not logged in the *Messages* buffer." + (declare (indent defun) + (debug t)) + `(let ((inhibit-quit t) + evil-echo-area-message + evil-write-echo-area) + (unwind-protect + (progn + (evil-echo-area-save) + ,@body) + (evil-echo-area-restore)))) + +(defmacro evil-without-display (&rest body) + "Execute BODY without Evil displays. +Inhibits echo area messages, mode line updates and cursor changes." + (declare (indent defun) + (debug t)) + `(let ((evil-no-display t)) + ,@body)) + +(defvar evil-cached-header-line-height nil + "Cached height of the header line. +Used for fallback implementation on older Emacsen.") + +(defun evil-header-line-height () + "Return the height of the header line. +If there is no header line, return 0. +Used as a fallback implementation of `window-header-line-height' on +older Emacsen." + (let ((posn (posn-at-x-y 0 0))) + (or (when (eq (posn-area posn) 'header-line) + (cdr (posn-object-width-height posn))) + 0))) + +(defun evil-posn-x-y (position) + "Return the x and y coordinates in POSITION. +This function returns y offset from the top of the buffer area including +the header line and the tab line (on Emacs 27 and later versions). + +On Emacs 24 and later versions, the y-offset returned by +`posn-at-point' is relative to the text area excluding the header +line and the tab line, while y offset taken by `posn-at-x-y' is relative to +the buffer area including the header line and the tab line. +This asymmetry is by design according to GNU Emacs team. +This function fixes the asymmetry between them. + +Learned from mozc.el." + (let ((xy (posn-x-y position))) + (when header-line-format + (setcdr xy (+ (cdr xy) + (or (and (fboundp 'window-header-line-height) + (window-header-line-height)) + evil-cached-header-line-height + (setq evil-cached-header-line-height (evil-header-line-height)))))) + (when (fboundp 'window-tab-line-height) + (setcdr xy (+ (cdr xy) (window-tab-line-height)))) + xy)) + +(defun evil-count-lines (beg end) + "Return absolute line-number-difference betweeen `beg` and `end`. +This should give the same results no matter where on the line `beg` +and `end` are." + (if (= beg end) + 0 + (let* ((last (max beg end)) + (end-at-bol (save-excursion (goto-char last) + (bolp)))) + (if end-at-bol + (count-lines beg end) + (1- (count-lines beg end)))))) + +;;; Movement + +(defun evil-normalize-position (pos) + "Return POS if it does not exceed the buffer boundaries. +If POS is less than `point-min', return `point-min'. +Is POS is more than `point-max', return `point-max'. +If POS is a marker, return its position." + (cond + ((not (number-or-marker-p pos)) + pos) + ((< pos (point-min)) + (point-min)) + ((> pos (point-max)) + (point-max)) + ((markerp pos) + (marker-position pos)) + (t + pos))) + +(defmacro evil-save-goal-column (&rest body) + "Restores the goal column after execution of BODY. +See also `evil-save-column'." + (declare (indent defun) + (debug t)) + `(let ((goal-column goal-column) + (temporary-goal-column temporary-goal-column)) + ,@body)) + +(defmacro evil-save-column (&rest body) + "Restores the column after execution of BODY. +See also `evil-save-goal-column'." + (declare (indent defun) + (debug t)) + `(let ((col (current-column))) + (evil-save-goal-column + ,@body + (move-to-column col)))) + +(defun evil--stick-to-eol-p () + "Called by vertical movement commands to help determine cursor position." + (let ((goal-col (or goal-column + (if (consp temporary-goal-column) + (car temporary-goal-column) + temporary-goal-column)))) + (and evil-track-eol + (= most-positive-fixnum goal-col) + (eq last-command 'next-line)))) + +(defun evil-eolp () + "Like `eolp' but accounts for `evil-move-beyond-eol' being nil." + (ignore-errors + (save-excursion + (unless (or evil-move-beyond-eol (memq evil-state '(insert replace))) + (forward-char)) + (eolp)))) + +(defmacro evil-ensure-column (&rest body) + "Execute BODY so that column after execution is correct. +If `evil-start-of-line' is nil, treat BODY as if it were a `next-line' command. +This mostly copies the approach of Emacs' `line-move-1', but is modified +so it is more compatible with evil's notions of eol & tracking." + (declare (indent defun) + (debug t)) + (let ((normalize-temporary-goal-column + `(if (consp temporary-goal-column) + ;; Ensure a negative value is never set for `temporary-goal-column' + ;; as it may have a negative component when both `whitespace-mode' + ;; and `display-line-numbers-mode' are enabled. + ;; See #1297 + (setq temporary-goal-column (max 0 (+ (car temporary-goal-column) + (cdr temporary-goal-column))))))) + `(progn + (unless evil-start-of-line (setq this-command 'next-line)) + ,normalize-temporary-goal-column + (if (not (memq last-command '(next-line previous-line))) + (setq temporary-goal-column + (if (and evil-track-eol + (evil-eolp) + (memq real-last-command '(move-end-of-line evil-end-of-line))) + most-positive-fixnum + (current-column)))) + ,@body + (if evil-start-of-line + (evil-first-non-blank) + ,normalize-temporary-goal-column + (line-move-to-column (truncate (or goal-column temporary-goal-column))))))) + +(defun evil-narrow (beg end) + "Restrict the buffer to BEG and END. +BEG or END may be nil, specifying a one-sided restriction including +`point-min' or `point-max'. See also `evil-with-restriction.'" + (setq beg (or (evil-normalize-position beg) (point-min))) + (setq end (or (evil-normalize-position end) (point-max))) + (narrow-to-region beg end)) + +(defmacro evil-with-restriction (beg end &rest body) + "Execute BODY with the buffer narrowed to BEG and END. +BEG or END may be nil as passed to `evil-narrow'; this creates +a one-sided restriction." + (declare (indent 2) + (debug t)) + `(save-restriction + (let ((evil-restriction-stack + (cons (cons (point-min) (point-max)) evil-restriction-stack))) + (evil-narrow ,beg ,end) + ,@body))) + +(defmacro evil-without-restriction (&rest body) + "Execute BODY with the top-most narrowing removed. +This works only if the previous narrowing has been generated by +`evil-with-restriction'." + (declare (indent defun) + (debug t)) + `(save-restriction + (widen) + (narrow-to-region (car (car evil-restriction-stack)) + (cdr (car evil-restriction-stack))) + (let ((evil-restriction-stack (cdr evil-restriction-stack))) + ,@body))) + +(defmacro evil-narrow-to-field (&rest body) + "Narrow to the current field." + (declare (indent defun) + (debug t)) + `(evil-with-restriction (field-beginning) (field-end) + ,@body)) + +(defun evil-move-beginning-of-line (&optional arg) + "Move to the beginning of the line as displayed. +Like `move-beginning-of-line', but retains the goal column." + (evil-save-goal-column + (move-beginning-of-line arg) + (beginning-of-line))) + +(defun evil-move-end-of-line (&optional arg) + "Move to the end of the line as displayed. +Like `move-end-of-line', but retains the goal column." + (evil-save-goal-column + (move-end-of-line arg) + (end-of-line))) + +(defun evil-adjust-cursor (&optional _) + "Move point one character back if at the end of a non-empty line. +This behavior is controled by `evil-move-beyond-eol'." + (when (and (eolp) + (not evil-move-beyond-eol) + (not (bolp)) + (= (point) + (save-excursion + (evil-move-end-of-line) + (point)))) + (evil-move-cursor-back t))) + +(defun evil-move-cursor-back (&optional force) + "Move point one character back within the current line. +Contingent on the variable `evil-move-cursor-back' or the FORCE +argument. Honors field boundaries, i.e., constrains the movement +to the current field as recognized by `line-beginning-position'." + (when (or evil-move-cursor-back force) + (unless (or (= (point) (line-beginning-position)) + (and (boundp 'visual-line-mode) + visual-line-mode + (= (point) (save-excursion + (beginning-of-visual-line) + (point))))) + (backward-char)))) + +(defun evil-line-position (line &optional column) + "Return the position of LINE. +If COLUMN is specified, return its position on the line. +A negative number means the end of the line." + (save-excursion + (when (fboundp 'evil-goto-line) + (evil-goto-line line)) + (if (numberp column) + (if (< column 0) + (beginning-of-line 2) + (move-to-column column)) + (beginning-of-line)) + (point))) + +(defun evil-column (&optional pos) + "Return the horizontal position of POS. +POS defaults to point." + (save-excursion + (when pos + (goto-char pos)) + (current-column))) + +(defun evil-move-to-column (column &optional dir force) + "Move point to column COLUMN in the current line. +Places point at left of the tab character (at the right if DIR +is non-nil) and returns point." + (interactive "p") + (move-to-column column force) + (unless force + (when (or (not dir) (and (numberp dir) (< dir 1))) + (when (> (current-column) column) + (evil-move-cursor-back)))) + (point)) + +(defmacro evil-loop (spec &rest body) + "Loop with countdown variable. +Evaluate BODY with VAR counting down from COUNT to 0. +COUNT can be negative, in which case VAR counts up instead. +The return value is the value of VAR when the loop +terminates, which is 0 if the loop completes successfully. +RESULT specifies a variable for storing this value. + +\(fn (VAR COUNT [RESULT]) BODY...)" + (declare (indent defun) + (debug dolist)) + (let* ((i (make-symbol "loopvar")) + (var (pop spec)) + (count (pop spec)) + (result (pop spec))) + (setq var (or (unless (eq var result) var) i) + result (or result var)) + `(let ((,var ,count)) + (setq ,result ,var) + (while (/= ,var 0) + ,@body + (if (> ,var 0) + (setq ,var (1- ,var)) + (setq ,var (1+ ,var))) + (setq ,result ,var)) + ,var))) + +;;; Motions + +(defmacro evil-motion-loop (spec &rest body) + "Loop a certain number of times. +Evaluate BODY repeatedly COUNT times with VAR bound to 1 or -1, +depending on the sign of COUNT. RESULT, if specified, holds +the number of unsuccessful iterations, which is 0 if the loop +completes successfully. This is also the return value. + +Each iteration must move point; if point does not change, +the loop immediately quits. See also `evil-loop'. + +\(fn (VAR COUNT [RESULT]) BODY...)" + (declare (indent defun) + (debug ((symbolp form &optional symbolp) body))) + (let* ((var (or (pop spec) (make-symbol "unitvar"))) + (countval (or (pop spec) 0)) + (result (pop spec)) + (i (make-symbol "loopvar")) + (count (make-symbol "countvar")) + (done (make-symbol "donevar")) + (orig (make-symbol "origvar"))) + `(let* ((,count ,countval) + (,var (if (< ,count 0) -1 1))) + (catch ',done + (evil-loop (,i ,count ,result) + (let ((,orig (point))) + ,@body + (when (= (point) ,orig) + (throw ',done ,i)))))))) + +(defmacro evil-signal-without-movement (&rest body) + "Catches errors provided point moves within this scope." + (declare (indent defun) + (debug t)) + `(let ((p (point))) + (condition-case err + (progn ,@body) + (error + (when (= p (point)) + (signal (car err) (cdr err))))))) + +(defun evil-signal-at-bob-or-eob (&optional count) + "Signals error if `point' is at boundaries. +If `point' is at bob and COUNT is negative this function signal +'beginning-of-buffer. If `point' is at eob and COUNT is positive +this function singal 'end-of-buffer. This function should be used +in motions. COUNT defaults to 1." + (setq count (or count 1)) + (cond + ((< count 0) (evil-signal-at-bob)) + ((> count 0) (evil-signal-at-eob)))) + +(defun evil-signal-at-bob () + "Signals 'beginning-of-buffer if `point' is at bob. +This function should be used in backward motions. If `point' is at +bob so that no further backward motion is possible the error +'beginning-of-buffer is raised." + (when (bobp) (signal 'beginning-of-buffer nil))) + +(defun evil-signal-at-eob () + "Signals 'end-of-buffer if `point' is at eob. +This function should be used in forward motions. If `point' is close +to eob so that no further forward motion is possible the error +'end-of-buffer is raised. This is the case if `point' is at +`point-max' or if is one position before `point-max', +`evil-move-beyond-eol' is nil and `point' is not at the end +of a line. The latter is necessary because `point' cannot be +moved to `point-max' if `evil-move-beyond-eol' is nil and +the last line in the buffer is not empty." + (when (or (eobp) + (and (not (eolp)) + (not evil-move-beyond-eol) + (save-excursion (forward-char) (eobp)))) + (signal 'end-of-buffer nil))) + +(defmacro evil-with-hproject-point-on-window (&rest body) + "Project point after BODY to current window. +If point is on a position left or right of the current window +then it is moved to the left and right boundary of the window, +respectively. If `auto-hscroll-mode' is non-nil then the left and +right positions are increased or decreased, respectively, by +`horizontal-margin' so that no automatic scrolling occurs." + (declare (indent defun) + (debug t)) + (let ((diff (make-symbol "diff")) + (left (make-symbol "left")) + (right (make-symbol "right"))) + `(let ((,diff (if auto-hscroll-mode (1+ hscroll-margin) 0)) + auto-hscroll-mode) + ,@body + (let* ((,left (+ (window-hscroll) ,diff)) + (,right (+ (window-hscroll) (window-width) (- ,diff) -1))) + (move-to-column (min (max (current-column) ,left) ,right)))))) + +(defun evil-goto-min (&rest positions) + "Go to the smallest position in POSITIONS. +Non-numerical elements are ignored. +See also `evil-goto-max'." + (when (setq positions (evil-filter-list + #'(lambda (elt) + (not (number-or-marker-p elt))) + positions)) + (goto-char (apply #'min positions)))) + +(defun evil-goto-max (&rest positions) + "Go to the largest position in POSITIONS. +Non-numerical elements are ignored. +See also `evil-goto-min'." + (when (setq positions (evil-filter-list + #'(lambda (elt) + (not (number-or-marker-p elt))) + positions)) + (goto-char (apply #'max positions)))) + +(defun evil-forward-not-thing (thing &optional count) + "Move point to the end or beginning of the complement of THING." + (evil-motion-loop (dir (or count 1)) + (let (bnd) + (cond + ((> dir 0) + (while (and (setq bnd (bounds-of-thing-at-point thing)) + (< (point) (cdr bnd))) + (goto-char (cdr bnd))) + ;; no thing at (point) + (if (zerop (forward-thing thing)) + ;; now at the end of the next thing + (let ((bnd (bounds-of-thing-at-point thing))) + (if (or (< (car bnd) (point)) ; end of a thing + (= (car bnd) (cdr bnd))) ; zero width thing + (goto-char (car bnd)) + ;; beginning of yet another thing, go back + (forward-thing thing -1))) + (goto-char (point-max)))) + (t + (while (and (not (bobp)) + (or (backward-char) t) + (setq bnd (bounds-of-thing-at-point thing)) + (< (point) (cdr bnd))) + (goto-char (car bnd))) + ;; either bob or no thing at point + (goto-char + (if (and (not (bobp)) + (zerop (forward-thing thing -1)) + (setq bnd (bounds-of-thing-at-point thing))) + (cdr bnd) + (point-min)))))))) + +(defun evil-bounds-of-not-thing-at-point (thing &optional which) + "Returns the bounds of a complement of THING at point. +If there is a THING at point nil is returned. Otherwise if WHICH +is nil or 0 a cons cell (BEG . END) is returned. If WHICH is +negative the beginning is returned. If WHICH is positive the END +is returned." + (let ((pnt (point))) + (let ((beg (save-excursion + (and (zerop (forward-thing thing -1)) + (forward-thing thing)) + (if (> (point) pnt) (point-min) (point)))) + (end (save-excursion + (and (zerop (forward-thing thing)) + (forward-thing thing -1)) + (if (< (point) pnt) (point-max) (point))))) + (when (and (<= beg (point)) (<= (point) end) (< beg end)) + (cond + ((or (not which) (zerop which)) (cons beg end)) + ((< which 0) beg) + ((> which 0) end)))))) + +(defun evil-forward-nearest (count &rest forwards) + "Moves point forward to the first of several motions. +FORWARDS is a list of forward motion functions (i.e. each moves +point forward to the next end of a text object (if passed a +1) +or backward to the preceeding beginning of a text object (if +passed a -1)). This function calls each of these functions once +and moves point to the nearest of the resulting positions. If +COUNT is positive point is moved forward COUNT times, if negative +point is moved backward -COUNT times." + (evil-motion-loop (dir (or count 1)) + (let ((pnt (point)) + (nxt (if (> dir 0) (point-max) (point-min)))) + (dolist (fwd forwards) + (goto-char pnt) + (condition-case nil + (evil-with-restriction + (and (< dir 0) + (save-excursion + (goto-char nxt) + (line-beginning-position 0))) + (and (> dir 0) + (save-excursion + (goto-char nxt) + (line-end-position 2))) + (if (and (zerop (funcall fwd dir)) + (/= (point) pnt) + (or (and (> dir 0) (< (point) nxt)) + (and (< dir 0) (> (point) nxt)))) + (setq nxt (point)))) + (error))) + (goto-char nxt)))) + +(defun bounds-of-evil-string-at-point (&optional state) + "Return the bounds of a string at point. +If STATE is given it used a parsing state at point." + (save-excursion + (let ((state (or state (syntax-ppss)))) + (and (nth 3 state) + (cons (nth 8 state) + (and (parse-partial-sexp (point) + (point-max) + nil + nil + state + 'syntax-table) + (point))))))) +(put 'evil-string 'bounds-of-thing-at-point #'bounds-of-evil-string-at-point) + +(defun bounds-of-evil-comment-at-point () + "Return the bounds of a string at point." + (save-excursion + (let ((state (syntax-ppss))) + (and (nth 4 state) + (cons (nth 8 state) + (and (parse-partial-sexp (point) + (point-max) + nil + nil + state + 'syntax-table) + (point))))))) +(put 'evil-comment 'bounds-of-thing-at-point #'bounds-of-evil-comment-at-point) + +;; The purpose of this function is to provide line motions which +;; preserve the column. This is how `previous-line' and `next-line' +;; work, but unfortunately the behaviour is hard-coded: if and only if +;; the last command was `previous-line' or `next-line', the column is +;; preserved. Furthermore, in contrast to Vim, when we cannot go +;; further, those motions move point to the beginning resp. the end of +;; the line (we never want point to leave its column). The code here +;; comes from simple.el, and I hope it will work in future. +(defun evil-line-move (count &optional noerror) + "A wrapper for line motions which conserves the column. +Signals an error at buffer boundaries unless NOERROR is non-nil." + (cond + (noerror + (condition-case nil + (evil-line-move count) + (error nil))) + (t + (evil-signal-without-movement + (setq this-command (if (>= count 0) + #'next-line + #'previous-line)) + (let ((opoint (point))) + (condition-case err + (with-no-warnings + (funcall this-command (abs count))) + ((beginning-of-buffer end-of-buffer) + (let ((col (or goal-column + (if (consp temporary-goal-column) + (car temporary-goal-column) + temporary-goal-column)))) + (if line-move-visual + (vertical-motion (cons col 0)) + (line-move-finish col opoint (< count 0))) + ;; Maybe we should just `ding'? + (signal (car err) (cdr err)))))))))) + +(defun evil-forward-syntax (syntax &optional count) + "Move point to the end or beginning of a sequence of characters in +SYNTAX. +Stop on reaching a character not in SYNTAX." + (let ((notsyntax (if (= (aref syntax 0) ?^) + (substring syntax 1) + (concat "^" syntax)))) + (evil-motion-loop (dir (or count 1)) + (cond + ((< dir 0) + (skip-syntax-backward notsyntax) + (skip-syntax-backward syntax)) + (t + (skip-syntax-forward notsyntax) + (skip-syntax-forward syntax)))))) + +(defun evil-forward-chars (chars &optional count) + "Move point to the end or beginning of a sequence of CHARS. +CHARS is a character set as inside [...] in a regular expression." + (let ((notchars (if (= (aref chars 0) ?^) + (substring chars 1) + (concat "^" chars)))) + (evil-motion-loop (dir (or count 1)) + (cond + ((< dir 0) + (skip-chars-backward notchars) + (skip-chars-backward chars)) + (t + (skip-chars-forward notchars) + (skip-chars-forward chars)))))) + +(defun evil-up-block (beg end &optional count) + "Move point to the end or beginning of text enclosed by BEG and END. +BEG and END should be regular expressions matching the opening +and closing delimiters, respectively. If COUNT is greater than +zero point is moved forward otherwise it is moved +backwards. Whenever an opening delimiter is found the COUNT is +increased by one, if a closing delimiter is found the COUNT is +decreased by one. The motion stops when COUNT reaches zero. The +match-data reflects the last successful match (that caused COUNT +to reach zero). The behaviour of this functions is similar to +`up-list'." + (let* ((count (or count 1)) + (forwardp (> count 0)) + (dir (if forwardp +1 -1))) + (catch 'done + (while (not (zerop count)) + (let* ((pnt (point)) + (cl (save-excursion + (and (re-search-forward (if forwardp end beg) nil t dir) + (or (/= pnt (point)) + (progn + ;; zero size match, repeat search from + ;; the next position + (forward-char dir) + (re-search-forward (if forwardp end beg) nil t dir))) + (point)))) + (match (match-data t)) + (op (save-excursion + (and (not (equal beg end)) + (re-search-forward (if forwardp beg end) cl t dir) + (or (/= pnt (point)) + (progn + ;; zero size match, repeat search from + ;; the next position + (forward-char dir) + (re-search-forward (if forwardp beg end) cl t dir))) + (point))))) + (cond + ((not cl) + (goto-char (if forwardp (point-max) (point-min))) + (set-match-data nil) + (throw 'done count)) + (t + (if op + (progn + (setq count (if forwardp (1+ count) (1- count))) + (goto-char op)) + (setq count (if forwardp (1- count) (1+ count))) + (if (zerop count) (set-match-data match)) + (goto-char cl)))))) + 0))) + +(defun evil-up-paren (open close &optional count) + "Move point to the end or beginning of balanced parentheses. +OPEN and CLOSE should be characters identifying the opening and +closing parenthesis, respectively. If COUNT is greater than zero +point is moved forward otherwise it is moved backwards. Whenever +an opening delimiter is found the COUNT is increased by one, if a +closing delimiter is found the COUNT is decreased by one. The +motion stops when COUNT reaches zero. The match-data reflects the +last successful match (that caused COUNT to reach zero)." + ;; Always use the default `forward-sexp-function'. This is important + ;; for modes that use a custom one like `python-mode'. + ;; (addresses #364) + (let (forward-sexp-function) + (with-syntax-table (copy-syntax-table (syntax-table)) + (modify-syntax-entry open (format "(%c" close)) + (modify-syntax-entry close (format ")%c" open)) + (let ((rest (evil-motion-loop (dir count) + (let ((pnt (point))) + (condition-case nil + (cond + ((> dir 0) + (while (progn + (up-list dir) + (/= (char-before) close)))) + (t + (while (progn + (up-list dir) + (/= (char-after) open))))) + (error (goto-char pnt))))))) + (cond + ((= rest count) (set-match-data nil)) + ((> count 0) (set-match-data (list (1- (point)) (point)))) + (t (set-match-data (list (point) (1+ (point)))))) + rest)))) + +(defun evil-up-xml-tag (&optional count) + "Move point to the end or beginning of balanced xml tags. +OPEN and CLOSE should be characters identifying the opening and +closing parenthesis, respectively. If COUNT is greater than zero +point is moved forward otherwise it is moved backwards. Whenever +an opening delimiter is found the COUNT is increased by one, if a +closing delimiter is found the COUNT is decreased by one. The +motion stops when COUNT reaches zero. The match-data reflects the +last successful match (that caused COUNT to reach zero)." + (let* ((dir (if (> (or count 1) 0) +1 -1)) + (count (abs (or count 1))) + (op (if (> dir 0) 1 2)) + (cl (if (> dir 0) 2 1)) + (orig (point)) + pnt tags match) + (catch 'done + (while (> count 0) + ;; find the previous opening tag + (while + (and (setq match + (re-search-forward + "<\\([^/ >\n]+\\)\\(?:=>?\\|[^\"/>]\\|\"[^\"]*\"\\)*?>\\|</\\([^>]+?\\)>" + nil t dir)) + (cond + ((match-beginning op) + (push (match-string op) tags)) + ((null tags) nil) ; free closing tag + ((and (< dir 0) + (string= (car tags) (match-string cl))) + ;; in backward direction we only accept matching + ;; tags. If the current tag is a free opener + ;; without matching closing tag, the subsequents + ;; test will make us ignore this tag + (pop tags)) + ((and (> dir 0)) + ;; non matching openers are considered free openers + (while (and tags + (not (string= (car tags) + (match-string cl)))) + (pop tags)) + (pop tags))))) + (unless (setq match (and match (match-data t))) + (setq match nil) + (throw 'done count)) + ;; found closing tag, look for corresponding opening tag + (cond + ((> dir 0) + (setq pnt (match-end 0)) + (goto-char (match-beginning 0))) + (t + (setq pnt (match-beginning 0)) + (goto-char (match-end 0)))) + (let* ((tag (match-string cl)) + (refwd (concat "<\\(/\\)?" + (regexp-quote tag) + "\\(?:>\\|[ \n]\\(?:[^\"/>]\\|\"[^\"]*\"\\)*?>\\)")) + (cnt 1)) + (while (and (> cnt 0) (re-search-backward refwd nil t dir)) + (setq cnt (+ cnt (if (match-beginning 1) dir (- dir))))) + (if (zerop cnt) (setq count (1- count) tags nil)) + (goto-char pnt))) + (if (> count 0) + (set-match-data nil) + (set-match-data match) + (goto-char (if (> dir 0) (match-end 0) (match-beginning 0))))) + ;; if not found, set to point-max/point-min + (unless (zerop count) + (set-match-data nil) + (goto-char (if (> dir 0) (point-max) (point-min))) + (if (/= (point) orig) (setq count (1- count)))) + (* dir count))) + +(defun evil-forward-quote (quote &optional count) + "Move point to the end or beginning of a string. +QUOTE is the character delimiting the string. If COUNT is greater +than zero point is moved forward otherwise it is moved +backwards." + (let (reset-parser) + (with-syntax-table (copy-syntax-table (syntax-table)) + (unless (= (char-syntax quote) ?\") + (modify-syntax-entry quote "\"") + (setq reset-parser t)) + ;; global parser state is out of state, use local one + (let* ((pnt (point)) + (state (save-excursion + (beginning-of-defun) + (parse-partial-sexp (point) pnt nil nil (syntax-ppss)))) + (bnd (bounds-of-evil-string-at-point state))) + (when (and bnd (< (point) (cdr bnd))) + ;; currently within a string + (if (> count 0) + (progn + (goto-char (cdr bnd)) + (setq count (1- count))) + (goto-char (car bnd)) + (setq count (1+ count)))) + ;; forward motions work with local parser state + (cond + ((> count 0) + ;; no need to reset global parser state because we only use + ;; the local one + (setq reset-parser nil) + (catch 'done + (while (and (> count 0) (not (eobp))) + (setq state (parse-partial-sexp (point) (point-max) + nil + nil + state + 'syntax-table)) + (cond + ((nth 3 state) + (setq bnd (bounds-of-thing-at-point 'evil-string)) + (goto-char (cdr bnd)) + (setq count (1- count))) + ((eobp) (goto-char pnt) (throw 'done nil)))))) + ((< count 0) + ;; need to update global cache because of backward motion + (setq reset-parser (and reset-parser (point))) + (save-excursion + (beginning-of-defun) + (syntax-ppss-flush-cache (point))) + (catch 'done + (while (and (< count 0) (not (bobp))) + (setq pnt (point)) + (while (and (not (bobp)) + (or (eobp) (/= (char-after) quote))) + (backward-char)) + (cond + ((setq bnd (bounds-of-thing-at-point 'evil-string)) + (goto-char (car bnd)) + (setq count (1+ count))) + ((bobp) (goto-char pnt) (throw 'done nil)) + (t (backward-char)))))) + (t (setq reset-parser nil))))) + (when reset-parser + ;; reset global cache + (save-excursion + (goto-char reset-parser) + (beginning-of-defun) + (syntax-ppss-flush-cache (point)))) + count)) + +;;; Thing-at-point motion functions for Evil text objects and motions +(defun forward-evil-empty-line (&optional count) + "Move forward COUNT empty lines." + (setq count (or count 1)) + (cond + ((> count 0) + (while (and (> count 0) (not (eobp))) + (when (and (bolp) (eolp)) + (setq count (1- count))) + (forward-line 1))) + (t + (while (and (< count 0) (not (bobp)) + (zerop (forward-line -1))) + (when (and (bolp) (eolp)) + (setq count (1+ count)))))) + count) + +(defun forward-evil-space (&optional count) + "Move forward COUNT whitespace sequences [[:space:]]+." + (evil-forward-chars "[:space:]" count)) + +(defun forward-evil-word (&optional count) + "Move forward COUNT words. +Moves point COUNT words forward or (- COUNT) words backward if +COUNT is negative. Point is placed after the end of the word (if +forward) or at the first character of the word (if backward). A +word is a sequence of word characters matching +\[[:word:]] (recognized by `forward-word'), a sequence of +non-whitespace non-word characters '[^[:word:]\\n\\r\\t\\f ]', or +an empty line matching ^$." + (evil-forward-nearest + count + #'(lambda (&optional cnt) + (let ((word-separating-categories evil-cjk-word-separating-categories) + (word-combining-categories evil-cjk-word-combining-categories) + (pnt (point))) + (forward-word cnt) + (if (= pnt (point)) cnt 0))) + #'(lambda (&optional cnt) + (evil-forward-chars "^[:word:]\n\r\t\f " cnt)) + #'forward-evil-empty-line)) + +(defun forward-evil-WORD (&optional count) + "Move forward COUNT \"WORDS\". +Moves point COUNT WORDS forward or (- COUNT) WORDS backward if +COUNT is negative. Point is placed after the end of the WORD (if +forward) or at the first character of the WORD (if backward). A +WORD is a sequence of non-whitespace characters +'[^\\n\\r\\t\\f ]', or an empty line matching ^$." + (evil-forward-nearest count + #'(lambda (&optional cnt) + (evil-forward-chars "^\n\r\t\f " cnt)) + #'forward-evil-empty-line)) + +(defun forward-evil-symbol (&optional count) + "Move forward COUNT symbols. +Moves point COUNT symbols forward or (- COUNT) symbols backward +if COUNT is negative. Point is placed after the end of the +symbol (if forward) or at the first character of the symbol (if +backward). A symbol is either determined by `forward-symbol', or +is a sequence of characters not in the word, symbol or whitespace +syntax classes." + (evil-forward-nearest + count + #'(lambda (&optional cnt) + (evil-forward-syntax "^w_->" cnt)) + #'(lambda (&optional cnt) + (let ((pnt (point))) + (forward-symbol cnt) + (if (= pnt (point)) cnt 0))) + #'forward-evil-empty-line)) + +(defun forward-evil-defun (&optional count) + "Move forward COUNT defuns. +Moves point COUNT defuns forward or (- COUNT) defuns backward +if COUNT is negative. A defun is defined by +`beginning-of-defun' and `end-of-defun' functions." + (evil-motion-loop (dir (or count 1)) + (if (> dir 0) (end-of-defun) (beginning-of-defun)))) + +(defun forward-evil-sentence (&optional count) + "Move forward COUNT sentences. +Moves point COUNT sentences forward or (- COUNT) sentences +backward if COUNT is negative. This function is the same as +`forward-sentence' but returns the number of sentences that could +NOT be moved over." + (evil-motion-loop (dir (or count 1)) + (condition-case nil + (forward-sentence dir) + (error)))) + +(defun forward-evil-paragraph (&optional count) + "Move forward COUNT paragraphs. +Moves point COUNT paragraphs forward or (- COUNT) paragraphs backward +if COUNT is negative. A paragraph is defined by +`start-of-paragraph-text' and `forward-paragraph' functions." + (evil-motion-loop (dir (or count 1)) + (cond + ((> dir 0) (forward-paragraph)) + ((not (bobp)) (start-of-paragraph-text) (beginning-of-line))))) + +(defvar evil-forward-quote-char ?\" + "The character to be used by `forward-evil-quote'.") + +(defun forward-evil-quote (&optional count) + "Move forward COUNT strings. +The quotation character is specified by the global variable +`evil-forward-quote-char'. This character is passed to +`evil-forward-quote'." + (evil-forward-quote evil-forward-quote-char count)) + +(defun forward-evil-quote-simple (&optional count) + "Move forward COUNT strings. +The quotation character is specified by the global variable +`evil-forward-quote-char'. This functions uses Vim's rules +parsing from the beginning of the current line for quotation +characters. It should only be used when looking for strings +within comments and buffer *must* be narrowed to the comment." + (let ((dir (if (> (or count 1) 0) 1 -1)) + (ch evil-forward-quote-char) + (pnt (point)) + (cnt 0)) + (beginning-of-line) + ;; count number of quotes before pnt + (while (< (point) pnt) + (when (= (char-after) ch) + (setq cnt (1+ cnt))) + (forward-char)) + (setq cnt (- (* 2 (abs count)) (mod cnt 2))) + (cond + ((> dir 0) + (while (and (not (eolp)) (not (zerop cnt))) + (when (= (char-after) ch) (setq cnt (1- cnt))) + (forward-char)) + (when (not (zerop cnt)) (goto-char (point-max)))) + (t + (while (and (not (bolp)) (not (zerop cnt))) + (when (= (char-before) ch) (setq cnt (1- cnt))) + (forward-char -1)) + (when (not (zerop cnt)) (goto-char (point-min))))) + (/ cnt 2))) + +;;; Motion functions +(defun evil-forward-beginning (thing &optional count) + "Move forward to beginning of THING. +The motion is repeated COUNT times." + (setq count (or count 1)) + (if (< count 0) + (forward-thing thing count) + (let ((bnd (bounds-of-thing-at-point thing)) + rest) + (when (and bnd (< (point) (cdr bnd))) + (goto-char (cdr bnd))) + (condition-case nil + (when (zerop (setq rest (forward-thing thing count))) + (when (and (bounds-of-thing-at-point thing) + (not (bobp)) + ;; handle final empty line + (not (and (bolp) (eobp)))) + (forward-char -1)) + (beginning-of-thing thing)) + (error)) + rest))) + +(defun evil-backward-beginning (thing &optional count) + "Move backward to beginning of THING. +The motion is repeated COUNT times. This is the same as calling +`evil-backward-beginning' with -COUNT." + (evil-forward-beginning thing (- (or count 1)))) + +(defun evil-forward-end (thing &optional count) + "Move forward to end of THING. +The motion is repeated COUNT times." + (setq count (or count 1)) + (cond + ((> count 0) + (unless (eobp) (forward-char)) + (prog1 (forward-thing thing count) + (unless (bobp) (forward-char -1)))) + (t + (let ((bnd (bounds-of-thing-at-point thing)) + rest) + (when (and bnd (< (point) (cdr bnd) )) + (goto-char (car bnd))) + (condition-case nil + (when (zerop (setq rest (forward-thing thing count))) + (end-of-thing thing) + (forward-char -1)) + (error)) + rest)))) + +(defun evil-backward-end (thing &optional count) + "Move backward to end of THING. +The motion is repeated COUNT times. This is the same as calling +`evil-backward-end' with -COUNT." + (evil-forward-end thing (- (or count 1)))) + +(defun evil-forward-word (&optional count) + "Move by words. +Moves point COUNT words forward or (- COUNT) words backward if +COUNT is negative. This function is the same as `forward-word' +but returns the number of words by which point could *not* be +moved." + (setq count (or count 1)) + (let* ((dir (if (>= count 0) +1 -1)) + (count (abs count))) + (while (and (> count 0) + (forward-word dir)) + (setq count (1- count))) + count)) + +(defun evil-in-comment-p (&optional pos) + "Checks if POS is within a comment according to current syntax. +If POS is nil, (point) is used. The return value is the beginning +position of the comment." + (setq pos (or pos (point))) + (let ((chkpos + (cond + ((eobp) pos) + ((= (char-syntax (char-after)) ?<) (1+ pos)) + ((and (not (zerop (logand (car (syntax-after (point))) + (lsh 1 16)))) + (not (zerop (logand (or (car (syntax-after (1+ (point)))) 0) + (lsh 1 17))))) + (+ pos 2)) + ((and (not (zerop (logand (car (syntax-after (point))) + (lsh 1 17)))) + (not (zerop (logand (or (car (syntax-after (1- (point)))) 0) + (lsh 1 16))))) + (1+ pos)) + (t pos)))) + (let ((syn (save-excursion (syntax-ppss chkpos)))) + (and (nth 4 syn) (nth 8 syn))))) + +(defun evil-looking-at-start-comment (&optional move) + "Returns t if point is at the start of a comment. +point must be on one of the opening characters of a block comment +according to the current syntax table. Futhermore these +characters must been parsed as opening characters, i.e. they +won't be considered as comment starters inside a string or +possibly another comment. Point is moved to the first character +of the comment opener if MOVE is non-nil." + (cond + ;; one character opener + ((= (char-syntax (char-after)) ?<) + (equal (point) (evil-in-comment-p (1+ (point))))) + ;; two character opener on first char + ((and (not (zerop (logand (car (syntax-after (point))) + (lsh 1 16)))) + (not (zerop (logand (or (car (syntax-after (1+ (point)))) 0) + (lsh 1 17))))) + (equal (point) (evil-in-comment-p (+ 2 (point))))) + ;; two character opener on second char + ((and (not (zerop (logand (car (syntax-after (point))) + (lsh 1 17)))) + (not (zerop (logand (or (car (syntax-after (1- (point)))) 0) + (lsh 1 16))))) + (and (equal (1- (point)) (evil-in-comment-p (1+ (point)))) + (prog1 t (when move (backward-char))))))) + +(defun evil-looking-at-end-comment (&optional move) + "Returns t if point is at the end of a comment. +point must be on one of the opening characters of a block comment +according to the current syntax table. Futhermore these +characters must been parsed as opening characters, i.e. they +won't be considered as comment starters inside a string or +possibly another comment. Point is moved right after the comment +closer if MOVE is non-nil." + (cond + ;; one char closer + ((= (char-syntax (char-after)) ?>) + (and (evil-in-comment-p) ; in comment + (not (evil-in-comment-p (1+ (point)))) + (prog1 t (when move (forward-char))))) + ;; two char closer on first char + ((and (not (zerop (logand (car (syntax-after (point))) + (lsh 1 18)))) + (not (zerop (logand (or (car (syntax-after (1+ (point)))) 0) + (lsh 1 19))))) + (and (evil-in-comment-p) + (not (evil-in-comment-p (+ (point) 2))) + (prog1 t (when move (forward-char 2))))) + ;; two char closer on second char + ((and (not (zerop (logand (car (syntax-after (point))) + (lsh 1 19)))) + (not (zerop (logand (or (car (syntax-after (1- (point)))) 0) + (lsh 1 18))))) + (and (evil-in-comment-p) + (not (evil-in-comment-p (1+ (point)))) + (prog1 t (when move (forward-char))))))) + +(defun evil-insert-newline-above () + "Inserts a new line above point and places point in that line +with regard to indentation." + (evil-narrow-to-field + (evil-move-beginning-of-line) + (insert (if use-hard-newlines hard-newline "\n")) + (forward-line -1) + (back-to-indentation))) + +(defun evil-insert-newline-below () + "Inserts a new line below point and places point in that line +with regard to indentation." + (evil-narrow-to-field + (evil-move-end-of-line) + (insert (if use-hard-newlines hard-newline "\n")) + (back-to-indentation))) + +;;; Markers + +(defun evil-global-marker-p (char) + "Whether CHAR denotes a global marker." + (or (and (>= char ?A) (<= char ?Z)) + (assq char (default-value 'evil-markers-alist)))) + +(defun evil-set-marker (char &optional pos advance) + "Set the marker denoted by CHAR to position POS. +POS defaults to the current position of point. +If ADVANCE is t, the marker advances when inserting text at it; +otherwise, it stays behind." + (interactive (list (read-char))) + (catch 'done + (let ((marker (evil-get-marker char t)) alist) + (unless (markerp marker) + (cond + ((and marker (symbolp marker) (boundp marker)) + (set marker (or (symbol-value marker) (make-marker))) + (setq marker (symbol-value marker))) + ((eq marker 'evil-jump-backward-swap) + (evil-set-jump) + (throw 'done nil)) + ((functionp marker) + (user-error "Cannot set special marker `%c'" char)) + ((evil-global-marker-p char) + (setq alist (default-value 'evil-markers-alist) + marker (make-marker)) + (evil--add-to-alist 'alist char marker) + (setq-default evil-markers-alist alist)) + (t + (setq marker (make-marker)) + (evil--add-to-alist 'evil-markers-alist char marker)))) + (add-hook 'kill-buffer-hook #'evil-swap-out-markers nil t) + (set-marker-insertion-type marker advance) + (set-marker marker (or pos (point)))))) + +(defun evil-get-marker (char &optional raw) + "Return the marker denoted by CHAR. +This is either a marker object as returned by `make-marker', +a number, a cons cell (FILE . POS) with FILE being a string +and POS a number, or nil. If RAW is non-nil, then the +return value may also be a variable, a movement function, +or a marker object pointing nowhere." + (let ((marker (if (evil-global-marker-p char) + (cdr-safe (assq char (default-value + 'evil-markers-alist))) + (cdr-safe (assq char evil-markers-alist))))) + (save-excursion + (if raw + marker + (when (and (symbolp marker) (boundp marker)) + (setq marker (symbol-value marker))) + (when (functionp marker) + (save-window-excursion + (funcall marker) + (setq marker (move-marker (make-marker) (point))))) + (when (markerp marker) + (if (eq (marker-buffer marker) (current-buffer)) + (setq marker (marker-position marker)) + (setq marker (and (marker-buffer marker) marker)))) + (when (or (numberp marker) + (markerp marker) + (and (consp marker) + (stringp (car marker)) + (numberp (cdr marker)))) + marker))))) + +(defun evil-swap-out-markers () + "Turn markers into file references when the buffer is killed." + (and buffer-file-name + (dolist (entry evil-markers-alist) + (and (markerp (cdr entry)) + (eq (marker-buffer (cdr entry)) (current-buffer)) + (setcdr entry (cons buffer-file-name + (marker-position (cdr entry)))))))) +(put 'evil-swap-out-markers 'permanent-local-hook t) + +(defun evil--eval-expr (input) + "Eval INPUT and return stringified result, if of a suitable type. +If INPUT starts with a number, +, -, or . use `calc-eval' instead." + (let* ((first-char (car (remove ?\s (string-to-list input)))) + (calcable-p (and first-char (or (<= ?0 first-char ?9) + (memq first-char '(?- ?+ ?.))))) + (result (if calcable-p + (let ((calc-multiplication-has-precedence nil)) + (calc-eval input)) + (eval (car (read-from-string input)))))) + (cond + (calcable-p result) + ((or (stringp result) + (numberp result) + (symbolp result)) + (format "%s" result)) + ((sequencep result) + (mapconcat (lambda (x) (format "%s" x)) result "\n")) + (t (user-error "Using %s as a string" (type-of result)))))) + +(defvar evil-paste-clear-minibuffer-first nil + "`evil-paste-before' cannot have `delete-minibuffer-contents' called before +it fetches certain registers becuase this would trigger various ex-updates, +sometimes moving point, so `C-a' `C-w' etc. would miss their intended target.") + +(defun evil-ex-remove-default () + "Remove the default text shown in the ex minibuffer. +When ex starts, the previous command is shown enclosed in +parenthesis. This function removes this text when the first key +is pressed." + (when (and (not (eq this-command 'exit-minibuffer)) + (/= (minibuffer-prompt-end) (point-max))) + (if (eq this-command 'evil-ex-delete-backward-char) + (setq this-command 'ignore)) + (if (eq this-original-command 'evil-paste-from-register) + (setq evil-paste-clear-minibuffer-first t) + (delete-minibuffer-contents))) + (remove-hook 'pre-command-hook #'evil-ex-remove-default)) +(put 'evil-ex-remove-default 'permanent-local-hook t) + +(defun evil-get-register (register &optional noerror) + "Return contents of REGISTER. +Signal an error if empty, unless NOERROR is non-nil. + +The following special registers are supported. + \" the unnamed register + * the clipboard contents + + the clipboard contents + <C-w> the word at point (ex mode only) + <C-a> the WORD at point (ex mode only) + <C-o> the symbol at point (ex mode only) + <C-f> the current file at point (ex mode only) + % the current file name (read only) + # the alternate file name (read only) + / the last search pattern (read only) + : the last command line (read only) + . the last inserted text (read only) + - the last small (less than a line) delete + _ the black hole register + = the expression register (read only)" + (condition-case err + (when (characterp register) + (or (cond + ((eq register ?\") + (current-kill 0)) + ((<= ?1 register ?9) + (let ((reg (- register ?1))) + (and (< reg (length kill-ring)) + (current-kill reg t)))) + ((memq register '(?* ?+)) + ;; the following code is modified from + ;; `x-selection-value-internal' + (let ((what (if (eq register ?*) 'PRIMARY 'CLIPBOARD)) + (request-type (or (and (boundp 'x-select-request-type) + x-select-request-type) + '(UTF8_STRING COMPOUND_TEXT STRING))) + text) + (unless (consp request-type) + (setq request-type (list request-type))) + (while (and request-type (not text)) + (condition-case nil + (setq text (evil-get-selection what (pop request-type))) + (error nil))) + (when text + (remove-text-properties 0 (length text) '(foreign-selection nil) text)) + text)) + ((eq register ?\C-W) + (unless (evil-ex-p) + (user-error "Register <C-w> only available in ex state")) + (with-current-buffer evil-ex-current-buffer + (thing-at-point 'evil-word))) + ((eq register ?\C-A) + (unless (evil-ex-p) + (user-error "Register <C-a> only available in ex state")) + (with-current-buffer evil-ex-current-buffer + (thing-at-point 'evil-WORD))) + ((eq register ?\C-O) + (unless (evil-ex-p) + (user-error "Register <C-o> only available in ex state")) + (with-current-buffer evil-ex-current-buffer + (thing-at-point 'evil-symbol))) + ((eq register ?\C-F) + (unless (evil-ex-p) + (user-error "Register <C-f> only available in ex state")) + (with-current-buffer evil-ex-current-buffer + (thing-at-point 'filename))) + ((eq register ?\C-L) + (unless (evil-ex-p) + (user-error "Register <C-l> only available in ex state")) + (with-current-buffer evil-ex-current-buffer + (replace-regexp-in-string "\n\\'" "" (thing-at-point 'line)))) + ((eq register ?%) + (or (buffer-file-name (and (evil-ex-p) + (minibufferp) + evil-ex-current-buffer)) + (user-error "No file name"))) + ((= register ?#) + (or (with-current-buffer (other-buffer) (buffer-file-name)) + (user-error "No file name"))) + ((eq register ?/) + (or (car-safe + (or (and (boundp 'evil-search-module) + (eq evil-search-module 'evil-search) + evil-ex-search-history) + (and isearch-regexp regexp-search-ring) + search-ring)) + (user-error "No previous regular expression"))) + ((eq register ?:) + (or (car-safe evil-ex-history) + (user-error "No previous command line"))) + ((eq register ?.) + evil-last-insertion) + ((eq register ?-) + evil-last-small-deletion) + ((eq register ?=) + (let ((enable-recursive-minibuffers t)) + (setq evil-last-=-register-input + (minibuffer-with-setup-hook + (lambda () (when evil-last-=-register-input + (add-hook 'pre-command-hook #'evil-ex-remove-default))) + (read-from-minibuffer + "=" + (and evil-last-=-register-input + (propertize evil-last-=-register-input 'face 'shadow)) + evil-eval-map + nil + 'evil-eval-history + evil-last-=-register-input + t))) + (evil--eval-expr evil-last-=-register-input))) + ((eq register ?_) ; the black hole register + "") + (t + (setq register (downcase register)) + (get-register register))) + (user-error "Register `%c' is empty" register))) + (error (unless noerror (signal (car err) (cdr err)))))) + +(defun evil-append-register (register text) + "Append TEXT to the contents of register REGISTER." + (let ((content (get-register register))) + (cond + ((not content) + (set-register register text)) + ((not (stringp content)) + ;; if the register does not contain a string treat it as a vector + (set-register register (vconcat content text))) + ((or (text-property-not-all 0 (length content) + 'yank-handler nil + content) + (text-property-not-all 0 (length text) + 'yank-handler nil + text)) + ;; some non-trivial yank-handler -> always switch to line handler + ;; ensure complete lines + (when (and (> (length content) 0) + (/= (aref content (1- (length content))) ?\n)) + (setq content (concat content "\n"))) + (when (and (> (length text) 0) + (/= (aref text (1- (length text))) ?\n)) + (setq text (concat text "\n"))) + (setq text (concat content text)) + (remove-list-of-text-properties 0 (length text) '(yank-handler) text) + (setq text (propertize text 'yank-handler '(evil-yank-line-handler))) + (set-register register text)) + (t + (set-register register (concat content text)))))) + +(defun evil-set-register (register text) + "Set the contents of register REGISTER to TEXT. +If REGISTER is an upcase character then text is appended to that +register instead of replacing its content." + (cond + ((not (characterp register)) + (user-error "Invalid register")) + ;; don't allow modification of read-only registers + ((member register '(?: ?. ?%)) + (user-error "Can't modify read-only register")) + ((eq register ?\") + (kill-new text)) + ((and (<= ?1 register) (<= register ?9)) + (if (null kill-ring) + (kill-new text) + (let ((kill-ring-yank-pointer kill-ring-yank-pointer) + interprogram-paste-function + interprogram-cut-function) + (current-kill (- register ?1)) + (setcar kill-ring-yank-pointer text)))) + ((eq register ?*) + (evil-set-selection 'PRIMARY text)) + ((eq register ?+) + (evil-set-selection 'CLIPBOARD text)) + ((eq register ?-) + (setq evil-last-small-deletion text)) + ((eq register ?_) ; the black hole register + nil) + ((and (<= ?A register) (<= register ?Z)) + (evil-append-register (downcase register) text)) + (t + (set-register register text)))) + +(defun evil-register-list () + "Returns an alist of all registers, but only those named +with number or character. Registers with symbol or string in names are ignored +to keep Vim compatibility with register jumps." + (sort (append (mapcar #'(lambda (reg) + (cons reg (evil-get-register reg t))) + '(?\" ?* ?+ ?% ?# ?/ ?: ?. ?- + ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) + (list (cons ?= evil-last-=-register-input)) + (cl-remove-if-not (lambda (reg) (number-or-marker-p (car reg))) register-alist) + nil) + #'(lambda (reg1 reg2) (< (car reg1) (car reg2))))) + +(defsubst evil-kbd-macro-suppress-motion-error () + "Returns non-nil if a motion error should be suppressed. +Whether the motion error should be suppressed depends on the +variable `evil-kbd-macro-suppress-motion-error'." + (or (and defining-kbd-macro + (memq evil-kbd-macro-suppress-motion-error '(t record))) + (and executing-kbd-macro + (memq evil-kbd-macro-suppress-motion-error '(t replay))))) + +;;; Region + +;; `set-mark' does too much at once +(defun evil-move-mark (pos) + "Set buffer's mark to POS. +If POS is nil, delete the mark." + (when pos + (setq pos (evil-normalize-position pos))) + (set-marker (mark-marker) pos)) + +(defun evil-save-transient-mark-mode () + "Save Transient Mark mode and make it buffer-local. +Any changes to Transient Mark mode are now local to the current +buffer, until `evil-restore-transient-mark-mode' is called. + +Variables pertaining to Transient Mark mode are listed in +`evil-transient-vars', and their values are stored in +`evil-transient-vals'." + (dolist (var evil-transient-vars) + (when (and (boundp var) + (not (assq var evil-transient-vals))) + (push (list var (symbol-value var) + (local-variable-p var)) + evil-transient-vals) + (make-variable-buffer-local var) + (put var 'permanent-local t)))) + +(defun evil-restore-transient-mark-mode () + "Restore Transient Mark mode. +This presupposes that `evil-save-transient-mark-mode' has been +called earlier. If Transient Mark mode was disabled before but +enabled in the meantime, this function disables it; if it was +enabled before but disabled in the meantime, this function +enables it. + +The earlier settings of Transient Mark mode are stored in +`evil-transient-vals'." + (let (entry local var val) + (while (setq entry (pop evil-transient-vals)) + (setq var (pop entry) + val (pop entry) + local (pop entry)) + (unless local + (kill-local-variable var)) + (unless (equal (symbol-value var) val) + (if (fboundp var) + (funcall var (if val 1 -1)) + (setq var val)))))) + +(defun evil-save-mark () + "Save the current mark, including whether it is transient. +See also `evil-restore-mark'." + (unless evil-visual-previous-mark + (setq evil-visual-previous-mark (mark t)) + (evil-save-transient-mark-mode))) + +(defun evil-restore-mark () + "Restore the mark, including whether it was transient. +See also `evil-save-mark'." + (when evil-visual-previous-mark + (evil-restore-transient-mark-mode) + (evil-move-mark evil-visual-previous-mark) + (setq evil-visual-previous-mark nil))) + +;; In theory, an active region implies Transient Mark mode, and +;; disabling Transient Mark mode implies deactivating the region. +;; In practice, Emacs never clears `mark-active' except in Transient +;; Mark mode, so we define our own toggle functions to make things +;; more predictable. +(defun evil-transient-mark (&optional arg) + "Toggle Transient Mark mode. +Ensure that the region is properly deactivated. +Enable with positive ARG, disable with negative ARG." + (unless (numberp arg) + (setq arg (if transient-mark-mode -1 1))) + (cond + ((< arg 1) + (evil-active-region -1) + ;; Transient Mark mode cannot be disabled + ;; while CUA mode is enabled + (when (fboundp 'cua-mode) + (cua-mode -1)) + (when transient-mark-mode + (transient-mark-mode -1))) + (t + (unless transient-mark-mode + (evil-active-region -1) + (transient-mark-mode 1))))) + +(defun evil-active-region (&optional arg) + "Toggle active region. +Ensure that Transient Mark mode is properly enabled. +Enable with positive ARG, disable with negative ARG." + (unless (numberp arg) + (setq arg (if (region-active-p) -1 1))) + (cond + ((and (< arg 1)) + (when (or transient-mark-mode mark-active) + (setq mark-active nil + deactivate-mark nil) + (when (boundp 'cua--explicit-region-start) + (setq cua--explicit-region-start nil)) + (run-hooks 'deactivate-mark-hook))) + (t + (evil-transient-mark 1) + (when deactivate-mark + (setq deactivate-mark nil)) + (unless (mark t) + (evil-move-mark (point))) + (unless (region-active-p) + (set-mark (mark t))) + (when (boundp 'cua--explicit-region-start) + (setq cua--explicit-region-start t))))) + +(defmacro evil-with-transient-mark-mode (&rest body) + "Execute BODY with Transient Mark mode. +Then restore Transient Mark mode to its previous setting." + (declare (indent defun) + (debug t)) + `(let ((inhibit-quit t) + evil-transient-vals) + (unwind-protect + (progn + (evil-save-transient-mark-mode) + (evil-transient-mark 1) + ,@body) + (evil-restore-transient-mark-mode)))) + +(defmacro evil-with-active-region (beg end &rest body) + "Execute BODY with an active region from BEG to END." + (declare (indent 2) + (debug t)) + `(let ((beg ,beg) (end ,end) + evil-transient-vals) + (evil-with-transient-mark-mode + (save-excursion + (evil-active-region 1) + (evil-move-mark beg) + (goto-char end) + ,@body)))) + +(defun evil-exchange-point-and-mark () + "Exchange point and mark without activating the region." + (let* ((point (point)) + (mark (or (mark t) point))) + (set-marker (mark-marker) point) + (goto-char mark))) + +(defun evil-apply-on-block (func beg end pass-columns &rest args) + "Call FUNC for each line of a block selection. +The selection is specified by the region BEG and END. FUNC must +take at least two arguments, the beginning and end of each +line. If PASS-COLUMNS is non-nil, these values are the columns, +otherwise they are buffer positions. Extra arguments to FUNC may +be passed via ARGS." + (let ((eol-col (and (memq last-command '(next-line previous-line)) + (numberp temporary-goal-column) + temporary-goal-column)) + startcol startpt endcol endpt) + (save-excursion + (goto-char beg) + (setq startcol (current-column)) + (beginning-of-line) + (setq startpt (point)) + (goto-char end) + (setq endcol (current-column)) + (forward-line 1) + (setq endpt (point-marker)) + ;; ensure the start column is the left one. + (evil-sort startcol endcol) + ;; maybe find maximal column + (when eol-col + (setq eol-col 0) + (goto-char startpt) + (while (< (point) endpt) + (setq eol-col (max eol-col + (evil-column (line-end-position)))) + (forward-line 1)) + (setq endcol (max endcol + (min eol-col + (1+ (min (1- most-positive-fixnum) + (truncate temporary-goal-column))))))) + ;; start looping over lines + (goto-char startpt) + (while (< (point) endpt) + (if pass-columns + (apply func startcol endcol args) + (apply func + (save-excursion (evil-move-to-column startcol)) + (save-excursion (evil-move-to-column endcol t)) + args)) + (forward-line 1))))) + +(defun evil-apply-on-rectangle (function start end &rest args) + "Like `apply-on-rectangle' but maybe extends to eol. +If `temporary-goal-column' is set to a big number, then the +region of each line is extended to the end of each line. The end +column is set to the maximal column in all covered lines." + (apply #'evil-apply-on-block function start end t args)) + +;;; Insertion + +(defun evil-concat-ranges (ranges) + "Concatenate RANGES. +RANGES must be a list of ranges. They must be ordered so that +successive ranges share their boundaries. The return value is a +single range of disjoint union of the ranges or nil if the +disjoint union is not a single range." + (let ((range (car-safe ranges)) (ranges (cdr ranges)) r) + (while (and range (setq r (car-safe ranges))) + (setq range + (cond ((and (= (cdr r) (car range))) (cons (car r) (cdr range))) + ((and (= (cdr range) (car r))) (cons (car range) (cdr r))))) + (setq ranges (cdr ranges))) + range)) + +(defun evil-track-last-insertion (beg end len) + "Track the last insertion range and its text. +The insertion range is stored as a pair of buffer positions in +`evil-current-insertion'. If a subsequent change is compatible, +then the current range is modified, otherwise it is replaced by a +new range. Compatible changes are changes that do not create a +disjoin range." + ;; deletion + (when (> len 0) + (if (and evil-current-insertion + (>= beg (car evil-current-insertion)) + (<= (+ beg len) (cdr evil-current-insertion))) + (setcdr evil-current-insertion + (- (cdr evil-current-insertion) len)) + (setq evil-current-insertion nil))) + ;; insertion + (if (and evil-current-insertion + (>= beg (car evil-current-insertion)) + (<= beg (cdr evil-current-insertion))) + (setcdr evil-current-insertion + (+ (- end beg) + (cdr evil-current-insertion))) + (setq evil-current-insertion (cons beg end)))) +(put 'evil-track-last-insertion 'permanent-local-hook t) + +(defun evil-start-track-last-insertion () + "Start tracking the last insertion." + (setq evil-current-insertion nil) + (add-hook 'after-change-functions #'evil-track-last-insertion nil t)) + +(defun evil-stop-track-last-insertion () + "Stop tracking the last insertion. +The tracked insertion is set to `evil-last-insertion'." + (setq evil-last-insertion + (and evil-current-insertion + ;; Check whether the insertion range is a valid buffer + ;; range. If a buffer modification is done from within + ;; another change hook or modification-hook (yasnippet + ;; does this using overlay modification-hooks), then the + ;; insertion information may be invalid. There is no way + ;; to detect this situation, but at least we should + ;; ensure that no error occurs (see bug #272). + (>= (car evil-current-insertion) (point-min)) + (<= (cdr evil-current-insertion) (point-max)) + (buffer-substring-no-properties (car evil-current-insertion) + (cdr evil-current-insertion)))) + (remove-hook 'after-change-functions #'evil-track-last-insertion t)) + +;;; Paste + +(defun evil-yank-characters (beg end &optional register yank-handler) + "Saves the characters defined by the region BEG and END in the kill-ring." + (let ((text (filter-buffer-substring beg end))) + (when yank-handler + (setq text (propertize text 'yank-handler (list yank-handler)))) + (when register + (evil-set-register register text)) + (when evil-was-yanked-without-register + (evil-set-register ?0 text)) ; "0 register contains last yanked text + (unless (eq register ?_) + (kill-new text)))) + +(defun evil-yank-lines (beg end &optional register yank-handler) + "Saves the lines in the region BEG and END into the kill-ring." + (let* ((text (filter-buffer-substring beg end)) + (yank-handler (list (or yank-handler + #'evil-yank-line-handler) + nil + t))) + ;; Ensure the text ends with a newline. This is required + ;; if the deleted lines were the last lines in the buffer. + (when (or (zerop (length text)) + (/= (aref text (1- (length text))) ?\n)) + (setq text (concat text "\n"))) + (setq text (propertize text 'yank-handler yank-handler)) + (when register + (evil-set-register register text)) + (when evil-was-yanked-without-register + (evil-set-register ?0 text)) ; "0 register contains last yanked text + (unless (eq register ?_) + (kill-new text)))) + +(defun evil-yank-rectangle (beg end &optional register yank-handler) + "Saves the rectangle defined by region BEG and END into the kill-ring." + (let ((lines (list nil))) + (evil-apply-on-rectangle #'extract-rectangle-line beg end lines) + ;; We remove spaces from the beginning and the end of the next. + ;; Spaces are inserted explicitly in the yank-handler in order to + ;; NOT insert lines full of spaces. + (setq lines (nreverse (cdr lines))) + ;; `text' is used as default insert text when pasting this rectangle + ;; in another program, e.g., using the X clipboard. + (let* ((yank-handler (list (or yank-handler + #'evil-yank-block-handler) + lines + t + 'evil-delete-yanked-rectangle)) + (text (propertize (mapconcat #'identity lines "\n") + 'yank-handler yank-handler))) + (when register + (evil-set-register register text)) + (when evil-was-yanked-without-register + (evil-set-register ?0 text)) ; "0 register contains last yanked text + (unless (eq register ?_) + (kill-new text)) + text))) + +(defun evil-remove-yank-excluded-properties (text) + "Removes `yank-excluded-properties' from TEXT." + (if (eq yank-excluded-properties t) + (set-text-properties 0 (length text) nil text) + (remove-list-of-text-properties 0 (length text) + yank-excluded-properties text))) + +(defun evil-yank-line-handler (text) + "Inserts the current text linewise." + (let ((text (apply #'concat (make-list (or evil-paste-count 1) text))) + (opoint (point))) + (evil-remove-yank-excluded-properties text) + (cond + ((eq this-command 'evil-paste-before) + (evil-move-beginning-of-line) + (evil-move-mark (point)) + (insert text) + (setq evil-last-paste + (list 'evil-paste-before + evil-paste-count + opoint + (mark t) + (point))) + (evil-set-marker ?\[ (mark)) + (evil-set-marker ?\] (1- (point))) + (evil-exchange-point-and-mark) + (back-to-indentation)) + ((eq this-command 'evil-paste-after) + (evil-move-end-of-line) + (evil-move-mark (point)) + (insert "\n") + (insert text) + (evil-set-marker ?\[ (1+ (mark))) + (evil-set-marker ?\] (1- (point))) + (delete-char -1) ; delete the last newline + (setq evil-last-paste + (list 'evil-paste-after + evil-paste-count + opoint + (mark t) + (point))) + (evil-move-mark (1+ (mark t))) + (evil-exchange-point-and-mark) + (back-to-indentation)) + (t + (insert text))))) + +(defun evil-yank-block-handler (lines) + "Inserts the current text as block." + (let ((count (or evil-paste-count 1)) + (col (if (eq this-command 'evil-paste-after) + (1+ (current-column)) + (current-column))) + (current-line (line-number-at-pos (point))) + (opoint (point)) + epoint) + (dolist (line lines) + ;; concat multiple copies according to count + (setq line (apply #'concat (make-list count line))) + ;; strip whitespaces at beginning and end + (string-match "^ *\\(.*?\\) *$" line) + (let ((text (match-string 1 line)) + (begextra (match-beginning 1)) + (endextra (- (match-end 0) (match-end 1)))) + ;; maybe we have to insert a new line at eob + (while (< (line-number-at-pos (point)) + current-line) + (goto-char (point-max)) + (insert "\n")) + (setq current-line (1+ current-line)) + ;; insert text unless we insert an empty line behind eol + (unless (and (< (evil-column (line-end-position)) col) + (zerop (length text))) + ;; if we paste behind eol, it may be sufficient to insert tabs + (if (< (evil-column (line-end-position)) col) + (move-to-column (+ col begextra) t) + (move-to-column col t) + (insert (make-string begextra ?\s))) + (evil-remove-yank-excluded-properties text) + (insert text) + (unless (eolp) + ;; text follows, so we have to insert spaces + (insert (make-string endextra ?\s))) + (setq epoint (point))) + (forward-line 1))) + (setq evil-last-paste + (list this-command + evil-paste-count + opoint + (length lines) ; number of rows + (* count (length (car lines))))) ; number of colums + (evil-set-marker ?\[ opoint) + (evil-set-marker ?\] (1- epoint)) + (goto-char opoint) + (when (and (eq this-command 'evil-paste-after) + (not (eolp))) + (forward-char)))) + +(defun evil-delete-yanked-rectangle (nrows ncols) + "Special function to delete the block yanked by a previous paste command. +Supplied as the `undo' element of a yank handler." + (let ((opoint (point)) + (col (if (eq last-command 'evil-paste-after) + (1+ (current-column)) + (current-column)))) + (dotimes (_ nrows) + (delete-region (save-excursion + (move-to-column col) + (point)) + (save-excursion + (move-to-column (+ col ncols)) + (point))) + (unless (eobp) (forward-line))) + (goto-char opoint))) + +;; TODO: if undoing is disabled in the current buffer, paste-pop won't +;; work. Although this is probably not a big problem, because usually +;; buffers where `evil-paste-pop' may be useful have undoing enabled. +;; A solution would be to temporarily enable undo when pasting and +;; store the undo information in a special variable that does not +;; interfere with `buffer-undo-list'. +(defun evil-paste-pop (count) + "Replace the just-yanked stretch of killed text with a different stretch. +This command is allowed only immediatly after a `yank', +`evil-paste-before', `evil-paste-after' or `evil-paste-pop'. +This command uses the same paste command as before, i.e., when +used after `evil-paste-after' the new text is also yanked using +`evil-paste-after', used with the same paste-count argument. + +The COUNT argument inserts the COUNTth previous kill. If COUNT +is negative this is a more recent kill." + (interactive "p") + (unless (memq last-command + '(evil-paste-after + evil-paste-before + evil-visual-paste)) + (user-error "Previous command was not an evil-paste: %s" last-command)) + (unless evil-last-paste + (user-error "Previous paste command used a register")) + (evil-undo-pop) + (when (eq last-command 'evil-visual-paste) + (evil-swap evil-visual-previous-mark evil-visual-mark) + (evil-swap evil-visual-previous-point evil-visual-point)) + (goto-char (nth 2 evil-last-paste)) + (setq this-command (nth 0 evil-last-paste)) + ;; use temporary kill-ring, so the paste cannot modify it + (let ((kill-ring (list (current-kill + (if (and (> count 0) (nth 5 evil-last-paste)) + ;; if was visual paste then skip the + ;; text that has been replaced + (1+ count) + count)))) + (kill-ring-yank-pointer kill-ring)) + (when (eq last-command 'evil-visual-paste) + (let ((evil-no-display t)) + (evil-visual-restore))) + (funcall (nth 0 evil-last-paste) (nth 1 evil-last-paste)) + ;; if this was a visual paste, then mark the last paste as NOT + ;; being the first visual paste + (when (eq last-command 'evil-visual-paste) + (setcdr (nthcdr 4 evil-last-paste) nil)))) + +(defun evil-paste-pop-next (count) + "Same as `evil-paste-pop' but with negative argument." + (interactive "p") + (evil-paste-pop (- count))) + +;;; Interactive forms + +(defun evil-match-interactive-code (interactive &optional pos) + "Match an interactive code at position POS in string INTERACTIVE. +Returns the first matching entry in `evil-interactive-alist', or nil." + (let ((length (length interactive)) + (pos (or pos 0))) + (catch 'done + (dolist (entry evil-interactive-alist) + (let* ((string (car entry)) + (end (+ (length string) pos))) + (when (and (<= end length) + (string= string + (substring interactive pos end))) + (throw 'done entry))))))) + +(defun evil-concatenate-interactive-forms (&rest forms) + "Concatenate interactive list expressions FORMS. +Returns a single expression where successive expressions +are joined, if possible." + (let (result) + (when forms + (while (cdr forms) + (cond + ((null (car forms)) + (pop forms)) + ((and (eq (car (car forms)) 'list) + (eq (car (cadr forms)) 'list)) + (setq forms (cons (append (car forms) + (cdr (cadr forms))) + (cdr (cdr forms))))) + (t + (push (pop forms) result)))) + (when (car forms) + (push (pop forms) result)) + (setq result (nreverse result)) + (cond + ((null result)) + ((null (cdr result)) + (car result)) + (t + `(append ,@result)))))) + +(defun evil-interactive-string (string) + "Evaluate the interactive string STRING. +The string may contain extended interactive syntax. +The return value is a cons cell (FORM . PROPERTIES), +where FORM is a single list-expression to be passed to +a standard `interactive' statement, and PROPERTIES is a +list of command properties as passed to `evil-define-command'." + (let ((length (length string)) + (pos 0) + code expr forms match plist prompt properties) + (while (< pos length) + (if (eq (aref string pos) ?\n) + (setq pos (1+ pos)) + (setq match (evil-match-interactive-code string pos)) + (if (null match) + (user-error "Unknown interactive code: `%s'" + (substring string pos)) + (setq code (car match) + expr (car (cdr match)) + plist (cdr (cdr match)) + pos (+ pos (length code))) + (when (functionp expr) + (setq prompt + (substring string pos + (or (string-match "\n" string pos) + length)) + pos (+ pos (length prompt)) + expr `(funcall ,expr ,prompt))) + (setq forms (append forms (list expr)) + properties (append properties plist))))) + (cons `(append ,@forms) properties))) + +(defun evil-interactive-form (&rest args) + "Evaluate interactive forms ARGS. +The return value is a cons cell (FORM . PROPERTIES), +where FORM is a single list-expression to be passed to +a standard `interactive' statement, and PROPERTIES is a +list of command properties as passed to `evil-define-command'." + (let (forms properties) + (dolist (arg args) + (if (not (stringp arg)) + (setq forms (append forms (list arg))) + (setq arg (evil-interactive-string arg) + forms (append forms (cdr (car arg))) + properties (append properties (cdr arg))))) + (cons (apply #'evil-concatenate-interactive-forms forms) + properties))) + +;;; Types + +(defun evil-type (object &optional default) + "Return the type of OBJECT, or DEFAULT if none." + (let (type) + (cond + ((overlayp object) + (setq type (overlay-get object :type))) + ((evil-range-p object) + (setq type (nth 2 object))) + ((listp object) + (setq type (plist-get object :type))) + ((commandp object) + (setq type (evil-get-command-property object :type))) + ((symbolp object) + (setq type (get object 'type)))) + (setq type (or type default)) + (and (evil-type-p type) type))) + +(defun evil-set-type (object type) + "Set the type of OBJECT to TYPE. +For example, (evil-set-type 'next-line 'line) +will make `line' the type of the `next-line' command." + (cond + ((overlayp object) + (overlay-put object :type type)) + ((evil-range-p object) + (evil-set-range-type object type)) + ((listp object) + (plist-put object :type type)) + ((commandp object) + (evil-set-command-property object :type type)) + ((symbolp object) + (put object 'type type))) + object) + +(defun evil-type-property (type prop) + "Return property PROP for TYPE." + (evil-get-property evil-type-properties type prop)) + +(defun evil-type-p (sym) + "Whether SYM is the name of a type." + (assq sym evil-type-properties)) + +(defun evil-expand (beg end type &rest properties) + "Expand BEG and END as TYPE with PROPERTIES. +Returns a list (BEG END TYPE PROPERTIES ...), where the tail +may contain a property list." + (apply #'evil-transform + ;; don't expand if already expanded + (unless (plist-get properties :expanded) :expand) + beg end type properties)) + +(defun evil-contract (beg end type &rest properties) + "Contract BEG and END as TYPE with PROPERTIES. +Returns a list (BEG END TYPE PROPERTIES ...), where the tail +may contain a property list." + (apply #'evil-transform :contract beg end type properties)) + +(defun evil-normalize (beg end type &rest properties) + "Normalize BEG and END as TYPE with PROPERTIES. +Returns a list (BEG END TYPE PROPERTIES ...), where the tail +may contain a property list." + (apply #'evil-transform :normalize beg end type properties)) + +(defun evil-transform (transform beg end type &rest properties) + "Apply TRANSFORM on BEG and END with PROPERTIES. +Returns a list (BEG END TYPE PROPERTIES ...), where the tail +may contain a property list. If TRANSFORM is undefined, +return positions unchanged." + (let* ((type (or type (evil-type properties))) + (transform (when (and type transform) + (evil-type-property type transform)))) + (if transform + (apply transform beg end properties) + (apply #'evil-range beg end type properties)))) + +(defun evil-describe (beg end type &rest properties) + "Return description of BEG and END with PROPERTIES. +If no description is available, return the empty string." + (let* ((type (or type (evil-type properties))) + (properties (plist-put properties :type type)) + (describe (evil-type-property type :string))) + (or (when describe + (apply describe beg end properties)) + ""))) + +;;; Ranges + +(defun evil-range (beg end &optional type &rest properties) + "Return a list (BEG END [TYPE] PROPERTIES...). +BEG and END are buffer positions (numbers or markers), +TYPE is a type as per `evil-type-p', and PROPERTIES is +a property list." + (let ((beg (evil-normalize-position beg)) + (end (evil-normalize-position end))) + (when (and (numberp beg) (numberp end)) + (append (list (min beg end) (max beg end)) + (when (evil-type-p type) + (list type)) + properties)))) + +(defun evil-range-p (object) + "Whether OBJECT is a range." + (and (listp object) + (>= (length object) 2) + (numberp (nth 0 object)) + (numberp (nth 1 object)))) + +(defun evil-range-beginning (range) + "Return beginning of RANGE." + (when (evil-range-p range) + (let ((beg (evil-normalize-position (nth 0 range))) + (end (evil-normalize-position (nth 1 range)))) + (min beg end)))) + +(defun evil-range-end (range) + "Return end of RANGE." + (when (evil-range-p range) + (let ((beg (evil-normalize-position (nth 0 range))) + (end (evil-normalize-position (nth 1 range)))) + (max beg end)))) + +(defun evil-range-properties (range) + "Return properties of RANGE." + (when (evil-range-p range) + (if (evil-type range) + (nthcdr 3 range) + (nthcdr 2 range)))) + +(defun evil-copy-range (range) + "Return a copy of RANGE." + (copy-sequence range)) + +(defun evil-set-range (range &optional beg end type &rest properties) + "Set RANGE to have beginning BEG and end END. +The TYPE and additional PROPERTIES may also be specified. +If an argument is nil, it's not used; the previous value is retained. +See also `evil-set-range-beginning', `evil-set-range-end', +`evil-set-range-type' and `evil-set-range-properties'." + (when (evil-range-p range) + (let ((beg (or (evil-normalize-position beg) + (evil-range-beginning range))) + (end (or (evil-normalize-position end) + (evil-range-end range))) + (type (or type (evil-type range))) + (plist (evil-range-properties range))) + (evil-sort beg end) + (setq plist (evil-concat-plists plist properties)) + (evil-set-range-beginning range beg) + (evil-set-range-end range end) + (evil-set-range-type range type) + (evil-set-range-properties range plist) + range))) + +(defun evil-set-range-beginning (range beg &optional copy) + "Set RANGE's beginning to BEG. +If COPY is non-nil, return a copy of RANGE." + (when copy + (setq range (evil-copy-range range))) + (setcar range beg) + range) + +(defun evil-set-range-end (range end &optional copy) + "Set RANGE's end to END. +If COPY is non-nil, return a copy of RANGE." + (when copy + (setq range (evil-copy-range range))) + (setcar (cdr range) end) + range) + +(defun evil-set-range-type (range type &optional copy) + "Set RANGE's type to TYPE. +If COPY is non-nil, return a copy of RANGE." + (when copy + (setq range (evil-copy-range range))) + (if type + (setcdr (cdr range) + (cons type (evil-range-properties range))) + (setcdr (cdr range) (evil-range-properties range))) + range) + +(defun evil-set-range-properties (range properties &optional copy) + "Set RANGE's properties to PROPERTIES. +If COPY is non-nil, return a copy of RANGE." + (when copy + (setq range (evil-copy-range range))) + (if (evil-type range) + (setcdr (cdr (cdr range)) properties) + (setcdr (cdr range) properties)) + range) + +(defun evil-range-union (range1 range2 &optional type) + "Return the union of the ranges RANGE1 and RANGE2. +If the ranges have conflicting types, use RANGE1's type. +This can be overridden with TYPE." + (when (and (evil-range-p range1) + (evil-range-p range2)) + (evil-range (min (evil-range-beginning range1) + (evil-range-beginning range2)) + (max (evil-range-end range1) + (evil-range-end range2)) + (or type + (evil-type range1) + (evil-type range2))))) + +(defun evil-subrange-p (range1 range2) + "Whether RANGE1 is contained within RANGE2." + (and (evil-range-p range1) + (evil-range-p range2) + (<= (evil-range-beginning range2) + (evil-range-beginning range1)) + (>= (evil-range-end range2) + (evil-range-end range1)))) + +(defun evil-select-inner-unrestricted-object (thing beg end type &optional count line) + "Return an inner text object range of COUNT objects. +If COUNT is positive, return objects following point; if COUNT is +negative, return objects preceding point. If one is unspecified, +the other is used with a negative argument. THING is a symbol +understood by `thing-at-point'. BEG, END and TYPE specify the +current selection. If LINE is non-nil, the text object should be +linewise, otherwise it is character wise." + (let* ((count (or count 1)) + (bnd (or (let ((b (bounds-of-thing-at-point thing))) + (and b (< (point) (cdr b)) b)) + (evil-bounds-of-not-thing-at-point thing)))) + ;; check if current object is selected + (when (or (not beg) (not end) + (> beg (car bnd)) + (< end (cdr bnd)) + (and (eq type 'inclusive) + (= (1+ beg) end))) ; empty region does not count + (when (or (not beg) (< (car bnd) beg)) (setq beg (car bnd))) + (when (or (not end) (> (cdr bnd) end)) (setq end (cdr bnd))) + (setq count (if (> count 0) (1- count) (1+ count)))) + (goto-char (if (< count 0) beg end)) + (evil-forward-nearest count + #'(lambda (cnt) (forward-thing thing cnt)) + #'(lambda (cnt) (evil-forward-not-thing thing cnt))) + (evil-range (if (>= count 0) beg (point)) + (if (< count 0) end (point)) + (if line 'line type) + :expanded t))) + +(defun evil-select-inner-object (thing beg end type &optional count line) + "Return an inner text object range of COUNT objects. +Selection is restricted to the current line. +If COUNT is positive, return objects following point; if COUNT is +negative, return objects preceding point. If one is unspecified, +the other is used with a negative argument. THING is a symbol +understood by `thing-at-point'. BEG, END and TYPE specify the +current selection. If LINE is non-nil, the text object should be +linewise, otherwise it is character wise." + (save-restriction + (narrow-to-region (save-excursion (beginning-of-line) (point)) + (save-excursion (end-of-line) (point))) + (evil-select-inner-unrestricted-object thing beg end type count line))) + +(defun evil-select-an-unrestricted-object (thing beg end type count &optional line) + "Return an outer text object range of COUNT objects. +If COUNT is positive, return objects following point; if COUNT is +negative, return objects preceding point. If one is unspecified, +the other is used with a negative argument. THING is a symbol +understood by thing-at-point. BEG, END and TYPE specify the +current selection. If LINE is non-nil, the text object should be +linewise, otherwise it is character wise." + (let* ((dir (if (> (or count 1) 0) +1 -1)) + (count (abs (or count 1))) + (objbnd (let ((b (bounds-of-thing-at-point thing))) + (and b (< (point) (cdr b)) b))) + (bnd (or objbnd (evil-bounds-of-not-thing-at-point thing))) + addcurrent other) + ;; check if current object is not selected + (when (or (not beg) (not end) + (> beg (car bnd)) + (< end (cdr bnd)) + (and (eq type 'inclusive) + (= (1+ beg) end))) ; empty region does not count + ;; if not, enlarge selection + (when (or (not beg) (< (car bnd) beg)) (setq beg (car bnd))) + (when (or (not end) (> (cdr bnd) end)) (setq end (cdr bnd))) + (if objbnd (setq addcurrent t))) + ;; make other and (point) reflect the selection + (cond + ((> dir 0) (goto-char end) (setq other beg)) + (t (goto-char beg) (setq other end))) + (cond + ;; do nothing more than only current is selected + ((not (and (= beg (car bnd)) (= end (cdr bnd))))) + ;; current match is thing, add whitespace + (objbnd + (let ((wsend (evil-with-restriction + ;; restrict to current line if we do non-line selection + (and (not line) (line-beginning-position)) + (and (not line) (line-end-position)) + (evil-bounds-of-not-thing-at-point thing dir)))) + (cond + (wsend + ;; add whitespace at end + (goto-char wsend) + (setq addcurrent t)) + (t + ;; no whitespace at end, try beginning + (save-excursion + (goto-char other) + (setq wsend + (evil-with-restriction + ;; restrict to current line if we do non-line selection + (and (not line) (line-beginning-position)) + (and (not line) (line-end-position)) + (evil-bounds-of-not-thing-at-point thing (- dir)))) + (when wsend (setq other wsend addcurrent t))))))) + ;; current match is whitespace, add thing + (t + (forward-thing thing dir) + (setq addcurrent t))) + ;; possibly count current object as selection + (if addcurrent (setq count (1- count))) + ;; move + (dotimes (_ count) + (let ((wsend (evil-bounds-of-not-thing-at-point thing dir))) + (if (and wsend (/= wsend (point))) + ;; start with whitespace + (forward-thing thing dir) + ;; start with thing + (forward-thing thing dir) + (setq wsend (evil-bounds-of-not-thing-at-point thing dir)) + (when wsend (goto-char wsend))))) + ;; return range + (evil-range (if (> dir 0) other (point)) + (if (< dir 0) other (point)) + (if line 'line type) + :expanded t))) + +(defun evil-select-an-object (thing beg end type &optional count line) + "Return an outer text object range of COUNT objects. +Selection is restricted to the current line. +If COUNT is positive, return objects following point; if COUNT is +negative, return objects preceding point. If one is unspecified, +the other is used with a negative argument. THING is a symbol +understood by thing-at-point. BEG, END and TYPE specify the +current selection. If LINE is non-nil, the text object should be +linewise, otherwise it is character wise." + (save-restriction + (narrow-to-region (save-excursion (beginning-of-line) (point)) + (save-excursion (end-of-line) (point))) + (evil-select-an-unrestricted-object thing beg end type count line))) + +(defun evil--get-block-range (op cl selection-type) + "Return the exclusive range of a visual selection. +OP and CL are pairs of buffer positions for the opening and +closing delimiter of a range. SELECTION-TYPE is the desired type +of selection. It is a symbol that determines which parts of the +block are selected. If it is 'inclusive or t the returned range +is \(cons (car OP) (cdr CL)). If it is 'exclusive or nil the +returned range is (cons (cdr OP) (car CL)). If it is +'exclusive-line the returned range will skip whitespace at the +end of the line of OP and at the beginning of the line of CL." + (cond + ((memq selection-type '(inclusive t)) (cons (car op) (cdr cl))) + ((memq selection-type '(exclusive nil)) (cons (cdr op) (car cl))) + ((eq selection-type 'exclusive-line) + (let ((beg (cdr op)) + (end (car cl))) + (save-excursion + (goto-char beg) + (when (and (eolp) (not (eobp))) + (setq beg (line-beginning-position 2))) + (goto-char end) + (skip-chars-backward " \t") + (when (bolp) + (setq end (point)) + (goto-char beg) + (when (and (not (bolp)) (< beg end)) + (setq end (1- end))))) + (cons beg end))) + (t + (user-error "Unknown selection-type %s" selection-type)))) + +(defun evil-select-block (thing beg end type count + &optional + selection-type + countcurrent + fixedscan) + "Return a range (BEG END) of COUNT delimited text objects. +BEG END TYPE are the currently selected (visual) range. The +delimited object must be given by THING-up function (see +`evil-up-block'). + +SELECTION-TYPE is symbol that determines which parts of the block +are selected. If it is 'inclusive or t OPEN and CLOSE are +included in the range. If it is 'exclusive or nil the delimiters +are not contained. If it is 'exclusive-line the delimiters are +not included as well as adjacent whitespace until the beginning +of the next line or the end of the previous line. If the +resulting selection consists of complete lines only and visual +state is not active, the returned selection is linewise. + +If COUNTCURRENT is non-nil an objected is counted if the current +selection matches that object exactly. + +Usually scanning for the surrounding block starts at (1+ beg) +and (1- end). If this might fail due to the behavior of THING +then FIXEDSCAN can be set to t. In this case the scan starts at +BEG and END. One example where this might fail is if BEG and END +are the delimiters of a string or comment." + (save-excursion + (save-match-data + (let* ((orig-beg beg) + (orig-end end) + (beg (or beg (point))) + (end (or end (point))) + (count (abs (or count 1))) + op cl op-end cl-end) + ;; We always assume at least one selected character. + (if (= beg end) (setq end (1+ end))) + ;; We scan twice: starting at (1+ beg) forward and at (1- end) + ;; backward. The resulting selection is the smaller one. + (goto-char (if fixedscan beg (1+ beg))) + (when (and (zerop (funcall thing +1)) (match-beginning 0)) + (setq cl (cons (match-beginning 0) (match-end 0))) + (goto-char (car cl)) + (when (and (zerop (funcall thing -1)) (match-beginning 0)) + (setq op (cons (match-beginning 0) (match-end 0))))) + ;; start scanning from end + (goto-char (if fixedscan end (1- end))) + (when (and (zerop (funcall thing -1)) (match-beginning 0)) + (setq op-end (cons (match-beginning 0) (match-end 0))) + (goto-char (cdr op-end)) + (when (and (zerop (funcall thing +1)) (match-beginning 0)) + (setq cl-end (cons (match-beginning 0) (match-end 0))))) + ;; Bug #607: use the tightest selection that contains the + ;; original selection. If non selection contains the original, + ;; use the larger one. + (cond + ((and (not op) (not cl-end)) + (error "No surrounding delimiters found")) + ((or (not op) ; first not found + (and cl-end ; second found + (>= (car op-end) (car op)) ; second smaller + (<= (cdr cl-end) (cdr cl)) + (<= (car op-end) beg) ; second contains orig + (>= (cdr cl-end) end))) + (setq op op-end cl cl-end))) + (setq op-end op cl-end cl) ; store copy + ;; if the current selection contains the surrounding + ;; delimiters, they do not count as new selection + (let ((cnt (if (and orig-beg orig-end (not countcurrent)) + (let ((sel (evil--get-block-range op cl selection-type))) + (if (and (<= orig-beg (car sel)) + (>= orig-end (cdr sel))) + count + (1- count))) + (1- count)))) + ;; starting from the innermost surrounding delimiters + ;; increase selection + (when (> cnt 0) + (setq op (progn + (goto-char (car op-end)) + (funcall thing (- cnt)) + (if (match-beginning 0) + (cons (match-beginning 0) (match-end 0)) + op)) + cl (progn + (goto-char (cdr cl-end)) + (funcall thing cnt) + (if (match-beginning 0) + (cons (match-beginning 0) (match-end 0)) + cl))))) + (let ((sel (evil--get-block-range op cl selection-type))) + (setq op (car sel) + cl (cdr sel))) + (cond + ((and (equal op orig-beg) (equal cl orig-end) + (or (not countcurrent) + (and countcurrent (/= count 1)))) + (error "No surrounding delimiters found")) + ((save-excursion + (and (not (evil-visual-state-p)) + (eq type 'inclusive) + (progn (goto-char op) (bolp)) + (progn (goto-char cl) (bolp)))) + (evil-range op cl 'line :expanded t)) + (t + (evil-range op cl type :expanded t))))))) + +(defun evil-select-paren (open close beg end type count &optional inclusive) + "Return a range (BEG END) of COUNT delimited text objects. +OPEN and CLOSE specify the opening and closing delimiter, +respectively. BEG END TYPE are the currently selected (visual) +range. If INCLUSIVE is non-nil, OPEN and CLOSE are included in +the range; otherwise they are excluded. + +The types of OPEN and CLOSE specify which kind of THING is used +for parsing with `evil-select-block'. If OPEN and CLOSE are +characters `evil-up-paren' is used. Otherwise OPEN and CLOSE +must be regular expressions and `evil-up-block' is used. + +If the selection is exclusive, whitespace at the end or at the +beginning of the selection until the end-of-line or beginning-of-line +is ignored." + ;; we need special linewise exclusive selection + (unless inclusive (setq inclusive 'exclusive-line)) + (cond + ((and (characterp open) (characterp close)) + (let ((thing #'(lambda (&optional cnt) + (evil-up-paren open close cnt))) + (bnd (or (bounds-of-thing-at-point 'evil-string) + (bounds-of-thing-at-point 'evil-comment) + ;; If point is at the opening quote of a string, + ;; this must be handled as if point is within the + ;; string, i.e. the selection must be extended + ;; around the string. Otherwise + ;; `evil-select-block' might do the wrong thing + ;; because it accidentally moves point inside the + ;; string (for inclusive selection) when looking + ;; for the current surrounding block. (re #364) + (and (= (point) (or beg (point))) + (save-excursion + (goto-char (1+ (or beg (point)))) + (or (bounds-of-thing-at-point 'evil-string) + (bounds-of-thing-at-point 'evil-comment))))))) + (if (not bnd) + (evil-select-block thing beg end type count inclusive) + (or (evil-with-restriction (car bnd) (cdr bnd) + (condition-case nil + (evil-select-block thing beg end type count inclusive) + (error nil))) + (save-excursion + (setq beg (or beg (point)) + end (or end (point))) + (goto-char (car bnd)) + (let ((extbeg (min beg (car bnd))) + (extend (max end (cdr bnd)))) + (evil-select-block thing + extbeg extend + type + count + inclusive + (or (< extbeg beg) (> extend end)) + t))))))) + (t + (evil-select-block #'(lambda (&optional cnt) + (evil-up-block open close cnt)) + beg end type count inclusive)))) + +(defun evil-select-quote-thing (thing beg end _type count &optional inclusive) + "Selection THING as if it described a quoted object. +THING is typically either 'evil-quote or 'evil-chars. This +function is called from `evil-select-quote'." + (save-excursion + (let* ((count (or count 1)) + (dir (if (> count 0) 1 -1)) + (bnd (let ((b (bounds-of-thing-at-point thing))) + (and b (< (point) (cdr b)) b))) + addcurrent + wsboth) + (if inclusive (setq inclusive t) + (when (= (abs count) 2) + (setq count dir) + (setq inclusive 'quote-only)) + ;; never extend with exclusive selection + (setq beg nil end nil)) + ;; check if the previously selected range does not contain a + ;; string + (unless (and beg end + (save-excursion + (goto-char (if (> dir 0) beg end)) + (forward-thing thing dir) + (and (<= beg (point)) (< (point) end)))) + ;; if so forget the range + (setq beg nil end nil)) + ;; check if there is a current object, if not fetch one + (when (not bnd) + (unless (and (zerop (forward-thing thing dir)) + (setq bnd (bounds-of-thing-at-point thing))) + (error "No quoted string found")) + (if (> dir 0) + (setq end (point)) + (setq beg (point))) + (setq addcurrent t)) + ;; check if current object is not selected + (when (or (not beg) (not end) (> beg (car bnd)) (< end (cdr bnd))) + ;; if not, enlarge selection + (when (or (not beg) (< (car bnd) beg)) (setq beg (car bnd))) + (when (or (not end) (> (cdr bnd) end)) (setq end (cdr bnd))) + (setq addcurrent t wsboth t)) + ;; maybe count current element + (when addcurrent + (setq count (if (> dir 0) (1- count) (1+ count)))) + ;; enlarge selection + (goto-char (if (> dir 0) end beg)) + (when (and (not addcurrent) + (= count (forward-thing thing count))) + (error "No quoted string found")) + (if (> dir 0) (setq end (point)) (setq beg (point))) + ;; add whitespace + (cond + ((not inclusive) (setq beg (1+ beg) end (1- end))) + ((not (eq inclusive 'quote-only)) + ;; try to add whitespace in forward direction + (goto-char (if (> dir 0) end beg)) + (if (setq bnd (bounds-of-thing-at-point 'evil-space)) + (if (> dir 0) (setq end (cdr bnd)) (setq beg (car bnd))) + ;; if not found try backward direction + (goto-char (if (> dir 0) beg end)) + (if (and wsboth (setq bnd (bounds-of-thing-at-point 'evil-space))) + (if (> dir 0) (setq beg (car bnd)) (setq end (cdr bnd))))))) + (evil-range beg end + ;; HACK: fixes #583 + ;; When not in visual state, an empty range is + ;; possible. However, this cannot be achieved with + ;; inclusive ranges, hence we use exclusive ranges + ;; in this case. In visual state the range must be + ;; inclusive because otherwise the selection would + ;; be wrong. + (if (evil-visual-state-p) 'inclusive 'exclusive) + :expanded t)))) + +(defun evil-select-quote (quote beg end type count &optional inclusive) + "Return a range (BEG END) of COUNT quoted text objects. +QUOTE specifies the quotation delimiter. BEG END TYPE are the +currently selected (visual) range. + +If INCLUSIVE is nil the previous selection is ignore. If there is +quoted string at point this object will be selected, otherwise +the following (if (> COUNT 0)) or preceeding object (if (< COUNT +0)) is selected. If (/= (abs COUNT) 2) the delimiting quotes are not +contained in the range, otherwise they are contained in the range. + +If INCLUSIVE is non-nil the selection depends on the previous +selection. If the currently selection contains at least one +character that is contained in a quoted string then the selection +is extended, otherwise it is thrown away. If there is a +non-selected object at point then this object is added to the +selection. Otherwise the selection is extended to the +following (if (> COUNT 0)) or preceeding object (if (< COUNT +0)). Any whitespace following (or preceeding if (< COUNT 0)) the +new selection is added to the selection. If no such whitespace +exists and the selection contains only one quoted string then the +preceeding (or following) whitespace is added to the range. " + (let ((evil-forward-quote-char quote)) + (or (let ((bnd (or (bounds-of-thing-at-point 'evil-comment) + (bounds-of-thing-at-point 'evil-string)))) + (when (and bnd (< (point) (cdr bnd)) + (/= (char-after (car bnd)) quote) + (/= (char-before (cdr bnd)) quote)) + (evil-with-restriction (car bnd) (cdr bnd) + (condition-case nil + (evil-select-quote-thing 'evil-quote-simple + beg end type + count + inclusive) + (error nil))))) + (let ((evil-forward-quote-char quote)) + (evil-select-quote-thing 'evil-quote + beg end type + count + inclusive))))) + +(defun evil-select-xml-tag (beg end type &optional count inclusive) + "Return a range (BEG END) of COUNT matching XML tags. +If INCLUSIVE is non-nil, the tags themselves are included +from the range." + (cond + ((and (not inclusive) (= (abs (or count 1)) 1)) + (let ((rng (evil-select-block #'evil-up-xml-tag beg end type count nil t))) + (if (or (and beg (= beg (evil-range-beginning rng)) + end (= end (evil-range-end rng))) + (= (evil-range-beginning rng) (evil-range-end rng))) + (evil-select-block #'evil-up-xml-tag beg end type count t) + rng))) + (t + (evil-select-block #'evil-up-xml-tag beg end type count inclusive)))) + +(defun evil-expand-range (range &optional copy) + "Expand RANGE according to its type. +Return a new range if COPY is non-nil." + (when copy + (setq range (evil-copy-range range))) + (unless (plist-get (evil-range-properties range) :expanded) + (setq range (evil-transform-range :expand range))) + range) + +(defun evil-contract-range (range &optional copy) + "Contract RANGE according to its type. +Return a new range if COPY is non-nil." + (evil-transform-range :contract range copy)) + +(defun evil-normalize-range (range &optional copy) + "Normalize RANGE according to its type. +Return a new range if COPY is non-nil." + (evil-transform-range :normalize range copy)) + +(defun evil-transform-range (transform range &optional copy) + "Apply TRANSFORM to RANGE according to its type. +Return a new range if COPY is non-nil." + (when copy + (setq range (evil-copy-range range))) + (when (evil-type range) + (apply #'evil-set-range range + (apply #'evil-transform transform range))) + range) + +(defun evil-describe-range (range) + "Return description of RANGE. +If no description is available, return the empty string." + (apply #'evil-describe range)) + +;;; Undo + +(defun evil-start-undo-step (&optional continue) + "Start a undo step. +All following buffer modifications are grouped together as a +single action. If CONTINUE is non-nil, preceding modifications +are included. The step is terminated with `evil-end-undo-step'." + (when (and (listp buffer-undo-list) + (not evil-in-single-undo)) + (if evil-undo-list-pointer + (evil-refresh-undo-step) + (unless (or continue (null (car-safe buffer-undo-list))) + (undo-boundary)) + (setq evil-undo-list-pointer (or buffer-undo-list t))))) + +(defun evil-end-undo-step (&optional continue) + "End a undo step started with `evil-start-undo-step'. +Adds an undo boundary unless CONTINUE is specified." + (when (and (listp buffer-undo-list) + evil-undo-list-pointer + (not evil-in-single-undo)) + (evil-refresh-undo-step) + (unless (or continue (null (car-safe buffer-undo-list))) + (undo-boundary)) + (setq evil-undo-list-pointer nil))) + +(defun evil-refresh-undo-step () + "Refresh `buffer-undo-list' entries for current undo step. +Undo boundaries until `evil-undo-list-pointer' are removed to +make the entries undoable as a single action. See +`evil-start-undo-step'." + (when evil-undo-list-pointer + (setq buffer-undo-list + (evil-filter-list #'null buffer-undo-list evil-undo-list-pointer)) + (setq evil-undo-list-pointer (or buffer-undo-list t)))) + +(defmacro evil-with-undo (&rest body) + "Execute BODY with enabled undo. +If undo is disabled in the current buffer, the undo information +is stored in `evil-temporary-undo' instead of `buffer-undo-list'." + (declare (indent defun) + (debug t)) + `(unwind-protect + (let (buffer-undo-list) + (unwind-protect + (progn ,@body) + (setq evil-temporary-undo buffer-undo-list) + ;; ensure evil-temporary-undo starts with exactly one undo + ;; boundary marker, i.e. nil + (unless (null (car-safe evil-temporary-undo)) + (push nil evil-temporary-undo)))) + (unless (eq buffer-undo-list t) + ;; undo is enabled, so update the global buffer undo list + (setq buffer-undo-list + ;; prepend new undos (if there are any) + (if (cdr evil-temporary-undo) + (nconc evil-temporary-undo buffer-undo-list) + buffer-undo-list) + evil-temporary-undo nil)))) + +(defmacro evil-with-single-undo (&rest body) + "Execute BODY as a single undo step." + (declare (indent defun) + (debug t)) + `(let (evil-undo-list-pointer) + (evil-with-undo + (unwind-protect + (progn + (evil-start-undo-step) + (let ((evil-in-single-undo t)) + ,@body)) + (evil-end-undo-step))))) + +(defun evil-undo-pop () + "Undo the last buffer change. +Removes the last undo information from `buffer-undo-list'. +If undo is disabled in the current buffer, use the information +in `evil-temporary-undo' instead." + (let ((paste-undo (list nil))) + (let ((undo-list (if (eq buffer-undo-list t) + evil-temporary-undo + buffer-undo-list))) + (when (or (not undo-list) (car undo-list)) + (user-error "Can't undo previous change")) + (while (and undo-list (null (car undo-list))) + (pop undo-list)) ; remove nil + (while (and undo-list (car undo-list)) + (push (pop undo-list) paste-undo)) + (let ((buffer-undo-list (nreverse paste-undo))) + (evil-save-echo-area + (undo))) + (if (eq buffer-undo-list t) + (setq evil-temporary-undo nil) + (setq buffer-undo-list undo-list))))) + +;;; Search +(defun evil-transform-regexp (regexp replacements-alist) + (replace-regexp-in-string + "\\\\+[^\\\\]" + #'(lambda (txt) + (let* ((b (match-beginning 0)) + (e (match-end 0)) + (ch (aref txt (1- e))) + (repl (assoc ch replacements-alist))) + (if (and repl (zerop (mod (length txt) 2))) + (concat (substring txt b (- e 2)) + (cdr repl)) + txt))) + regexp nil t)) + +(defun evil-transform-magic (str magic quote transform &optional _start) + "Transforms STR with magic characters. +MAGIC is a regexp that matches all potential magic +characters. Each occurence of CHAR as magic character within str +is replaced by the result of calling the associated TRANSFORM +function. TRANSFORM is a function taking two arguments, the +character to be transformed and the rest of string after the +character. The function should return a triple (REPLACEMENT REST +. STOP) where REPLACEMENT is the replacement and REST is the rest +of the string that has not been transformed. If STOP is non-nil +then the substitution stops immediately. The replacement starts +at position START, everything before that position is returned +literally. The result is a pair (RESULT . REST). RESULT is a +list containing the transformed parts in order. If two +subsequents parts are both strings, they are concatenated. REST +is the untransformed rest string (usually \"\" but may be more if +TRANSFORM stopped the substitution). Which characters are +considered as magic characters (i.e. the transformation happens +if the character is NOT preceeded by a backslash) is determined +by `evil-magic'. The special tokens \\v, \\V, \\m and \\M have +always a special meaning (like in Vim) and should not be +contained in TRANSFORMS, otherwise their meaning is overwritten. + +The parameter QUOTE is a quoting function applied to literal +transformations, usually `regexp-quote' or `replace-quote'." + (save-match-data + (let ((regexp (concat "\\(?:\\`\\|[^\\]\\)\\(\\\\\\(?:\\(" magic "\\)\\|\\(.\\)\\)\\|\\(" magic "\\)\\)")) + (magic-chars (evil-get-magic evil-magic)) + (evil-magic evil-magic) + (quote (or quote #'identity)) + result stop) + (while (and (not stop) str (string-match regexp str)) + (unless (zerop (match-beginning 1)) + (push (substring str 0 (match-beginning 1)) result)) + (let ((char (or (match-string 2 str) + (match-string 3 str) + (match-string 4 str))) + (rest (substring str (match-end 0)))) + (cond + ((match-beginning 4) + ;; magic character without backslash + (if (string-match magic-chars char) + ;; magic, do transform + (let ((trans (funcall transform (aref char 0) rest))) + (push (car trans) result) + (setq str (cadr trans) stop (nthcdr 2 trans))) + ;; non-magic, literal transformation + (push (funcall quote char) result) + (setq str rest))) + ((match-beginning 2) + ;; magic character with backslash + (if (not (string-match magic-chars char)) + ;; non-magic, do transform + (let ((trans (funcall transform (aref char 0) rest))) + (push (car trans) result) + (setq str (cadr trans) stop (nthcdr 2 trans))) + ;; magic, literal transformation + (push (funcall quote char) result) + (setq str rest))) + ((memq (aref char 0) '(?m ?M ?v ?V)) + (setq evil-magic (cdr (assq (aref char 0) + '((?m . t) + (?M . nil) + (?v . very-magic) + (?V . very-nomagic))))) + (setq magic-chars (evil-get-magic evil-magic)) + (setq str rest)) + (t + ;; non-magic char with backslash, literal transformation + (push (funcall quote char) result) + (setq str rest))))) + (cond + ((and str (not stop)) + (push str result) + (setq str "")) + ((not str) + (setq str ""))) + ;; concatenate subsequent strings + ;; note that result is in reverse order + (let (repl) + (while result + (cond + ((and (stringp (car result)) + (zerop (length (car result)))) + (pop result)) + ((and (stringp (car result)) + (stringp (cadr result))) + (setq result (cons (concat (cadr result) + (car result)) + (nthcdr 2 result)))) + (t + (push (pop result) repl)))) + (cons repl str))))) + +(defconst evil-vim-regexp-replacements + '((?n . "\n") (?r . "\r") + (?t . "\t") (?b . "\b") + (?s . "[[:space:]]") (?S . "[^[:space:]]") + (?d . "[[:digit:]]") (?D . "[^[:digit:]]") + (?x . "[[:xdigit:]]") (?X . "[^[:xdigit:]]") + (?o . "[0-7]") (?O . "[^0-7]") + (?a . "[[:alpha:]]") (?A . "[^[:alpha:]]") + (?l . "[a-z]") (?L . "[^a-z]") + (?u . "[A-Z]") (?U . "[^A-Z]") + (?y . "\\s") (?Y . "\\S") + (?\( . "\\(") (?\) . "\\)") + (?{ . "\\{") (?} . "\\}") + (?\[ . "[") (?\] . "]") + (?< . "\\<") (?> . "\\>") + (?_ . "\\_") + (?* . "*") (?+ . "+") + (?? . "?") (?= . "?") + (?. . ".") + (?` . "`") (?^ . "^") + (?$ . "$") (?| . "\\|"))) + +(defconst evil-regexp-magic "[][(){}<>_dDsSxXoOaAlLuUwWyY.*+?=^$`|nrtb]") + +(defun evil-transform-vim-style-regexp (regexp) + "Transforms vim-style backslash codes to Emacs regexp. +This includes the backslash codes \\d, \\D, \\s, \\S, \\x, \\X, +\\o, \\O, \\a, \\A, \\l, \\L, \\u, \\U and \\w, \\W. The new +codes \\y and \\Y can be used instead of the Emacs code \\s and +\\S which have a different meaning in Vim-style." + (car + (car + (evil-transform-magic + regexp evil-regexp-magic #'regexp-quote + #'(lambda (char rest) + (let ((repl (assoc char evil-vim-regexp-replacements))) + (if repl + (list (cdr repl) rest) + (list (concat "\\" (char-to-string char)) rest)))))))) + +;;; Substitute + +(defun evil-downcase-first (str) + "Return STR with the first letter downcased." + (if (zerop (length str)) + str + (concat (downcase (substring str 0 1)) + (substring str 1)))) + +(defun evil-upcase-first (str) + "Return STR with the first letter upcased." + (if (zerop (length str)) + str + (concat (upcase (substring str 0 1)) + (substring str 1)))) + +(defun evil-get-magic (magic) + "Returns a regexp matching the magic characters according to MAGIC. +Depending on the value of MAGIC the following characters are +considered magic. + t [][{}*+?.&~$^ + nil [][{}*+?$^ + 'very-magic not 0-9A-Za-z_ + 'very-nomagic empty." + (cond + ((eq magic t) "[][}{*+?.&~$^]") + ((eq magic 'very-magic) "[^0-9A-Za-z_]") + ((eq magic 'very-nomagic) "\\\\") + (t "[][}{*+?$^]"))) + +;; TODO: support magic characters in patterns +(defconst evil-replacement-magic "[eElLuU0-9&#,rnbt=]" + "All magic characters in a replacement string") + +(defun evil-compile-subreplacement (to &optional start) + "Convert a regexp replacement TO to Lisp from START until \\e or \\E. +Returns a pair (RESULT . REST). RESULT is a list suitable for +`perform-replace' if necessary, the original string if not. +REST is the unparsed remainder of TO." + (let ((result + (evil-transform-magic + to evil-replacement-magic #'replace-quote + #'(lambda (char rest) + (cond + ((eq char ?#) + (list '(number-to-string replace-count) rest)) + ((eq char ?r) (list "\r" rest)) + ((eq char ?n) (list "\n" rest)) + ((eq char ?b) (list "\b" rest)) + ((eq char ?t) (list "\t" rest)) + ((memq char '(?e ?E)) + `("" ,rest . t)) + ((memq char '(?l ?L ?u ?U)) + (let ((result (evil-compile-subreplacement rest)) + (func (cdr (assoc char + '((?l . evil-downcase-first) + (?L . downcase) + (?u . evil-upcase-first) + (?U . upcase)))))) + (list `(,func + (replace-quote + (evil-match-substitute-replacement + ,(car result) + (not case-replace)))) + (cdr result)))) + ((eq char ?=) + (when (or (zerop (length rest)) + (not (eq (aref rest 0) ?@))) + (user-error "Expected @ after \\=")) + (when (< (length rest) 2) + (user-error "Expected register after \\=@")) + (list (evil-get-register (aref rest 1)) + (substring rest 2))) + ((eq char ?,) + (let* ((obj (read-from-string rest)) + (result `(replace-quote ,(car obj))) + (end + ;; swallow a space after a symbol + (if (and (or (symbolp (car obj)) + ;; swallow a space after 'foo, + ;; but not after (quote foo) + (and (eq (car-safe (car obj)) 'quote) + (not (= ?\( (aref rest 0))))) + (eq (string-match " " rest (cdr obj)) + (cdr obj))) + (1+ (cdr obj)) + (cdr obj)))) + (list result (substring rest end)))) + ((eq char ?0) + (list "\\&" rest)) + (t + (list (concat "\\" (char-to-string char)) rest)))) + start))) + (let ((rest (cdr result)) + (result (car result))) + (replace-match-string-symbols result) + (cons (if (cdr result) + (cons 'concat result) + (or (car result) "")) + rest)))) + +(defun evil-compile-replacement (to) + "Maybe convert a regexp replacement TO to Lisp. +Returns a list suitable for `perform-replace' if necessary, the +original string if not. Currently the following magic characters +in replacements are supported: 0-9&#lLuUrnbt, +The magic character , (comma) start an Emacs-lisp expression." + (when (stringp to) + (save-match-data + (cons 'replace-eval-replacement + (car (evil-compile-subreplacement to)))))) + +(defun evil-replace-match (replacement &optional fixedcase string) + "Replace text match by last search with REPLACEMENT. +If REPLACEMENT is an expression it will be evaluated to compute +the replacement text, otherwise the function behaves as +`replace-match'." + (if (stringp replacement) + (replace-match replacement fixedcase nil string) + (replace-match (funcall (car replacement) + (cdr replacement) + 0) + fixedcase nil string))) + +(defun evil-match-substitute-replacement (replacement &optional fixedcase string) + "Return REPLACEMENT as it will be inserted by `evil-replace-match'." + (if (stringp replacement) + (match-substitute-replacement replacement fixedcase nil string) + (match-substitute-replacement (funcall (car replacement) + (cdr replacement) + 0) + fixedcase nil string))) + +;;; Alignment + +(defun evil-justify-lines (beg end justify position) + "Justifes all lines in a range. +BEG and END specify the range of those lines to be +justified. JUSTIFY is either 'left, 'right or 'center according +to the justification type. POSITION is the maximal text width for +right and center justification or the column at which the lines +should be left-aligned for left justification." + (let ((fill-column position) + adaptive-fill-mode fill-prefix) + (evil-with-restriction + (save-excursion + (goto-char beg) + (line-beginning-position)) + (save-excursion + (goto-char end) + (if (bolp) + (line-end-position 0) + (line-end-position))) + (goto-char (point-min)) + (while (progn + (if (eq justify 'left) + (indent-line-to position) + (when (re-search-forward "^[[:space:]]*" nil t) + (delete-region (match-beginning 0) + (match-end 0))) + (justify-current-line justify nil t)) + (and (zerop (forward-line)) (bolp)))) + (goto-char (point-min)) + (back-to-indentation)))) + +;;; View helper + +(defvar-local evil-list-view-select-action nil) +(put 'evil-list-view-select-action 'permanent-local t) + +(define-derived-mode evil-list-view-mode tabulated-list-mode + "Evil List View" + (tabulated-list-init-header) + (tabulated-list-print)) + +(defun evil-list-view-goto-entry () + (interactive) + (when (and evil-list-view-select-action + (not (eobp))) + (let* ((line (line-number-at-pos (point))) + (entry (elt tabulated-list-entries (1- line)))) + (funcall evil-list-view-select-action (nth 1 entry))))) + +(defun evil-list-view-quit () + (interactive) + (quit-window 'kill)) + +(define-key evil-list-view-mode-map (kbd "q") #'evil-list-view-quit) +(define-key evil-list-view-mode-map [follow-link] nil) ;; allows mouse-1 to be activated +(define-key evil-list-view-mode-map [mouse-1] #'evil-list-view-goto-entry) +(define-key evil-list-view-mode-map [return] #'evil-list-view-goto-entry) + +(defmacro evil-with-view-list (&rest properties) + "Opens new list view buffer. + +PROPERTIES is a property-list which supports the following properties: + +:name (required) The name of the buffer. +:mode-name (required) The name for the mode line. +:format (required) The value for `tabulated-list-format'. +:entries (required) The value for `tabulated-list-entries'. +:select-action (optional) A function for row selection. + It takes in a single parameter, which is the selected row's + vector value that is passed into `:entries'. +" + (declare (indent defun) (debug t)) + `(let ((bufname (concat "*" ,(plist-get properties :name) "*")) + (inhibit-read-only t)) + (and (get-buffer bufname) + (kill-buffer bufname)) + (let ((buf (get-buffer-create bufname))) + (with-current-buffer buf + (setq tabulated-list-format ,(plist-get properties :format)) + (setq tabulated-list-entries ,(plist-get properties :entries)) + (setq evil-list-view-select-action ,(plist-get properties :select-action)) + (evil-list-view-mode) + (setq mode-name ,(plist-get properties :mode-name)) + (evil-motion-state)) + (switch-to-buffer-other-window buf)))) + +(provide 'evil-common) + +;;; evil-common.el ends here |