Mercurial > hg > xemacs-beta

comparison lisp/gnus/smiley.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 0293115a14e9
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
31 31
32 ;; To use: 32 ;; To use:
33 ;; (require 'smiley) 33 ;; (require 'smiley)
34 ;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t) 34 ;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t)
35 35
36 ;; The smilies were drawn by Joe Reiss <joe@jreiss.async.vt.edu>.
37
36 (require 'annotations) 38 (require 'annotations)
39 (require 'messagexmas)
37 (eval-when-compile (require 'cl)) 40 (eval-when-compile (require 'cl))
38 41
39 (defvar smiley-data-directory (message-xmas-find-glyph-directory "smilies") 42 (defvar smiley-data-directory (message-xmas-find-glyph-directory "smilies")
40 "Location of the smiley faces files.") 43 "Location of the smiley faces files.")
41 44
42 (defvar smiley-regexp-alist 45 ;; Notice the subtle differences in the regular expessions in the two alists below
43 '(("\\s-\\(:-*\\]\\)" 1 "FaceGrinning.xpm") 46
44 ("\\s-\\(:-*[oO]\\)" 1 "FaceStartled.xpm") 47 (defvar smiley-deformed-regexp-alist
45 ("\\s-\\(:-*[)>]\\)" 1 "FaceHappy.xpm") 48 '(("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm")
46 ("\\s-\\(;-*[>)]\\)" 1 "FaceWinking.xpm") 49 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
47 ("\\s-\\(:-[/\\]\\)" 1 "FaceIronic.xpm") 50 ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
48 ("\\s-\\(:-*|\\)" 1 "FaceStraight.xpm") 51 ("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm")
49 ("\\s-\\(:-*<\\)" 1 "FaceAngry.xpm") 52 ("\\(:-*[/\\\"]\\)[^/]" 1 "FaceIronic.xpm")
50 ("\\s-\\(:-*d\\)" 1 "FaceTasty.xpm") 53 ("\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
51 ("\\s-\\(:-*[pP]\\)" 1 "FaceYukky.xpm") 54 ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
52 ("\\s-\\(8-*|\\)" 1 "FaceKOed.xpm") 55 ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
53 ("\\s-\\(:-*(\\)" 1 "FaceAngry.xpm")) 56 ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
54 "A list of regexps to map smilies to real images.") 57 ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
58 ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
59 ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
60 ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
61 ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm")
62 ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
63 "Normal and deformed faces for smilies.")
64
65 (defvar smiley-nosey-regexp-alist
66 '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm")
67 ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
68 ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
69 ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm")
70 ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm") ;; The exception that confirms the rule
71 ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
72 ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
73 ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
74 ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
75 ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
76 ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
77 ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
78 ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
79 ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
80 ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm")
81 ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
82 "Smileys with noses. These get less false matches.")
83
84 (defvar smiley-regexp-alist smiley-deformed-regexp-alist
85 "A list of regexps to map smilies to real images.
86 Defaults to the content of smiley-deformed-regexp-alist.
87 An alternative smiley-nose-regexp-alist that
88 matches less aggresively is available.")
55 89
56 (defvar smiley-flesh-color "yellow" 90 (defvar smiley-flesh-color "yellow"
57 "Flesh color.") 91 "Flesh color.")
58 92
59 (defvar smiley-features-color "black" 93 (defvar smiley-features-color "black"
61 95
62 (defvar smiley-tongue-color "red" 96 (defvar smiley-tongue-color "red"
63 "Tongue color.") 97 "Tongue color.")
64 98
65 (defvar smiley-circle-color "black" 99 (defvar smiley-circle-color "black"
66 "Tongue color.") 100 "Circle color.")
67 101
68 (defvar smiley-glyph-cache nil) 102 (defvar smiley-glyph-cache nil)
69 (defvar smiley-running-xemacs (string-match "XEmacs" emacs-version)) 103 (defvar smiley-running-xemacs (string-match "XEmacs" emacs-version))
70 104
71 (defun smiley-create-glyph (smiley pixmap) 105 (defun smiley-create-glyph (smiley pixmap)
85 (cons 'tty smiley))))) 119 (cons 'tty smiley)))))
86 (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache)) 120 (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
87 (set-glyph-face glyph 'default) 121 (set-glyph-face glyph 'default)
88 glyph)))) 122 glyph))))
89 123
90 ;;;###interactive 124 ;;;###autoload
91 (defun smiley-region (beg end) 125 (defun smiley-region (beg end)
92 "Smilify the region between point and mark." 126 "Smilify the region between point and mark."
93 (interactive "r") 127 (interactive "r")
94 (smiley-buffer (current-buffer) beg end)) 128 (smiley-buffer (current-buffer) beg end))
95 129
96 ;;;###interactive 130 ;;;###autoload
97 (defun smiley-buffer (&optional buffer st nd) 131 (defun smiley-buffer (&optional buffer st nd)
98 (interactive) 132 (interactive)
99 (save-excursion 133 (when (featurep 'x)
100 (and buffer (set-buffer buffer)) 134 (save-excursion
101 (let ((buffer-read-only nil) 135 (when buffer
102 (alist smiley-regexp-alist) 136 (set-buffer buffer))
103 entry regexp beg group file) 137 (let ((buffer-read-only nil)
104 (goto-char (or st (point-min))) 138 (alist smiley-regexp-alist)
105 (setq beg (point)) 139 entry regexp beg group file)
106 ;; loop through alist 140 (goto-char (or st (point-min)))
107 (while (setq entry (pop alist)) 141 (setq beg (point))
108 (setq regexp (car entry) 142 ;; loop through alist
109 group (cadr entry) 143 (while (setq entry (pop alist))
110 file (caddr entry)) 144 (setq regexp (car entry)
111 (goto-char beg) 145 group (cadr entry)
112 (while (re-search-forward regexp nd t) 146 file (caddr entry))
113 (let* ((start (match-beginning group)) 147 (goto-char beg)
114 (end (match-end group)) 148 (while (re-search-forward regexp nd t)
115 (glyph (smiley-create-glyph (buffer-substring start end) 149 (let* ((start (match-beginning group))
116 file))) 150 (end (match-end group))
117 (when glyph 151 (glyph (smiley-create-glyph (buffer-substring start end)
118 (mapcar 'delete-annotation (annotations-at end)) 152 file)))
119 (let ((ext (make-extent start end))) 153 (when glyph
120 (set-extent-property ext 'invisible t) 154 (mapcar 'delete-annotation (annotations-at end))
121 (set-extent-property ext 'end-open t) 155 (let ((ext (make-extent start end)))
122 (set-extent-property ext 'intangible t)) 156 (set-extent-property ext 'invisible t)
123 (make-annotation glyph end 'text) 157 (set-extent-property ext 'end-open t)
124 (when (smiley-end-paren-p start end) 158 (set-extent-property ext 'intangible t))
125 (make-annotation ")" end 'text)) 159 (make-annotation glyph end 'text)
126 (goto-char end)))))))) 160 (when (smiley-end-paren-p start end)
161 (make-annotation ")" end 'text))
162 (goto-char end)))))))))
127 163
128 (defun smiley-end-paren-p (start end) 164 (defun smiley-end-paren-p (start end)
129 "Try to guess whether the current smiley is an end-paren smiley." 165 "Try to guess whether the current smiley is an end-paren smiley."
130 (save-excursion 166 (save-excursion
131 (goto-char start) 167 (goto-char start)