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