Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; smiley.el --- displaying smiley faces |
d32525fd | 2 | |
73b0cd50 | 3 | ;; Copyright (C) 2000-2011 Free Software Foundation, Inc. |
b246235b DL |
4 | |
5 | ;; Author: Dave Love <fx@gnu.org> | |
6 | ;; Keywords: news mail multimedia | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
5e809f55 | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
b246235b | 11 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
b246235b DL |
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 | |
5e809f55 | 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
b246235b DL |
18 | ;; GNU General Public License for more details. |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
b246235b DL |
22 | |
23 | ;;; Commentary: | |
24 | ||
25 | ;; A re-written, simplified version of Wes Hardaker's XEmacs smiley.el | |
26 | ;; which might be merged back to smiley.el if we get an assignment for | |
27 | ;; that. We don't have assignments for the images smiley.el uses, but | |
d32525fd DL |
28 | ;; I'm not sure we need that degree of rococoness and defaults like a |
29 | ;; yellow background. Also, using PBM means we can display the images | |
30 | ;; more generally. -- fx | |
ea8ae765 MB |
31 | ;; `smiley.el' was replaced by `smiley-ems.el' on 2002-01-26 (after fx' |
32 | ;; comment). | |
33 | ||
34 | ;; Test smileys: | |
35 | ;; smile ^:-) ^:) | |
36 | ;; blink ;-) ;) | |
37 | ;; forced :-] | |
38 | ;; braindamaged 8-) | |
39 | ;; indifferent :-| | |
40 | ;; wry :-/ :-\ | |
41 | ;; sad :-( | |
f5e92214 | 42 | ;; frown :-{ |
ea8ae765 MB |
43 | ;; evil >:-) |
44 | ;; cry ;-( | |
45 | ;; dead X-) | |
46 | ;; grin :-D | |
b246235b DL |
47 | |
48 | ;;; Code: | |
49 | ||
23f87bed | 50 | (eval-when-compile (require 'cl)) |
b246235b | 51 | (require 'nnheader) |
23f87bed | 52 | (require 'gnus-art) |
b246235b DL |
53 | |
54 | (defgroup smiley nil | |
55 | "Turn :-)'s into real images." | |
56 | :group 'gnus-visual) | |
57 | ||
01c52d31 MB |
58 | (defvar smiley-data-directory) |
59 | ||
60 | (defcustom smiley-style | |
61 | (if (or (and (fboundp 'face-attribute) | |
62 | (>= (face-attribute 'default :height) 160)) | |
63 | (and (fboundp 'face-height) | |
64 | (>= (face-height 'default) 14))) | |
65 | 'medium | |
66 | 'low-color) | |
67 | "Smiley style." | |
68 | :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 | |
69 | (const :tag "medium, ~10 colors" medium) ;; 16x16 | |
70 | (const :tag "dull, grayscale" grayscale));; 14x14 | |
71 | :set (lambda (symbol value) | |
72 | (set-default symbol value) | |
73 | (setq smiley-data-directory (smiley-directory)) | |
74 | (smiley-update-cache)) | |
75 | :initialize 'custom-initialize-default | |
330f707b | 76 | :version "23.1" ;; No Gnus |
01c52d31 MB |
77 | :group 'smiley) |
78 | ||
79 | ;; For compatibility, honor the variable `smiley-data-directory' if the user | |
80 | ;; has set it. | |
81 | ||
82 | (defun smiley-directory (&optional style) | |
83 | "Return a the location of the smiley faces files. | |
84 | STYLE specifies which style to use, see `smiley-style'. If STYLE | |
85 | is nil, use `smiley-style'." | |
86 | (unless style (setq style smiley-style)) | |
87 | (nnheader-find-etc-directory | |
88 | (concat "images/smilies" | |
89 | (cond ((eq smiley-style 'low-color) "") | |
90 | ((eq smiley-style 'medium) "/medium") | |
91 | ((eq smiley-style 'grayscale) "/grayscale"))))) | |
92 | ||
93 | (defcustom smiley-data-directory (smiley-directory) | |
94 | "*Location of the smiley faces files." | |
95 | :set (lambda (symbol value) | |
96 | (set-default symbol value) | |
97 | (smiley-update-cache)) | |
98 | :initialize 'custom-initialize-default | |
23f87bed | 99 | :type 'directory |
b246235b DL |
100 | :group 'smiley) |
101 | ||
102 | ;; The XEmacs version has a baroque, if not rococo, set of these. | |
103 | (defcustom smiley-regexp-alist | |
07466c8e KY |
104 | '(("\\(;-)\\)\\W" 1 "blink") |
105 | ("[^;]\\(;)\\)\\W" 1 "blink") | |
23f87bed MB |
106 | ("\\(:-]\\)\\W" 1 "forced") |
107 | ("\\(8-)\\)\\W" 1 "braindamaged") | |
108 | ("\\(:-|\\)\\W" 1 "indifferent") | |
109 | ("\\(:-[/\\]\\)\\W" 1 "wry") | |
110 | ("\\(:-(\\)\\W" 1 "sad") | |
ecc7b2ba | 111 | ("\\(X-)\\)\\W" 1 "dead") |
01c52d31 MB |
112 | ("\\(:-{\\)\\W" 1 "frown") |
113 | ("\\(>:-)\\)\\W" 1 "evil") | |
114 | ("\\(;-(\\)\\W" 1 "cry") | |
115 | ("\\(:-D\\)\\W" 1 "grin") | |
116 | ;; "smile" must be come after "evil" | |
117 | ("\\(\\^?:-?)\\)\\W" 1 "smile")) | |
b246235b | 118 | "*A list of regexps to map smilies to images. |
ea8ae765 MB |
119 | The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in |
120 | regexp to replace with IMAGE. IMAGE is the name of an image file in | |
23f87bed | 121 | `smiley-data-directory'." |
1a10d421 | 122 | :version "24.1" |
b246235b DL |
123 | :type '(repeat (list regexp |
124 | (integer :tag "Regexp match number") | |
125 | (string :tag "Image name"))) | |
126 | :set (lambda (symbol value) | |
127 | (set-default symbol value) | |
128 | (smiley-update-cache)) | |
129 | :initialize 'custom-initialize-default | |
130 | :group 'smiley) | |
131 | ||
23f87bed MB |
132 | (defcustom gnus-smiley-file-types |
133 | (let ((types (list "pbm"))) | |
134 | (when (gnus-image-type-available-p 'xpm) | |
135 | (push "xpm" types)) | |
ca3cf0a5 G |
136 | (when (gnus-image-type-available-p 'gif) |
137 | (push "gif" types)) | |
23f87bed | 138 | types) |
ea8ae765 | 139 | "*List of suffixes on smiley file names to try." |
ca3cf0a5 | 140 | :version "24.1" |
23f87bed MB |
141 | :type '(repeat string) |
142 | :group 'smiley) | |
143 | ||
b246235b DL |
144 | (defvar smiley-cached-regexp-alist nil) |
145 | ||
146 | (defun smiley-update-cache () | |
ea8ae765 | 147 | (setq smiley-cached-regexp-alist nil) |
23f87bed MB |
148 | (dolist (elt (if (symbolp smiley-regexp-alist) |
149 | (symbol-value smiley-regexp-alist) | |
150 | smiley-regexp-alist)) | |
151 | (let ((types gnus-smiley-file-types) | |
152 | file type) | |
153 | (while (and (not file) | |
154 | (setq type (pop types))) | |
155 | (unless (file-exists-p | |
156 | (setq file (expand-file-name (concat (nth 2 elt) "." type) | |
157 | smiley-data-directory))) | |
158 | (setq file nil))) | |
159 | (when type | |
160 | (let ((image (gnus-create-image file (intern type) nil | |
161 | :ascent 'center))) | |
162 | (when image | |
163 | (push (list (car elt) (cadr elt) image) | |
164 | smiley-cached-regexp-alist))))))) | |
b246235b | 165 | |
ea8ae765 MB |
166 | ;; Not implemented: |
167 | ;; (defvar smiley-mouse-map | |
168 | ;; (let ((map (make-sparse-keymap))) | |
169 | ;; (define-key map [down-mouse-2] 'ignore) ; override widget | |
170 | ;; (define-key map [mouse-2] | |
171 | ;; 'smiley-mouse-toggle-buffer) | |
172 | ;; map)) | |
b246235b DL |
173 | |
174 | ;;;###autoload | |
175 | (defun smiley-region (start end) | |
23f87bed MB |
176 | "Replace in the region `smiley-regexp-alist' matches with corresponding images. |
177 | A list of images is returned." | |
b246235b | 178 | (interactive "r") |
23f87bed | 179 | (when (gnus-graphic-display-p) |
b246235b DL |
180 | (unless smiley-cached-regexp-alist |
181 | (smiley-update-cache)) | |
182 | (save-excursion | |
183 | (let ((beg (or start (point-min))) | |
23f87bed | 184 | group image images string) |
b246235b | 185 | (dolist (entry smiley-cached-regexp-alist) |
5768681d DL |
186 | (setq group (nth 1 entry) |
187 | image (nth 2 entry)) | |
b246235b DL |
188 | (goto-char beg) |
189 | (while (re-search-forward (car entry) end t) | |
23f87bed MB |
190 | (setq string (match-string group)) |
191 | (goto-char (match-end group)) | |
192 | (delete-region (match-beginning group) (match-end group)) | |
b246235b | 193 | (when image |
23f87bed MB |
194 | (push image images) |
195 | (gnus-add-wash-type 'smiley) | |
196 | (gnus-add-image 'smiley image) | |
197 | (gnus-put-image image string 'smiley)))) | |
198 | images)))) | |
199 | ||
200 | ;;;###autoload | |
201 | (defun smiley-buffer (&optional buffer) | |
2b8f62e9 JB |
202 | "Run `smiley-region' at the BUFFER, specified in the argument or |
203 | interactively. If there's no argument, do it at the current buffer." | |
23f87bed MB |
204 | (interactive "bBuffer to run smiley-region: ") |
205 | (save-excursion | |
206 | (if buffer | |
207 | (set-buffer (get-buffer buffer))) | |
208 | (smiley-region (point-min) (point-max)))) | |
b246235b DL |
209 | |
210 | (defun smiley-toggle-buffer (&optional arg) | |
23f87bed | 211 | "Toggle displaying smiley faces in article buffer. |
b246235b DL |
212 | With arg, turn displaying on if and only if arg is positive." |
213 | (interactive "P") | |
23f87bed MB |
214 | (gnus-with-article-buffer |
215 | (if (if (numberp arg) | |
216 | (> arg 0) | |
217 | (not (memq 'smiley gnus-article-wash-types))) | |
218 | (smiley-region (point-min) (point-max)) | |
219 | (gnus-delete-images 'smiley)))) | |
b246235b DL |
220 | |
221 | (defun smiley-mouse-toggle-buffer (event) | |
222 | "Toggle displaying smiley faces. | |
223 | With arg, turn displaying on if and only if arg is positive." | |
224 | (interactive "e") | |
225 | (save-excursion | |
226 | (save-window-excursion | |
227 | (mouse-set-point event) | |
228 | (smiley-toggle-buffer)))) | |
229 | ||
b246235b DL |
230 | (provide 'smiley) |
231 | ||
23f87bed | 232 | ;;; smiley.el ends here |