cgit.sxemacs.org Git - packages/blob - xemacs-packages/ess/lisp/mouseme.el

   1 ;;; mouseme.el --- mouse menu with commands that operate on strings
   2
   3 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
   4
   5 ;; Author: Howard Melman <howard@silverstream.com>
   6 ;; Keywords: mouse menu
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs 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 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This package provides a command `mouse-me' to be bound to a mouse
  28 ;; button.  It pops up a menu of commands that operate on strings or a
  29 ;; region.  The string passed to the selected command is the word or
  30 ;; symbol clicked on (with surrounding quotes or other punctuation
  31 ;; removed), or the region (if either it was just selected with the
  32 ;; mouse or if it was active with `transient-mark-mode' on).  If the
  33 ;; command accepts a region, the selected region (or the region of the
  34 ;; word or symbol clicked on) will be passed to the command.
  35
  36 ;; The idea is that for any given string in a buffer you may want to
  37 ;; do different things regardless of the mode of the buffer.  URLs
  38 ;; now appear in email, news articles, comments in code, and in plain
  39 ;; text.  You may want to visit that URL in a browser or you may just
  40 ;; want to copy it to the kill-ring.  For an email address you might
  41 ;; want to compose mail to it, finger it, look it up in bbdb, copy it to
  42 ;; the kill ring.  For a word you may want to spell check it, copy it,
  43 ;; change its case, grep for it, etc.  Mouse-me provides a menu to
  44 ;; make this easy.
  45
  46 ;; The menu popped up is generated by calling the function in the
  47 ;; variable `mouse-me-build-menu-function' which defaults to calling
  48 ;; `mouse-me-build-menu' which builds the menu from the variable
  49 ;; `mouse-me-menu-commands'.  See the documentation for these
  50 ;; functions and variables for details.
  51
  52 ;; To install, add something like the following to your ~/.emacs:
  53 ;;   (require 'mouseme)
  54 ;;   (global-set-key [S-mouse-2] 'mouse-me)
  55
  56 ;;; Code:
  57
  58 (require 'browse-url)
  59 (require 'thingatpt)
  60
  61 (eval-when-compile (require 'compile))
  62
  63 ;;;; Variables
  64
  65 (defgroup mouseme nil
  66   "Popup menu of commands that work on strings."
  67   :prefix "mouse-me-"
  68   :group 'hypermedia)
  69
  70 (defcustom mouse-me-get-string-function 'mouse-me-get-string
  71   "*Function used by `mouse-me' to get string when no region selected.
  72 The default is `mouse-me-get-string' but this variable may commonly
  73 be made buffer local and set to something more appropriate for
  74 a specific mode (e.g., `word-at-point').  The function will be called
  75 with no arguments and with point at where the mouse was clicked.
  76 It can return either the string or to be most efficient, a list of
  77 three elements: the string and the beginning and ending points of the
  78 string in the buffer."
  79   :type 'function
  80   :options '(mouse-me-get-string)
  81   :group 'mouseme)
  82
  83 (defcustom mouse-me-build-menu-function 'mouse-me-build-menu
  84   "*Function used by `mouse-me' to build the popup menu.
  85 The default is `mouse-me-build-menu' but this variable may commonly
  86 be made buffer local and set to something more appropriate for
  87 a specific mode.  The function will be called with one argument,
  88 the string selected, as returned by `mouse-me-get-string-function'."
  89   :type 'function
  90   :options '(mouse-me-build-menu)
  91   :group 'mouseme)
  92
  93 (defvar mouse-me-grep-use-extension 't
  94   "*If non-nil `mouse-me-grep' grep's in files with current file's extension.")
  95
  96 (defcustom mouse-me-menu-commands
  97   '(("Copy" . kill-new)
  98     ("Kill" . kill-region)
  99     ("Capitalize" . capitalize-region)
 100     ("Lowercase" . downcase-region)
 101     ("Uppercase" . upcase-region)
 102     ("ISpell" . ispell-region)
 103     "----"
 104     ("Browse URL" . browse-url)
 105     ("Dired" . dired)
 106     ("Execute File" . mouse-me-execute)
 107     ("Mail to" . compose-mail)
 108     ("Finger" . mouse-me-finger)
 109     ("BBDB Lookup" . mouse-me-bbdb)
 110     "----"
 111     ("Imenu" . imenu)
 112     ("Find Tag" . find-tag)
 113     ("Grep" . mouse-me-grep)
 114     ("Find-Grep" . mouse-me-find-grep)
 115     "----"
 116     ("Apropos" . apropos)
 117     ("Describe Function" . mouse-me-describe-function)
 118     ("Describe Variable" . mouse-me-describe-variable)
 119     ("Command Info" . mouse-me-emacs-command-info)
 120     ("Man Page" . (if (fboundp 'woman) 'woman 'man))
 121     ("Profile Function" . mouse-me-elp-instrument-function))
 122     "*Command menu used by `mouse-me-build-menu'.
 123 A list of elements where each element is either a cons cell or a string.
 124 If a cons cell the car is a string to be displayed in the menu and the
 125 cdr is either a function to call passing a string to, or a list which evals
 126 to a function to call passing a string to.  If the element is a string
 127 it makes a non-selectable element in the menu.  To make a separator line
 128 use a string consisting solely of hyphens.
 129
 130 The function returned from this menu will be called with one string
 131 argument.  Or if the function has the symbol property `mouse-me-type'
 132 and if its value is the symbol `region' it will be called with the
 133 beginning and ending points of the selected string.  If the value is
 134 the symbol `string' it will be called with one string argument."
 135   :type '(repeat sexp)
 136   :group 'mouseme)
 137
 138 (put 'kill-region 'mouse-me-type 'region)
 139 (put 'ispell-region 'mouse-me-type 'region)
 140 (put 'capitalize-region 'mouse-me-type 'region)
 141 (put 'downcase-region 'mouse-me-type 'region)
 142 (put 'upcase-region 'mouse-me-type 'region)
 143
 144 ;;;; Commands
 145
 146 ;;;###autoload
 147 (defun mouse-me (event)
 148   "Popup a menu of functions to run on selected string or region."
 149   (interactive "e")
 150   (mouse-me-helper event #'(lambda ()
 151     (or (x-popup-menu event (funcall mouse-me-build-menu-function name))
 152         (error "No command to run")))))
 153
 154 ;;;; Exposed Functions
 155
 156 ;; Some tests:
 157 ;; <URL:http://foo.bar.com/sss/ss.html>
 158 ;; <http://foo.bar.com/sss/ss.html>
 159 ;; http://foo.bar.com/sss/ss.html
 160 ;; http://www.ditherdog.com/howard/
 161 ;; mailto:howard@silverstream.com
 162 ;; howard@silverstream.com
 163 ;; <howard@silverstream.com>
 164 ;; import com.sssw.srv.agents.AgentsRsrc;
 165 ;; public AgoHttpRequestEvent(Object o, String db, Request r)
 166 ;; <DIV><A href=3D"http://www.amazon.com/exec/obidos/ASIN/156592391X"><IMG =
 167 ;; <A HREF="http://www.suntimes.com/ebert/ebert.html">
 168 ;; d:\howard\elisp\spoon
 169 ;; \howard\elisp\spoon
 170 ;; \\absolut\howard\elisp\spoon
 171 ;; //absolut/d/Howard/Specs/servlet-2.1.pdf
 172 ;; \\absolut\d\Howard\Specs\servlet-2.1.pdf
 173 ;; gnuserv-frame.
 174
 175 (defun mouse-me-get-string ()
 176   "Return a string from the buffer of text surrounding point.
 177 Returns a list of three elements, the string and the beginning and
 178 ending positions of the string in the buffer in that order."
 179   (save-match-data
 180     (save-excursion
 181       (let ((start (point)) beg end str p)
 182         (skip-syntax-forward "^ >()\"")
 183         (setq end (point))
 184         (goto-char start)
 185         (skip-syntax-backward "^ >()\"")
 186         (setq beg (point))
 187         (setq str (buffer-substring-no-properties beg end))
 188         ;; remove junk from the beginning
 189         (if (string-match "^\\([][\"'`.,?:;!@#$%^&*()_+={}|<>-]+\\)" str)
 190             (setq str (substring str (match-end 1))
 191                   beg (+ beg (match-end 1))))
 192         ;; remove URL: from the front, it's common in email
 193         (if (string-match "^\\(URL:\\)" str)
 194             (setq str (substring str (match-end 1))
 195                   beg (+ beg (match-end 1))))
 196         ;; remove junk from the end
 197         (if (string-match "\\([][\"'.,?:;!@#$%^&*()_+={}|<>-]+\\)$" str)
 198             (setq end (- end (length (match-string 1 str))) ; must set end first
 199                   str (substring str 0 (match-beginning 1))))
 200         (list str beg end)))))
 201
 202 (defun mouse-me-build-menu (name)
 203   "Return a menu tailored for NAME for `mouse-me' from `mouse-me-menu-commands'."
 204   (list "Mouse Me" (cons "Mouse Me"
 205                          (append (list (cons
 206                                         (if (< (length name) 65)
 207                                             name
 208                                           "...Long String...")
 209                                         'kill-new)
 210                                        "---")
 211                                  mouse-me-menu-commands))))
 212
 213 ;;;; Commands for the menu
 214
 215 (defun mouse-me-emacs-command-info (string)
 216   "Look in Emacs info for command named STRING."
 217   (interactive "sCommand: ")
 218   (let ((s (intern-soft string)))
 219     (if (and s (commandp s))
 220         (Info-goto-emacs-command-node s)
 221       (error "No command named `%s'" string))))
 222
 223 (defun mouse-me-describe-function (string)
 224   "Describe function named STRING."
 225   (interactive "sFunction: ")
 226   (let ((s (intern-soft string)))
 227     (if (and s (fboundp s))
 228         (describe-function s)
 229       (error "No function named `%s'" string))))
 230
 231 (defun mouse-me-describe-variable (string)
 232   "Desribe variable named STRING."
 233   (interactive "sVariable: ")
 234   (let ((s (intern-soft string)))
 235     (if (and s (boundp s))
 236         (describe-variable s)
 237       (error "No variable named `%s'" string))))
 238
 239 (defun mouse-me-elp-instrument-function (string)
 240   "Instrument Lisp function named STRING."
 241   (interactive "sFunction: ")
 242   (let ((s (intern-soft string)))
 243     (if (and s (fboundp s))
 244         (elp-instrument-function s)
 245       (error "Must be the name of an existing Lisp function"))))
 246
 247 (defun mouse-me-execute (string)
 248   "Execute STRING as a filename."
 249   (interactive "sFile: ")
 250   (w32-shell-execute "open" (convert-standard-filename string)))
 251
 252 (defun mouse-me-bbdb (string)
 253   "Lookup STRING in bbdb."
 254   (interactive "sBBDB Lookup: ")
 255   (if (fboundp 'bbdb)
 256       (bbdb string nil)
 257     (error "BBDB not loaded")))
 258
 259 (defun mouse-me-finger (string)
 260   "Finger a STRING mail address."
 261   (interactive "sFinger: ")
 262   (save-match-data
 263     (if (string-match "\\(.*\\)@\\([-.a-zA-Z0-9]+\\)$" string)
 264         (finger (match-string 1 string) (match-string 2 string))
 265       (error "Not in user@host form: %s" string))))
 266
 267 (defun mouse-me-grep (string)
 268   "Grep for a STRING."
 269   (interactive "sGrep: ")
 270   (require 'compile)
 271   (grep-compute-defaults)
 272   (let ((ext (mouse-me-buffer-file-extension)))
 273     (grep (concat grep-command string
 274                   (if mouse-me-grep-use-extension
 275                       (if ext
 276                           (concat " *" ext)
 277                         " *"))))))
 278
 279 (defun mouse-me-find-grep (string)
 280   "Grep for a STRING."
 281   (interactive "sGrep: ")
 282   (grep-compute-defaults)
 283   (let ((reg grep-find-command)
 284         (ext (mouse-me-buffer-file-extension))
 285         beg end)
 286     (if (string-match "\\(^.+-type f \\)\\(.+$\\)" reg)
 287         (setq reg (concat (match-string 1 reg)
 288                           (if mouse-me-grep-use-extension
 289                               (concat "-name \"*" ext "\" "))
 290                           (match-string 2 reg))))
 291     (grep-find (concat reg string))))
 292
 293 ;;;; Internal Functions
 294
 295 (defun mouse-me-buffer-file-extension ()
 296   "Return the extension of the current buffer's filename or nil.
 297 Returned extension is a string begining with a period."
 298   (let* ((bfn (buffer-file-name))
 299          (filename (and bfn (file-name-sans-versions bfn)))
 300          (index (and filename (string-match "\\.[^.]*$" filename))))
 301     (if index
 302         (substring filename index)
 303       "")))
 304
 305 (defun mouse-me-helper (event func)
 306   "Determine the string to use to process EVENT and call FUNC to get cmd."
 307   (let (name sp sm mouse beg end cmd mmtype)
 308     ;; temporarily goto where the event occurred, get the name clicked
 309     ;; on and enough info to figure out what to do with it
 310     (save-match-data
 311       (save-excursion
 312         (setq sp (point))               ; saved point
 313         (setq sm (mark t))              ; saved mark
 314         (set-buffer (window-buffer (posn-window (event-start event))))
 315         (setq mouse (goto-char (posn-point (event-start event))))
 316         ;; if there is a region and point is inside it
 317         ;; check for sm first incase (null (mark t))
 318         ;; set name to either the thing they clicked on or region
 319         (if (and sm
 320                  (or (and transient-mark-mode mark-active)
 321                      (eq last-command 'mouse-drag-region))
 322                  (>= mouse (setq beg (min sp sm)))
 323                  (<= mouse (setq end (max sp sm))))
 324             (setq name (buffer-substring beg end))
 325           (setq name (funcall mouse-me-get-string-function))
 326           (if (listp name)
 327               (setq beg (nth 1 name)
 328                     end (nth 2 name)
 329                     name (car name))
 330             (goto-char mouse)
 331             (while (not (looking-at (regexp-quote name)))
 332               (backward-char 1))
 333             (setq beg (point))
 334             (setq end (search-forward name))))))
 335     ;; check if name is null, meaning they clicked on no word
 336     (if (or (null name)
 337             (and (stringp name) (string= name "" )))
 338         (error "No string to pass to function"))
 339     ;; popup a menu to get a command to run
 340     (setq cmd (funcall func))
 341     ;; run the command, eval'ing if it was a list
 342     (if (listp cmd)
 343         (setq cmd (eval cmd)))
 344     (setq mmtype (get cmd 'mouse-me-type))
 345     (cond ((eq mmtype 'region)
 346            (funcall cmd beg end))
 347           ((eq mmtype 'string)
 348            (funcall cmd name))
 349           (t
 350            (funcall cmd name)))))
 351
 352 (provide 'mouseme)
 353
 354 ;;; mouseme.el ends here