;;; search-menu.el --- pop up a window for control search and replace --- FSF Emacs 19:

;; Author: Bryan M. Kramer   <kramer@ai.toronto.edu>
;; Created: April 22, 1994
;; Version: 1.1   April 25, 1994.
;; Keywords: search, replace, form


;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:
;;  ----------
;;
;;  This is useful for certain kinds of editing. i-search is usually more
;;  appropriate for searching.
;;  
;;  usage: (load-library "search-menu")
;;         M-x search-menu
;;
;;    (it's more convenient from a menu or a key sequence)
;;
;; Optional Customization:
;;    
;;    Specify the size and location of the control menu by specifying
;;    frame parameters in searchm-frame-parameters
;;
;;    Specify the colours and fonts using the variables:
;;
;;    	searchm-button-face - font, foreground, and background for
;;    	            	    	buttons
;;    	searchm-button-mouse-face - font, foreground, and background for
;;    	                            buttons when under mouse
;;    	searchm-buffer-name-face - font, foreground and background for target buffer
;;    	    	    	    	   name
;;    	searchm-field-face - font, foreground, and background used for fields
;;    	searchm-field-label-face - font, foreground, and background used for field labels
;;
;;    eg: (setq searchm-button-face '("9x15" "white" "blue"))
;;
;;    Setting these to nil is possible and very safe (uses your emacs' defaults.)
;;
;;
;;    In addition    	    	    	   
;;      searchm-button-font set to a font name will change only the button fonts
;;
;;  TO CHANGE BUFFER BEING SEARCHED, invoke M-x search-menu from the desired buffer
;;
;;  buttons are activated using shift left mouse
;;  (I'd like to use left mouse but I haven't figured out how to get it to work
;;  with drag and transient mark etc.)
;;  
;;  type a regexp beside pattern:, the click on "Search" and the expected will occur;
;;        ditto "Search Backward"
;;  "Replace" will replace the pattern with the "Substitution:" if the current
;;        buffer location is looking-at the pattern.
;;  "Replace and Search" will follow the replacement with a search
;;  "Replace All" will replace all subsequent matches a la replace-regexp
;;  "Undo" undoes the last change
;;  "Execute Emacs-Lisp" interprets the contents of of the Emacs-Lisp: field as an s-expression
;;      and evaluates it. Presumably it does something different at different locations
;;      in the target buffer
;;  "Grep" invokes grep with Pattern: on either the file of the target buffer (default) or the
;;      specified files.
;;
;;  NOTES:
;;  	Field extraction (i.e. for patterns and subsitutions)
;;  	               truncates leading and trailing whitespace.
;;  	
;;
;;;  Change Log
;;
;;   Apr 25, 1994 -- changed style to match FSF conventions; added comments.
;;   	    	     add variables to control fonts and colours, bug fixes
;;   	    	     more robustness, now loads if default fonts or colours
;;   	    	     do not exist
;;
;;   Apr 27, 1994 -- changed to make use of text properties to find commands
;;   	    	     for buttons and to make everything but fields read only
;;
;;   	    	     



(defvar searchm-frame-parameters '((top . 100) (left . -200) (height . 14)
				   (width . 60) (menu-bar-lines . 0) (minibuffer . nil)
				   (vertical-scroll-bars . nil)))

(defvar searchm-use-black-and-white nil "Force black and white display of search menu")

(defvar searchm-button-font "-adobe-courier-bold-o-normal--12-120-75-75-m-70-iso8859-1"
  "Font to use for buttons")

(defun searchm-fontify-button (pos1 pos2)
  (put-text-property pos1 pos2 'mouse-face 'searchm-highlight)
  (put-text-property pos1 pos2 'face 'searchm-button)
  )

(defvar searchm-current-buffer nil "Buffer search-menu is looking at")
(defvar searchm-current-directory nil "Directory of buffer that search-menu is looking at")

(defvar searchm-control-buffer nil "Buffer containing search menu")


(defvar searchm-button-face '(searchm-button-font "white" "CadetBlue")
  "font, foreground, and background for search menu buttons")

(defvar searchm-buffer-name-face '(searchm-button-font "red" "white")
  "font, foreground, and background for search menu buffer name display")

(defvar searchm-button-mouse-face '(searchm-button-font "black" "darkseagreen2")
  "font, foreground, and background for search menu buttons under mouse")

(defvar searchm-field-face '(nil nil "grey89"))

(defvar searchm-field-label-face '(searchm-button-font nil nil))

;; set the face font only if there is no error

(defun searchm-set-face-font (name font-spec)
  (condition-case nil
      (set-face-font name font-spec)
    (error (set-face-font name nil))
    )
  )


;; Process colour spec (foreground background) and make appropriate
;; choices depending on whether the colours exist and if the fields
;; should be inverted

(defun searchm-verify-colours (name spec invert-on-black-and-white)
  (cond ((and (not searchm-use-black-and-white) (x-display-color-p))
	 (let ((fore (car spec))
	       (back (car (cdr spec)))
	       (invalid nil))
	   (if (or (null fore) (and (stringp fore) (x-color-defined-p fore)))
	       (set-face-foreground name fore)
	     (setq invalid t))
	   (if (or (null back) (and (stringp back) (x-color-defined-p back)))
	       (set-face-background name back)
	     (setq invalid t))
	   (if invalid
	       (if invert-on-black-and-white
		   (progn
		     (set-face-foreground name "white")
		     (set-face-background name "black"))
		 (progn
		   (set-face-background name "white")
		   (set-face-foreground name "black"))))))
	((and spec (equal (car spec) "white"))
	 (set-face-foreground name "white")
	 (set-face-background name "black"))
	((and spec (equal (car spec) "black"))
	 (set-face-foreground name "black")
	 (set-face-background name "white"))
	(invert-on-black-and-white
	 (set-face-foreground name "white")
	 (set-face-background name "black"))
	(t
	 (set-face-background name "white")
	 (set-face-foreground name "black"))))


;; create or modify the face as specified by spec

(defun searchm-create-face (name spec invert-on-black-and-white)
  (if (not (member name (face-list)))
      (make-face name))
  (cond ((and (symbolp spec) (member spec (face-list)))
	 (copy-face name spec))
	((listp spec)
	 (if (symbolp (car spec))
	     (searchm-set-face-font name (eval (car spec)))
	   (searchm-set-face-font name (car spec)))
	 (searchm-verify-colours name (cdr spec) invert-on-black-and-white))
	(t (error "Invalid face specification"))))

(searchm-create-face 'searchm-button searchm-button-face t)
(searchm-create-face 'searchm-buffer searchm-buffer-name-face t)
(searchm-create-face 'searchm-highlight searchm-button-mouse-face nil)
(searchm-create-face 'searchm-field-label searchm-field-label-face t)
(searchm-create-face 'searchm-field searchm-field-face t)

(defvar searchm-s 'searchm-s)
(defvar searchm-b 'searchm-b)
(defvar searchm-e 'searchm-e)
(defvar searchm-f 'searchm-f)
(defvar searchm-ps 'searchm-ps)
(defvar searchm-pg 'searchm-pg)
(defvar searchm-p 'searchm-p)
(defvar searchm-g-args 'searchm-g-args)


;; Set the face and mouse face for the first match of the pattern

(defun searchm-set-properties (pattern face mouse-face writable command)
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward pattern)
      (let ((pos1 (match-beginning 0))
	    (pos2 (match-end 0)))
	(put-text-property pos1 pos2 'face face)
	(if mouse-face
	  (put-text-property pos1 pos2 'mouse-face mouse-face))
	(if command
	    (put-text-property pos1 pos2 'searchm-command command))
	(if writable
	    (put-text-property pos1 pos2 'read-only nil))))))


;; Set properties for a field - pattern indicates start of field
;; end-of-line is considered end. Must make it writable

(defun searchm-set-field (pattern face mouse-face writable command)
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward pattern)
	(let ((pos1 (match-end 0))
	      (pos2 (progn (end-of-line) (point))))
	  (put-text-property (- pos1 1) pos2 'face face)
	  (if mouse-face
	      (put-text-property pos1 pos2 'mouse-face mouse-face))
	  (if command
	      (put-text-property pos1 pos2 'searchm-command command))
	  (if writable
	      (progn (put-text-property pos1 (+ 1 pos1) 'read-only 'a)
		(put-text-property pos2 (+ 1 pos2) 'read-only 'b)))))))


(defvar searchm-command-patterns
    '(
      ("\\<Replace and Search\\>" searchm-rep-search searchm-ps)
      ("\\<Beginning of Buffer\\>" beginning-of-buffer)
      ("\\<Execute Emacs-Lisp\\>" searchm-emacs-lisp searchm-f)
      ("\\<Replace All\\>" searchm-replace-all searchm-ps)
      ("\\<Search Backward\\>" searchm-search-back searchm-s)
      ("\\<Search\\>" searchm-search searchm-s)
      ("\\<Replace\\>" searchm-replace searchm-ps)
      ("\\<Undo\\>" searchm-undo)
      ("\\<Dismiss\\>" searchm-dismiss)
      ("\\<Grep\\>" searchm-grep searchm-pg)
      )
  "Possible commands in search menu")


;; invoke the grep command as specified by the search control window

(defun searchm-grep (form files)
  (if (null form) (error "No grep pattern."))
  (grep (concat "grep -n -i -e '" form "' "
		(or files
		    (file-name-nondirectory (buffer-file-name searchm-current-buffer))))
	)
  )


;; execute some emacs lisp form

(defun searchm-emacs-lisp (form) (eval form))


;; get rid of control window

(defun searchm-dismiss ()
  (let* ((window (get-buffer-window searchm-control-buffer t))
	 (frame (and (windowp window) (window-frame window))))
    (if (framep frame)
	(delete-frame frame))))


;; what can I say?

(defun searchm-undo ()
  (undo 1))


;; replace text at point with substitution 

(defun searchm-replace (pattern substitution)
  (if (null pattern) (error "No search pattern specified"))
  (if (looking-at pattern)
    (progn (undo-boundary) (replace-match (or substitution "")))
    (error "Text at current position does not match pattern. Have you moved the point?")))


;; replace all remaining occurrences of pattern with substitution

(defun searchm-replace-all (pattern substitution)
  (if (null pattern) (error "No search pattern specified"))
  (undo-boundary)
  (while (re-search-forward pattern nil t)
    (replace-match (or substitution "") nil nil)))


;; replace and search again in the controlled buffer

(defun searchm-rep-search (pattern substitution)
  (if (null pattern) (error "No search pattern specified"))
  (if (looking-at pattern)
      (progn
	(undo-boundary)
	(replace-match (or substitution ""))
	(searchm-search pattern))
    (error "Text at current position does not match pattern. Have you moved the point?")))


;; Search forward in the controlled buffer for pattern

(defun searchm-search (pattern)
  (if (null pattern) (error "No search pattern specified"))
  (forward-char)
  (if (re-search-forward pattern)
      (progn
	(deactivate-mark)
	(goto-char (match-end 0))
	(push-mark (match-beginning 0) t t)
	(exchange-point-and-mark))))


;; Search backward in the controlled buffer for pattern

(defun searchm-search-back (pattern)
  (if (null pattern) (error "No search pattern specified"))
  (if (re-search-backward pattern)
      (progn
	(deactivate-mark)
	(goto-char (match-end 0))
	(set-mark (match-beginning 0))
	(exchange-point-and-mark))))
  

;; Extract a field value (as specified by n) from the control buffer

(defun searchm-pattern-field (n)
  (save-excursion
    (let ((pos (point-min)))
      (goto-char (point-min))
      (cond ((eq n searchm-s)
	     (if (re-search-forward "^Substitution:[ 	]*\\(.*[^ 	]\\)[ 	]*$" (point-max) 'yes)
		 (buffer-substring (match-beginning 1) (match-end 1))))
	    ((eq n searchm-b)
	     (if (re-search-forward "^Buffer::[ 	]+\\(.*[^ 	]\\)[ 	]*$" (point-max) 'yes)
		 (buffer-substring (match-beginning 1) (match-end 1))))
	    ((eq n searchm-e)
	     (if (re-search-forward "^Emacs-Lisp:[ 	]*\\(.*[^ 	]\\)[ 	]*$" (point-max) 'yes)
		 (car (read-from-string (buffer-substring (match-beginning 1) (match-end 1))))))
	    ((eq n searchm-g-args)
	     (if (re-search-forward "^Grep.Files:[ 	]*\\(.*[^ 	]\\)[ 	]*$" (point-max) 'yes)
		 (buffer-substring (match-beginning 1) (match-end 1))))
	    (t
	     (if (re-search-forward "^Pattern:[ 	]*\\(.*[^ 	]\\)[ 	]*$" (point-max) 'yes)
		 (buffer-substring (match-beginning 1) (match-end 1))))))))


;; find values (from the buffer) of the arguments specified by the command

(defun searchm-get-args (command)
  (let ((spec (car (cdr command))))
    (cond ((eq spec searchm-pg)
	   (list (car command) (searchm-pattern-field searchm-p) (searchm-pattern-field searchm-g-args)))
	  ((eq spec searchm-ps)
	   (list (car command) (searchm-pattern-field searchm-p) (searchm-pattern-field searchm-s)))
	  ((eq spec searchm-f)
	   (list (car command) (searchm-pattern-field searchm-e)))
	  ((eq spec searchm-s)
	   (list (car command) (searchm-pattern-field searchm-p)))
	  (t (list (car command))))))


;; Execute a command in the context of the controlled buffer

(defun searchm-do-command (command)
  (let ((expr (searchm-get-args command)))
    (save-window-excursion
      (save-excursion
	(if searchm-current-buffer
	    (progn
	      (set-buffer searchm-current-buffer)
	      (let ((window (get-buffer-window searchm-current-buffer t)))
		(if (and (windowp window) (window-live-p window))
		    (progn
		      (select-window window)
		      (apply (car expr) (cdr expr)))
		  (error "Window is no longer live."))))
	  (error "No target buffer"))))))
	 


;; Identify the command, if any, that is at the position in the buffer
;; Commands are specified in teh searchm-command-patterns variable

(defun searchm-command-at-pos (buffer pos)
  (get-text-property pos 'searchm-command buffer))




;; Find and execute the command, if any, specified by a mouse click

(defun searchm-respond-to-click (click)
  ""
  (interactive "e")
  (let* ((start (event-start click))
	 (window (car start))
	 (buffer (and window (window-buffer window)))
	 (pos (car (cdr start)))
	 (command (and buffer (searchm-command-at-pos buffer pos))))
    (if command
	(searchm-do-command command)
      ;;(mouse-drag-region click)
      ;;(mouse-set-point click)
      )))

;; function to do search from key stroke

(defun searchm-call-search (&optional args)
  ""
  (interactive "P")
  (searchm-do-command '(searchm-search searchm-s)))

;; no-op to shadow global key bindings

(defun searchm-noop (&optional args)
  ""
  (interactive "P")
  (beep))

;; no-op to shadow global key bindings

(defun searchm-mouse-noop (click)
  ""
  (interactive "e")
  nil)


;; make everything in buf unreadable except those that already have
;; that property

(defun searchm-make-readonly (buf)
  (save-window-excursion
    (save-excursion
      (set-buffer buf)
      (goto-char (point-min))
      (end-of-line)
      (let ((p1 (+ (point) 1))
	    p2)
	(while (and p1 (setq p2 (next-single-property-change p1 'read-only buf)))
	  (put-text-property p1 (- p2 1) 'read-only t)
	  (setq p1 (next-single-property-change p2 'read-only buf))
	  (if p1 (setq p1 (+ 1 p1)))
	  )))))

;; create the search buffer

(defun searchm-setup-buffer (buf)
  (save-window-excursion
    (save-excursion
      (set-buffer buf)
      (insert-string "Buffer: \n\n")
      (insert-string "Pattern:\t  \n")
      (insert-string "Substitution:\t  \n")
      (insert-string "Emacs-Lisp:\t  \n\n")
      (insert-string "Search\tSearch Backward\t\tBeginning of Buffer\n\n")
      (insert-string "Replace\tReplace and Search\tReplace All\n\n")
      (insert-string "Undo\tExecute Emacs-Lisp\tDismiss\n\n")
      (insert-string "Grep\tFiles:\t  \n")
      ;(put-text-property (point-min) (point-max) 'read-only t buf)
      (searchm-set-properties "Buffer:.*$" 'searchm-buffer nil nil nil)
      (searchm-set-field "^Pattern:\t " 'searchm-field nil t nil)
      (searchm-set-field "^Substitution:\t " 'searchm-field nil t nil)
      (searchm-set-field "^Emacs-Lisp:\t " 'searchm-field nil t nil)
      (searchm-set-field "Files:\t " 'searchm-field nil t nil)
      (searchm-set-properties "^Pattern:\t" 'searchm-field-label nil nil nil)
      (searchm-set-properties "^Substitution:\t" 'searchm-field-label nil nil nil)
      (searchm-set-properties "^Emacs-Lisp:\t" 'searchm-field-label nil nil nil)
      (searchm-set-properties "Files:\t" 'searchm-field-label nil nil nil)
      (let ((ptr searchm-command-patterns))
	(while ptr
	  (searchm-set-properties (car (car ptr)) 'searchm-button 'searchm-highlight
				  nil (cdr (car ptr)))
	  (setq ptr (cdr ptr))
	  )
	) 
      (searchm-make-readonly buf)
      (local-set-key [S-mouse-1] 'searchm-respond-to-click)
      (local-set-key [S-down-mouse-1] 'searchm-mouse-noop)
      (local-set-key [S-up-mouse-1] 'mouse-set-point)
      (local-set-key "\C-m" 'searchm-call-search)
      (local-set-key "\C-j" 'searchm-call-search)
      (local-set-key "\C-y" 'yank)
      )
    )
  )

;; return the search control buffer, creating it if it is not present in a
;; reasonable form

(defun searchm-get-control-buffer ()
  (if (or (not searchm-control-buffer)
	  (not (bufferp searchm-control-buffer))
	  (null (buffer-name searchm-control-buffer))) ; deleted
      (progn
	(setq searchm-control-buffer (get-buffer-create "*sm control*"))
	(searchm-setup-buffer searchm-control-buffer)
	))
  searchm-control-buffer)


;; display the search control menu first inserting the name of the controlled buffer

(defun searchm-display-control-menu ()
  (let* ((buf (searchm-get-control-buffer))
	 (window (get-buffer-window buf t))
	 (frame (and window (window-live-p window) (window-frame window))))
    (if (null frame)
	(setq frame (make-frame searchm-frame-parameters)))
    (select-frame frame)
    (set-window-buffer (selected-window) buf)
    (beginning-of-buffer)
    (kill-line)
    (insert-string "Buffer: \t" (buffer-name searchm-current-buffer))
    (searchm-set-properties "Buffer:.*$" 'searchm-buffer nil nil nil)
    (re-search-forward "^Pattern:\t ")
    (make-frame-visible frame)
    (raise-frame frame)))


(defun search-menu ()
  "Pop up a frame containing fields and buttons for doing search."
  (interactive)
  (setq searchm-current-buffer (current-buffer))
  (searchm-display-control-menu)
  )


(provide 'search-menu)

;;; search-menu.el ends here

