emacs/nxhtml/util/anchored-transpose.el

   1 ;;; anchored-transpose.el --- Transposes a phrase around an anchor phrase
   2
   3 ;; Copyright (C) 2004 Free Software Foundation, Inc.
   4
   5 ;; Author: Rick Bielawski <rbielaws@i1.net>
   6 ;; Keywords: tools convenience
   7
   8 ;; This file is free software; you can redistribute it and/or modify it under
   9 ;; the terms of the GNU General Public License as published by the Free
  10 ;; Software Foundation; either version 2, or (at your option) any later
  11 ;; version.
  12
  13 ;; This file is distributed in the hope that it will be useful, but WITHOUT
  14 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
  16 ;; more details.
  17
  18 ;;; Commentary:
  19
  20 ;; `anchored-transpose' is an interactive autoload function to transpose
  21 ;; portions of a region around an anchor phrase.  In other words it swaps
  22 ;; two regions.
  23 ;;
  24 ;; See C-h f anchored-transpose <ret> for a complete description.
  25
  26 ;;; Installing:
  27
  28 ;; 1) Put anchored-transpose.el on your load path.
  29 ;; 2) Put the following 2 lines in your .emacs
  30 ;;    (global-set-key [?\C-x ?t] 'anchored-transpose) ;; Just a suggestion...
  31 ;;    (autoload 'anchored-transpose "anchored-transpose" nil t)
  32
  33 ;;; History:
  34
  35 ;; 2004-09-24 RGB Seems useable enough to release.
  36 ;; 2004-10-15 RGB Only comments and doc strings were updated.
  37 ;; 2004-10-22 RGB Added support for 2 phrase selection.
  38 ;; 2004-12-01 RGB Added secondary selection support.
  39 ;; 2005-07-21 RGB Updated help text and comments.
  40 ;;                Added support for A  C B  D and C  A D  B selection.
  41 ;;                Fixed bug affecting multi line selections.
  42 ;; 2005-09-28 RGB Allow swapping regions with no anchor text between.
  43
  44 ;; Changes by Lennart Borgman
  45 ;; 2009-11-25 LB  Set and clear secondary selection from keyboard.
  46 ;;                Always use secondary selection.
  47 ;;                Keep selections right after swapping.
  48 ;;                Clear them if not used again.
  49 ;;                Swap between buffers.
  50 ;;                Check for read-only.
  51 ;;                Probably broke something... ;-)
  52
  53 ;;; Code:
  54
  55 (defvar anchored-transpose-anchor ()
  56   "begin/end when `anchored-transpose' is in progress else nil")
  57
  58 ;;;###autoload
  59 (defun anchored-transpose (beg1 end1 flg1 &optional beg2 end2 flg2 win2)
  60   "Transpose portions of the region around an anchor phrase.
  61
  62 `this phrase but not that word'    can be transposed into
  63 `that word but not this phrase'
  64
  65 I want this phrase but not that word.
  66        |----------------------------|. .This is the entire phrase.
  67                   |-------|. . . . . . .This is the anchor phrase.
  68
  69 First select the entire phrase and type \\[anchored-transpose].
  70 This set the secondary selection.
  71
  72 Then select the anchor phrase and type \\[anchored-transpose]
  73 again.  Alternatively you can do the selections like this:
  74
  75 I want this phrase but not that word.
  76        |----------|       |---------|   Separate phrase selection.
  77
  78 By default the anchor phrase will automatically include
  79 any surrounding whitespace even if you don't explicitly select
  80 it.  Also, it won't include certain trailing punctuation.  See
  81 `anchored-transpose-do-fuzzy' for details.  A prefix arg prior to
  82 either selection means `no fuzzy logic, use selections
  83 literally'.
  84
  85 You can select the regions to be swapped separately in any
  86 order.
  87
  88 After swapping both primary and secondary selection are still
  89 active.  They will be canceled after second next command if you
  90 do not swap regions again.  \(Second because this allow you to
  91 adjust the regions and try again.)
  92
  93 You can also swap text between different buffers this way.
  94
  95 Typing \\[anchored-transpose] with nothing selected clears any
  96 prior selection, ie secondary selection."
  97   (interactive `(,(region-beginning) ,(region-end)
  98                  ,current-prefix-arg
  99                  ,@anchored-transpose-anchor))
 100   (setq anchored-transpose-anchor nil)
 101   (when (and mouse-secondary-overlay
 102              mark-active
 103              (overlay-buffer mouse-secondary-overlay)
 104              (/= (overlay-start mouse-secondary-overlay)
 105                  (overlay-end mouse-secondary-overlay)))
 106     (if (eq (overlay-buffer mouse-secondary-overlay) (current-buffer))
 107         (progn
 108           (setq beg2 (overlay-start mouse-secondary-overlay))
 109           (setq end2 (overlay-end mouse-secondary-overlay))
 110           (setq flg2 flg1)
 111           (delete-overlay mouse-secondary-overlay))
 112       (let* ((sec-buf (overlay-buffer mouse-secondary-overlay))
 113              (sec-win (get-buffer-window sec-buf))
 114              (sec-new nil))
 115         (unless sec-win
 116           (setq sec-new t)
 117           (setq sec-win (split-window)))
 118         (with-selected-window sec-win
 119           (set-window-buffer (selected-window) sec-buf)
 120           (goto-char (overlay-start mouse-secondary-overlay)))
 121         (if (not (y-or-n-p "Swap between buffers "))
 122             (when sec-new (delete-window sec-win))
 123           (setq beg2 (overlay-start mouse-secondary-overlay))
 124           (setq end2 (overlay-end mouse-secondary-overlay))
 125           (setq flg2 flg1)
 126           (setq win2 sec-win)))))
 127   (setq win2 (or win2 (selected-window)))
 128   (if mark-active
 129       (if end2                     ; then both regions are marked.  swap them.
 130           (if (not (eq win2 (selected-window)))
 131               (anchored-transpose-swap beg1 end1 beg2 end2 win2)
 132             (if (and (< beg1 beg2)        ;A  C B  D
 133                      (< end1 end2)
 134                      (> end1 beg2))
 135                 (apply 'anchored-transpose-swap
 136                        (anchored-transpose-do-fuzzy
 137                         beg1 beg2 end1 end2 flg1 flg2 flg1 flg2))
 138               (if (and (> beg1 beg2)      ;C  A D  B
 139                        (> end1 end2)
 140                        (> end2 beg1))
 141                   (apply 'anchored-transpose-swap
 142                          (anchored-transpose-do-fuzzy
 143                           beg2 beg1 end2 end1 flg2 flg1 flg2 flg1))
 144                 (if (and (< beg1 beg2)    ;A  C D  B
 145                          (> end1 end2))
 146                     (apply 'anchored-transpose-swap
 147                            (anchored-transpose-do-fuzzy
 148                             beg1 beg2 end2 end1 flg1 flg2 flg2 flg1))
 149                   (if (and (> beg1 beg2)  ;C  A B  D
 150                            (< end1 end2))
 151                       (apply 'anchored-transpose-swap
 152                              (anchored-transpose-do-fuzzy
 153                               beg2 beg1 end1 end2 flg2 flg1 flg1 flg2))
 154                     (if (<= end1 beg2)    ;A B  C D
 155                         (apply 'anchored-transpose-swap
 156                                (anchored-transpose-do-fuzzy
 157                                 beg1 end1 beg2 end2 flg1 flg1 flg2 flg2))
 158                       (if (<= end2 beg1)  ;C D A B
 159                           (apply 'anchored-transpose-swap
 160                                  (anchored-transpose-do-fuzzy
 161                                   beg2 end2 beg1 end1 flg2 flg2 flg1 flg1))
 162                         (error "Regions have invalid overlap"))))))))
 163         ;; 1st of 2 regions.  Save it and wait for the other.
 164         ;;(setq anchored-transpose-anchor (list beg1 end1 flg1))
 165         (if (or buffer-read-only
 166                 (get-char-property beg1 'read-only)
 167                 (get-char-property end1 'read-only))
 168             ;; Fix-me: move test, clean up a bit.
 169             (message "Buffer text is readonly")
 170           (set-secondary-selection beg1 end1)
 171           (setq deactivate-mark t)
 172           (message "%s" (this-command-keys))
 173           (message (propertize "Transpose: Select second region and call again - (without selection to cancel)"
 174                                'face 'secondary-selection))))
 175     (if (and mouse-secondary-overlay
 176              (overlay-buffer mouse-secondary-overlay))
 177         (progn
 178           (cancel-secondary-selection)
 179           (message (propertize "Canceled secondary selection" 'face
 180                                'highlight)))
 181       (message (propertize "Command requires a marked region" 'face
 182                            'highlight)))))
 183
 184 ;;;###autoload
 185 (defun set-secondary-selection (beg end)
 186   "Set the secondary selection to the current region.
 187 This must be bound to a mouse drag event."
 188   (interactive "r")
 189   (move-overlay mouse-secondary-overlay beg end (current-buffer))
 190   (when (called-interactively-p 'interactive)
 191     ;;(deactivate-mark)
 192     )
 193   (x-set-selection
 194    'SECONDARY
 195    (buffer-substring (overlay-start mouse-secondary-overlay)
 196                      (overlay-end mouse-secondary-overlay))))
 197
 198 ;;;###autoload
 199 (defun cancel-secondary-selection ()
 200   (interactive)
 201   (delete-overlay mouse-secondary-overlay)
 202   (x-set-selection 'SECONDARY nil))
 203
 204 (defun anchored-transpose-do-fuzzy (r1beg r1end r2beg r2end
 205                                           lit1 lit2 lit3 lit4)
 206   "Returns the first 4 arguments after adjusting their value if necessary.
 207
 208 I want this phrase but not that word.
 209        |----------------------------|. .This is the entire phrase.
 210                   |-------|. . . . . . .This is the anchor phrase.
 211      R1BEG      R1END   R2BEG     R2END
 212
 213 R1BEG and R1END define the first region and R2BEG and R2END the second.
 214
 215 The flags, LIT1 thru LIT4 indicate if fuzzy logic should be applied to the
 216 beginning of R1BEG, the end of R1END, the beginning of R2BEG, the end of R2END
 217 respectively.  If any flag is nil then fuzzy logic will be applied.  Otherwise
 218 the value passed should be returned LITerally (that is, unchanged).
 219
 220 See `anchored-transpose-fuzzy-begin' and `anchored-transpose-fuzzy-end' for
 221 specifics on what adjustments these routines will make when LITx is nil."
 222   (list
 223    (if lit1 r1beg
 224      (anchored-transpose-fuzzy-begin r1beg r1end "[\t ]+"))
 225    (if lit2 r1end
 226      (anchored-transpose-fuzzy-end   r1beg r1end "\\s +"))
 227    (if lit3 r2beg
 228      (anchored-transpose-fuzzy-begin r2beg r2end "[\t ]+"))
 229    (if lit4 r2end
 230      (anchored-transpose-fuzzy-end   r2beg r2end "\\s *[.!?]"))
 231    nil))
 232
 233 (defun anchored-transpose-fuzzy-end (beg end what)
 234   "Returns END or new value for END based on the regexp WHAT.
 235 BEG and END are buffer positions defining a region.  If that region ends
 236 with WHAT then the value for END is adjusted to exclude that matching text.
 237
 238 NOTE: The regexp is applied differently than `looking-back' applies a regexp.
 239
 240 Example: if (buffer-string beg end) contains `1234' the regexp `432' matches
 241 it, not `234' as `looking-back' would.  Also, your regexp never sees the char
 242 at BEG so the match will always leave at least 1 character to transpose.
 243 The reason for not using looking-back is that it's not greedy enough.
 244 \(looking-back \" +\") will only match one space no matter how many exist."
 245   (let ((str (concat
 246               (reverse (append (buffer-substring (1+ beg) end) nil)))))
 247     (if (string-match (concat "`" what) str)
 248         (- end (length (match-string 0 str)))
 249       end)))
 250
 251 (defun anchored-transpose-fuzzy-begin (beg end what)
 252   "Returns BEG or a new value for BEG based on the regexp WHAT.
 253 BEG and END are buffer positions defining a region.  If the region begins
 254 with WHAT then BEG is adjusted to exclude the matching text.
 255
 256 NOTE: Your regexp never sees the last char defined by beg/end.  This insures
 257 at least 1 char is always left to transpose."
 258   (let ((str (buffer-substring beg (1- end))))
 259     (if (string-match (concat "`" what) str)
 260         (+ beg (length (match-string 0 str)))
 261       beg)))
 262
 263 (defun anchored-transpose-swap (r1beg r1end r2beg r2end win2)
 264   "Swaps region r1beg/r1end with r2beg/r2end. Flags are currently ignored.
 265 Point is left at r1end."
 266   (let ((reg1 (buffer-substring r1beg r1end))
 267         (reg2 nil)
 268         (old-buffer (current-buffer)))
 269     (when win2
 270       (unless (eq (selected-window) win2)
 271         (select-window win2)
 272         (set-buffer (window-buffer (selected-window)))))
 273     (setq reg2 (delete-and-extract-region r2beg r2end))
 274     (goto-char r2beg)
 275     (let ((new-mark (point)))
 276       (insert reg1)
 277       (push-mark new-mark))
 278     ;; I want to leave point at the end of phrase 2 in current buffer.
 279     (save-excursion
 280       (with-current-buffer old-buffer
 281         (goto-char r1beg)
 282         (delete-region r1beg r1end)
 283         (let ((here (point)))
 284           (insert reg2)
 285           (set-secondary-selection here (point)))))
 286     (setq deactivate-mark nil)
 287     (when (eq old-buffer (current-buffer))
 288       (add-hook 'post-command-hook 'anchored-swap-post-command t t))))
 289
 290 (defun anchored-swap-post-command ()
 291   (condition-case err
 292       (unless mark-active
 293         (cancel-secondary-selection)
 294         (remove-hook 'post-command-hook 'anchored-swap-post-command t))
 295     (error (message "anchored-swap-post-command: %s" err))))
 296
 297 (provide 'anchored-transpose)
 298
 299 ;; Because I like it this way.  So there!
 300 ;;; fill-column:78 ***
 301 ;;; emacs-lisp-docstring-fill-column:78 ***
 302 ;;;
 303 ;;; Local Variables: ***
 304 ;;; End: ***
 305 ;;; anchored-transpose.el ends here.