emacs/nxhtml/util/search-form.el

   1 ;;; search-form.el --- Search form
   2 ;;
   3 ;; Author: Lennart Borgman (lennart O borgman A gmail O com)
   4 ;; Created: 2008-05-05T01:50:20+0200 Sun
   5 ;; Version: 0.11
   6 ;; Last-Updated:
   7 ;; URL:
   8 ;; Keywords:
   9 ;; Compatibility:
  10 ;;
  11 ;; Features that might be required by this library:
  12 ;;
  13 ;;   `cus-edit', `cus-face', `cus-load', `cus-start', `wid-edit'.
  14 ;;
  15 ;;;;;;;;;;seasfireplstring                                                             ;;
  16 ;;
  17 ;;; Commentary:
  18 ;;
  19 ;; After an idea by Eric Ludlam on Emacs Devel:
  20 ;;
  21 ;;  http://lists.gnu.org/archive/html/emacs-devel/2008-05/msg00152.html
  22 ;;
  23 ;; NOT QUITE READY! Tagged files have not been tested.
  24 ;;
  25 ;; Fix-me: work on other windows buffer by default, not buffer from
  26 ;; where search form was created.
  27 ;;
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;
  30 ;;; Change log:
  31 ;;
  32 ;;
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;;
  35 ;; This program is free software; you can redistribute it and/or
  36 ;; modify it under the terms of the GNU General Public License as
  37 ;; published by the Free Software Foundation; either version 2, or
  38 ;; (at your option) any later version.
  39 ;;
  40 ;; This program is distributed in the hope that it will be useful,
  41 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  42 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  43 ;; General Public License for more details.
  44 ;;
  45 ;; You should have received a copy of the GNU General Public License
  46 ;; along with this program; see the file COPYING.  If not, write to
  47 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  48 ;; Floor, Boston, MA 02110-1301, USA.
  49 ;;
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51 ;;
  52 ;;; Code:
  53
  54 (eval-when-compile (require 'ourcomments-util))
  55 (require 'cus-edit)
  56 (require 'grep)
  57
  58 (defvar search-form-sfield nil)
  59 (make-variable-buffer-local 'search-form-sfield)
  60 (defvar search-form-rfield nil)
  61 (make-variable-buffer-local 'search-form-rfield)
  62
  63 (defvar search-form-win-config nil)
  64 (make-variable-buffer-local 'search-form-win-config)
  65 (put 'search-form-win-config 'permanent-local t)
  66
  67 (defvar search-form-current-buffer nil)
  68
  69 (defun search-form-multi-occur-get-buffers ()
  70   (let* ((bufs (list (read-buffer "First buffer to search: "
  71                                   (current-buffer) t)))
  72          (buf nil)
  73          (ido-ignore-item-temp-list bufs))
  74     (while (not (string-equal
  75                  (setq buf (read-buffer
  76                             (if (eq read-buffer-function 'ido-read-buffer)
  77                                 "Next buffer to search (C-j to end): "
  78                               "Next buffer to search (RET to end): ")
  79                             nil t))
  80                  ""))
  81       (add-to-list 'bufs buf)
  82       (setq ido-ignore-item-temp-list bufs))
  83     (nreverse (mapcar #'get-buffer bufs))))
  84
  85 (defvar search-form-buffer) ;; dyn var, silence compiler
  86 (defvar search-form-search-string) ;; dyn var, silence compiler
  87 (defvar search-form-replace-string) ;; dyn var, silence compiler
  88
  89 (defun search-form-notify-1 (use-search-field
  90                              use-replace-field
  91                              w
  92                              hide-form
  93                              display-orig-buf)
  94   (let ((search-form-search-string  (when use-search-field  (widget-value search-form-sfield)))
  95         (search-form-replace-string (when use-replace-field (widget-value search-form-rfield)))
  96         (search-form-buffer (current-buffer))
  97         (this-search (widget-get w :do-search))
  98         (do-it t))
  99     (if (and use-search-field
 100                (= 0 (length search-form-search-string)))
 101         (progn
 102           (setq do-it nil)
 103           (message "Please specify a search string"))
 104       (when (and use-replace-field
 105                  (= 0 (length search-form-replace-string)))
 106         (setq do-it nil)
 107         (message "Please specify a replace string")))
 108     (when do-it
 109       (if hide-form
 110           (progn
 111             (set-window-configuration search-form-win-config)
 112             (funcall this-search search-form-search-string)
 113             ;;(kill-buffer search-form-buffer)
 114             )
 115         (when display-orig-buf
 116           (let ((win (display-buffer search-form-current-buffer t)))
 117             (select-window win t)))
 118         ;;(funcall this-search search-form-search-string))
 119         (funcall this-search w)
 120         ))))
 121
 122 (defun search-form-notify-no-field (w &rest ignore)
 123   (search-form-notify-1 nil nil w nil t))
 124
 125 (defun search-form-notify-sfield (w &rest ignore)
 126   (search-form-notify-1 t nil w nil t))
 127
 128 (defun search-form-notify-sfield-nobuf (w &rest ignore)
 129   (search-form-notify-1 t nil w nil nil))
 130
 131 (defun search-form-notify-both-fields (w &rest ignore)
 132   (search-form-notify-1 t t w nil t))
 133
 134 (defun search-form-insert-button (title function descr do-search-fun)
 135   (widget-insert "  ")
 136   (let ((button-title (format " %-15s " title)))
 137     (widget-create 'push-button
 138                    :do-search do-search-fun
 139                    :notify 'search-form-notify-no-field
 140                    :current-buffer search-form-current-buffer
 141                    button-title))
 142   (widget-insert " " descr)
 143   (widget-insert "\n"))
 144
 145 (defun search-form-insert-search (title search-fun descr do-search-fun no-buf)
 146   (widget-insert "  ")
 147   (let ((button-title (format " %-15s " title)))
 148     (if no-buf
 149         (widget-create 'push-button
 150                        :do-search do-search-fun
 151                        :notify 'search-form-notify-sfield-nobuf
 152                        :current-buffer search-form-current-buffer
 153                        button-title)
 154       (widget-create 'push-button
 155                      :do-search do-search-fun
 156                      :notify 'search-form-notify-sfield
 157                      :current-buffer search-form-current-buffer
 158                      button-title)
 159       ))
 160   (widget-insert " " descr " ")
 161   (search-form-insert-help search-fun)
 162   (widget-insert "\n"))
 163
 164 (defun search-form-insert-fb (descr
 165                               use-sfield
 166                               forward-fun
 167                               do-forward-fun
 168                               backward-fun
 169                               do-backward-fun)
 170   (widget-insert (format "  %s: " descr))
 171   (widget-create 'push-button
 172                  :do-search do-forward-fun
 173                  :use-sfield use-sfield
 174                  :notify '(lambda (widget &rest event)
 175                             (if (widget-get widget :use-sfield)
 176                                 (search-form-notify-sfield widget)
 177                               (search-form-notify-no-field widget)))
 178                  :current-buffer search-form-current-buffer
 179                  " Forward ")
 180   (widget-insert " ")
 181   (search-form-insert-help forward-fun)
 182   (widget-insert "  ")
 183   (widget-create 'push-button
 184                  :do-search do-backward-fun
 185                  :use-sfield use-sfield
 186                  :notify '(lambda (widget &rest event)
 187                             (if (widget-get widget :use-sfield)
 188                                 (search-form-notify-sfield widget)
 189                               (search-form-notify-no-field widget)))
 190                  :current-buffer search-form-current-buffer
 191                  " Backward ")
 192   (widget-insert " ")
 193   (search-form-insert-help backward-fun)
 194   (widget-insert "\n"))
 195
 196 (defun search-form-insert-replace (title replace-fun descr do-replace-fun)
 197   (widget-insert "  ")
 198   (let ((button-title (format " %-15s " title)))
 199     (widget-create 'push-button
 200                    :do-search do-replace-fun
 201                    :notify 'search-form-notify-both-fields
 202                    :current-buffer search-form-current-buffer
 203                    button-title))
 204   (widget-insert " " descr " ")
 205   (search-form-insert-help replace-fun)
 206   (widget-insert "\n"))
 207
 208 (defun search-form-insert-help (fun)
 209   (widget-insert "(")
 210   (widget-create 'function-link
 211                  :value fun
 212                  :tag "help"
 213                  :button-face 'link)
 214   (widget-insert ")"))
 215
 216 (defun sf-widget-field-value-set (widget value)
 217   "Set current text in editing field."
 218   (let ((from (widget-field-start widget))
 219         (to (widget-field-end widget))
 220         (buffer (widget-field-buffer widget))
 221         (size (widget-get widget :size))
 222         (secret (widget-get widget :secret))
 223         (old (current-buffer)))
 224     (if (and from to)
 225         (progn
 226           (set-buffer buffer)
 227           (while (and size
 228                       (not (zerop size))
 229                       (> to from)
 230                       (eq (char-after (1- to)) ?\s))
 231             (setq to (1- to)))
 232           (goto-char to)
 233           (delete-region from to)
 234           (insert value)
 235           (let ((result (buffer-substring-no-properties from to)))
 236             (when secret
 237               (let ((index 0))
 238                 (while (< (+ from index) to)
 239                   (aset result index
 240                         (get-char-property (+ from index) 'secret))
 241                   (setq index (1+ index)))))
 242             (set-buffer old)
 243             result))
 244       (widget-get widget :value))))
 245
 246 (defvar search-form-form nil)
 247
 248 (defun search-form-isearch-end ()
 249   (condition-case err
 250       (progn
 251         (message "sfie: search-form-form=%s" (widget-value (cdr search-form-form)))
 252         (remove-hook 'isearch-mode-end-hook 'search-form-isearch-end)
 253         ;; enter isearch-string in field
 254         (with-current-buffer (car search-form-form)
 255           ;; Fix-me: trashes the widget, it disappears... - there seem
 256           ;; to be know default set function.
 257           ;;(widget-value-set (cdr search-form-form) isearch-string)
 258           ))
 259     (error (message "search-form-isearch-end: %S" err))))
 260
 261 (defun search-form-isearch-forward (w)
 262   (interactive)
 263   (add-hook 'isearch-mode-end-hook 'search-form-isearch-end)
 264   (with-current-buffer search-form-buffer
 265     (setq search-form-form (cons search-form-buffer search-form-sfield))
 266     (message "sfif: cb=%s field=%S" (current-buffer) (widget-value (cdr search-form-form)))
 267     )
 268   (call-interactively 'isearch-forward))
 269
 270 (defun search-form-isearch-backward (w)
 271   (interactive)
 272   (add-hook 'isearch-mode-end-hook 'search-form-isearch-end)
 273   (setq search-form-form search-form-sfield)
 274   (call-interactively 'isearch-backward))
 275
 276 ;;;###autoload
 277 (defun search-form ()
 278   "Display a form for search and replace."
 279   (interactive)
 280   (let* ((buf-name "*Search Form*")
 281          (cur-buf (current-buffer))
 282          (buffer (get-buffer-create buf-name))
 283          (win-config (current-window-configuration)))
 284     (setq search-form-current-buffer (current-buffer))
 285     (with-current-buffer buffer
 286       (set (make-local-variable 'search-form-win-config) win-config))
 287     (switch-to-buffer-other-window buffer)
 288
 289     (kill-all-local-variables) ;; why???
 290     (let ((inhibit-read-only t))
 291       (erase-buffer))
 292     ;;(Custom-mode)
 293     (remove-overlays)
 294
 295     (make-local-variable 'widget-button-face)
 296     (setq widget-button-face custom-button)
 297     (setq show-trailing-whitespace nil)
 298     (when custom-raised-buttons
 299       (set (make-local-variable 'widget-push-button-prefix) "")
 300       (set (make-local-variable 'widget-push-button-suffix) "")
 301       (set (make-local-variable 'widget-link-prefix) "")
 302       (set (make-local-variable 'widget-link-suffix) ""))
 303
 304     (widget-insert (propertize "Search/Replace, buffer: " 'face 'font-lock-comment-face))
 305     (widget-insert (format "%s" (buffer-name search-form-current-buffer)))
 306     (let ((file (buffer-file-name search-form-current-buffer)))
 307       (when file
 308         (insert " (" file ")")))
 309     (widget-insert "\n\n")
 310     (search-form-insert-fb
 311      "Incremental String Search" nil
 312      'isearch-forward
 313      'search-form-isearch-forward
 314      'isearch-backward
 315      'search-form-isearch-backward)
 316
 317     (search-form-insert-fb
 318      "Incremental Regexp Search" nil
 319      'isearch-forward-regexp
 320      (lambda (w) (call-interactively 'isearch-forward-regexp))
 321      'isearch-backward-regexp
 322      (lambda (w) (call-interactively 'isearch-backward-regexp)))
 323
 324     ;; Fix-me: in multiple buffers, from buffer-list
 325
 326     (widget-insert (make-string (window-width) ?-) "\n")
 327
 328     (widget-insert "Search: ")
 329     (setq search-form-sfield
 330           (widget-create 'editable-field
 331                          :size 58))
 332     (widget-insert "\n\n")
 333     (widget-insert (propertize "* Buffers:" 'face 'font-lock-comment-face) "\n")
 334     (search-form-insert-fb "String Search" t
 335                            'search-forward
 336                            (lambda (w) (search-forward search-form-search-string))
 337                            'search-backward
 338                            (lambda (w) (search-backward search-form-search-string)))
 339
 340     (search-form-insert-fb "Regexp Search" t
 341                            're-search-forward
 342                            (lambda (w) (re-search-forward search-form-search-string))
 343                            're-search-backward
 344                            (lambda (w) (re-search-backward search-form-search-string)))
 345
 346     ;; occur
 347     (search-form-insert-search "Occur" 'occur
 348                                "Lines in buffer"
 349                                (lambda (w)
 350                                  (with-current-buffer (widget-get w :current-buffer)
 351                                    (occur search-form-search-string)))
 352                                t)
 353
 354     ;; multi-occur
 355     ;; Fix-me: This should be done from buffer-list. Have juri finished that?
 356     (search-form-insert-search "Multi-Occur" 'multi-occur
 357                                "Lines in specified buffers"
 358                                (lambda (w)
 359                                  (let ((bufs (search-form-multi-occur-get-buffers)))
 360                                    (multi-occur bufs search-form-search-string)))
 361                                t)
 362     ;;
 363     (widget-insert "\n")
 364     (widget-insert (propertize "* Files:" 'face 'font-lock-comment-face)
 365                    "\n")
 366
 367     (search-form-insert-search "Search in Dir" 'lgrep
 368                                "Grep in directory"
 369                                'search-form-lgrep
 370                                t)
 371     (search-form-insert-search "Search in Tree" 'rgrep
 372                                "Grep in directory tree"
 373                                'search-form-rgrep
 374                                t)
 375
 376     (widget-insert "\n")
 377
 378     (search-form-insert-search "Tagged Files" 'tags-search
 379                                "Search files in tags table"
 380                                (lambda (w)
 381                                  (with-current-buffer (widget-get w :current-buffer)
 382                                    (tags-search search-form-search-string)))
 383                                t)
 384
 385     (widget-insert (make-string (window-width) ?-) "\n")
 386
 387     (widget-insert "Replace: ")
 388     (setq search-form-rfield
 389           (widget-create 'editable-field
 390                          :size 58))
 391     (widget-insert "\n\n")
 392
 393     (widget-insert (propertize "* Buffers:" 'face 'font-lock-comment-face) "\n")
 394     (search-form-insert-replace "Replace String"
 395                                 'query-replace
 396                                 "In buffer from point"
 397                                 (lambda (w)
 398                                   (query-replace search-form-search-string search-form-replace-string)))
 399
 400     (search-form-insert-replace "Replace Regexp"
 401                                 'query-replace-regexp
 402                                 "In buffer from point"
 403                                 (lambda (w)
 404                                   (query-replace-regexp search-form-search-string search-form-replace-string)))
 405
 406     (widget-insert "\n" (propertize "* Files:" 'face 'font-lock-comment-face) "\n")
 407
 408     ;; fix-me: rdir-query-replace (from to file-regexp root &optional delimited)
 409     (search-form-insert-replace "Replace in Dir"
 410                                 'ldir-query-replace
 411                                 "Replace in files in directory"
 412                                 'search-form-ldir-replace)
 413     (search-form-insert-replace "Replace in Tree"
 414                                 'rdir-query-replace
 415                                 "Replace in files in directory tree"
 416                                 'search-form-rdir-replace)
 417
 418     (widget-insert "\n")
 419
 420     (search-form-insert-replace "Tagged Files"
 421                                 'tags-query-replace
 422                                 "Replace in files in tags tables"
 423                                 (lambda (w)
 424                                   (tags-query-replace search-form-search-string search-form-replace-string)))
 425
 426     (buffer-disable-undo)
 427     (widget-setup)
 428     (buffer-enable-undo)
 429     (use-local-map widget-keymap)
 430     (fit-window-to-buffer)
 431     (widget-forward 1)
 432     ))
 433
 434 (defun search-form-lgrep (w)
 435   (search-form-r-or-lgrep w t))
 436
 437 (defun search-form-rgrep (w)
 438   (search-form-r-or-lgrep w nil))
 439
 440 (defun search-form-r-or-lgrep (w l)
 441   (with-current-buffer (widget-get w :current-buffer)
 442     (let* ((regexp search-form-search-string)
 443            (files (grep-read-files regexp))
 444            (dir (read-directory-name (if l "In directory: "
 445                                        "Base directory: ")
 446                                      nil default-directory t)))
 447       (if l
 448           (lgrep regexp files dir)
 449         (rgrep regexp files dir)
 450         ))))
 451
 452 (defun search-form-ldir-replace (w)
 453   (search-form-l-or-r-dir-replace w t))
 454
 455 (defun search-form-rdir-replace (w)
 456   (search-form-l-or-r-dir-replace w nil))
 457
 458 (defun search-form-l-or-r-dir-replace (w l)
 459   (let ((files (replace-read-files search-form-search-string search-form-replace-string))
 460         (dir (read-directory-name (if l
 461                                       "In directory: "
 462                                     "In directory tree: ")
 463                                   nil
 464                                   (file-name-directory
 465                                    (buffer-file-name search-form-current-buffer))
 466                                   t)))
 467     (if l
 468         (ldir-query-replace search-form-search-string search-form-replace-string files dir)
 469       (rdir-query-replace search-form-search-string search-form-replace-string files dir))))
 470
 471 (provide 'search-form)
 472 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 473 ;;; search-form.el ends here