1 |
|
;;; smiley.el --- displaying smiley faces |
2 |
|
|
3 |
|
;; Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. |
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 |
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 |
33 |
|
|
34 |
|
;;; Test smileys: :-) :-\ :-( :-/ |
35 |
|
|
36 |
|
;;; Code: |
37 |
|
|
38 |
|
(eval-when-compile (require 'cl)) |
39 |
|
(require 'nnheader) |
40 |
|
(require 'gnus-art) |
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") |
48 |
|
"*Location of the smiley faces files." |
49 |
|
:type 'directory |
50 |
|
:group 'smiley) |
51 |
|
|
52 |
|
;; The XEmacs version has a baroque, if not rococo, set of these. |
53 |
|
(defcustom smiley-regexp-alist |
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")) |
62 |
|
"*A list of regexps to map smilies to images. |
63 |
|
The elements are (REGEXP MATCH FILE), where MATCH is the submatch in |
64 |
|
regexp to replace with IMAGE. IMAGE is the name of a PBM file in |
65 |
|
`smiley-data-directory'." |
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 |
|
|
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." |
81 |
|
:type '(repeat string) |
82 |
|
:group 'smiley) |
83 |
|
|
84 |
|
(defvar smiley-cached-regexp-alist nil) |
85 |
|
|
86 |
|
(defun smiley-update-cache () |
87 |
|
(dolist (elt (if (symbolp smiley-regexp-alist) |
88 |
|
(symbol-value smiley-regexp-alist) |
89 |
|
smiley-regexp-alist)) |
90 |
|
(let ((types gnus-smiley-file-types) |
91 |
|
file type) |
92 |
|
(while (and (not file) |
93 |
|
(setq type (pop types))) |
94 |
|
(unless (file-exists-p |
95 |
|
(setq file (expand-file-name (concat (nth 2 elt) "." type) |
96 |
|
smiley-data-directory))) |
97 |
|
(setq file nil))) |
98 |
|
(when type |
99 |
|
(let ((image (gnus-create-image file (intern type) nil |
100 |
|
:ascent 'center))) |
101 |
|
(when image |
102 |
|
(push (list (car elt) (cadr elt) image) |
103 |
|
smiley-cached-regexp-alist))))))) |
104 |
|
|
105 |
|
(defvar smiley-mouse-map |
106 |
|
(let ((map (make-sparse-keymap))) |
107 |
|
(define-key map [down-mouse-2] 'ignore) ; override widget |
108 |
|
(define-key map [mouse-2] |
109 |
|
'smiley-mouse-toggle-buffer) |
110 |
|
map)) |
111 |
|
|
112 |
|
;;;###autoload |
113 |
|
(defun smiley-region (start end) |
114 |
|
"Replace in the region `smiley-regexp-alist' matches with corresponding images. |
115 |
|
A list of images is returned." |
116 |
|
(interactive "r") |
117 |
|
(when (gnus-graphic-display-p) |
118 |
|
(unless smiley-cached-regexp-alist |
119 |
|
(smiley-update-cache)) |
120 |
|
(save-excursion |
121 |
|
(let ((beg (or start (point-min))) |
122 |
|
group image images string) |
123 |
|
(dolist (entry smiley-cached-regexp-alist) |
124 |
|
(setq group (nth 1 entry) |
125 |
|
image (nth 2 entry)) |
126 |
|
(goto-char beg) |
127 |
|
(while (re-search-forward (car entry) end t) |
128 |
|
(setq string (match-string group)) |
129 |
|
(goto-char (match-end group)) |
130 |
|
(delete-region (match-beginning group) (match-end group)) |
131 |
|
(when image |
132 |
|
(push image images) |
133 |
|
(gnus-add-wash-type 'smiley) |
134 |
|
(gnus-add-image 'smiley image) |
135 |
|
(gnus-put-image image string 'smiley)))) |
136 |
|
images)))) |
137 |
|
|
138 |
|
;;;###autoload |
139 |
|
(defun smiley-buffer (&optional buffer) |
140 |
|
"Run `smiley-region' at the buffer, specified in the argument or |
141 |
|
interactively. If there's no argument, do it at the current buffer" |
142 |
|
(interactive "bBuffer to run smiley-region: ") |
143 |
|
(save-excursion |
144 |
|
(if buffer |
145 |
|
(set-buffer (get-buffer buffer))) |
146 |
|
(smiley-region (point-min) (point-max)))) |
147 |
|
|
148 |
|
(defun smiley-toggle-buffer (&optional arg) |
149 |
|
"Toggle displaying smiley faces in article buffer. |
150 |
|
With arg, turn displaying on if and only if arg is positive." |
151 |
|
(interactive "P") |
152 |
|
(gnus-with-article-buffer |
153 |
|
(if (if (numberp arg) |
154 |
|
(> arg 0) |
155 |
|
(not (memq 'smiley gnus-article-wash-types))) |
156 |
|
(smiley-region (point-min) (point-max)) |
157 |
|
(gnus-delete-images 'smiley)))) |
158 |
|
|
159 |
|
(defun smiley-mouse-toggle-buffer (event) |
160 |
|
"Toggle displaying smiley faces. |
161 |
|
With arg, turn displaying on if and only if arg is positive." |
162 |
|
(interactive "e") |
163 |
|
(save-excursion |
164 |
|
(save-window-excursion |
165 |
|
(mouse-set-point event) |
166 |
|
(smiley-toggle-buffer)))) |
167 |
|
|
168 |
|
(provide 'smiley) |
169 |
|
|
170 |
|
;;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818 |
171 |
|
;;; smiley.el ends here |