Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; smiley.el --- displaying smiley faces |
d32525fd | 2 | |
ba318903 | 3 | ;; Copyright (C) 2000-2014 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) | |
059fc511 GM |
62 | ;; In batch mode, attributes can be unspecified. |
63 | (condition-case nil | |
64 | (>= (face-attribute 'default :height) 160) | |
65 | (error nil))) | |
01c52d31 MB |
66 | (and (fboundp 'face-height) |
67 | (>= (face-height 'default) 14))) | |
68 | 'medium | |
69 | 'low-color) | |
70 | "Smiley style." | |
71 | :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 | |
72 | (const :tag "medium, ~10 colors" medium) ;; 16x16 | |
73 | (const :tag "dull, grayscale" grayscale));; 14x14 | |
74 | :set (lambda (symbol value) | |
75 | (set-default symbol value) | |
76 | (setq smiley-data-directory (smiley-directory)) | |
77 | (smiley-update-cache)) | |
78 | :initialize 'custom-initialize-default | |
330f707b | 79 | :version "23.1" ;; No Gnus |
01c52d31 MB |
80 | :group 'smiley) |
81 | ||
82 | ;; For compatibility, honor the variable `smiley-data-directory' if the user | |
83 | ;; has set it. | |
84 | ||
85 | (defun smiley-directory (&optional style) | |
86 | "Return a the location of the smiley faces files. | |
87 | STYLE specifies which style to use, see `smiley-style'. If STYLE | |
88 | is nil, use `smiley-style'." | |
89 | (unless style (setq style smiley-style)) | |
90 | (nnheader-find-etc-directory | |
91 | (concat "images/smilies" | |
92 | (cond ((eq smiley-style 'low-color) "") | |
93 | ((eq smiley-style 'medium) "/medium") | |
94 | ((eq smiley-style 'grayscale) "/grayscale"))))) | |
95 | ||
96 | (defcustom smiley-data-directory (smiley-directory) | |
97 | "*Location of the smiley faces files." | |
98 | :set (lambda (symbol value) | |
99 | (set-default symbol value) | |
100 | (smiley-update-cache)) | |
101 | :initialize 'custom-initialize-default | |
23f87bed | 102 | :type 'directory |
b246235b DL |
103 | :group 'smiley) |
104 | ||
105 | ;; The XEmacs version has a baroque, if not rococo, set of these. | |
106 | (defcustom smiley-regexp-alist | |
07466c8e KY |
107 | '(("\\(;-)\\)\\W" 1 "blink") |
108 | ("[^;]\\(;)\\)\\W" 1 "blink") | |
23f87bed MB |
109 | ("\\(:-]\\)\\W" 1 "forced") |
110 | ("\\(8-)\\)\\W" 1 "braindamaged") | |
111 | ("\\(:-|\\)\\W" 1 "indifferent") | |
112 | ("\\(:-[/\\]\\)\\W" 1 "wry") | |
113 | ("\\(:-(\\)\\W" 1 "sad") | |
ecc7b2ba | 114 | ("\\(X-)\\)\\W" 1 "dead") |
01c52d31 MB |
115 | ("\\(:-{\\)\\W" 1 "frown") |
116 | ("\\(>:-)\\)\\W" 1 "evil") | |
117 | ("\\(;-(\\)\\W" 1 "cry") | |
118 | ("\\(:-D\\)\\W" 1 "grin") | |
119 | ;; "smile" must be come after "evil" | |
120 | ("\\(\\^?:-?)\\)\\W" 1 "smile")) | |
b246235b | 121 | "*A list of regexps to map smilies to images. |
ea8ae765 MB |
122 | The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in |
123 | regexp to replace with IMAGE. IMAGE is the name of an image file in | |
23f87bed | 124 | `smiley-data-directory'." |
1a10d421 | 125 | :version "24.1" |
b246235b DL |
126 | :type '(repeat (list regexp |
127 | (integer :tag "Regexp match number") | |
128 | (string :tag "Image name"))) | |
129 | :set (lambda (symbol value) | |
130 | (set-default symbol value) | |
131 | (smiley-update-cache)) | |
132 | :initialize 'custom-initialize-default | |
133 | :group 'smiley) | |
134 | ||
23f87bed MB |
135 | (defcustom gnus-smiley-file-types |
136 | (let ((types (list "pbm"))) | |
137 | (when (gnus-image-type-available-p 'xpm) | |
138 | (push "xpm" types)) | |
ca3cf0a5 G |
139 | (when (gnus-image-type-available-p 'gif) |
140 | (push "gif" types)) | |
23f87bed | 141 | types) |
ea8ae765 | 142 | "*List of suffixes on smiley file names to try." |
ca3cf0a5 | 143 | :version "24.1" |
23f87bed MB |
144 | :type '(repeat string) |
145 | :group 'smiley) | |
146 | ||
b246235b DL |
147 | (defvar smiley-cached-regexp-alist nil) |
148 | ||
149 | (defun smiley-update-cache () | |
ea8ae765 | 150 | (setq smiley-cached-regexp-alist nil) |
23f87bed MB |
151 | (dolist (elt (if (symbolp smiley-regexp-alist) |
152 | (symbol-value smiley-regexp-alist) | |
153 | smiley-regexp-alist)) | |
154 | (let ((types gnus-smiley-file-types) | |
155 | file type) | |
156 | (while (and (not file) | |
157 | (setq type (pop types))) | |
158 | (unless (file-exists-p | |
159 | (setq file (expand-file-name (concat (nth 2 elt) "." type) | |
160 | smiley-data-directory))) | |
161 | (setq file nil))) | |
162 | (when type | |
163 | (let ((image (gnus-create-image file (intern type) nil | |
164 | :ascent 'center))) | |
165 | (when image | |
166 | (push (list (car elt) (cadr elt) image) | |
167 | smiley-cached-regexp-alist))))))) | |
b246235b | 168 | |
ea8ae765 MB |
169 | ;; Not implemented: |
170 | ;; (defvar smiley-mouse-map | |
171 | ;; (let ((map (make-sparse-keymap))) | |
172 | ;; (define-key map [down-mouse-2] 'ignore) ; override widget | |
173 | ;; (define-key map [mouse-2] | |
174 | ;; 'smiley-mouse-toggle-buffer) | |
175 | ;; map)) | |
b246235b DL |
176 | |
177 | ;;;###autoload | |
178 | (defun smiley-region (start end) | |
23f87bed MB |
179 | "Replace in the region `smiley-regexp-alist' matches with corresponding images. |
180 | A list of images is returned." | |
b246235b | 181 | (interactive "r") |
23f87bed | 182 | (when (gnus-graphic-display-p) |
b246235b DL |
183 | (unless smiley-cached-regexp-alist |
184 | (smiley-update-cache)) | |
185 | (save-excursion | |
186 | (let ((beg (or start (point-min))) | |
23f87bed | 187 | group image images string) |
b246235b | 188 | (dolist (entry smiley-cached-regexp-alist) |
5768681d DL |
189 | (setq group (nth 1 entry) |
190 | image (nth 2 entry)) | |
b246235b DL |
191 | (goto-char beg) |
192 | (while (re-search-forward (car entry) end t) | |
23f87bed MB |
193 | (setq string (match-string group)) |
194 | (goto-char (match-end group)) | |
195 | (delete-region (match-beginning group) (match-end group)) | |
b246235b | 196 | (when image |
23f87bed MB |
197 | (push image images) |
198 | (gnus-add-wash-type 'smiley) | |
199 | (gnus-add-image 'smiley image) | |
200 | (gnus-put-image image string 'smiley)))) | |
201 | images)))) | |
202 | ||
203 | ;;;###autoload | |
204 | (defun smiley-buffer (&optional buffer) | |
2b8f62e9 JB |
205 | "Run `smiley-region' at the BUFFER, specified in the argument or |
206 | interactively. If there's no argument, do it at the current buffer." | |
23f87bed MB |
207 | (interactive "bBuffer to run smiley-region: ") |
208 | (save-excursion | |
209 | (if buffer | |
210 | (set-buffer (get-buffer buffer))) | |
211 | (smiley-region (point-min) (point-max)))) | |
b246235b DL |
212 | |
213 | (defun smiley-toggle-buffer (&optional arg) | |
23f87bed | 214 | "Toggle displaying smiley faces in article buffer. |
b246235b DL |
215 | With arg, turn displaying on if and only if arg is positive." |
216 | (interactive "P") | |
23f87bed MB |
217 | (gnus-with-article-buffer |
218 | (if (if (numberp arg) | |
219 | (> arg 0) | |
220 | (not (memq 'smiley gnus-article-wash-types))) | |
221 | (smiley-region (point-min) (point-max)) | |
222 | (gnus-delete-images 'smiley)))) | |
b246235b DL |
223 | |
224 | (defun smiley-mouse-toggle-buffer (event) | |
225 | "Toggle displaying smiley faces. | |
226 | With arg, turn displaying on if and only if arg is positive." | |
227 | (interactive "e") | |
228 | (save-excursion | |
229 | (save-window-excursion | |
230 | (mouse-set-point event) | |
231 | (smiley-toggle-buffer)))) | |
232 | ||
b246235b DL |
233 | (provide 'smiley) |
234 | ||
23f87bed | 235 | ;;; smiley.el ends here |