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

   1 ;;; easy-kill.el --- kill things easily              -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2013  Leo Liu
   4
   5 ;; Author: Leo Liu <sdl.web@gmail.com>
   6 ;; Version: 0.9.0
   7 ;; Package-Requires: ((emacs "24"))
   8 ;; Keywords: 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.
  33 ;;
  34 ;; `easy-mark-sexp' can be a handy replacement for `mark-sexp' which
  35 ;; allows you to use +,=/- to do list-wise expanding/shrinking.
  36 ;;
  37 ;; To use: (global-set-key [remap mark-sexp] 'easy-mark-sexp)
  38
  39 ;; Please send bug reports or feature requests to:
  40 ;;      https://github.com/leoliu/easy-kill/issues
  41
  42 ;;; Code:
  43
  44 (eval-when-compile (require 'cl))
  45 (require 'thingatpt)
  46
  47 (eval-and-compile
  48   (or (fboundp 'set-temporary-overlay-map) ; new in 24.3
  49       (defun set-temporary-overlay-map (map &optional keep-pred)
  50         (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
  51                (overlaysym (make-symbol "t"))
  52                (alist (list (cons overlaysym map)))
  53                (clearfun
  54                 `(lambda ()
  55                    (unless ,(cond ((null keep-pred) nil)
  56                                   ((eq t keep-pred)
  57                                    `(eq this-command
  58                                         (lookup-key ',map
  59                                                     (this-command-keys-vector))))
  60                                   (t `(funcall ',keep-pred)))
  61                      (set ',overlaysym nil) ;Just in case.
  62                      (remove-hook 'pre-command-hook ',clearfunsym)
  63                      (setq emulation-mode-map-alists
  64                            (delq ',alist emulation-mode-map-alists))))))
  65           (set overlaysym overlaysym)
  66           (fset clearfunsym clearfun)
  67           (add-hook 'pre-command-hook clearfunsym)
  68           (push alist emulation-mode-map-alists)))))
  69
  70 (defcustom easy-kill-alist
  71   '((?w . word)
  72     (?s . sexp)
  73     (?l . list)
  74     (?f . filename)
  75     (?d . defun)
  76     (?e . line)
  77     (?b . buffer-file-name))
  78   "A list of (CHAR . THING).
  79 CHAR is used immediately following `easy-kill' to select THING."
  80   :type '(repeat (cons character symbol))
  81   :group 'killing)
  82
  83 (defcustom easy-kill-try-things '(url email line)
  84   "A list of things for `easy-kill' to try."
  85   :type '(repeat symbol)
  86   :group 'killing)
  87
  88 (defface easy-kill-selection '((t (:inherit secondary-selection)))
  89   "Faced used to highlight kill candidate."
  90   :group 'killing)
  91
  92 (defface easy-kill-origin '((t (:inverse-video t :inherit error)))
  93   "Faced used to highlight the origin."
  94   :group 'killing)
  95
  96 (defvar easy-kill-base-map
  97   (let ((map (make-sparse-keymap)))
  98     (define-key map "-" 'easy-kill-shrink)
  99     (define-key map "+" 'easy-kill-expand)
 100     (define-key map "=" 'easy-kill-expand)
 101     (define-key map "@" 'easy-kill-append)
 102     (define-key map [remap set-mark-command] 'easy-kill-mark-region)
 103     (define-key map [remap kill-region] 'easy-kill-region)
 104     (define-key map [remap keyboard-quit] 'easy-kill-abort)
 105     (mapc (lambda (d)
 106             (define-key map (number-to-string d) 'easy-kill-digit-argument))
 107           (number-sequence 0 9))
 108     map))
 109
 110 (defun easy-kill-map ()
 111   "Build the keymap according to `easy-kill-alist'."
 112   (let ((map (make-sparse-keymap)))
 113     (set-keymap-parent map easy-kill-base-map)
 114     (mapc (lambda (c)
 115             ;; (define-key map (vector meta-prefix-char c) 'easy-kill-select)
 116             (define-key map (char-to-string c) 'easy-kill-thing))
 117           (mapcar 'car easy-kill-alist))
 118     map))
 119
 120 (defvar easy-kill-inhibit-message nil)
 121
 122 (defun easy-kill-message-nolog (format-string &rest args)
 123   "Same as `message' except not writing to *Messages* buffer.
 124 Do nothing if `easy-kill-inhibit-message' is non-nil."
 125   (unless easy-kill-inhibit-message
 126     (let (message-log-max)
 127       (apply 'message format-string args))))
 128
 129 (defvar easy-kill-candidate nil)
 130 (defvar easy-kill-append nil)
 131 (defvar easy-kill-mark nil)
 132
 133 (defun easy-kill-init-candidate (n)
 134   (let ((o (make-overlay (point) (point))))
 135     (unless easy-kill-mark
 136       (overlay-put o 'face 'easy-kill-selection))
 137     (overlay-put o 'origin (point))
 138     ;; Use higher priority to avoid shadowing by, for example,
 139     ;; `hl-line-mode'.
 140     (overlay-put o 'priority 999)
 141     (when easy-kill-mark
 142       (let ((i (make-overlay (point) (point))))
 143         (overlay-put i 'priority (1+ (overlay-get o 'priority)))
 144         (overlay-put i 'face 'easy-kill-origin)
 145         (overlay-put i 'as (propertize " " 'face 'easy-kill-origin))
 146         (overlay-put o 'origin-indicator i)))
 147     (setq easy-kill-candidate o)
 148     (let ((easy-kill-inhibit-message t))
 149       (dolist (thing easy-kill-try-things)
 150         (easy-kill-thing thing n)
 151         (or (string= (easy-kill-candidate) "")
 152             (return))))
 153     o))
 154
 155 (defun easy-kill-indicate-origin ()
 156   (let ((i (overlay-get easy-kill-candidate 'origin-indicator))
 157         (origin (overlay-get easy-kill-candidate 'origin)))
 158     (cond
 159      ((not (overlayp i)) nil)
 160      ((= origin (point))
 161       (overlay-put i 'after-string nil))
 162      ((memq (char-after origin) '(?\t ?\n))
 163       (overlay-put i 'after-string (overlay-get i 'as)))
 164      (t (move-overlay i origin (1+ origin))
 165         (overlay-put i 'after-string nil)))))
 166
 167 (defun easy-kill-candidate ()
 168   "Get the kill candidate as a string.
 169 If the overlay specified by variable `easy-kill-candidate' has
 170 non-zero length, it is the string covered by the overlay.
 171 Otherwise, it is the value of the overlay's candidate property."
 172   (with-current-buffer (overlay-buffer easy-kill-candidate)
 173     (or (if (/= (overlay-start easy-kill-candidate)
 174                 (overlay-end easy-kill-candidate))
 175             (filter-buffer-substring (overlay-start easy-kill-candidate)
 176                                      (overlay-end easy-kill-candidate))
 177           (overlay-get easy-kill-candidate 'candidate))
 178         "")))
 179
 180 (defun easy-kill-adjust-candidate (thing &optional beg end)
 181   "Adjust kill candidate to THING, BEG, END.
 182 If BEG is a string, shrink the overlay to zero length and set its
 183 candidate property instead."
 184   (let* ((o easy-kill-candidate)
 185          (beg (or beg (overlay-start o)))
 186          (end (or end (overlay-end o))))
 187     (overlay-put o 'thing thing)
 188     (if (stringp beg)
 189         (progn
 190           (move-overlay o (point) (point))
 191           (overlay-put o 'candidate beg)
 192           (let ((easy-kill-inhibit-message nil))
 193             (easy-kill-message-nolog "%s" beg)))
 194       (move-overlay o beg end))
 195     (cond (easy-kill-mark (easy-kill-mark-region)
 196                           (easy-kill-indicate-origin))
 197           ((and interprogram-cut-function
 198                 (not (string= (easy-kill-candidate) "")))
 199            (funcall interprogram-cut-function (easy-kill-candidate))))))
 200
 201 (defun easy-kill-save-candidate ()
 202   (unless (string= (easy-kill-candidate) "")
 203     ;; Don't modify the clipboard here since it is called in
 204     ;; `pre-command-hook' per `easy-kill-activate-keymap' and will
 205     ;; confuse `yank' if it is current command. Also
 206     ;; `easy-kill-adjust-candidate' already did that.
 207     (let ((interprogram-cut-function nil)
 208           (interprogram-paste-function nil))
 209       (kill-new (if easy-kill-append
 210                     (concat (car kill-ring) (easy-kill-candidate))
 211                   (easy-kill-candidate))
 212                 easy-kill-append))
 213     t))
 214
 215 (defun easy-kill-destroy-candidate ()
 216   (let ((hook (make-symbol "easy-kill-destroy-candidate")))
 217     (fset hook `(lambda ()
 218                   (let ((o ,easy-kill-candidate))
 219                     (when o
 220                       (let ((i (overlay-get o 'origin-indicator)))
 221                         (and (overlayp i) (delete-overlay i)))
 222                       (delete-overlay o)))
 223                   (remove-hook 'post-command-hook ',hook)))
 224     ;; Run in `post-command-hook' so that exit commands can still use
 225     ;; `easy-kill-candidate'.
 226     (add-hook 'post-command-hook hook)))
 227
 228 (defun easy-kill-expand ()
 229   (interactive)
 230   (easy-kill-thing nil '+))
 231
 232 (defun easy-kill-digit-argument (n)
 233   (interactive
 234    (list (- (logand (if (integerp last-command-event)
 235                         last-command-event
 236                       (get last-command-event 'ascii-character))
 237                     ?\177)
 238             ?0)))
 239   (easy-kill-thing nil n))
 240
 241 (defun easy-kill-shrink ()
 242   (interactive)
 243   (easy-kill-thing nil '-))
 244
 245 ;; helper for `easy-kill-thing'.
 246 (defun easy-kill-thing-forward (n)
 247   (let ((thing (overlay-get easy-kill-candidate 'thing))
 248         (direction (if (minusp n) -1 +1))
 249         (start (overlay-start easy-kill-candidate))
 250         (end (overlay-end easy-kill-candidate)))
 251     (when (and thing (/= n 0))
 252       (let ((new-end (save-excursion
 253                        (goto-char end)
 254                        (with-demoted-errors
 255                          (dotimes (_ (abs n))
 256                            (forward-thing thing direction)
 257                            (when (<= (point) start)
 258                              (forward-thing thing 1)
 259                              (return))))
 260                        (point))))
 261         (when (/= end new-end)
 262           (easy-kill-adjust-candidate thing nil new-end)
 263           t)))))
 264
 265 (defun easy-kill-thing (&optional thing n inhibit-handler)
 266   ;; N can be -, + and digits
 267   (interactive
 268    (list (cdr (assq last-command-event easy-kill-alist))
 269          (prefix-numeric-value current-prefix-arg)))
 270   (let ((thing (or thing (overlay-get easy-kill-candidate 'thing)))
 271         (n (or n 1)))
 272     (when easy-kill-mark
 273       (goto-char (overlay-get easy-kill-candidate 'origin)))
 274     (cond
 275      ((and (not inhibit-handler)
 276            (fboundp (intern-soft (format "easy-kill-on-%s" thing))))
 277       (funcall (intern (format "easy-kill-on-%s" thing)) n))
 278      ((or (eq thing (overlay-get easy-kill-candidate 'thing))
 279           (memq n '(+ -)))
 280       (easy-kill-thing-forward (pcase n
 281                                  (`+ 1)
 282                                  (`- -1)
 283                                  (n n))))
 284      (t (let ((bounds (bounds-of-thing-at-point thing)))
 285           (if (not bounds)
 286               (easy-kill-message-nolog "No `%s'" thing)
 287             (easy-kill-adjust-candidate thing (car bounds) (cdr bounds))
 288             (easy-kill-thing-forward (1- n))))))
 289     (when easy-kill-mark
 290       (easy-kill-adjust-candidate (overlay-get easy-kill-candidate 'thing)))))
 291
 292 (put 'easy-kill-abort 'easy-kill-exit t)
 293 (defun easy-kill-abort ()
 294   (interactive)
 295   (when easy-kill-mark
 296     ;; The after-string may interfere with `goto-char'.
 297     (overlay-put (overlay-get easy-kill-candidate 'origin-indicator)
 298                  'after-string nil)
 299     (goto-char (overlay-get easy-kill-candidate 'origin))
 300     (setq deactivate-mark t))
 301   (ding))
 302
 303 (put 'easy-kill-region 'easy-kill-exit t)
 304 (defun easy-kill-region ()
 305   "Kill current selection and exit."
 306   (interactive "*")
 307   (let ((beg (overlay-start easy-kill-candidate))
 308         (end (overlay-end easy-kill-candidate)))
 309     (if (= beg end)
 310         (easy-kill-message-nolog "Empty region")
 311       (kill-region beg end))))
 312
 313 (put 'easy-kill-mark-region 'easy-kill-exit t)
 314 (defun easy-kill-mark-region ()
 315   (interactive)
 316   (let ((beg (overlay-start easy-kill-candidate))
 317         (end (overlay-end easy-kill-candidate)))
 318     (if (= beg end)
 319         (easy-kill-message-nolog "Empty region")
 320       (set-mark beg)
 321       (goto-char end)
 322       (activate-mark))))
 323
 324 (put 'easy-kill-append 'easy-kill-exit t)
 325 (defun easy-kill-append ()
 326   (interactive)
 327   (setq easy-kill-append t)
 328   (when (easy-kill-save-candidate)
 329     (setq deactivate-mark t)
 330     (easy-kill-message-nolog "Appended")))
 331
 332 (defun easy-kill-activate-keymap ()
 333   (let ((map (easy-kill-map)))
 334     (set-temporary-overlay-map
 335      map
 336      (lambda ()
 337        ;; Prevent any error from activating the keymap forever.
 338        (with-demoted-errors
 339          (or (and (not (and (symbolp this-command)
 340                             (get this-command 'easy-kill-exit)))
 341                   (or (eq this-command (lookup-key map (this-single-command-keys)))
 342                       (let ((cmd (key-binding (this-single-command-keys) nil t)))
 343                         (command-remapping cmd nil (list map)))))
 344              (ignore
 345               (easy-kill-destroy-candidate)
 346               (unless (or easy-kill-mark
 347                           (and (symbolp this-command)
 348                                (get this-command 'easy-kill-exit)))
 349                 (easy-kill-save-candidate)))))))))
 350
 351 ;;;###autoload
 352 (defun easy-kill (&optional n)
 353   "Kill thing at point in the order of region, url, email and line.
 354 Temporally activate additional key bindings as follows:
 355
 356   letters => select or expand selection according to `easy-kill-alist';
 357   0..9    => expand selection by that number;
 358   +,=/-   => expand or shrink selection;
 359   @       => append selection to previous kill;
 360   C-w     => kill selection;
 361   C-SPC   => turn selection into an active region;
 362   C-g     => abort;
 363   others  => save selection and exit."
 364   (interactive "p")
 365   (if (use-region-p)
 366       (if (fboundp 'rectangle-mark)
 367           (with-no-warnings             ; new in 24.4
 368             (kill-ring-save (region-beginning) (region-end) t))
 369         (kill-ring-save (region-beginning) (region-end)))
 370     (setq easy-kill-mark nil)
 371     (setq easy-kill-append (eq last-command 'kill-region))
 372     (easy-kill-init-candidate n)
 373     (when (zerop (buffer-size))
 374       (easy-kill-message-nolog "Warn: `easy-kill' activated in empty buffer"))
 375     (easy-kill-activate-keymap)))
 376
 377 ;;;###autoload
 378 (defun easy-mark (&optional n)
 379   "Like `easy-kill' (which see) but for marking."
 380   (interactive "p")
 381   (setq easy-kill-mark t)
 382   (easy-kill-init-candidate n)
 383   (easy-kill-activate-keymap))
 384
 385 ;;;###autoload
 386 (defun easy-mark-sexp (&optional n)
 387   (interactive "p")
 388   (let ((easy-kill-try-things '(sexp)))
 389     (easy-mark n)
 390     (unless (overlay-get easy-kill-candidate 'thing)
 391       (overlay-put easy-kill-candidate 'thing 'sexp)
 392       (easy-kill-thing 'sexp n))))
 393
 394 ;;;; Extended things
 395
 396 ;;; Handler for `buffer-file-name'.
 397
 398 (defun easy-kill-on-buffer-file-name (n)
 399   "Get `buffer-file-name' or `default-directory'.
 400 If N is zero, remove the directory part; -, remove the file name
 401 party; +, full path."
 402   (if easy-kill-mark
 403       (easy-kill-message-nolog "Not supported in `easy-mark'")
 404     (let ((file (or buffer-file-name default-directory)))
 405       (when file
 406         (let* ((file (directory-file-name file))
 407                (text (pcase n
 408                        (`- (file-name-directory file))
 409                        ((pred (eq 0)) (file-name-nondirectory file))
 410                        (_ file))))
 411           (easy-kill-adjust-candidate 'buffer-file-name text))))))
 412
 413 ;;; Handler for `url'.
 414
 415 (defun easy-kill-on-url (&optional _n)
 416   "Get url at point or from char properties.
 417 Char properties `help-echo', `shr-url' and `w3m-href-anchor' are
 418 inspected."
 419   (if (or easy-kill-mark (bounds-of-thing-at-point 'url))
 420       (easy-kill-thing 'url nil t)
 421     (let ((get-url (lambda (text)
 422                      (when (stringp text)
 423                        (with-temp-buffer
 424                          (insert text)
 425                          (and (bounds-of-thing-at-point 'url)
 426                               (thing-at-point 'url)))))))
 427       (dolist (p '(help-echo shr-url w3m-href-anchor))
 428         (pcase-let* ((`(,text . ,ov)
 429                       (get-char-property-and-overlay (point) p))
 430                      (url (or (funcall get-url text)
 431                               (funcall get-url
 432                                        (and ov (overlay-get ov p))))))
 433           (when url
 434             (easy-kill-adjust-candidate 'url url)
 435             (return url)))))))
 436
 437 ;;; Handler for `sexp' and `list'.
 438
 439 (defvar up-list-fn)                     ; Dynamically bound
 440
 441 (defun easy-kill-backward-up ()
 442   (let ((ppss (syntax-ppss)))
 443     (condition-case nil
 444         (progn
 445           (funcall (or (bound-and-true-p up-list-fn) #'up-list) -1)
 446           ;; `up-list' may jump to another string.
 447           (when (and (nth 3 ppss) (< (point) (nth 8 ppss)))
 448             (goto-char (nth 8 ppss))))
 449       (scan-error (and (nth 3 ppss) (goto-char (nth 8 ppss)))))))
 450
 451 (defun easy-kill-backward-down (point &optional bound)
 452   (condition-case nil
 453       (progn
 454         (easy-kill-backward-up)
 455         (backward-prefix-chars)
 456         (if (and (or (not bound) (> (point) bound))
 457                  (/= point (point)))
 458             (easy-kill-backward-down (point) bound)
 459           (goto-char point)))
 460     (scan-error (goto-char point))))
 461
 462 (defun easy-kill-bounds-of-list (n)
 463   (save-excursion
 464     (pcase n
 465       (`+ (goto-char (overlay-start easy-kill-candidate))
 466           (easy-kill-backward-up))
 467       (`- (easy-kill-backward-down
 468            (point) (overlay-start easy-kill-candidate)))
 469       (_ (error "Unsupported argument `%s'" n)))
 470     (bounds-of-thing-at-point 'sexp)))
 471
 472 (defvar nxml-sexp-element-flag)
 473
 474 (defun easy-kill-on-nxml-element (n)
 475   (let ((nxml-sexp-element-flag t)
 476         (up-list-fn 'nxml-up-element))
 477     (cond
 478      ((memq n '(+ -))
 479       (let ((bounds (easy-kill-bounds-of-list n)))
 480         (when bounds
 481           (easy-kill-adjust-candidate 'list (car bounds) (cdr bounds)))))
 482      ((eq 'list (overlay-get easy-kill-candidate 'thing))
 483       (let ((new-end (save-excursion
 484                        (goto-char (overlay-end easy-kill-candidate))
 485                        (forward-sexp n)
 486                        (point))))
 487         (when (and new-end (/= new-end (overlay-end easy-kill-candidate)))
 488           (easy-kill-adjust-candidate 'list nil new-end))))
 489      (t (save-excursion
 490           (ignore-errors (easy-kill-backward-up))
 491           (easy-kill-thing 'sexp n t)
 492           (overlay-put easy-kill-candidate 'thing 'list))))))
 493
 494 (defun easy-kill-on-list (n)
 495   (cond
 496    ((derived-mode-p 'nxml-mode)
 497     (easy-kill-on-nxml-element n))
 498    ((memq n '(+ -))
 499     (let ((bounds (easy-kill-bounds-of-list n)))
 500       (when bounds
 501         (easy-kill-adjust-candidate 'list (car bounds) (cdr bounds)))))
 502    (t (easy-kill-thing 'list n t))))
 503
 504 (defun easy-kill-on-sexp (n)
 505   (let ((nxml-sexp-element-flag t))
 506     (if (memq n '(+ -))
 507         (easy-kill-on-list n)
 508       (easy-kill-thing 'sexp n t))))
 509
 510 (provide 'easy-kill)
 511 ;;; easy-kill.el ends here