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.6.0
   7 ;; Keywords: convenience
   8 ;; Created: 2013-08-12
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; `easy-kill' aims to be a drop-in replacement for `kill-ring-save'.
  26 ;;
  27 ;; To use: (global-set-key "\M-w" 'easy-kill)
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32 (require 'thingatpt)
  33
  34 (defcustom easy-kill-alist
  35   '((?w . word)
  36     (?s . sexp)
  37     (?l . list)
  38     (?f . filename)
  39     (?d . defun)
  40     (?b . buffer-file-name))
  41   "A list of (Key . THING)."
  42   :type '(repeat (cons character symbol))
  43   :group 'killing)
  44
  45 (defun easy-kill-map ()
  46   (let ((map (make-sparse-keymap)))
  47     (define-key map "-" 'easy-kill-shrink)
  48     (define-key map "+" 'easy-kill-enlarge)
  49     (define-key map "=" 'easy-kill-enlarge)
  50     (mapc (lambda (d)
  51             (define-key map (number-to-string d) 'easy-kill-digit-argument))
  52           (number-sequence 0 9))
  53     (mapc (lambda (c)
  54             ;; (define-key map (vector meta-prefix-char c) 'easy-kill-select)
  55             (define-key map (char-to-string c) 'easy-kill-thing))
  56           (mapcar 'car easy-kill-alist))
  57     map))
  58
  59 (defface easy-kill-face '((t (:inherit 'secondary-selection)))
  60   "Faced used to highlight kill candidate."
  61   :group 'killing)
  62
  63 (defun easy-kill-message-nolog (format-string &rest args)
  64   "Same as `message' except not writing to *Messages* buffer."
  65   (let (message-log-max)
  66     (apply 'message format-string args)))
  67
  68 (defun easy-kill-strip-trailing (s)
  69   (cond ((stringp s)
  70          (if (string-match "[ \t\f\r\n]*\\'" s)
  71              (substring s 0 (match-beginning 0))
  72            (error "`string-match' failed in `easy-kill-strip'")))
  73         (t s)))
  74
  75 (defvar easy-kill-candidate nil)
  76
  77 (defun easy-kill-candidate ()
  78   "Get the kill candidate as a string.
  79 If the overlay specified by variable `easy-kill-candidate' has
  80 non-zero length, it is the string covered by the overlay.
  81 Otherwise, it is the value of the overlay's candidate property."
  82   (easy-kill-strip-trailing
  83    (if (/= (overlay-start easy-kill-candidate)
  84            (overlay-end easy-kill-candidate))
  85        (buffer-substring (overlay-start easy-kill-candidate)
  86                          (overlay-end easy-kill-candidate))
  87      (overlay-get easy-kill-candidate 'candidate))))
  88
  89 (defun easy-kill-adjust-candidate (thing &optional beg end)
  90   "Adjust kill candidate to THING, BEG, END.
  91 If BEG is a string, shring the overlay to zero length and set its
  92 candidate property instead."
  93   (let ((o easy-kill-candidate))
  94     (overlay-put o 'thing thing)
  95     (if (stringp beg)
  96         (progn
  97           (move-overlay o (point) (point))
  98           (overlay-put o 'candidate beg)
  99           (easy-kill-message-nolog "%s" beg))
 100       (move-overlay o (or beg (overlay-start o)) (or end (overlay-end 0)))))
 101   (and interprogram-cut-function
 102        (funcall interprogram-cut-function (easy-kill-candidate))))
 103
 104 (defun easy-kill-enlarge (n)
 105   (interactive "p")
 106   (let ((thing (overlay-get easy-kill-candidate 'thing)))
 107     (when thing
 108       (if (get thing 'easy-kill-enlarge)
 109           (funcall (get thing 'easy-kill-enlarge) n)
 110         (let ((direction (if (minusp n) -1 +1))
 111               (start (overlay-start easy-kill-candidate))
 112               (end (overlay-end easy-kill-candidate)))
 113           (when thing
 114             (save-excursion
 115               (goto-char end)
 116               (with-demoted-errors
 117                 (dotimes (_ (abs n))
 118                   (forward-thing thing direction)
 119                   (when (<= (point) start)
 120                     (forward-thing thing 1)
 121                     (return))))
 122               (when (/= end (point))
 123                 (easy-kill-adjust-candidate thing nil (point))
 124                 t))))))))
 125
 126 (defun easy-kill-shrink (n)
 127   (interactive "p")
 128   (easy-kill-enlarge (- n)))
 129
 130 (defun easy-kill-digit-argument (&optional n)
 131   (interactive
 132    (list (- (logand (if (integerp last-command-event)
 133                         last-command-event
 134                       (get last-command-event 'ascii-character))
 135                     ?\177)
 136             ?0)))
 137   (easy-kill-thing (overlay-get easy-kill-candidate 'thing) n))
 138
 139 (defun easy-kill-thing (thing &optional n inhibit-handler)
 140   (interactive
 141    (list (cdr (assoc (car (last (listify-key-sequence
 142                                  (single-key-description last-command-event))))
 143                      easy-kill-alist))
 144          (prefix-numeric-value current-prefix-arg)))
 145   (let ((n (or n 1)))
 146     (cond
 147      ((and (not inhibit-handler)
 148            (intern-soft (format "easy-kill-on-%s" thing)))
 149       (funcall (intern-soft (format "easy-kill-on-%s" thing)) n))
 150      ((eq thing (overlay-get easy-kill-candidate 'thing))
 151       (easy-kill-enlarge n))
 152      (t (let ((bounds (bounds-of-thing-at-point thing)))
 153           (if (not bounds)
 154               (when (called-interactively-p 'interact)
 155                 (easy-kill-message-nolog "No `%s'" thing))
 156             (easy-kill-adjust-candidate thing (car bounds) (cdr bounds))
 157             (easy-kill-enlarge (1- n))))))))
 158
 159 (defun easy-kill-activate-keymap ()
 160   (let ((map (easy-kill-map)))
 161     (set-temporary-overlay-map
 162      map
 163      (lambda ()
 164        ;; When any error happens the keymap is active forever.
 165        (with-demoted-errors
 166          (or (let ((cmd (lookup-key map (this-command-keys))))
 167                (eq this-command
 168                    (if (and (numberp cmd)
 169                             universal-argument-num-events
 170                             (> (length (this-command-keys))
 171                                universal-argument-num-events))
 172                        (lookup-key map (substring (this-command-keys)
 173                                                   universal-argument-num-events))
 174                      cmd)))
 175              (when easy-kill-candidate
 176                ;; Do not modify the clipboard here because it will
 177                ;; intercept pasting from other programs and
 178                ;; `easy-kill-remember' already did the work.
 179                (let ((interprogram-cut-function nil)
 180                      (interprogram-paste-function nil)
 181                      (candidate (easy-kill-candidate)))
 182                  (unless(member candidate '(nil ""))
 183                    (kill-new candidate)))
 184                (delete-overlay easy-kill-candidate)
 185                (setq easy-kill-candidate nil)
 186                nil)))))))
 187
 188 ;;;###autoload
 189 (defun easy-kill (&optional n)
 190   "Kill thing at point in the order of region, url, email and line."
 191   (interactive "p")
 192   (setq easy-kill-candidate
 193         (let ((o (make-overlay (point) (point))))
 194           (overlay-put o 'face 'easy-kill-face)
 195           ;; Use higher priority to avoid shadowing by, for example,
 196           ;; `hl-line-mode'.
 197           (overlay-put o 'priority 999)
 198           o))
 199   (setq deactivate-mark t)
 200   (dolist (thing (if (use-region-p)
 201                      '(region url email line)
 202                    '(url email line)))
 203     (easy-kill-thing thing n)
 204     (when (overlay-get easy-kill-candidate 'thing)
 205       (return)))
 206   (easy-kill-activate-keymap))
 207
 208 ;;; Extended things
 209
 210 (put 'region 'bounds-of-thing-at-point
 211      (lambda () (cons (region-beginning) (region-end))))
 212
 213 (defun easy-kill-on-buffer-file-name (n)
 214   "Get `buffer-file-name' or `default-directory'.
 215 If N is zero, remove the directory part; negative, remove the
 216 file name party; positive, full path."
 217   (let ((file (or buffer-file-name default-directory)))
 218     (when file
 219       (let* ((file (directory-file-name file))
 220              (text (cond
 221                     ((zerop n) (file-name-nondirectory file))
 222                     ((plusp n) file)
 223                     (t (file-name-directory file)))))
 224         (easy-kill-adjust-candidate 'buffer-file-name text)))))
 225
 226 (put 'buffer-file-name 'easy-kill-enlarge 'easy-kill-on-buffer-file-name)
 227
 228 (defun easy-kill-on-url (&optional _n)
 229   "Get url at point or from char properties.
 230 Char properties `help-echo', `shr-url' and `w3m-href-anchor' are
 231 inspected."
 232   (if (bounds-of-thing-at-point 'url)
 233       (easy-kill-thing 'url nil t)
 234     (let ((get-url (lambda (text)
 235                      (when (stringp text)
 236                        (with-temp-buffer
 237                          (insert text)
 238                          (and (bounds-of-thing-at-point 'url)
 239                               (thing-at-point 'url)))))))
 240       (dolist (p '(help-echo shr-url w3m-href-anchor))
 241         (pcase-let* ((`(,text . ,ov)
 242                       (get-char-property-and-overlay (point) p))
 243                      (url (or (funcall get-url text)
 244                               (funcall get-url
 245                                        (and ov (overlay-get ov p))))))
 246           (when url
 247             (easy-kill-adjust-candidate 'url url)
 248             (return url)))))))
 249
 250 (provide 'easy-kill)
 251 ;;; easy-kill.el ends here