lisp/erc/erc-button.el

   1 ;; erc-button.el --- A way of buttonizing certain things in ERC buffers
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2006, 2007, 2008 Free Software Foundation, Inc.
   5
   6 ;; Author: Mario Lang <mlang@delysid.org>
   7 ;; Keywords: irc, button, url, regexp
   8 ;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErcButton
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Heavily borrowed from gnus-art.el. Thanks to the original authors.
  30 ;; This buttonizes nicks and other stuff to make it all clickable.
  31 ;; To enable, add to your ~/.emacs:
  32 ;; (require 'erc-button)
  33 ;; (erc-button-mode 1)
  34 ;;
  35 ;; Todo:
  36 ;; * Rewrite all this to do the same, but use button.el from GNU Emacs
  37 ;; if it's available for xemacs too.  Why? button.el is much faster,
  38 ;; and much more elegant, and solves the problem we get with large buffers
  39 ;; and a large erc-button-marker-list.
  40
  41 \f
  42 ;;; Code:
  43
  44 (require 'erc)
  45 (require 'wid-edit)
  46 (require 'erc-fill)
  47
  48 ;;; Minor Mode
  49
  50 (defgroup erc-button nil
  51   "Define how text can be turned into clickable buttons."
  52   :group 'erc)
  53
  54 ;;;###autoload (autoload 'erc-button-mode "erc-button" nil t)
  55 (define-erc-module button nil
  56   "This mode buttonizes all messages according to `erc-button-alist'."
  57   ((add-hook 'erc-insert-modify-hook 'erc-button-add-buttons 'append)
  58    (add-hook 'erc-send-modify-hook 'erc-button-add-buttons 'append)
  59    (add-hook 'erc-complete-functions 'erc-button-next)
  60    (add-hook 'erc-mode-hook 'erc-button-setup))
  61   ((remove-hook 'erc-insert-modify-hook 'erc-button-add-buttons)
  62    (remove-hook 'erc-send-modify-hook 'erc-button-add-buttons)
  63    (remove-hook 'erc-complete-functions 'erc-button-next)
  64    (remove-hook 'erc-mode-hook 'erc-button-setup)
  65    (when (featurep 'xemacs)
  66      (dolist (buffer (erc-buffer-list))
  67        (with-current-buffer buffer
  68          (kill-local-variable 'widget-button-face))))))
  69
  70 ;;; Variables
  71
  72 (defface erc-button '((t (:bold t)))
  73   "ERC button face."
  74   :group 'erc-faces)
  75
  76 (defcustom erc-button-face 'erc-button
  77   "Face used for highlighting buttons in ERC buffers.
  78
  79 A button is a piece of text that you can activate by pressing
  80 `RET' or `mouse-2' above it. See also `erc-button-keymap'."
  81   :type 'face
  82   :group 'erc-faces)
  83
  84 (defcustom erc-button-nickname-face 'erc-nick-default-face
  85   "Face used for ERC nickname buttons."
  86   :type 'face
  87   :group 'erc-faces)
  88
  89 (defcustom erc-button-mouse-face 'highlight
  90   "Face used for mouse highlighting in ERC buffers.
  91
  92 Buttons will be displayed in this face when the mouse cursor is
  93 above them."
  94   :type 'face
  95   :group 'erc-faces)
  96
  97 (defcustom erc-button-url-regexp
  98   (concat "\\(www\\.\\|\\(s?https?\\|"
  99           "ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)"
 100           "\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?"
 101           "[-a-zA-Z0-9_=!?#$@~`%&*+\\/:;.,()]+[-a-zA-Z0-9_=#$@~`%&*+\\/()]")
 102   "Regular expression that matches URLs."
 103   :group 'erc-button
 104   :type 'regexp)
 105
 106 (defcustom erc-button-wrap-long-urls nil
 107   "If non-nil, \"long\" URLs matching `erc-button-url-regexp' will be wrapped.
 108
 109 If this variable is a number, consider URLs longer than its value to
 110 be \"long\".  If t, URLs will be considered \"long\" if they are
 111 longer than `erc-fill-column'."
 112   :group 'erc-button
 113   :type '(choice integer boolean))
 114
 115 (defcustom erc-button-buttonize-nicks t
 116   "Flag indicating whether nicks should be buttonized or not."
 117   :group 'erc-button
 118   :type 'boolean)
 119
 120 (defcustom erc-button-rfc-url "http://www.faqs.org/rfcs/rfc%s.html"
 121   "*URL used to browse rfc references.
 122 %s is replaced by the number."
 123   :group 'erc-button
 124   :type 'string)
 125
 126 (defcustom erc-button-google-url "http://www.google.com/search?q=%s"
 127   "*URL used to browse Google search references.
 128 %s is replaced by the search string."
 129   :group 'erc-button
 130   :type 'string)
 131
 132 (defcustom erc-button-alist
 133   ;; Since the callback is only executed when the user is clicking on
 134   ;; a button, it makes no sense to optimize performance by
 135   ;; bytecompiling lambdas in this alist.  On the other hand, it makes
 136   ;; things hard to maintain.
 137   '(('nicknames 0 erc-button-buttonize-nicks erc-nick-popup 0)
 138     (erc-button-url-regexp 0 t browse-url 0)
 139     ("<URL: *\\([^<> ]+\\) *>" 0 t browse-url 1)
 140     ("(\\(\\([^~\n \t@][^\n \t@]*\\)@\\([a-zA-Z0-9.:-]+\\)\\)" 1 t finger 2 3)
 141     ;; emacs internal
 142     ("[`]\\([a-zA-Z][-a-zA-Z_0-9]+\\)[']" 1 t erc-button-describe-symbol 1)
 143     ;; pseudo links
 144     ("\\bInfo:[\"]\\([^\"]+\\)[\"]" 0 t Info-goto-node 1)
 145     ("\\b\\(Ward\\|Wiki\\|WardsWiki\\|TheWiki\\):\\([A-Z][a-z]+\\([A-Z][a-z]+\\)+\\)"
 146      0 t (lambda (page)
 147            (browse-url (concat "http://c2.com/cgi-bin/wiki?" page)))
 148      2)
 149     ("EmacsWiki:\\([A-Z][a-z]+\\([A-Z][a-z]+\\)+\\)" 0 t erc-browse-emacswiki 1)
 150     ("Lisp:\\([a-zA-Z.+-]+\\)" 0 t erc-browse-emacswiki-lisp 1)
 151     ("\\bGoogle:\\([^ \t\n\r\f]+\\)"
 152      0 t (lambda (keywords)
 153            (browse-url (format erc-button-google-url keywords)))
 154      1)
 155     ("\\brfc[#: ]?\\([0-9]+\\)"
 156      0 t (lambda (num)
 157            (browse-url (format erc-button-rfc-url num)))
 158      1)
 159     ;; other
 160     ("\\s-\\(@\\([0-9][0-9][0-9]\\)\\)" 1 t erc-button-beats-to-time 2))
 161   "*Alist of regexps matching buttons in ERC buffers.
 162 Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
 163
 164 REGEXP is the string matching text around the button or a symbol
 165   indicating a variable holding that string, or a list of
 166   strings, or an alist with the strings in the car.  Note that
 167   entries in lists or alists are considered to be nicks or other
 168   complete words.  Therefore they are enclosed in \\< and \\>
 169   while searching.  REGEXP can also be the quoted symbol
 170   'nicknames, which matches the nickname of any user on the
 171   current server.
 172
 173 BUTTON is the number of the regexp grouping actually matching the
 174   button,  This is ignored if REGEXP is 'nicknames.
 175
 176 FORM is a lisp expression which must eval to true for the button to
 177   be added,
 178
 179 CALLBACK is the function to call when the user push this button.
 180   CALLBACK can also be a symbol.  Its variable value will be used
 181   as the callback function.
 182
 183 PAR is a number of a regexp grouping whose text will be passed to
 184   CALLBACK.  There can be several PAR arguments.  If REGEXP is
 185   'nicknames, these are ignored, and CALLBACK will be called with
 186   the nickname matched as the argument."
 187   :group 'erc-button
 188   :type '(repeat
 189           (list :tag "Button"
 190                 (choice :tag "Matches"
 191                         regexp
 192                         (variable :tag "Variable containing regexp")
 193                         (const :tag "Nicknames" 'nicknames))
 194                 (integer :tag "Number of the regexp section that matches")
 195                 (choice :tag "When to buttonize"
 196                         (const :tag "Always" t)
 197                         (sexp :tag "Only when this evaluates to non-nil"))
 198                 (function :tag "Function to call when button is pressed")
 199                 (repeat :tag "Sections of regexp to send to the function"
 200                         :inline t
 201                         (integer :tag "Regexp section number")))))
 202
 203 (defcustom erc-emacswiki-url "http://www.emacswiki.org/cgi-bin/wiki.pl?"
 204   "*URL of the EmacsWiki Homepage."
 205   :group 'erc-button
 206   :type 'string)
 207
 208 (defcustom erc-emacswiki-lisp-url "http://www.emacswiki.org/elisp/"
 209   "*URL of the EmacsWiki ELisp area."
 210   :group 'erc-button
 211   :type 'string)
 212
 213 (defvar erc-button-keymap
 214   (let ((map (make-sparse-keymap)))
 215     (define-key map (kbd "RET") 'erc-button-press-button)
 216     (if (featurep 'xemacs)
 217         (define-key map (kbd "<button2>") 'erc-button-click-button)
 218       (define-key map (kbd "<mouse-2>") 'erc-button-click-button))
 219     (define-key map (kbd "TAB") 'erc-button-next)
 220     (define-key map (kbd "<backtab>") 'erc-button-previous)
 221     (set-keymap-parent map erc-mode-map)
 222     map)
 223   "Local keymap for ERC buttons.")
 224
 225 (defvar erc-button-syntax-table
 226   (let ((table (make-syntax-table)))
 227     (modify-syntax-entry ?\( "w" table)
 228     (modify-syntax-entry ?\) "w" table)
 229     (modify-syntax-entry ?\[ "w" table)
 230     (modify-syntax-entry ?\] "w" table)
 231     (modify-syntax-entry ?\{ "w" table)
 232     (modify-syntax-entry ?\} "w" table)
 233     (modify-syntax-entry ?` "w" table)
 234     (modify-syntax-entry ?' "w" table)
 235     (modify-syntax-entry ?^ "w" table)
 236     (modify-syntax-entry ?- "w" table)
 237     (modify-syntax-entry ?_ "w" table)
 238     (modify-syntax-entry ?| "w" table)
 239     (modify-syntax-entry ?\\ "w" table)
 240     table)
 241   "Syntax table used when buttonizing messages.
 242 This syntax table should make all the valid nick characters word
 243 constituents.")
 244
 245 (defvar erc-button-keys-added nil
 246   "Internal variable used to keep track of whether we've added the
 247 global-level ERC button keys yet.")
 248
 249 (defun erc-button-setup ()
 250   "Add ERC mode-level button movement keys.  This is only done once."
 251   ;; Make XEmacs use `erc-button-face'.
 252   (when (featurep 'xemacs)
 253     (set (make-local-variable 'widget-button-face) nil))
 254   ;; Add keys.
 255   (unless erc-button-keys-added
 256     (define-key erc-mode-map (kbd "<backtab>") 'erc-button-previous)
 257     (setq erc-button-keys-added t)))
 258
 259 (defun erc-button-add-buttons ()
 260   "Find external references in the current buffer and make buttons of them.
 261 \"External references\" are things like URLs, as
 262 specified by `erc-button-alist'."
 263   (interactive)
 264   (save-excursion
 265     (with-syntax-table erc-button-syntax-table
 266       (let ((buffer-read-only nil)
 267             (inhibit-point-motion-hooks t)
 268             (inhibit-field-text-motion t)
 269             (alist erc-button-alist)
 270             entry regexp data)
 271         (erc-button-remove-old-buttons)
 272         (dolist (entry alist)
 273           (if (equal (car entry) (quote (quote nicknames)))
 274               (erc-button-add-nickname-buttons entry)
 275             (progn
 276               (setq regexp (or (and (stringp (car entry)) (car entry))
 277                                (and (boundp (car entry))
 278                                     (symbol-value (car entry)))))
 279               (cond ((stringp regexp)
 280                      (erc-button-add-buttons-1 regexp entry))
 281                     ((and (listp regexp) (stringp (car regexp)))
 282                      (dolist (r regexp)
 283                        (erc-button-add-buttons-1
 284                         (concat "\\<" (regexp-quote r) "\\>")
 285                         entry)))
 286                     ((and (listp regexp) (listp (car regexp))
 287                           (stringp (caar regexp)))
 288                      (dolist (elem regexp)
 289                        (erc-button-add-buttons-1
 290                         (concat "\\<" (regexp-quote (car elem)) "\\>")
 291                         entry)))))))))))
 292
 293 (defun erc-button-add-nickname-buttons (entry)
 294   "Search through the buffer for nicknames, and add buttons."
 295   (let ((form (nth 2 entry))
 296         (fun (nth 3 entry))
 297         bounds word)
 298     (when (or (eq t form)
 299               (eval form))
 300       (goto-char (point-min))
 301       (while (forward-word 1)
 302         (setq bounds (bounds-of-thing-at-point 'word))
 303         (setq word (buffer-substring-no-properties
 304                     (car bounds) (cdr bounds)))
 305         (when (or (and (erc-server-buffer-p) (erc-get-server-user word))
 306                   (and erc-channel-users (erc-get-channel-user word)))
 307           (erc-button-add-button (car bounds) (cdr bounds)
 308                                  fun t (list word)))))))
 309
 310 (defun erc-button-add-buttons-1 (regexp entry)
 311   "Search through the buffer for matches to ENTRY and add buttons."
 312   (goto-char (point-min))
 313   (while (re-search-forward regexp nil t)
 314     (let ((start (match-beginning (nth 1 entry)))
 315           (end (match-end (nth 1 entry)))
 316           (form (nth 2 entry))
 317           (fun (nth 3 entry))
 318           (data (mapcar 'match-string (nthcdr 4 entry))))
 319       (when (or (eq t form)
 320                 (eval form))
 321         (erc-button-add-button start end fun nil data regexp)))))
 322
 323 (defun erc-button-remove-old-buttons ()
 324   "Remove all existing buttons.
 325 This is called with narrowing in effect, just before the text is
 326 buttonized again.  Removing a button means to remove all the properties
 327 that `erc-button-add-button' adds, except for the face."
 328   (remove-text-properties
 329    (point-min) (point-max)
 330    '(erc-callback nil
 331                   erc-data nil
 332                   mouse-face nil
 333                   keymap nil)))
 334
 335 (defun erc-button-add-button (from to fun nick-p &optional data regexp)
 336   "Create a button between FROM and TO with callback FUN and data DATA.
 337 NICK-P specifies if this is a nickname button.
 338 REGEXP is the regular expression which matched for this button."
 339   ;; Really nasty hack to <URL: > ise urls, and line-wrap them if
 340   ;; they're going to be wider than `erc-fill-column'.
 341   ;; This could be a lot cleaner, but it works for me -- lawrence.
 342   (let (fill-column)
 343     (when (and erc-button-wrap-long-urls
 344                (string= regexp erc-button-url-regexp)
 345                (> (- to from)
 346                   (setq fill-column (- (if (numberp erc-button-wrap-long-urls)
 347                                            erc-button-wrap-long-urls
 348                                          erc-fill-column)
 349                                        (length erc-fill-prefix)))))
 350       (setq to (prog1 (point-marker) (insert ">"))
 351             from (prog2 (goto-char from) (point-marker) (insert "<URL: ")))
 352       (let ((pos (copy-marker from)))
 353         (while (> (- to pos) fill-column)
 354           (goto-char (+ pos fill-column))
 355           (insert "\n" erc-fill-prefix) ; This ought to figure out
 356                                         ; what type of filling we're
 357                                         ; doing, and indent accordingly.
 358           (move-marker pos (point))))))
 359   (if nick-p
 360       (when erc-button-nickname-face
 361         (erc-button-add-face from to erc-button-nickname-face))
 362     (when erc-button-face
 363       (erc-button-add-face from to erc-button-face)))
 364   (add-text-properties
 365    from to
 366    (nconc (and erc-button-mouse-face
 367                (list 'mouse-face erc-button-mouse-face))
 368           (list 'erc-callback fun)
 369           (list 'keymap erc-button-keymap)
 370           (list 'rear-nonsticky t)
 371           (and data (list 'erc-data data))))
 372   (widget-convert-button 'link from to :action 'erc-button-press-button
 373                          :suppress-face t
 374                          ;; Make XEmacs use our faces.
 375                          :button-face (if nick-p
 376                                           erc-button-nickname-face
 377                                         erc-button-face)
 378                          ;; Make XEmacs behave with mouse-clicks, for
 379                          ;; some reason, widget stuff overrides the
 380                          ;; 'keymap text-property.
 381                          :mouse-down-action 'erc-button-click-button))
 382
 383 (defun erc-button-add-face (from to face)
 384   "Add FACE to the region between FROM and TO."
 385   ;; If we just use `add-text-property', then this will overwrite any
 386   ;; face text property already used for the button.  It will not be
 387   ;; merged correctly.  If we use overlays, then redisplay will be
 388   ;; very slow with lots of buttons.  This is why we manually merge
 389   ;; face text properties.
 390   (let ((old (erc-list (get-text-property from 'face)))
 391         (pos from)
 392         (end (next-single-property-change from 'face nil to))
 393         new)
 394     ;; old is the face at pos, in list form.  It is nil if there is no
 395     ;; face at pos.  If nil, the new face is FACE.  If not nil, the
 396     ;; new face is a list containing FACE and the old stuff.  end is
 397     ;; where this face changes.
 398     (while (< pos to)
 399       (setq new (if old (cons face old) face))
 400       (put-text-property pos end 'face new)
 401       (setq pos end
 402             old (erc-list (get-text-property pos 'face))
 403             end (next-single-property-change pos 'face nil to)))))
 404
 405 ;; widget-button-click calls with two args, we ignore the first.
 406 ;; Since Emacs runs this directly, rather than with
 407 ;; widget-button-click, we need to fake an extra arg in the
 408 ;; interactive spec.
 409 (defun erc-button-click-button (ignore event)
 410   "Call `erc-button-press-button'."
 411   (interactive "P\ne")
 412   (save-excursion
 413     (mouse-set-point event)
 414     (erc-button-press-button)))
 415
 416 ;; XEmacs calls this via widget-button-press with a bunch of arguments
 417 ;; which we don't care about.
 418 (defun erc-button-press-button (&rest ignore)
 419   "Check text at point for a callback function.
 420 If the text at point has a `erc-callback' property,
 421 call it with the value of the `erc-data' text property."
 422   (interactive)
 423   (let* ((data (get-text-property (point) 'erc-data))
 424          (fun (get-text-property (point) 'erc-callback)))
 425     (unless fun
 426       (message "No button at point"))
 427     (when (and fun (symbolp fun) (not (fboundp fun)))
 428       (error "Function %S is not bound" fun))
 429     (apply fun data)))
 430
 431 (defun erc-button-next ()
 432   "Go to the next button in this buffer."
 433   (interactive)
 434   (let ((here (point)))
 435     (when (< here (erc-beg-of-input-line))
 436       (while (and (get-text-property here 'erc-callback)
 437                   (not (= here (point-max))))
 438         (setq here (1+ here)))
 439       (while (and (not (get-text-property here 'erc-callback))
 440                   (not (= here (point-max))))
 441         (setq here (1+ here)))
 442       (if (< here (point-max))
 443           (goto-char here)
 444         (error "No next button"))
 445       t)))
 446
 447 (defun erc-button-previous ()
 448   "Go to the previous button in this buffer."
 449   (interactive)
 450   (let ((here (point)))
 451     (when (< here (erc-beg-of-input-line))
 452       (while (and (get-text-property here 'erc-callback)
 453                   (not (= here (point-min))))
 454         (setq here (1- here)))
 455       (while (and (not (get-text-property here 'erc-callback))
 456                   (not (= here (point-min))))
 457         (setq here (1- here)))
 458       (if (> here (point-min))
 459           (goto-char here)
 460         (error "No previous button"))
 461       t)))
 462
 463 (defun erc-browse-emacswiki (thing)
 464   "Browse to thing in the emacs-wiki."
 465   (browse-url (concat erc-emacswiki-url thing)))
 466
 467 (defun erc-browse-emacswiki-lisp (thing)
 468   "Browse to THING in the emacs-wiki elisp area."
 469   (browse-url (concat erc-emacswiki-lisp-url thing)))
 470
 471 ;;; Nickname buttons:
 472
 473 (defcustom erc-nick-popup-alist
 474   '(("DeOp"  . (erc-cmd-DEOP nick))
 475     ("Kick"  . (erc-cmd-KICK (concat nick " "
 476                                      (read-from-minibuffer
 477                                       (concat "Kick " nick ", reason: ")))))
 478     ("Msg"   . (erc-cmd-MSG (concat nick " "
 479                                     (read-from-minibuffer
 480                                      (concat "Message to " nick ": ")))))
 481     ("Op"    . (erc-cmd-OP nick))
 482     ("Query" . (erc-cmd-QUERY nick))
 483     ("Whois" . (erc-cmd-WHOIS nick))
 484     ("Lastlog" . (erc-cmd-LASTLOG nick)))
 485   "*An alist of possible actions to take on a nickname.
 486 An entry looks like (\"Action\" . SEXP) where SEXP is evaluated with
 487 the variable `nick' bound to the nick in question.
 488
 489 Examples:
 490  (\"DebianDB\" .
 491   (shell-command
 492    (format
 493     \"ldapsearch -x -P 2 -h db.debian.org -b dc=debian,dc=org ircnick=%s\"
 494     nick)))"
 495   :group 'erc-button
 496   :type '(repeat (cons (string :tag "Op")
 497                        sexp)))
 498
 499 (defun erc-nick-popup (nick)
 500   (let* ((completion-ignore-case t)
 501          (action (completing-read (concat "What action to take on '" nick "'? ")
 502                                   erc-nick-popup-alist))
 503          (code (cdr (assoc action erc-nick-popup-alist))))
 504     (when code
 505       (erc-set-active-buffer (current-buffer))
 506       (eval code))))
 507
 508 ;;; Callback functions
 509 (defun erc-button-describe-symbol (symbol-name)
 510   "Describe SYMBOL-NAME.
 511 Use `describe-function' for functions, `describe-variable' for variables,
 512 and `apropos' for other symbols."
 513   (let ((symbol (intern-soft symbol-name)))
 514     (cond ((and symbol (fboundp symbol))
 515            (describe-function symbol))
 516           ((and symbol (boundp symbol))
 517            (describe-variable symbol))
 518           (t (apropos symbol-name)))))
 519
 520 (defun erc-button-beats-to-time (beats)
 521   "Display BEATS in a readable time format."
 522   (let* ((seconds (- (* (string-to-number beats) 86.4)
 523                      3600
 524                      (- (car (current-time-zone)))))
 525          (hours (mod (floor seconds 3600) 24))
 526          (minutes (mod (round seconds 60) 60)))
 527     (message (format "@%s is %d:%02d local time"
 528                      beats hours minutes))))
 529
 530 (provide 'erc-button)
 531
 532 ;;; erc-button.el ends here
 533 ;; Local Variables:
 534 ;; indent-tabs-mode: nil
 535 ;; End:
 536
 537 ;; arch-tag: 7d23bed4-2f30-4273-a03f-d7a274c605c4