(require 'annotations)
(require 'messagexmas)
-(eval-when-compile (require 'cl))
+(require 'cl)
(defvar smiley-data-directory (message-xmas-find-glyph-directory "smilies")
"Location of the smiley faces files.")
("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
("\\(:-*[)>}ยป]+\\)\\W" 1 "FaceHappy.xpm")
- ("\\(:-*[/\\\"]\\)[^\\]" 1 "FaceIronic.xpm")
+ ("\\(:-*[/\\\"]\\)[^/]" 1 "FaceIronic.xpm")
("\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
"A list of regexps to map smilies to real images.
Defaults to the content of smiley-deformed-regexp-alist.
An alternative smiley-nose-regexp-alist that
-matches less aggresively is available.")
+matches less aggresively is available.
+If this is a symbol, take its value.")
(defvar smiley-flesh-color "yellow"
"Flesh color.")
(defvar smiley-glyph-cache nil)
(defvar smiley-running-xemacs (string-match "XEmacs" emacs-version))
+(defvar smiley-map (make-sparse-keymap "smiley-keys")
+ "keymap to toggle smiley states")
+
+(define-key smiley-map [(button2)] 'smiley-toggle-extent)
+
(defun smiley-create-glyph (smiley pixmap)
(and
smiley-running-xemacs
(interactive "r")
(smiley-buffer (current-buffer) beg end))
+(defun smiley-toggle-extent (event)
+ "Toggle smiley at given point"
+ (interactive "e")
+ (let* ((ant (event-glyph-extent event))
+ (pt (event-closest-point event))
+ ext)
+ (if (annotationp ant)
+ (when (extentp (setq ext (extent-property ant 'smiley-extent)))
+ (set-extent-property ext 'invisible nil)
+ (hide-annotation ant))
+ (when pt
+ (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
+ (when (annotationp (setq ant
+ (extent-property ext 'smiley-annotation)))
+ (reveal-annotation ant)
+ (set-extent-property ext 'invisible t)))))))
+
;;;###autoload
(defun smiley-buffer (&optional buffer st nd)
(interactive)
- (save-excursion
- (and buffer (set-buffer buffer))
- (let ((buffer-read-only nil)
- (alist smiley-regexp-alist)
- entry regexp beg group file)
- (goto-char (or st (point-min)))
- (setq beg (point))
- ;; loop through alist
- (while (setq entry (pop alist))
- (setq regexp (car entry)
- group (cadr entry)
- file (caddr entry))
- (goto-char beg)
- (while (re-search-forward regexp nd t)
- (let* ((start (match-beginning group))
- (end (match-end group))
- (glyph (smiley-create-glyph (buffer-substring start end)
- file)))
- (when glyph
- (mapcar 'delete-annotation (annotations-at end))
- (let ((ext (make-extent start end)))
- (set-extent-property ext 'invisible t)
- (set-extent-property ext 'end-open t)
- (set-extent-property ext 'intangible t))
- (make-annotation glyph end 'text)
- (when (smiley-end-paren-p start end)
- (make-annotation ")" end 'text))
- (goto-char end))))))))
+ (when (featurep 'x)
+ (save-excursion
+ (when buffer
+ (set-buffer buffer))
+ (let ((buffer-read-only nil)
+ (alist (if (symbolp smiley-regexp-alist)
+ (symbol-value smiley-regexp-alist)
+ smiley-regexp-alist))
+ entry regexp beg group file)
+ (goto-char (or st (point-min)))
+ (setq beg (point))
+ ;; loop through alist
+ (while (setq entry (pop alist))
+ (setq regexp (car entry)
+ group (cadr entry)
+ file (caddr entry))
+ (goto-char beg)
+ (while (re-search-forward regexp nd t)
+ (let* ((start (match-beginning group))
+ (end (match-end group))
+ (glyph (smiley-create-glyph (buffer-substring start end)
+ file)))
+ (when glyph
+ (mapcar 'delete-annotation (annotations-at end))
+ (let ((ext (make-extent start end))
+ (ant (make-annotation glyph end 'text)))
+ ;; set text extent params
+ (set-extent-property ext 'end-open t)
+ (set-extent-property ext 'start-open t)
+ (set-extent-property ext 'invisible t)
+ (set-extent-property ext 'keymap smiley-map)
+ (set-extent-property ext 'mouse-face gnus-article-mouse-face)
+ (set-extent-property ext 'intangible t)
+ ;; set annotation params
+ (set-extent-property ant 'mouse-face gnus-article-mouse-face)
+ (set-extent-property ant 'keymap smiley-map)
+ ;; remember each other
+ (set-extent-property ant 'smiley-extent ext)
+ (set-extent-property ext 'smiley-annotation ant))
+ (when (smiley-end-paren-p start end)
+ (make-annotation ")" end 'text))
+ (goto-char end)))))))))
(defun smiley-end-paren-p (start end)
"Try to guess whether the current smiley is an end-paren smiley."