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     (save-restriction
 149       ;; Work around http://debbugs.gnu.org/15808; not needed in 24.4.
 150       (narrow-to-region (max (point-min) (- (point) 1000))
 151                         (min (point-max) (+ (point) 1000)))
 152       (let ((easy-kill-inhibit-message t))
 153         (dolist (thing easy-kill-try-things)
 154           (easy-kill-thing thing n)
 155           (or (string= (easy-kill-candidate) "")
 156               (return)))))
 157     o))
 158
 159 (defun easy-kill-indicate-origin ()
 160   (let ((i (overlay-get easy-kill-candidate 'origin-indicator))
 161         (origin (overlay-get easy-kill-candidate 'origin)))
 162     (cond
 163      ((not (overlayp i)) nil)
 164      ((= origin (point))
 165       (overlay-put i 'after-string nil))
 166      ((memq (char-after origin) '(?\t ?\n))
 167       (overlay-put i 'after-string (overlay-get i 'as)))
 168      (t (move-overlay i origin (1+ origin))
 169         (overlay-put i 'after-string nil)))))
 170
 171 (defun easy-kill-candidate ()
 172   "Get the kill candidate as a string.
 173 If the overlay specified by variable `easy-kill-candidate' has
 174 non-zero length, it is the string covered by the overlay.
 175 Otherwise, it is the value of the overlay's candidate property."
 176   (with-current-buffer (overlay-buffer easy-kill-candidate)
 177     (or (if (/= (overlay-start easy-kill-candidate)
 178                 (overlay-end easy-kill-candidate))
 179             (filter-buffer-substring (overlay-start easy-kill-candidate)
 180                                      (overlay-end easy-kill-candidate))
 181           (overlay-get easy-kill-candidate 'candidate))
 182         "")))
 183
 184 (defun easy-kill-adjust-candidate (thing &optional beg end)
 185   "Adjust kill candidate to THING, BEG, END.
 186 If BEG is a string, shrink the overlay to zero length and set its
 187 candidate property instead."
 188   (let* ((o easy-kill-candidate)
 189          (beg (or beg (overlay-start o)))
 190          (end (or end (overlay-end o))))
 191     (overlay-put o 'thing thing)
 192     (if (stringp beg)
 193         (progn
 194           (move-overlay o (point) (point))
 195           (overlay-put o 'candidate beg)
 196           (let ((easy-kill-inhibit-message nil))
 197             (easy-kill-message-nolog "%s" beg)))
 198       (move-overlay o beg end))
 199     (cond (easy-kill-mark (easy-kill-mark-region)
 200                           (easy-kill-indicate-origin))
 201           ((and interprogram-cut-function
 202                 (not (string= (easy-kill-candidate) "")))
 203            (funcall interprogram-cut-function (easy-kill-candidate))))))
 204
 205 (defun easy-kill-save-candidate ()
 206   (unless (string= (easy-kill-candidate) "")
 207     ;; Don't modify the clipboard here since it is called in
 208     ;; `pre-command-hook' per `easy-kill-activate-keymap' and will
 209     ;; confuse `yank' if it is current command. Also
 210     ;; `easy-kill-adjust-candidate' already did that.
 211     (let ((interprogram-cut-function nil)
 212           (interprogram-paste-function nil))
 213       (kill-new (if easy-kill-append
 214                     (concat (car kill-ring) (easy-kill-candidate))
 215                   (easy-kill-candidate))
 216                 easy-kill-append))
 217     t))
 218
 219 (defun easy-kill-destroy-candidate ()
 220   (let ((hook (make-symbol "easy-kill-destroy-candidate")))
 221     (fset hook `(lambda ()
 222                   (let ((o ,easy-kill-candidate))
 223                     (when o
 224                       (let ((i (overlay-get o 'origin-indicator)))
 225                         (and (overlayp i) (delete-overlay i)))
 226                       (delete-overlay o)))
 227                   (remove-hook 'post-command-hook ',hook)))
 228     ;; Run in `post-command-hook' so that exit commands can still use
 229     ;; `easy-kill-candidate'.
 230     (add-hook 'post-command-hook hook)))
 231
 232 (defun easy-kill-expand ()
 233   (interactive)
 234   (easy-kill-thing nil '+))
 235
 236 (defun easy-kill-digit-argument (n)
 237   (interactive
 238    (list (- (logand (if (integerp last-command-event)
 239                         last-command-event
 240                       (get last-command-event 'ascii-character))
 241                     ?\177)
 242             ?0)))
 243   (easy-kill-thing nil n))
 244
 245 (defun easy-kill-shrink ()
 246   (interactive)
 247   (easy-kill-thing nil '-))
 248
 249 ;; helper for `easy-kill-thing'.
 250 (defun easy-kill-thing-forward (n)
 251   (let ((thing (overlay-get easy-kill-candidate 'thing))
 252         (direction (if (minusp n) -1 +1))
 253         (start (overlay-start easy-kill-candidate))
 254         (end (overlay-end easy-kill-candidate)))
 255     (when (and thing (/= n 0))
 256       (let ((new-end (save-excursion
 257                        (goto-char end)
 258                        (with-demoted-errors
 259                          (dotimes (_ (abs n))
 260                            (forward-thing thing direction)
 261                            (when (<= (point) start)
 262                              (forward-thing thing 1)
 263                              (return))))
 264                        (point))))
 265         (when (/= end new-end)
 266           (easy-kill-adjust-candidate thing nil new-end)
 267           t)))))
 268
 269 (defun easy-kill-thing (&optional thing n inhibit-handler)
 270   ;; N can be -, + and digits
 271   (interactive
 272    (list (cdr (assq last-command-event easy-kill-alist))
 273          (prefix-numeric-value current-prefix-arg)))
 274   (let ((thing (or thing (overlay-get easy-kill-candidate 'thing)))
 275         (n (or n 1)))
 276     (when easy-kill-mark
 277       (goto-char (overlay-get easy-kill-candidate 'origin)))
 278     (cond
 279      ((and (not inhibit-handler)
 280            (fboundp (intern-soft (format "easy-kill-on-%s" thing))))
 281       (funcall (intern (format "easy-kill-on-%s" thing)) n))
 282      ((or (eq thing (overlay-get easy-kill-candidate 'thing))
 283           (memq n '(+ -)))
 284       (easy-kill-thing-forward (pcase n
 285                                  (`+ 1)
 286                                  (`- -1)
 287                                  (n n))))
 288      (t (let ((bounds (bounds-of-thing-at-point thing)))
 289           (if (not bounds)
 290               (easy-kill-message-nolog "No `%s'" thing)
 291             (easy-kill-adjust-candidate thing (car bounds) (cdr bounds))
 292             (easy-kill-thing-forward (1- n))))))
 293     (when easy-kill-mark
 294       (easy-kill-adjust-candidate (overlay-get easy-kill-candidate 'thing)))))
 295
 296 (put 'easy-kill-abort 'easy-kill-exit t)
 297 (defun easy-kill-abort ()
 298   (interactive)
 299   (when easy-kill-mark
 300     ;; The after-string may interfere with `goto-char'.
 301     (overlay-put (overlay-get easy-kill-candidate 'origin-indicator)
 302                  'after-string nil)
 303     (goto-char (overlay-get easy-kill-candidate 'origin))
 304     (setq deactivate-mark t))
 305   (ding))
 306
 307 (put 'easy-kill-region 'easy-kill-exit t)
 308 (defun easy-kill-region ()
 309   "Kill current selection and exit."
 310   (interactive "*")
 311   (let ((beg (overlay-start easy-kill-candidate))
 312         (end (overlay-end easy-kill-candidate)))
 313     (if (= beg end)
 314         (easy-kill-message-nolog "Empty region")
 315       (kill-region beg end))))
 316
 317 (put 'easy-kill-mark-region 'easy-kill-exit t)
 318 (defun easy-kill-mark-region ()
 319   (interactive)
 320   (let ((beg (overlay-start easy-kill-candidate))
 321         (end (overlay-end easy-kill-candidate)))
 322     (if (= beg end)
 323         (easy-kill-message-nolog "Empty region")
 324       (set-mark beg)
 325       (goto-char end)
 326       (activate-mark))))
 327
 328 (put 'easy-kill-append 'easy-kill-exit t)
 329 (defun easy-kill-append ()
 330   (interactive)
 331   (setq easy-kill-append t)
 332   (when (easy-kill-save-candidate)
 333     (setq deactivate-mark t)
 334     (easy-kill-message-nolog "Appended")))
 335
 336 (defun easy-kill-activate-keymap ()
 337   (let ((map (easy-kill-map)))
 338     (set-temporary-overlay-map
 339      map
 340      (lambda ()
 341        ;; Prevent any error from activating the keymap forever.
 342        (with-demoted-errors
 343          (or (and (not (and (symbolp this-command)
 344                             (get this-command 'easy-kill-exit)))
 345                   (or (eq this-command (lookup-key map (this-single-command-keys)))
 346                       (let ((cmd (key-binding (this-single-command-keys) nil t)))
 347                         (command-remapping cmd nil (list map)))))
 348              (ignore
 349               (easy-kill-destroy-candidate)
 350               (unless (or easy-kill-mark
 351                           (and (symbolp this-command)
 352                                (get this-command 'easy-kill-exit)))
 353                 (easy-kill-save-candidate)))))))))
 354
 355 ;;;###autoload
 356 (defun easy-kill (&optional n)
 357   "Kill thing at point in the order of region, url, email and line.
 358 Temporally activate additional key bindings as follows:
 359
 360   letters => select or expand selection according to `easy-kill-alist';
 361   0..9    => expand selection by that number;
 362   +,=/-   => expand or shrink selection;
 363   @       => append selection to previous kill;
 364   C-w     => kill selection;
 365   C-SPC   => turn selection into an active region;
 366   C-g     => abort;
 367   others  => save selection and exit."
 368   (interactive "p")
 369   (if (use-region-p)
 370       (if (fboundp 'rectangle-mark)
 371           (with-no-warnings             ; new in 24.4
 372             (kill-ring-save (region-beginning) (region-end) t))
 373         (kill-ring-save (region-beginning) (region-end)))
 374     (setq easy-kill-mark nil)
 375     (setq easy-kill-append (eq last-command 'kill-region))
 376     (easy-kill-init-candidate n)
 377     (when (zerop (buffer-size))
 378       (easy-kill-message-nolog "Warn: `easy-kill' activated in empty buffer"))
 379     (easy-kill-activate-keymap)))
 380
 381 ;;;###autoload
 382 (defun easy-mark (&optional n)
 383   "Like `easy-kill' (which see) but for marking."
 384   (interactive "p")
 385   (setq easy-kill-mark t)
 386   (easy-kill-init-candidate n)
 387   (easy-kill-activate-keymap))
 388
 389 ;;;###autoload
 390 (defun easy-mark-sexp (&optional n)
 391   (interactive "p")
 392   (let ((easy-kill-try-things '(sexp)))
 393     (easy-mark n)
 394     (unless (overlay-get easy-kill-candidate 'thing)
 395       (overlay-put easy-kill-candidate 'thing 'sexp)
 396       (easy-kill-thing 'sexp n))))
 397
 398 ;;;; Extended things
 399
 400 ;;; Handler for `buffer-file-name'.
 401
 402 (defun easy-kill-on-buffer-file-name (n)
 403   "Get `buffer-file-name' or `default-directory'.
 404 If N is zero, remove the directory part; -, remove the file name
 405 party; +, full path."
 406   (if easy-kill-mark
 407       (easy-kill-message-nolog "Not supported in `easy-mark'")
 408     (let ((file (or buffer-file-name default-directory)))
 409       (when file
 410         (let* ((file (directory-file-name file))
 411                (text (pcase n
 412                        (`- (file-name-directory file))
 413                        ((pred (eq 0)) (file-name-nondirectory file))
 414                        (_ file))))
 415           (easy-kill-adjust-candidate 'buffer-file-name text))))))
 416
 417 ;;; Handler for `url'.
 418
 419 (defun easy-kill-on-url (&optional _n)
 420   "Get url at point or from char properties.
 421 Char properties `help-echo', `shr-url' and `w3m-href-anchor' are
 422 inspected."
 423   (if (or easy-kill-mark (bounds-of-thing-at-point 'url))
 424       (easy-kill-thing 'url nil t)
 425     (let ((get-url (lambda (text)
 426                      (when (stringp text)
 427                        (with-temp-buffer
 428                          (insert text)
 429                          (and (bounds-of-thing-at-point 'url)
 430                               (thing-at-point 'url)))))))
 431       (dolist (p '(help-echo shr-url w3m-href-anchor))
 432         (pcase-let* ((`(,text . ,ov)
 433                       (get-char-property-and-overlay (point) p))
 434                      (url (or (funcall get-url text)
 435                               (funcall get-url
 436                                        (and ov (overlay-get ov p))))))
 437           (when url
 438             (easy-kill-adjust-candidate 'url url)
 439             (return url)))))))
 440
 441 ;;; Handler for `sexp' and `list'.
 442
 443 (defvar up-list-fn)                     ; Dynamically bound
 444
 445 (defun easy-kill-backward-up ()
 446   (let ((ppss (syntax-ppss)))
 447     (condition-case nil
 448         (progn
 449           (funcall (or (bound-and-true-p up-list-fn) #'up-list) -1)
 450           ;; `up-list' may jump to another string.
 451           (when (and (nth 3 ppss) (< (point) (nth 8 ppss)))
 452             (goto-char (nth 8 ppss))))
 453       (scan-error (and (nth 3 ppss) (goto-char (nth 8 ppss)))))))
 454
 455 (defun easy-kill-backward-down (point &optional bound)
 456   (condition-case nil
 457       (progn
 458         (easy-kill-backward-up)
 459         (backward-prefix-chars)
 460         (if (and (or (not bound) (> (point) bound))
 461                  (/= point (point)))
 462             (easy-kill-backward-down (point) bound)
 463           (goto-char point)))
 464     (scan-error (goto-char point))))
 465
 466 (defun easy-kill-bounds-of-list (n)
 467   (save-excursion
 468     (pcase n
 469       (`+ (goto-char (overlay-start easy-kill-candidate))
 470           (easy-kill-backward-up))
 471       (`- (easy-kill-backward-down
 472            (point) (overlay-start easy-kill-candidate)))
 473       (_ (error "Unsupported argument `%s'" n)))
 474     (bounds-of-thing-at-point 'sexp)))
 475
 476 (defvar nxml-sexp-element-flag)
 477
 478 (defun easy-kill-on-nxml-element (n)
 479   (let ((nxml-sexp-element-flag t)
 480         (up-list-fn 'nxml-up-element))
 481     (cond
 482      ((memq n '(+ -))
 483       (let ((bounds (easy-kill-bounds-of-list n)))
 484         (when bounds
 485           (easy-kill-adjust-candidate 'list (car bounds) (cdr bounds)))))
 486      ((eq 'list (overlay-get easy-kill-candidate 'thing))
 487       (let ((new-end (save-excursion
 488                        (goto-char (overlay-end easy-kill-candidate))
 489                        (forward-sexp n)
 490                        (point))))
 491         (when (and new-end (/= new-end (overlay-end easy-kill-candidate)))
 492           (easy-kill-adjust-candidate 'list nil new-end))))
 493      (t (save-excursion
 494           (ignore-errors (easy-kill-backward-up))
 495           (easy-kill-thing 'sexp n t)
 496           (overlay-put easy-kill-candidate 'thing 'list))))))
 497
 498 (defun easy-kill-on-list (n)
 499   (cond
 500    ((derived-mode-p 'nxml-mode)
 501     (easy-kill-on-nxml-element n))
 502    ((memq n '(+ -))
 503     (let ((bounds (easy-kill-bounds-of-list n)))
 504       (when bounds
 505         (easy-kill-adjust-candidate 'list (car bounds) (cdr bounds)))))
 506    (t (easy-kill-thing 'list n t))))
 507
 508 (defun easy-kill-on-sexp (n)
 509   (let ((nxml-sexp-element-flag t))
 510     (if (memq n '(+ -))
 511         (easy-kill-on-list n)
 512       (easy-kill-thing 'sexp n t))))
 513
 514 (provide 'easy-kill)
 515 ;;; easy-kill.el ends here