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