1 ;;; smiley.el --- displaying smiley faces
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
4 ;; Free Software Foundation, Inc.
6 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
32 ;;; Test smileys: :-] :-o :-) ;-) :-\ :-| :-d :-P 8-| :-(
36 ;; (setq gnus-treat-display-smileys t)
38 ;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
42 (eval-when-compile (require 'cl))
46 (when (featurep 'xemacs)
47 (require 'annotations)
48 (require 'messagexmas)))
51 "Turn :-)'s into real images."
54 ;; FIXME: Where is the directory when using Emacs?
55 (defcustom smiley-data-directory
56 (if (featurep 'xemacs)
57 (message-xmas-find-glyph-directory "smilies")
58 "/usr/local/lib/xemacs/xemacs-packages/etc/smilies")
59 "*Location of the smiley faces files."
63 ;; Notice the subtle differences in the regular expressions in the
66 (defcustom smiley-deformed-regexp-alist
67 '(("\\(\\^_\\^;;;\\)\\W" 1 "WideFaceAse3.xbm")
68 ("\\(\\^_\\^;;\\)\\W" 1 "WideFaceAse2.xbm")
69 ("\\(\\^_\\^;\\)\\W" 1 "WideFaceAse1.xbm")
70 ("\\(\\^_\\^\\)\\W" 1 "WideFaceSmile.xbm")
71 ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
72 ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
73 ("\\(:-*[<
\e(I+
\e(B]+\\)\\W" 1 "FaceAngry.xpm")
74 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
75 ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
76 ("\\(:-*[)>}
\e(I;
\e(B]+\\)\\W" 1 "FaceHappy.xpm")
77 ("\\(=[)>
\e(I;
\e(B]+\\)\\W" 1 "FaceHappy.xpm")
78 ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
79 ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
80 ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
81 ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
82 ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
83 ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
84 ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
85 ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
86 ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
87 ("[^^;_]\\(;-*[>)}
\e(I;
\e(B]+\\)\\W" 1 "FaceWinking.xpm")
88 ("\\(:-*[Vv
\e(I5
\e(B]\\)\\W" 1 "FaceWry.xpm")
89 ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
90 "*Normal and deformed faces for smilies."
91 :type '(repeat (list regexp
92 (integer :tag "Match")
93 (string :tag "Image")))
96 (defcustom smiley-nosey-regexp-alist
97 '(("\\(:-+[<
\e(I+
\e(B]+\\)\\W" 1 "FaceAngry.xpm")
98 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
99 ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
100 ("\\(:-+[}
\e(I;
\e(B]+\\)\\W" 1 "FaceHappy.xpm")
101 ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm")
102 ("\\(=[)]+\\)\\W" 1 "FaceHappy.xpm")
103 ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
104 ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
105 ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
106 ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
107 ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
108 ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
109 ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
110 ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
111 ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
112 ("\\(;-+[>)}
\e(I;
\e(B]+\\)\\W" 1 "FaceWinking.xpm")
113 ("\\(:-+[Vv
\e(I5
\e(B]\\)\\W" 1 "FaceWry.xpm")
114 ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
115 ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
116 "*Smileys with noses. These get less false matches."
117 :type '(repeat (list regexp
118 (integer :tag "Match")
119 (string :tag "Image")))
122 (defcustom smiley-regexp-alist smiley-deformed-regexp-alist
123 "*A list of regexps to map smilies to real images.
124 Defaults to the contents of `smiley-deformed-regexp-alist'.
125 An alternative is `smiley-nosey-regexp-alist' that matches less
127 If this is a symbol, take its value."
128 :type '(radio (variable-item smiley-deformed-regexp-alist)
129 (variable-item smiley-nosey-regexp-alist)
132 (integer :tag "Match")
133 (string :tag "Image"))))
136 (defcustom smiley-flesh-color "yellow"
141 (defcustom smiley-features-color "black"
146 (defcustom smiley-tongue-color "red"
151 (defcustom smiley-circle-color "black"
156 (defcustom smiley-mouse-face 'highlight
157 "*Face used for mouse highlighting in the smiley buffer.
159 Smiley buttons will be displayed in this face when the cursor is
164 (defvar smiley-glyph-cache nil)
166 (defvar smiley-map (make-sparse-keymap "smiley-keys")
167 "Keymap to toggle smiley states.")
169 (define-key smiley-map [(button2)] 'smiley-toggle-extent)
170 (define-key smiley-map [(button3)] 'smiley-popup-menu)
172 (defun smiley-popup-menu (e)
176 ["Toggle This Smiley" (smiley-toggle-extent ,e) t]
177 ["Toggle All Smilies" (smiley-toggle-extents ,e) t])))
179 (defun smiley-create-glyph (smiley pixmap)
181 (cdr-safe (assoc pixmap smiley-glyph-cache))
182 (let* ((xpm-color-symbols
184 (append `(("flesh" ,smiley-flesh-color)
185 ("features" ,smiley-features-color)
186 ("tongue" ,smiley-tongue-color))
190 (cons (if (featurep 'gtk) 'gtk 'x)
191 (expand-file-name pixmap smiley-data-directory))
193 (expand-file-name pixmap smiley-data-directory))
194 (cons 'tty smiley)))))
195 (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
196 (set-glyph-face glyph 'default)
199 (defun smiley-create-glyph-ems (smiley pixmap)
201 (create-image (expand-file-name pixmap smiley-data-directory))
206 (defun smiley-region (beg end)
207 "Smilify the region between point and mark."
209 (smiley-buffer (current-buffer) beg end))
211 (defun smiley-toggle-extent (event)
212 "Toggle smiley at given point."
214 (let* ((ant (event-glyph-extent event))
215 (pt (event-closest-point event))
217 (if (annotationp ant)
218 (when (extentp (setq ext (extent-property ant 'smiley-extent)))
219 (set-extent-property ext 'invisible nil)
220 (hide-annotation ant))
222 (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
223 (when (annotationp (setq ant
224 (extent-property ext 'smiley-annotation)))
225 (reveal-annotation ant)
226 (set-extent-property ext 'invisible t)))))))
229 (defun smiley-toggle-extent-ems (event)
230 "Toggle smiley at given point.
231 Note -- this function hasn't been implemented yet."
233 (error "This function hasn't been implemented yet"))
235 (defun smiley-toggle-extents (e)
240 (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
241 (if (eq (extent-property e 'invisible) nil)
243 (reveal-annotation ant)
244 (set-extent-property e 'invisible t)
246 (hide-annotation ant)
247 (set-extent-property e 'invisible nil)))
252 (defun smiley-toggle-extents-ems (e)
254 (error "This function hasn't been implemented yet"))
257 (defun smiley-buffer (&optional buffer st nd)
259 (when (featurep '(or x gtk mswindows))
263 (let ((buffer-read-only nil)
264 (alist (if (symbolp smiley-regexp-alist)
265 (symbol-value smiley-regexp-alist)
266 smiley-regexp-alist))
267 (case-fold-search nil)
268 entry regexp beg group file)
271 (when (or (extent-property e 'smiley-extent)
272 (extent-property e 'smiley-annotation))
275 (goto-char (or st (point-min)))
277 ;; loop through alist
278 (while (setq entry (pop alist))
279 (setq regexp (car entry)
283 (while (re-search-forward regexp nd t)
284 (let* ((start (match-beginning group))
285 (end (match-end group))
286 (glyph (smiley-create-glyph (buffer-substring start end)
289 (mapcar 'delete-annotation (annotations-at end))
290 (let ((ext (make-extent start end))
291 (ant (make-annotation glyph end 'text)))
292 ;; set text extent params
293 (set-extent-property ext 'end-open t)
294 (set-extent-property ext 'start-open t)
295 (set-extent-property ext 'invisible t)
296 (set-extent-property ext 'keymap smiley-map)
297 (set-extent-property ext 'mouse-face smiley-mouse-face)
298 (set-extent-property ext 'intangible t)
299 ;; set annotation params
300 (set-extent-property ant 'mouse-face smiley-mouse-face)
301 (set-extent-property ant 'keymap smiley-map)
302 ;; remember each other
303 (set-extent-property ant 'smiley-extent ext)
304 (set-extent-property ext 'smiley-annotation ant)
308 "button2 toggles smiley, button3 pops up menu")
311 "button2 toggles smiley, button3 pops up menu")
312 (set-extent-property ext 'balloon-help
313 "Mouse button2 - toggle smiley
314 Mouse button3 - menu")
315 (set-extent-property ant 'balloon-help
316 "Mouse button2 - toggle smiley
317 Mouse button3 - menu"))
318 (when (smiley-end-paren-p start end)
319 (make-annotation ")" end 'text))
320 (goto-char end)))))))))
322 ;; FIXME: No popup menu, no customized color
323 (defun smiley-buffer-ems (&optional buffer st nd)
329 (let ((buffer-read-only nil)
330 (alist (if (symbolp smiley-regexp-alist)
331 (symbol-value smiley-regexp-alist)
332 smiley-regexp-alist))
333 (case-fold-search nil)
334 entry regexp beg group file)
335 (dolist (overlay (overlays-in (or st (point-min))
336 (or nd (point-max))))
337 (when (overlay-get overlay 'smiley)
338 (remove-text-properties (overlay-start overlay)
339 (overlay-end overlay) '(display))
340 (delete-overlay overlay)))
341 (goto-char (or st (point-min)))
343 ;; loop through alist
344 (while (setq entry (pop alist))
345 (setq regexp (car entry)
349 (while (re-search-forward regexp nd t)
350 (let* ((start (match-beginning group))
351 (end (match-end group))
352 (glyph (smiley-create-glyph nil file))
353 (overlay (make-overlay start end)))
355 (add-text-properties start end
357 (overlay-put overlay 'smiley glyph)
358 (goto-char end)))))))))
360 (defun smiley-end-paren-p (start end)
361 "Try to guess whether the current smiley is an end-paren smiley."
364 (when (and (re-search-backward "[()]" nil t)
365 (eq (char-after) ?\()
367 (or (not (re-search-forward "[()]" nil t))
368 (eq (char-after (1- (point))) ?\()))
371 (defun smiley-toggle-buffer (&optional arg buffer st nd)
372 "Toggle displaying smiley faces.
373 With arg, turn displaying on if and only if arg is positive."
379 (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
380 (if (eq (extent-property e 'invisible) nil)
381 (setq off (cons (cons ant e) off))
382 (setq on (cons (cons ant e) on)))))
385 (if (and (not (and (numberp arg) (< arg 0)))
386 (or (and (numberp arg) (> arg 0))
390 (reveal-annotation (caar off))
391 (set-extent-property (cdar off) 'invisible t)
392 (setq off (cdr off)))
395 (hide-annotation (caar on))
396 (set-extent-property (cdar on) 'invisible nil)
397 (setq on (cdr on))))))
399 ;; Simply removing all smiley if existing.
400 ;; FIXME: make it work as the one in XEmacs.
401 (defun smiley-toggle-buffer-ems (&optional arg buffer st nd)
402 "Toggle displaying smiley faces.
403 With arg, turn displaying on if and only if arg is positive."
409 (dolist (overlay (overlays-in (or st (point-min))
410 (or nd (point-max))))
411 (when (overlay-get overlay 'smiley)
412 (remove-text-properties (overlay-start overlay)
413 (overlay-end overlay) '(display))
416 (smiley-buffer buffer st nd)))))
418 (unless (featurep 'xemacs)
419 (defalias 'smiley-create-glyph 'smiley-create-glyph-ems)
420 (defalias 'smiley-toggle-extent 'smiley-toggle-extent-ems)
421 (defalias 'smiley-toggle-extents 'smiley-toggle-extents-ems)
422 (defalias 'smiley-buffer 'smiley-buffer-ems)
423 (defalias 'smiley-toggle-buffer 'smiley-toggle-buffer-ems))
425 (defvar gnus-article-buffer)
427 (defun gnus-smiley-display (&optional arg)
428 "Display \"smileys\" as small graphical icons.
429 With arg, turn displaying on if and only if arg is positive."
433 (let (buffer-read-only)
434 (smiley-toggle-buffer arg (current-buffer) (point) (point-max)))))
439 ;; coding: iso-8859-1
442 ;;; smiley.el ends here