code.delx.au - gnu-emacs-elpa/blob - packages/easy-kill/easy-kill.el

   1 ;;; easy-kill.el --- kill & mark things easily       -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2013-2014  Free Software Foundation, Inc.
   4
   5 ;; Author: Leo Liu <sdl.web@gmail.com>
   6 ;; Version: 0.9.3
   7 ;; Package-Requires: ((emacs "24") (cl-lib "0.5"))
   8 ;; Keywords: killing, convenience
   9 ;; Created: 2013-08-12
  10 ;; URL: https://github.com/leoliu/easy-kill
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; `easy-kill' aims to be a drop-in replacement for `kill-ring-save'.
  28 ;;
  29 ;; To use: (global-set-key [remap kill-ring-save] 'easy-kill)
  30
  31 ;; `easy-mark' is similar to `easy-kill' but marks the region
  32 ;; immediately. It can be a handy replacement for `mark-sexp' allowing
  33 ;; `+'/`-' to do list-wise expanding/shrinking.
  34 ;;
  35 ;; To use: (global-set-key [remap mark-sexp] 'easy-mark)
  36
  37 ;; Please send bug reports or feature requests to:
  38 ;;      https://github.com/leoliu/easy-kill/issues
  39
  40 ;;; Code:
  41
  42 (require 'cl-lib)
  43 (require 'thingatpt)
  44 (eval-when-compile (require 'cl))       ;For `defsetf'.
  45
  46 (eval-and-compile
  47   (cond
  48    ((fboundp 'set-transient-map) nil)
  49    ((fboundp 'set-temporary-overlay-map) ; new in 24.3
  50     (defalias 'set-transient-map 'set-temporary-overlay-map))
  51    (t
  52     (defun set-transient-map (map &optional keep-pred)
  53       (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
  54              (overlaysym (make-symbol "t"))
  55              (alist (list (cons overlaysym map)))
  56              (clearfun
  57               `(lambda ()
  58                  (unless ,(cond ((null keep-pred) nil)
  59                                 ((eq t keep-pred)
  60                                  `(eq this-command
  61                                       (lookup-key ',map
  62                                                   (this-command-keys-vector))))
  63                                 (t `(funcall ',keep-pred)))
  64                    (set ',overlaysym nil) ;Just in case.
  65                    (remove-hook 'pre-command-hook ',clearfunsym)
  66                    (setq emulation-mode-map-alists
  67                          (delq ',alist emulation-mode-map-alists))))))
  68         (set overlaysym overlaysym)
  69         (fset clearfunsym clearfun)
  70         (add-hook 'pre-command-hook clearfunsym)
  71         (push alist emulation-mode-map-alists))))))
  72
  73 (defcustom easy-kill-alist '((?w word     " ")
  74                              (?s sexp     "\n")
  75                              (?l list     "\n")
  76                              (?f filename "\n")
  77                              (?d defun    "\n\n")
  78                              (?e line     "\n")
  79                              (?b buffer-file-name))
  80   "A list of (CHAR THING APPEND).
  81 CHAR is used immediately following `easy-kill' to select THING.
  82 APPEND is optional and if non-nil specifies the separator (a
  83 string) for appending current selection to previous kill.
  84
  85 Note: each element can also be (CHAR . THING) but this is
  86 deprecated."
  87   :type '(repeat (list character symbol
  88                        (choice string (const :tag "None" nil))))
  89   :group 'killing)
  90
  91 (defcustom easy-kill-try-things '(url email line)
  92   "A list of things for `easy-kill' to try."
  93   :type '(repeat symbol)
  94   :group 'killing)
  95
  96 (defcustom easy-mark-try-things '(url email sexp)
  97   "A list of things for `easy-mark' to try."
  98   :type '(repeat symbol)
  99   :group 'killing)
 100
 101 (defface easy-kill-selection '((t (:inherit secondary-selection)))
 102   "Faced used to highlight kill candidate."
 103   :group 'killing)
 104
 105 (defface easy-kill-origin '((t (:inverse-video t :inherit error)))
 106   "Faced used to highlight the origin."
 107   :group 'killing)
 108
 109 (defvar easy-kill-base-map
 110   (let ((map (make-sparse-keymap)))
 111     (define-key map "-" 'easy-kill-shrink)
 112     (define-key map "+" 'easy-kill-expand)
 113     (define-key map "=" 'easy-kill-expand)
 114     (define-key map "@" 'easy-kill-append)
 115     ;; Note: didn't pick C-h because it is a very useful prefix key.
 116     (define-key map "?" 'easy-kill-help)
 117     (define-key map [remap set-mark-command] 'easy-kill-mark-region)
 118     (define-key map [remap kill-region] 'easy-kill-region)
 119     (define-key map [remap keyboard-quit] 'easy-kill-abort)
 120     (define-key map [remap exchange-point-and-mark]
 121       'easy-kill-exchange-point-and-mark)
 122     (mapc (lambda (d)
 123             (define-key map (number-to-string d) 'easy-kill-digit-argument))
 124           (number-sequence 0 9))
 125     map))
 126
 127 (defvar easy-kill-inhibit-message nil)
 128
 129 (defun easy-kill-echo (format-string &rest args)
 130   "Same as `message' except not writing to *Messages* buffer.
 131 Do nothing if `easy-kill-inhibit-message' is non-nil."
 132   (unless easy-kill-inhibit-message
 133     (let (message-log-max)
 134       (apply 'message format-string args))))
 135
 136 (defun easy-kill-trim (s &optional how)
 137   (let ((wchars "[ \t\n\r\f\v]*"))
 138     (pcase how
 139       (`left (and (string-match (concat "\\`" wchars) s)
 140                   (substring s (match-end 0))))
 141       (`right (substring s 0 (string-match-p (concat wchars "\\'") s)))
 142       (_ (easy-kill-trim (easy-kill-trim s 'left) 'right)))))
 143
 144 (defun easy-kill-mode-sname (m)
 145   (cl-check-type m (and (or symbol string) (not boolean)))
 146   (cl-etypecase m
 147     (symbol (easy-kill-mode-sname (symbol-name m)))
 148     (string (substring m 0 (string-match-p "\\(?:-minor\\)?-mode\\'" m)))))
 149
 150 (defun easy-kill-fboundp (name)
 151   "Like `fboundp' but NAME can be string or symbol.
 152 The value is the function's symbol if non-nil."
 153   (cl-etypecase name
 154     (string (easy-kill-fboundp (intern-soft name)))
 155     (symbol (and (fboundp name) name))))
 156
 157 (defun easy-kill-pair-to-list (pair)
 158   (pcase pair
 159     (`nil nil)
 160     (`(,beg . ,end) (list beg end))
 161     (_ (signal 'wrong-type-argument (list pair "Not a dot pair")))))
 162
 163 (defun easy-kill-interprogram-cut (text)
 164   "Make non-empty TEXT available to other programs."
 165   (cl-check-type text string)
 166   (and interprogram-cut-function
 167        (not (equal text ""))
 168        (funcall interprogram-cut-function text)))
 169
 170 (defun easy-kill-map ()
 171   "Build the keymap according to `easy-kill-alist'."
 172   (let ((map (make-sparse-keymap)))
 173     (set-keymap-parent map easy-kill-base-map)
 174     (mapc (lambda (c)
 175             ;; (define-key map (vector meta-prefix-char c) 'easy-kill-select)
 176             (define-key map (char-to-string c) 'easy-kill-thing))
 177           (mapcar 'car easy-kill-alist))
 178     map))
 179
 180 (defun easy-kill--fmt (x y &optional z)
 181   (cl-etypecase x
 182     (character (easy-kill--fmt
 183                 (single-key-description x)
 184                 (symbol-name y)
 185                 (and z (let ((print-escape-newlines t))
 186                          (prin1-to-string z)))))
 187     (string (with-output-to-string
 188               (princ x)
 189               (princ (make-string (- 16 (mod (length x) 16)) ?\s))
 190               (princ y)
 191               (when z
 192                 (princ (make-string (- 16 (mod (length y) 16)) ?\s))
 193                 (princ z))))))
 194
 195 (defun easy-kill-help ()
 196   (interactive)
 197   (help-setup-xref '(easy-kill-help) (called-interactively-p 'any))
 198   (with-help-window (help-buffer)
 199     (princ (concat (make-string 15 ?=) " "))
 200     (princ "Easy Kill/Mark Key Bindings ")
 201     (princ (concat (make-string 15 ?=) "\n\n"))
 202     (princ (easy-kill--fmt "Key" "Thing" "Separator"))
 203     (princ "\n")
 204     (princ (easy-kill--fmt "---" "-----" "---------"))
 205     (princ "\n\n")
 206     (princ (mapconcat (lambda (x) (pcase x
 207                                     (`(,c ,thing ,sep)
 208                                      (easy-kill--fmt c thing sep))
 209                                     ((or `(,c ,thing) `(,c . ,thing))
 210                                      (easy-kill--fmt c thing))))
 211                       easy-kill-alist "\n"))
 212     (princ "\n\n")
 213     (princ (substitute-command-keys "\\{easy-kill-base-map}"))))
 214
 215 (defvar easy-kill-candidate nil)
 216
 217 (defun easy-kill--bounds ()
 218   (cons (overlay-start easy-kill-candidate)
 219         (overlay-end easy-kill-candidate)))
 220
 221 ;;; Note: gv-define-setter not available in 24.1 and 24.2
 222 ;; (gv-define-setter easy-kill--bounds (val)
 223 ;;   (macroexp-let2 macroexp-copyable-p v val
 224 ;;     `(move-overlay easy-kill-candidate (car ,v) (cdr ,v))))
 225
 226 (defsetf easy-kill--bounds () (v)
 227   `(let ((tmp ,v))
 228      (move-overlay easy-kill-candidate (car tmp) (cdr tmp))))
 229
 230 (defmacro easy-kill-get (prop)
 231   "Get the value of the kill candidate's property PROP.
 232 Use `setf' to change property value."
 233   (pcase prop
 234     (`start  '(overlay-start easy-kill-candidate))
 235     (`end    '(overlay-end easy-kill-candidate))
 236     (`bounds '(easy-kill--bounds))
 237     (`buffer '(overlay-buffer easy-kill-candidate))
 238     (`properties '(append (list 'start (easy-kill-get start))
 239                           (list 'end (easy-kill-get end))
 240                           (list 'buffer (easy-kill-get buffer))
 241                           (overlay-properties easy-kill-candidate)))
 242     (_       `(overlay-get easy-kill-candidate ',prop))))
 243
 244 (defun easy-kill-init-candidate (n &optional mark)
 245   ;; Manipulate `easy-kill-candidate' directly during initialisation;
 246   ;; should use `easy-kill-get' elsewhere.
 247   (let ((o (make-overlay (point) (point))))
 248     (unless mark
 249       (overlay-put o 'face 'easy-kill-selection))
 250     (overlay-put o 'origin (point))
 251     (overlay-put o 'help-echo #'easy-kill-describe-candidate)
 252     ;; Use higher priority to avoid shadowing by, for example,
 253     ;; `hl-line-mode'.
 254     (overlay-put o 'priority 999)
 255     (when mark
 256       (overlay-put o 'mark 'start)
 257       (let ((i (make-overlay (point) (point))))
 258         (overlay-put i 'priority (1+ (overlay-get o 'priority)))
 259         (overlay-put i 'face 'easy-kill-origin)
 260         (overlay-put i 'as (propertize " " 'face 'easy-kill-origin))
 261         (overlay-put o 'origin-indicator i)))
 262     (setq easy-kill-candidate o)
 263     (save-restriction
 264       ;; Work around http://debbugs.gnu.org/15808; not needed in 24.4.
 265       (narrow-to-region (max (point-min) (- (point) 1000))
 266                         (min (point-max) (+ (point) 1000)))
 267       (let ((easy-kill-inhibit-message t))
 268         (cl-dolist (thing easy-kill-try-things)
 269           (easy-kill-thing thing n)
 270           (or (string= (easy-kill-candidate) "")
 271               (cl-return)))))
 272     o))
 273
 274 (defun easy-kill-indicate-origin ()
 275   (let ((i (easy-kill-get origin-indicator))
 276         (origin (easy-kill-get origin)))
 277     (cond
 278      ((not (overlayp i)) nil)
 279      ((= origin (point))
 280       (overlay-put i 'after-string nil))
 281      ((memq (char-after origin) '(?\t ?\n))
 282       (overlay-put i 'after-string (overlay-get i 'as)))
 283      (t (move-overlay i origin (1+ origin))
 284         (overlay-put i 'after-string nil)))))
 285
 286 (defun easy-kill-candidate ()
 287   "Get the kill candidate as a string.
 288 If the overlay specified by variable `easy-kill-candidate' has
 289 non-zero length, it is the string covered by the overlay.
 290 Otherwise, it is the value of the overlay's candidate property."
 291   (with-current-buffer (easy-kill-get buffer)
 292     (or (pcase (easy-kill-get bounds)
 293           (`(,_x . ,_x) (easy-kill-get candidate))
 294           (`(,beg . ,end) (filter-buffer-substring beg end)))
 295         "")))
 296
 297 (defun easy-kill-describe-candidate (&rest _)
 298   "Return a string that describes current kill candidate."
 299   (let* ((props (cl-loop for k in '(thing start end origin)
 300                          with all = (easy-kill-get properties)
 301                          ;; Allow describe-PROP to provide customised
 302                          ;; description.
 303                          for dk = (intern-soft (format "describe-%s" k))
 304                          for dv = (and dk (plist-get all dk))
 305                          for v = (or (if (functionp dv) (funcall dv) dv)
 306                                      (plist-get all k))
 307                          when v collect (format "%s:\t%s" k v)))
 308          (txt (mapconcat #'identity props "\n")))
 309     (format "cmd:\t%s\n%s"
 310             (if (easy-kill-get mark) "easy-mark" "easy-kill")
 311             txt)))
 312
 313 (defun easy-kill-adjust-candidate (thing &optional beg end)
 314   "Adjust kill candidate to THING, BEG, END.
 315 If BEG is a string, shrink the overlay to zero length and set its
 316 candidate property instead."
 317   (setf (easy-kill-get thing) thing)
 318   (cond ((stringp beg)
 319          (setf (easy-kill-get bounds) (cons (point) (point)))
 320          (setf (easy-kill-get candidate) beg)
 321          (let ((easy-kill-inhibit-message nil))
 322            (easy-kill-echo "%s" beg)))
 323         (t
 324          (setf (easy-kill-get bounds) (cons (or beg (easy-kill-get start))
 325                                             (or end (easy-kill-get end))))))
 326   (cond ((easy-kill-get mark)
 327          (easy-kill-mark-region)
 328          (easy-kill-indicate-origin))
 329         (t
 330          (easy-kill-interprogram-cut (easy-kill-candidate)))))
 331
 332 (defun easy-kill-save-candidate ()
 333   (unless (string= (easy-kill-candidate) "")
 334     ;; Don't modify the clipboard here since it is called in
 335     ;; `pre-command-hook' per `easy-kill-activate-keymap' and will
 336     ;; confuse `yank' if it is current command. Also
 337     ;; `easy-kill-adjust-candidate' already did that.
 338     (let ((interprogram-cut-function nil)
 339           (interprogram-paste-function nil))
 340       (kill-new (if (and (easy-kill-get append) kill-ring)
 341                     (cl-labels ((join (x sep y)
 342                                       (if sep (concat (easy-kill-trim x 'right)
 343                                                       sep
 344                                                       (easy-kill-trim y 'left))
 345                                         (concat x y))))
 346                       (join (car kill-ring)
 347                             (nth 2 (cl-rassoc (easy-kill-get thing)
 348                                               easy-kill-alist :key #'car))
 349                             (easy-kill-candidate)))
 350                   (easy-kill-candidate))
 351                 (easy-kill-get append)))
 352     t))
 353
 354 (defun easy-kill-destroy-candidate ()
 355   (let ((hook (make-symbol "easy-kill-destroy-candidate")))
 356     (fset hook `(lambda ()
 357                   (let ((o ,easy-kill-candidate))
 358                     (when o
 359                       (let ((i (overlay-get o 'origin-indicator)))
 360                         (and (overlayp i) (delete-overlay i)))
 361                       (delete-overlay o)))
 362                   (remove-hook 'post-command-hook ',hook)))
 363     ;; Run in `post-command-hook' so that exit commands can still use
 364     ;; `easy-kill-candidate'.
 365     (add-hook 'post-command-hook hook)))
 366
 367 (defun easy-kill-expand ()
 368   (interactive)
 369   (easy-kill-thing nil '+))
 370
 371 (defun easy-kill-digit-argument (n)
 372   "Expand selection by N number of things.
 373 If N is 0 shrink the selection to the initial size before any
 374 expansion."
 375   (interactive
 376    (list (- (logand (if (integerp last-command-event)
 377                         last-command-event
 378                       (get last-command-event 'ascii-character))
 379                     ?\177)
 380             ?0)))
 381   (easy-kill-thing nil n))
 382
 383 (defun easy-kill-shrink ()
 384   (interactive)
 385   (easy-kill-thing nil '-))
 386
 387 (defun easy-kill-thing-handler (base mode)
 388   "Get the handler for MODE or nil if none is defined.
 389 For example, if BASE is \"easy-kill-on-list\" and MODE is
 390 nxml-mode `nxml:easy-kill-on-list', `easy-kill-on-list:nxml' are
 391 checked in order. The former is never defined in this package and
 392 is safe for users to customise. If neither is defined continue
 393 checking on the parent mode. Finally `easy-kill-on-list' is
 394 checked."
 395   (or (and mode (or (easy-kill-fboundp
 396                      (concat (easy-kill-mode-sname mode) ":" base))
 397                     (easy-kill-fboundp
 398                      (concat base ":" (easy-kill-mode-sname mode)))))
 399       (let ((parent (get mode 'derived-mode-parent)))
 400         (and parent (easy-kill-thing-handler base parent)))
 401       (easy-kill-fboundp base)))
 402
 403 (defun easy-kill-bounds-of-thing-at-point (thing)
 404   "Easy Kill wrapper for `bounds-of-thing-at-point'."
 405   (pcase (easy-kill-thing-handler
 406           (format "easy-kill-bounds-of-%s-at-point" thing)
 407           major-mode)
 408     ((and (pred functionp) fn) (funcall fn))
 409     (_ (bounds-of-thing-at-point thing))))
 410
 411 (defun easy-kill-thing-forward-1 (thing &optional n)
 412   "Easy Kill wrapper for `forward-thing'."
 413   (pcase (easy-kill-thing-handler
 414           (format "easy-kill-thing-forward-%s" thing)
 415           major-mode)
 416     ((and (pred functionp) fn) (funcall fn n))
 417     (_ (forward-thing thing n))))
 418
 419 ;; Helper for `easy-kill-thing'.
 420 (defun easy-kill-thing-forward (n)
 421   (when (and (easy-kill-get thing) (/= n 0))
 422     (let* ((step (if (cl-minusp n) -1 +1))
 423            (thing (easy-kill-get thing))
 424            (bounds1 (or (easy-kill-pair-to-list
 425                          (easy-kill-bounds-of-thing-at-point thing))
 426                         (list (point) (point))))
 427            (start (easy-kill-get start))
 428            (end (easy-kill-get end))
 429            (front (or (car (cl-set-difference (list end start) bounds1))
 430                       (pcase step
 431                         (`-1 start)
 432                         (`1 end))))
 433            (new-front (save-excursion
 434                         (goto-char front)
 435                         (with-demoted-errors
 436                           (dotimes (_ (abs n))
 437                             (easy-kill-thing-forward-1 thing step)))
 438                         (point))))
 439       (pcase (and (/= front new-front)
 440                   (sort (cons new-front bounds1) #'<))
 441         (`(,start ,_ ,end)
 442          (easy-kill-adjust-candidate thing start end)
 443          t)))))
 444
 445 (defun easy-kill-thing (&optional thing n inhibit-handler)
 446   ;; N can be -, + and digits
 447   (interactive
 448    (list (pcase (assq last-command-event easy-kill-alist)
 449            (`(,_ ,th . ,_) th)
 450            (`(,_ . ,th) th))
 451          (prefix-numeric-value current-prefix-arg)))
 452   (let* ((thing (or thing (easy-kill-get thing)))
 453          (n (or n 1))
 454          (handler (and (not inhibit-handler)
 455                        (easy-kill-thing-handler (format "easy-kill-on-%s" thing)
 456                                                 major-mode))))
 457     (when (easy-kill-get mark)
 458       (goto-char (easy-kill-get origin)))
 459     (cond
 460      (handler (funcall handler n))
 461      ((or (memq n '(+ -))
 462           (and (eq thing (easy-kill-get thing))
 463                (not (zerop n))))
 464       (easy-kill-thing-forward (pcase n
 465                                  (`+ 1)
 466                                  (`- -1)
 467                                  (_ n))))
 468      (t (pcase (easy-kill-bounds-of-thing-at-point thing)
 469           (`nil (easy-kill-echo "No `%s'" thing))
 470           (`(,start . ,end)
 471            (easy-kill-adjust-candidate thing start end)
 472            (unless (zerop n)
 473              (easy-kill-thing-forward (1- n)))))))
 474     (when (easy-kill-get mark)
 475       (easy-kill-adjust-candidate (easy-kill-get thing)))))
 476
 477 (put 'easy-kill-abort 'easy-kill-exit t)
 478 (defun easy-kill-abort ()
 479   (interactive)
 480   (when (easy-kill-get mark)
 481     ;; The after-string may interfere with `goto-char'.
 482     (overlay-put (easy-kill-get origin-indicator) 'after-string nil)
 483     (goto-char (easy-kill-get origin))
 484     (setq deactivate-mark t))
 485   (ding))
 486
 487 (put 'easy-kill-region 'easy-kill-exit t)
 488 (defun easy-kill-region ()
 489   "Kill current selection and exit."
 490   (interactive "*")
 491   (pcase (easy-kill-get bounds)
 492     (`(,_x . ,_x) (easy-kill-echo "Empty region"))
 493     (`(,beg . ,end) (kill-region beg end))))
 494
 495 (put 'easy-kill-mark-region 'easy-kill-exit t)
 496 (defun easy-kill-mark-region ()
 497   (interactive)
 498   (pcase (easy-kill-get bounds)
 499     (`(,_x . ,_x)
 500      (easy-kill-echo "Empty region"))
 501     (`(,beg . ,end)
 502      (pcase (if (eq (easy-kill-get mark) 'end)
 503                 (list end beg) (list beg end))
 504        (`(,m ,pt)
 505         (set-mark m)
 506         (goto-char pt)))
 507      (activate-mark))))
 508
 509 (defun easy-kill-exchange-point-and-mark ()
 510   (interactive)
 511   (exchange-point-and-mark)
 512   (setf (easy-kill-get mark)
 513         (if (eq (point) (easy-kill-get start))
 514             'end 'start)))
 515
 516 (put 'easy-kill-append 'easy-kill-exit t)
 517 (defun easy-kill-append ()
 518   (interactive)
 519   (setf (easy-kill-get append) t)
 520   (when (easy-kill-save-candidate)
 521     (easy-kill-interprogram-cut (car kill-ring))
 522     (setq deactivate-mark t)
 523     (easy-kill-echo "Appended")))
 524
 525 (defun easy-kill-exit-p (cmd)
 526   (and (symbolp cmd) (get cmd 'easy-kill-exit)))
 527
 528 (defun easy-kill-activate-keymap ()
 529   (let ((map (easy-kill-map)))
 530     (set-transient-map
 531      map
 532      (lambda ()
 533        ;; Prevent any error from activating the keymap forever.
 534        (condition-case err
 535            (or (and (not (easy-kill-exit-p this-command))
 536                     (or (eq this-command
 537                             (lookup-key map (this-single-command-keys)))
 538                         (let ((cmd (key-binding
 539                                     (this-single-command-keys) nil t)))
 540                           (command-remapping cmd nil (list map)))))
 541                (ignore
 542                 (easy-kill-destroy-candidate)
 543                 (unless (or (easy-kill-get mark) (easy-kill-exit-p this-command))
 544                   (easy-kill-save-candidate))))
 545          (error (message "%s:%s" this-command (error-message-string err))
 546                 nil))))))
 547
 548 ;;;###autoload
 549 (defun easy-kill (&optional n)
 550   "Kill thing at point in the order of region, url, email and line.
 551 Temporally activate additional key bindings as follows:
 552
 553   letters => select or expand selection according to `easy-kill-alist';
 554   1..9    => expand selection by that number;
 555   0       => shrink to the initial selection;
 556   +,=/-   => expand or shrink selection;
 557   @       => append selection to previous kill;
 558   ?       => help;
 559   C-w     => kill selection;
 560   C-SPC   => turn selection into an active region;
 561   C-g     => abort;
 562   others  => save selection and exit."
 563   (interactive "p")
 564   (if (use-region-p)
 565       (if (fboundp 'rectangle-mark-mode) ; New in 24.4
 566           (with-no-warnings
 567             (kill-ring-save (region-beginning) (region-end) t))
 568         (kill-ring-save (region-beginning) (region-end)))
 569     (easy-kill-init-candidate n)
 570     (setf (easy-kill-get append) (eq last-command 'kill-region))
 571     (when (zerop (buffer-size))
 572       (easy-kill-echo "Warn: `easy-kill' activated in empty buffer"))
 573     (easy-kill-activate-keymap)))
 574
 575 ;;;###autoload
 576 (defalias 'easy-mark-sexp 'easy-mark
 577   "Use `easy-mark' instead. The alias may be removed in future.")
 578
 579 ;;;###autoload
 580 (defun easy-mark (&optional n)
 581   "Similar to `easy-kill' (which see) but for marking."
 582   (interactive "p")
 583   (let ((easy-kill-try-things easy-mark-try-things))
 584     (easy-kill-init-candidate n 'mark)
 585     (easy-kill-activate-keymap)
 586     (unless (easy-kill-get thing)
 587       (setf (easy-kill-get thing) 'sexp)
 588       (easy-kill-thing 'sexp n))))
 589
 590 ;;;; Extended things
 591
 592 ;;; Handler for `buffer-file-name'.
 593
 594 (defun easy-kill-on-buffer-file-name (n)
 595   "Get `buffer-file-name' or `default-directory'.
 596 If N is zero, remove the directory part; -, remove the file name
 597 part; +, full path."
 598   (if (easy-kill-get mark)
 599       (easy-kill-echo "Not supported in `easy-mark'")
 600     (pcase (or buffer-file-name default-directory)
 601       (`nil (easy-kill-echo "No `buffer-file-name'"))
 602       (file (let* ((file (directory-file-name file))
 603                    (text (pcase n
 604                            (`- (file-name-directory file))
 605                            (`0 (file-name-nondirectory file))
 606                            (_ file))))
 607               (easy-kill-adjust-candidate 'buffer-file-name text))))))
 608
 609 ;;; Handler for `defun-name'.
 610
 611 (defun easy-kill-on-defun-name (_n)
 612   "Get current defun name."
 613   (if (easy-kill-get mark)
 614       (easy-kill-echo "Not supported in `easy-mark'")
 615     (pcase (add-log-current-defun)
 616       (`nil (easy-kill-echo "No `defun-name' at point"))
 617       (name (easy-kill-adjust-candidate 'defun-name name)))))
 618
 619 ;;; Handler for `url'.
 620
 621 (defun easy-kill-on-url (&optional _n)
 622   "Get url at point or from char properties.
 623 Char properties `help-echo', `shr-url' and `w3m-href-anchor' are
 624 inspected."
 625   (if (or (easy-kill-get mark) (easy-kill-bounds-of-thing-at-point 'url))
 626       (easy-kill-thing 'url nil t)
 627     (cl-labels ((get-url (text)
 628                          (when (stringp text)
 629                            (with-temp-buffer
 630                              (insert text)
 631                              (pcase (easy-kill-bounds-of-thing-at-point 'url)
 632                                (`(,beg . ,end) (buffer-substring beg end)))))))
 633       (cl-dolist (p '(help-echo shr-url w3m-href-anchor))
 634         (pcase (get-char-property-and-overlay (point) p)
 635           (`(,text . ,ov)
 636            (pcase (or (get-url text)
 637                       (get-url (and ov (overlay-get ov p))))
 638              ((and url (guard url))
 639               (easy-kill-adjust-candidate 'url url)
 640               (cl-return url)))))))))
 641
 642 ;;; `defun'
 643
 644 ;; Work around http://debbugs.gnu.org/17247
 645 (defun easy-kill-thing-forward-defun (&optional n)
 646   (pcase (or n 1)
 647     ((pred cl-minusp) (beginning-of-defun (- n)))
 648     (n (end-of-defun n))))
 649
 650 ;;; Handler for `sexp' and `list'.
 651
 652 (defun easy-kill-bounds-of-list-at-point ()
 653   (let ((bos (and (nth 3 (syntax-ppss)) ;bounds of string
 654                   (save-excursion
 655                     (easy-kill-backward-up)
 656                     (easy-kill-bounds-of-thing-at-point 'sexp))))
 657         (b (bounds-of-thing-at-point 'list))
 658         (b1-in-b2 (lambda (b1 b2)
 659                     (and (> (car b1) (car b2))
 660                          (< (cdr b1) (cdr b2))))))
 661     (cond
 662      ((not b)                  bos)
 663      ((not bos)                b)
 664      ((= (car b) (point))      bos)
 665      ((funcall b1-in-b2 b bos) b)
 666      (t                        bos))))
 667
 668 (defvar up-list-fn)                     ; Dynamically bound
 669
 670 (defun easy-kill-backward-up ()
 671   (let ((ppss (syntax-ppss)))
 672     (condition-case nil
 673         (progn
 674           (funcall (or (bound-and-true-p up-list-fn) #'up-list) -1)
 675           ;; `up-list' may jump to another string.
 676           (when (and (nth 3 ppss) (< (point) (nth 8 ppss)))
 677             (goto-char (nth 8 ppss))))
 678       (scan-error (and (nth 3 ppss) (goto-char (nth 8 ppss)))))))
 679
 680 (defun easy-kill-forward-down (point &optional bound)
 681   (condition-case nil
 682       (progn
 683         (easy-kill-backward-up)
 684         (backward-prefix-chars)
 685         (if (and (or (not bound) (> (point) bound))
 686                  (/= point (point)))
 687             (easy-kill-forward-down (point) bound)
 688           (goto-char point)))
 689     (scan-error (goto-char point))))
 690
 691 (defun easy-kill-bounds-of-list (n)
 692   (save-excursion
 693     (pcase n
 694       (`+ (goto-char (easy-kill-get start))
 695           (easy-kill-backward-up))
 696       (`- (easy-kill-forward-down (point) (easy-kill-get start)))
 697       (_ (error "Unsupported argument `%s'" n)))
 698     (easy-kill-bounds-of-thing-at-point 'sexp)))
 699
 700 (defun easy-kill-on-list (n)
 701   (pcase n
 702     ((or `+ `-)
 703      (pcase (easy-kill-bounds-of-list n)
 704        (`(,beg . ,end)
 705         (easy-kill-adjust-candidate 'list beg end))))
 706     (_ (easy-kill-thing 'list n t))))
 707
 708 (defun easy-kill-on-sexp (n)
 709   (pcase n
 710     ((or `+ `-)
 711      (unwind-protect (easy-kill-thing 'list n)
 712        (setf (easy-kill-get thing) 'sexp)))
 713     (_ (easy-kill-thing 'sexp n t))))
 714
 715 ;;; nxml support for list-wise +/-
 716
 717 (defvar nxml-sexp-element-flag)
 718
 719 (defun easy-kill-on-list:nxml (n)
 720   (let ((nxml-sexp-element-flag t)
 721         (up-list-fn 'nxml-up-element))
 722     (cond
 723      ((memq n '(+ -))
 724       (pcase (easy-kill-bounds-of-list n)
 725         (`(,beg . ,end) (easy-kill-adjust-candidate 'list beg end))))
 726      ((and (eq 'list (easy-kill-get thing))
 727            (not (zerop n)))
 728       (let ((new-end (save-excursion
 729                        (goto-char (easy-kill-get end))
 730                        (forward-sexp n)
 731                        (point))))
 732         (when (and new-end (/= new-end (easy-kill-get end)))
 733           (easy-kill-adjust-candidate 'list nil new-end))))
 734      (t (save-excursion
 735           (ignore-errors (easy-kill-backward-up))
 736           (easy-kill-thing 'sexp n t)
 737           (setf (easy-kill-get thing) 'list))))))
 738
 739 ;;; org support for list-wise +/-
 740
 741 (defun easy-kill-bounds-of-list-at-point:org ()
 742   (eval-and-compile (require 'org-element))
 743   (let ((x (org-element-at-point)))
 744     (cons (org-element-property :begin x)
 745           (org-element-property :end x))))
 746
 747 (defun easy-kill-bounds-of-sexp-at-point:org ()
 748   (pcase (list (point) (easy-kill-bounds-of-list-at-point:org))
 749     (`(,beg (,beg . ,end))
 750      (cons beg end))
 751     (_ (bounds-of-thing-at-point 'sexp))))
 752
 753 (defun easy-kill-thing-forward-list:org (&optional n)
 754   (pcase (or n 1)
 755     (`0 nil)
 756     (n (dotimes (_ (abs n))
 757          (condition-case nil
 758              (if (cl-minusp n)
 759                  (org-backward-element)
 760                (org-forward-element))
 761            (error (pcase (easy-kill-bounds-of-thing-at-point 'list)
 762                     (`(,beg . ,end)
 763                      (goto-char (if (cl-minusp n) beg end))))))))))
 764
 765 (defun easy-kill-org-up-element (&optional n)
 766   ;; Make `org-up-element' more like `up-list'.
 767   (pcase (or n 1)
 768     (`0 nil)
 769     (n (ignore-errors
 770          (dotimes (_ (abs n))
 771            (pcase (list (point) (easy-kill-bounds-of-thing-at-point 'list))
 772              (`(,_beg (,_beg . ,_)) (org-up-element))
 773              (`(,_ (,beg . ,_))     (goto-char beg)))))
 774        (when (cl-plusp n)
 775          (goto-char (cdr (easy-kill-bounds-of-thing-at-point 'list)))))))
 776
 777 (defun easy-kill-on-list:org (n)
 778   (pcase n
 779     ((or `+ `-)
 780      (pcase (let ((up-list-fn #'easy-kill-org-up-element))
 781               (easy-kill-bounds-of-list n))
 782        (`(,beg . ,end) (easy-kill-adjust-candidate 'list beg end))))
 783     (_ (easy-kill-thing 'list n t)))
 784   (pcase (save-excursion
 785            (goto-char (easy-kill-get start))
 786            (org-element-type (org-element-at-point)))
 787     (`nil nil)
 788     (type (setf (easy-kill-get describe-thing)
 789                 (lambda ()
 790                   (format "%s (%s)" (easy-kill-get thing) type)))
 791           (easy-kill-echo "%s" type))))
 792
 793 ;;; js2 support for list-wise +/-
 794
 795 (defun easy-kill-find-js2-node (beg end &optional inner)
 796   (eval-and-compile (require 'js2-mode nil t))
 797   (let* ((node (js2-node-at-point))
 798          (last-node node))
 799     (while (progn
 800              (if (or (js2-ast-root-p node)
 801                      (and (<= (js2-node-abs-pos node) beg)
 802                           (>= (js2-node-abs-end node) end)
 803                           (or inner
 804                               (not (and (= (js2-node-abs-pos node) beg)
 805                                         (= (js2-node-abs-end node) end))))))
 806                  nil
 807                (setq last-node node
 808                      node (js2-node-parent node))
 809                t)))
 810     (if inner last-node node)))
 811
 812 (defun easy-kill-on-list:js2 (n)
 813   (let ((node (pcase n
 814                 ((or `+ `-)
 815                  (easy-kill-find-js2-node (easy-kill-get start)
 816                                           (easy-kill-get end)
 817                                           (eq n '-)))
 818                 ((guard (and (eq 'list (easy-kill-get thing))
 819                              (not (zerop n))))
 820                  (error "List forward not supported in js2-mode"))
 821                 (_ (js2-node-at-point)))))
 822     (easy-kill-adjust-candidate 'list
 823                                 (js2-node-abs-pos node)
 824                                 (js2-node-abs-end node))
 825     (setf (easy-kill-get describe-thing)
 826           ;; Also used by `sexp' so delay computation until needed.
 827           (lambda ()
 828             (format "%s (%s)" (easy-kill-get thing) (js2-node-short-name node))))
 829     (easy-kill-echo "%s" (js2-node-short-name node))))
 830
 831 (provide 'easy-kill)
 832 ;;; easy-kill.el ends here