;;; smiley.el --- displaying smiley faces
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;; Free Software Foundation, Inc.
;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
;; Keywords: fun
;; To use:
;; (require 'smiley)
-;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t)
+;; (setq gnus-treat-display-smileys t)
-;; The smilies were drawn by Joe Reiss <joe@jreiss.async.vt.edu>.
+;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
-(require 'annotations)
-(require 'messagexmas)
-(eval-when-compile (require 'cl))
+(require 'cl)
+(require 'custom)
-(defvar smiley-data-directory (message-xmas-find-glyph-directory "smilies")
- "Location of the smiley faces files.")
+(eval-and-compile
+ (when (featurep 'xemacs)
+ (require 'annotations)
+ (require 'messagexmas)))
-;; Notice the subtle differences in the regular expessions in the two alists below
+(defgroup smiley nil
+ "Turn :-)'s into real images."
+ :group 'gnus-visual)
-(defvar smiley-deformed-regexp-alist
- '(("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm")
+;; FIXME: Where is the directory when using Emacs?
+(defcustom smiley-data-directory
+ (if (featurep 'xemacs)
+ (message-xmas-find-glyph-directory "smilies")
+ "/usr/local/lib/xemacs/xemacs-packages/etc/smilies")
+ "*Location of the smiley faces files."
+ :type 'directory
+ :group 'smiley)
+
+;; Notice the subtle differences in the regular expressions in the
+;; two alists below.
+
+(defcustom smiley-deformed-regexp-alist
+ '(("\\(\\^_?\\^;;;\\)\\W" 1 "WideFaceAse3.xbm")
+ ("\\(\\^_?\\^;;\\)\\W" 1 "WideFaceAse2.xbm")
+ ("\\(\\^_?\\^;\\)\\W" 1 "WideFaceAse1.xbm")
+ ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm")
+ ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
+ ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
+ ("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm")
("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm")
- ("\\(:-*[/\\\"]\\)[^/]" 1 "FaceIronic.xpm")
- ("\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
+ ("\\(=[)»]+\\)\\W" 1 "FaceHappy.xpm")
+ ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
+ ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
+ ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm")
("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
- "Normal and deformed faces for smilies.")
+ "*Normal and deformed faces for smilies."
+ :type '(repeat (list regexp
+ (integer :tag "Match")
+ (string :tag "Image")))
+ :group 'smiley)
-(defvar smiley-nosey-regexp-alist
+(defcustom smiley-nosey-regexp-alist
'(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm")
("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm")
- ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm") ;; The exception that confirms the rule
+ ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm")
+ ("\\(=[)]+\\)\\W" 1 "FaceHappy.xpm")
("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
+ ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm")
+ ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
- "Smileys with noses. These get less false matches.")
+ "*Smileys with noses. These get less false matches."
+ :type '(repeat (list regexp
+ (integer :tag "Match")
+ (string :tag "Image")))
+ :group 'smiley)
+
+(defcustom smiley-regexp-alist smiley-deformed-regexp-alist
+ "*A list of regexps to map smilies to real images.
+Defaults to the contents of `smiley-deformed-regexp-alist'.
+An alternative is `smiley-nosey-regexp-alist' that matches less
+aggressively.
+If this is a symbol, take its value."
+ :type '(radio (variable-item smiley-deformed-regexp-alist)
+ (variable-item smiley-nosey-regexp-alist)
+ symbol
+ (repeat (list regexp
+ (integer :tag "Match")
+ (string :tag "Image"))))
+ :group 'smiley)
-(defvar smiley-regexp-alist smiley-deformed-regexp-alist
- "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.
-If this is a symbol, take its value.")
+(defcustom smiley-flesh-color "yellow"
+ "*Flesh color."
+ :type 'string
+ :group 'smiley)
-(defvar smiley-flesh-color "yellow"
- "Flesh color.")
+(defcustom smiley-features-color "black"
+ "*Features color."
+ :type 'string
+ :group 'smiley)
-(defvar smiley-features-color "black"
- "Features color.")
+(defcustom smiley-tongue-color "red"
+ "*Tongue color."
+ :type 'string
+ :group 'smiley)
-(defvar smiley-tongue-color "red"
- "Tongue color.")
+(defcustom smiley-circle-color "black"
+ "*Circle color."
+ :type 'string
+ :group 'smiley)
-(defvar smiley-circle-color "black"
- "Circle color.")
+(defcustom smiley-mouse-face 'highlight
+ "*Face used for mouse highlighting in the smiley buffer.
+
+Smiley buttons will be displayed in this face when the cursor is
+above them."
+ :type 'face
+ :group 'smiley)
(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")
+ "Keymap to toggle smiley states.")
(define-key smiley-map [(button2)] 'smiley-toggle-extent)
+(define-key smiley-map [(button3)] 'smiley-popup-menu)
+
+(defun smiley-popup-menu (e)
+ (interactive "e")
+ (popup-menu
+ `("Smilies"
+ ["Toggle This Smiley" (smiley-toggle-extent ,e) t]
+ ["Toggle All Smilies" (smiley-toggle-extents ,e) t])))
(defun smiley-create-glyph (smiley pixmap)
- (and
- smiley-running-xemacs
- (or
- (cdr-safe (assoc pixmap smiley-glyph-cache))
- (let* ((xpm-color-symbols
- (and (featurep 'xpm)
- (append `(("flesh" ,smiley-flesh-color)
- ("features" ,smiley-features-color)
- ("tongue" ,smiley-tongue-color))
- xpm-color-symbols)))
- (glyph (make-glyph
- (list
- (cons 'x (expand-file-name pixmap smiley-data-directory))
- (cons 'tty smiley)))))
- (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
- (set-glyph-face glyph 'default)
- glyph))))
+ (or
+ (cdr-safe (assoc pixmap smiley-glyph-cache))
+ (let* ((xpm-color-symbols
+ (and (featurep 'xpm)
+ (append `(("flesh" ,smiley-flesh-color)
+ ("features" ,smiley-features-color)
+ ("tongue" ,smiley-tongue-color))
+ xpm-color-symbols)))
+ (glyph (make-glyph
+ (list
+ (cons (if (featurep 'gtk) 'gtk 'x)
+ (expand-file-name pixmap smiley-data-directory))
+ (cons 'mswindows
+ (expand-file-name pixmap smiley-data-directory))
+ (cons 'tty smiley)))))
+ (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
+ (set-glyph-face glyph 'default)
+ glyph)))
+
+(defun smiley-create-glyph-ems (smiley pixmap)
+ (condition-case e
+ (create-image (expand-file-name pixmap smiley-data-directory))
+ (error nil)))
+
;;;###autoload
(defun smiley-region (beg end)
(smiley-buffer (current-buffer) beg end))
(defun smiley-toggle-extent (event)
- "Toggle smiley at given point"
+ "Toggle smiley at given point."
(interactive "e")
(let* ((ant (event-glyph-extent event))
(pt (event-closest-point event))
(when (extentp (setq ext (extent-property ant 'smiley-extent)))
(set-extent-property ext 'invisible nil)
(hide-annotation ant))
- (if 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)))))))
+ (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)))))))
+
+;; FIXME::
+(defun smiley-toggle-extent-ems (event)
+ "Toggle smiley at given point.
+Note -- this function hasn't been implemented yet."
+ (interactive "e")
+ (error "This function hasn't been implemented yet.")
+)
+
+(defun smiley-toggle-extents (e)
+ (interactive "e")
+ (map-extents
+ (lambda (e void)
+ (let (ant)
+ (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
+ (if (eq (extent-property e 'invisible) nil)
+ (progn
+ (reveal-annotation ant)
+ (set-extent-property e 'invisible t)
+ )
+ (hide-annotation ant)
+ (set-extent-property e 'invisible nil)))
+ nil))
+ (event-buffer e)))
+
+;; FIXME::
+(defun smiley-toggle-extents-ems (e)
+ (interactive "e")
+ (error "This function hasn't been implemented yet.")
+)
;;;###autoload
(defun smiley-buffer (&optional buffer st nd)
(interactive)
- (when (featurep 'x)
+ (when (featurep '(or x gtk mswindows))
(save-excursion
(when buffer
(set-buffer buffer))
(alist (if (symbolp smiley-regexp-alist)
(symbol-value smiley-regexp-alist)
smiley-regexp-alist))
+ (case-fold-search nil)
entry regexp beg group file)
+ (map-extents
+ (lambda (e void)
+ (when (or (extent-property e 'smiley-extent)
+ (extent-property e 'smiley-annotation))
+ (delete-extent e)))
+ buffer st nd)
(goto-char (or st (point-min)))
(setq beg (point))
;; loop through alist
(let ((ext (make-extent start end))
(ant (make-annotation glyph end 'text)))
;; set text extent params
- (set-extent-property ext 'invisible t)
(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-extent-property ext 'mouse-face smiley-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 'mouse-face smiley-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))
+ (set-extent-property ext 'smiley-annotation ant)
+ ;; Help
+ (set-extent-property
+ ext 'help-echo
+ "button2 toggles smiley, button3 pops up menu")
+ (set-extent-property
+ ant 'help-echo
+ "button2 toggles smiley, button3 pops up menu")
+ (set-extent-property ext 'balloon-help
+ "Mouse button2 - toggle smiley
+Mouse button3 - menu")
+ (set-extent-property ant 'balloon-help
+ "Mouse button2 - toggle smiley
+Mouse button3 - menu"))
(when (smiley-end-paren-p start end)
(make-annotation ")" end 'text))
(goto-char end)))))))))
+;; FIXME: No popup menu, no customized color
+(defun smiley-buffer-ems (&optional buffer st nd)
+ (interactive)
+ (when window-system
+ (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))
+ (case-fold-search nil)
+ entry regexp beg group file)
+ (dolist (overlay (overlays-in (or st (point-min))
+ (or nd (point-max))))
+ (when (overlay-get overlay 'smiley)
+ (remove-text-properties (overlay-start overlay)
+ (overlay-end overlay) '(display))
+ (delete-overlay overlay)))
+ (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 nil file))
+ (overlay (make-overlay start end)))
+ (when glyph
+ (add-text-properties start end
+ `(display ,glyph))
+ (overlay-put overlay 'smiley glyph)
+ (goto-char end)))))))))
+
(defun smiley-end-paren-p (start end)
"Try to guess whether the current smiley is an end-paren smiley."
(save-excursion
(goto-char start)
(when (and (re-search-backward "[()]" nil t)
- (= (following-char) ?\()
+ (eq (char-after) ?\()
(goto-char end)
(or (not (re-search-forward "[()]" nil t))
- (= (char-after (1- (point))) ?\()))
+ (eq (char-after (1- (point))) ?\()))
t)))
-;;;###autoload
-(defun gnus-smiley-display ()
- (interactive)
+(defun smiley-toggle-buffer (&optional arg buffer st nd)
+ "Toggle displaying smiley faces.
+With arg, turn displaying on if and only if arg is positive."
+ (interactive "P")
+ (let (on off)
+ (map-extents
+ (lambda (e void)
+ (let (ant)
+ (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
+ (if (eq (extent-property e 'invisible) nil)
+ (setq off (cons (cons ant e) off))
+ (setq on (cons (cons ant e) on)))))
+ nil)
+ buffer st nd)
+ (if (and (not (and (numberp arg) (< arg 0)))
+ (or (and (numberp arg) (> arg 0))
+ (null on)))
+ (if off
+ (while off
+ (reveal-annotation (caar off))
+ (set-extent-property (cdar off) 'invisible t)
+ (setq off (cdr off)))
+ (smiley-buffer))
+ (while on
+ (hide-annotation (caar on))
+ (set-extent-property (cdar on) 'invisible nil)
+ (setq on (cdr on))))))
+
+;; Simply removing all smiley if existing.
+;; FIXME: make it work as the one in XEmacs.
+(defun smiley-toggle-buffer-ems (&optional arg buffer st nd)
+ "Toggle displaying smiley faces.
+With arg, turn displaying on if and only if arg is positive."
+ (interactive "P")
(save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
- ;; We skip the headers.
- (unless (search-forward "\n\n" nil t)
- (goto-char (point-max)))
- (smiley-buffer (current-buffer) (point))))
+ (when buffer
+ (set-buffer buffer))
+ (let (found)
+ (dolist (overlay (overlays-in (or st (point-min))
+ (or nd (point-max))))
+ (when (overlay-get overlay 'smiley)
+ (remove-text-properties (overlay-start overlay)
+ (overlay-end overlay) '(display))
+ (setq found t)))
+ (unless found
+ (smiley-buffer buffer st nd)))))
+
+(unless (featurep 'xemacs)
+ (defalias 'smiley-create-glyph 'smiley-create-glyph-ems)
+ (defalias 'smiley-toggle-extent 'smiley-toggle-extent-ems)
+ (defalias 'smiley-toggle-extents 'smiley-toggle-extents-ems)
+ (defalias 'smiley-buffer 'smiley-buffer-ems)
+ (defalias 'smiley-toggle-buffer 'smiley-toggle-buffer-ems))
+
+(defvar gnus-article-buffer)
+;;;###autoload
+(defun gnus-smiley-display (&optional arg)
+ "Display \"smileys\" as small graphical icons.
+With arg, turn displaying on if and only if arg is positive."
+ (interactive "P")
+ (save-excursion
+ (article-goto-body)
+ (let (buffer-read-only)
+ (smiley-toggle-buffer arg (current-buffer) (point) (point-max)))))
(provide 'smiley)
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
;;; smiley.el ends here