Mercurial > hg > xemacs-beta

comparison lisp/gnus/smiley.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents ac2d302a0011
children d95e72db5c07
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; smiley.el --- displaying smiley faces 1 ;;; smiley.el --- displaying smiley faces
2 ;; Copyright (C) 1996 Free Software Foundation, Inc. 2 ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu> 4 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
5 ;; Keywords: fun 5 ;; Keywords: fun
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
31 31
32 ;; To use: 32 ;; To use:
33 ;; (require 'smiley) 33 ;; (require 'smiley)
34 ;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t) 34 ;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t)
35 35
36 ;; The smilies were drawn by Joe Reiss <joe@jreiss.async.vt.edu>. 36 ;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
37 37
38 (require 'annotations) 38 (require 'annotations)
39 (require 'messagexmas) 39 (require 'messagexmas)
40 (eval-when-compile (require 'cl)) 40 (require 'cl)
41 41 (require 'custom)
42 (defvar smiley-data-directory (message-xmas-find-glyph-directory "smilies") 42
43 "Location of the smiley faces files.") 43 (defgroup smiley nil
44 44 "Turn :-)'s into real images (XEmacs)."
45 ;; Notice the subtle differences in the regular expessions in the two alists below 45 :group 'gnus-visual)
46 46
47 (defvar smiley-deformed-regexp-alist 47 (defcustom smiley-data-directory (message-xmas-find-glyph-directory "smilies")
48 "Location of the smiley faces files."
49 :type 'directory
50 :group 'smiley)
51
52 ;; Notice the subtle differences in the regular expressions in the two alists below
53
54 (defcustom smiley-deformed-regexp-alist
48 '(("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm") 55 '(("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm")
49 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm") 56 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
50 ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm") 57 ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
51 ("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm") 58 ("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm")
52 ("\\(:-*[/\\\"]\\)[^/]" 1 "FaceIronic.xpm") 59 ("\\(:-*[/\\\"]\\)[^/]" 1 "FaceIronic.xpm")
56 ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm") 63 ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
57 ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm") 64 ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
58 ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm") 65 ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
59 ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm") 66 ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
60 ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm") 67 ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
61 ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm") 68 ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm")
62 ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm")) 69 ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
63 "Normal and deformed faces for smilies.") 70 "Normal and deformed faces for smilies."
64 71 :type '(repeat (list regexp
65 (defvar smiley-nosey-regexp-alist 72 (integer :tag "Match")
73 (string :tag "Image")))
74 :group 'smiley)
75
76 (defcustom smiley-nosey-regexp-alist
66 '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm") 77 '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm")
67 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm") 78 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
68 ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm") 79 ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
69 ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm") 80 ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm")
70 ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm") ;; The exception that confirms the rule 81 ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm")
71 ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm") 82 ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
72 ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm") 83 ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
73 ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm") 84 ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
74 ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm") 85 ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
75 ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm") 86 ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
76 ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm") 87 ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
77 ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm") 88 ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
78 ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm") 89 ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
79 ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm") 90 ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
80 ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm") 91 ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm")
92 ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
81 ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm")) 93 ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
82 "Smileys with noses. These get less false matches.") 94 "Smileys with noses. These get less false matches."
83 95 :type '(repeat (list regexp
84 (defvar smiley-regexp-alist smiley-deformed-regexp-alist 96 (integer :tag "Match")
97 (string :tag "Image")))
98 :group 'smiley)
99
100 (defcustom smiley-regexp-alist smiley-deformed-regexp-alist
85 "A list of regexps to map smilies to real images. 101 "A list of regexps to map smilies to real images.
86 Defaults to the content of smiley-deformed-regexp-alist. 102 Defaults to the content of smiley-deformed-regexp-alist.
87 An alternative smiley-nose-regexp-alist that 103 An alternative smiley-nosey-regexp-alist that
88 matches less aggresively is available.") 104 matches less aggressively is available.
89 105 If this is a symbol, take its value."
90 (defvar smiley-flesh-color "yellow" 106 :type '(radio (variable-item smiley-deformed-regexp-alist)
91 "Flesh color.") 107 (variable-item smiley-nosey-regexp-alist)
92 108 symbol
93 (defvar smiley-features-color "black" 109 (repeat (list regexp
94 "Features color.") 110 (integer :tag "Match")
95 111 (string :tag "Image"))))
96 (defvar smiley-tongue-color "red" 112 :group 'smiley)
97 "Tongue color.") 113
98 114 (defcustom smiley-flesh-color "yellow"
99 (defvar smiley-circle-color "black" 115 "Flesh color."
100 "Circle color.") 116 :type 'string
117 :group 'smiley)
118
119 (defcustom smiley-features-color "black"
120 "Features color."
121 :type 'string
122 :group 'smiley)
123
124 (defcustom smiley-tongue-color "red"
125 "Tongue color."
126 :type 'string
127 :group 'smiley)
128
129 (defcustom smiley-circle-color "black"
130 "Circle color."
131 :type 'string
132 :group 'smiley)
133
134 (defcustom smiley-mouse-face 'highlight
135 "Face used for mouse highlighting in the smiley buffer.
136
137 Smiley buttons will be displayed in this face when the cursor is
138 above them."
139 :type 'face
140 :group 'smiley)
141
101 142
102 (defvar smiley-glyph-cache nil) 143 (defvar smiley-glyph-cache nil)
103 (defvar smiley-running-xemacs (string-match "XEmacs" emacs-version)) 144 (defvar smiley-running-xemacs (string-match "XEmacs" emacs-version))
145
146 (defvar smiley-map (make-sparse-keymap "smiley-keys")
147 "keymap to toggle smiley states")
148
149 (define-key smiley-map [(button2)] 'smiley-toggle-extent)
104 150
105 (defun smiley-create-glyph (smiley pixmap) 151 (defun smiley-create-glyph (smiley pixmap)
106 (and 152 (and
107 smiley-running-xemacs 153 smiley-running-xemacs
108 (or 154 (or
125 (defun smiley-region (beg end) 171 (defun smiley-region (beg end)
126 "Smilify the region between point and mark." 172 "Smilify the region between point and mark."
127 (interactive "r") 173 (interactive "r")
128 (smiley-buffer (current-buffer) beg end)) 174 (smiley-buffer (current-buffer) beg end))
129 175
176 (defun smiley-toggle-extent (event)
177 "Toggle smiley at given point"
178 (interactive "e")
179 (let* ((ant (event-glyph-extent event))
180 (pt (event-closest-point event))
181 ext)
182 (if (annotationp ant)
183 (when (extentp (setq ext (extent-property ant 'smiley-extent)))
184 (set-extent-property ext 'invisible nil)
185 (hide-annotation ant))
186 (when pt
187 (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
188 (when (annotationp (setq ant
189 (extent-property ext 'smiley-annotation)))
190 (reveal-annotation ant)
191 (set-extent-property ext 'invisible t)))))))
192
130 ;;;###autoload 193 ;;;###autoload
131 (defun smiley-buffer (&optional buffer st nd) 194 (defun smiley-buffer (&optional buffer st nd)
132 (interactive) 195 (interactive)
133 (when (featurep 'x) 196 (when (featurep 'x)
134 (save-excursion 197 (save-excursion
135 (when buffer 198 (when buffer
136 (set-buffer buffer)) 199 (set-buffer buffer))
137 (let ((buffer-read-only nil) 200 (let ((buffer-read-only nil)
138 (alist smiley-regexp-alist) 201 (alist (if (symbolp smiley-regexp-alist)
202 (symbol-value smiley-regexp-alist)
203 smiley-regexp-alist))
139 entry regexp beg group file) 204 entry regexp beg group file)
140 (goto-char (or st (point-min))) 205 (goto-char (or st (point-min)))
141 (setq beg (point)) 206 (setq beg (point))
142 ;; loop through alist 207 ;; loop through alist
143 (while (setq entry (pop alist)) 208 (while (setq entry (pop alist))
150 (end (match-end group)) 215 (end (match-end group))
151 (glyph (smiley-create-glyph (buffer-substring start end) 216 (glyph (smiley-create-glyph (buffer-substring start end)
152 file))) 217 file)))
153 (when glyph 218 (when glyph
154 (mapcar 'delete-annotation (annotations-at end)) 219 (mapcar 'delete-annotation (annotations-at end))
155 (let ((ext (make-extent start end))) 220 (let ((ext (make-extent start end))
221 (ant (make-annotation glyph end 'text)))
222 ;; set text extent params
223 (set-extent-property ext 'end-open t)
224 (set-extent-property ext 'start-open t)
156 (set-extent-property ext 'invisible t) 225 (set-extent-property ext 'invisible t)
157 (set-extent-property ext 'end-open t) 226 (set-extent-property ext 'keymap smiley-map)
158 (set-extent-property ext 'intangible t)) 227 (set-extent-property ext 'mouse-face 'smiley-mouse-face)
159 (make-annotation glyph end 'text) 228 (set-extent-property ext 'intangible t)
229 ;; set annotation params
230 (set-extent-property ant 'mouse-face 'smiley-mouse-face)
231 (set-extent-property ant 'keymap smiley-map)
232 ;; remember each other
233 (set-extent-property ant 'smiley-extent ext)
234 (set-extent-property ext 'smiley-annotation ant))
160 (when (smiley-end-paren-p start end) 235 (when (smiley-end-paren-p start end)
161 (make-annotation ")" end 'text)) 236 (make-annotation ")" end 'text))
162 (goto-char end))))))))) 237 (goto-char end)))))))))
163 238
164 (defun smiley-end-paren-p (start end) 239 (defun smiley-end-paren-p (start end)