Commit | Line | Data |
---|---|---|
23f87bed | 1 | ;;; smiley.el --- displaying smiley faces |
d32525fd | 2 | |
23f87bed | 3 | ;; Copyright (C) 2000, 2001, 2002, 2003 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 | ||
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation; either version 2, or (at your option) | |
13 | ;; any later version. | |
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 | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 | ;; Boston, MA 02111-1307, USA. | |
24 | ||
25 | ;;; Commentary: | |
26 | ||
27 | ;; A re-written, simplified version of Wes Hardaker's XEmacs smiley.el | |
28 | ;; which might be merged back to smiley.el if we get an assignment for | |
29 | ;; that. We don't have assignments for the images smiley.el uses, but | |
d32525fd DL |
30 | ;; I'm not sure we need that degree of rococoness and defaults like a |
31 | ;; yellow background. Also, using PBM means we can display the images | |
32 | ;; more generally. -- fx | |
b246235b DL |
33 | |
34 | ;;; Test smileys: :-) :-\ :-( :-/ | |
35 | ||
36 | ;;; Code: | |
37 | ||
23f87bed | 38 | (eval-when-compile (require 'cl)) |
b246235b | 39 | (require 'nnheader) |
23f87bed | 40 | (require 'gnus-art) |
b246235b DL |
41 | |
42 | (defgroup smiley nil | |
43 | "Turn :-)'s into real images." | |
44 | :group 'gnus-visual) | |
45 | ||
46 | ;; Maybe this should go. | |
47 | (defcustom smiley-data-directory (nnheader-find-etc-directory "smilies") | |
23f87bed MB |
48 | "*Location of the smiley faces files." |
49 | :type 'directory | |
b246235b DL |
50 | :group 'smiley) |
51 | ||
52 | ;; The XEmacs version has a baroque, if not rococo, set of these. | |
53 | (defcustom smiley-regexp-alist | |
23f87bed MB |
54 | '(("\\(:-?)\\)\\W" 1 "smile") |
55 | ("\\(;-?)\\)\\W" 1 "blink") | |
56 | ("\\(:-]\\)\\W" 1 "forced") | |
57 | ("\\(8-)\\)\\W" 1 "braindamaged") | |
58 | ("\\(:-|\\)\\W" 1 "indifferent") | |
59 | ("\\(:-[/\\]\\)\\W" 1 "wry") | |
60 | ("\\(:-(\\)\\W" 1 "sad") | |
61 | ("\\(:-{\\)\\W" 1 "frown")) | |
b246235b DL |
62 | "*A list of regexps to map smilies to images. |
63 | The elements are (REGEXP MATCH FILE), where MATCH is the submatch in | |
23f87bed MB |
64 | regexp to replace with IMAGE. IMAGE is the name of a PBM file in |
65 | `smiley-data-directory'." | |
b246235b DL |
66 | :type '(repeat (list regexp |
67 | (integer :tag "Regexp match number") | |
68 | (string :tag "Image name"))) | |
69 | :set (lambda (symbol value) | |
70 | (set-default symbol value) | |
71 | (smiley-update-cache)) | |
72 | :initialize 'custom-initialize-default | |
73 | :group 'smiley) | |
74 | ||
23f87bed MB |
75 | (defcustom gnus-smiley-file-types |
76 | (let ((types (list "pbm"))) | |
77 | (when (gnus-image-type-available-p 'xpm) | |
78 | (push "xpm" types)) | |
79 | types) | |
80 | "*List of suffixes on picon file names to try." | |
a08b59c9 | 81 | :version "21.4" |
23f87bed MB |
82 | :type '(repeat string) |
83 | :group 'smiley) | |
84 | ||
b246235b DL |
85 | (defvar smiley-cached-regexp-alist nil) |
86 | ||
87 | (defun smiley-update-cache () | |
23f87bed MB |
88 | (dolist (elt (if (symbolp smiley-regexp-alist) |
89 | (symbol-value smiley-regexp-alist) | |
90 | smiley-regexp-alist)) | |
91 | (let ((types gnus-smiley-file-types) | |
92 | file type) | |
93 | (while (and (not file) | |
94 | (setq type (pop types))) | |
95 | (unless (file-exists-p | |
96 | (setq file (expand-file-name (concat (nth 2 elt) "." type) | |
97 | smiley-data-directory))) | |
98 | (setq file nil))) | |
99 | (when type | |
100 | (let ((image (gnus-create-image file (intern type) nil | |
101 | :ascent 'center))) | |
102 | (when image | |
103 | (push (list (car elt) (cadr elt) image) | |
104 | smiley-cached-regexp-alist))))))) | |
b246235b DL |
105 | |
106 | (defvar smiley-mouse-map | |
107 | (let ((map (make-sparse-keymap))) | |
108 | (define-key map [down-mouse-2] 'ignore) ; override widget | |
109 | (define-key map [mouse-2] | |
110 | 'smiley-mouse-toggle-buffer) | |
111 | map)) | |
112 | ||
113 | ;;;###autoload | |
114 | (defun smiley-region (start end) | |
23f87bed MB |
115 | "Replace in the region `smiley-regexp-alist' matches with corresponding images. |
116 | A list of images is returned." | |
b246235b | 117 | (interactive "r") |
23f87bed | 118 | (when (gnus-graphic-display-p) |
b246235b DL |
119 | (unless smiley-cached-regexp-alist |
120 | (smiley-update-cache)) | |
121 | (save-excursion | |
122 | (let ((beg (or start (point-min))) | |
23f87bed | 123 | group image images string) |
b246235b | 124 | (dolist (entry smiley-cached-regexp-alist) |
5768681d DL |
125 | (setq group (nth 1 entry) |
126 | image (nth 2 entry)) | |
b246235b DL |
127 | (goto-char beg) |
128 | (while (re-search-forward (car entry) end t) | |
23f87bed MB |
129 | (setq string (match-string group)) |
130 | (goto-char (match-end group)) | |
131 | (delete-region (match-beginning group) (match-end group)) | |
b246235b | 132 | (when image |
23f87bed MB |
133 | (push image images) |
134 | (gnus-add-wash-type 'smiley) | |
135 | (gnus-add-image 'smiley image) | |
136 | (gnus-put-image image string 'smiley)))) | |
137 | images)))) | |
138 | ||
139 | ;;;###autoload | |
140 | (defun smiley-buffer (&optional buffer) | |
141 | "Run `smiley-region' at the buffer, specified in the argument or | |
142 | interactively. If there's no argument, do it at the current buffer" | |
143 | (interactive "bBuffer to run smiley-region: ") | |
144 | (save-excursion | |
145 | (if buffer | |
146 | (set-buffer (get-buffer buffer))) | |
147 | (smiley-region (point-min) (point-max)))) | |
b246235b DL |
148 | |
149 | (defun smiley-toggle-buffer (&optional arg) | |
23f87bed | 150 | "Toggle displaying smiley faces in article buffer. |
b246235b DL |
151 | With arg, turn displaying on if and only if arg is positive." |
152 | (interactive "P") | |
23f87bed MB |
153 | (gnus-with-article-buffer |
154 | (if (if (numberp arg) | |
155 | (> arg 0) | |
156 | (not (memq 'smiley gnus-article-wash-types))) | |
157 | (smiley-region (point-min) (point-max)) | |
158 | (gnus-delete-images 'smiley)))) | |
b246235b DL |
159 | |
160 | (defun smiley-mouse-toggle-buffer (event) | |
161 | "Toggle displaying smiley faces. | |
162 | With arg, turn displaying on if and only if arg is positive." | |
163 | (interactive "e") | |
164 | (save-excursion | |
165 | (save-window-excursion | |
166 | (mouse-set-point event) | |
167 | (smiley-toggle-buffer)))) | |
168 | ||
b246235b DL |
169 | (provide 'smiley) |
170 | ||
23f87bed MB |
171 | ;;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818 |
172 | ;;; smiley.el ends here |