;;; smiley.el --- displaying smiley faces
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;; Free Software Foundation, Inc.
-;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
-
-;; Author: Dave Love <fx@gnu.org>
-;; Keywords: news mail multimedia
+;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
+;; Keywords: fun
;; This file is part of GNU Emacs.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; Commentary:
-;; A re-written, simplified version of Wes Hardaker's XEmacs smiley.el
-;; which might be merged back to smiley.el if we get an assignment for
-;; that. We don't have assignments for the images smiley.el uses, but
-;; I'm not sure we need that degree of rococoness and defaults like a
-;; yellow background. Also, using PBM means we can display the images
-;; more generally. -- fx
-;; `smiley.el' was replaced by `smiley-ems.el' on 2002-01-26 (after fx'
-;; comment).
-
-;; Test smileys:
-;; smile ^:-) ^:)
-;; blink ;-) ;)
-;; forced :-]
-;; braindamaged 8-)
-;; indifferent :-|
-;; wry :-/ :-\
-;; sad :-(
-;; frown :-{
-;; evil >:-)
-;; cry ;-(
-;; dead X-)
-;; grin :-D
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'nnheader)
-(require 'gnus-art)
+;;
+;; comments go here.
+;;
+
+;;; Test smileys: :-] :-o :-) ;-) :-\ :-| :-d :-P 8-| :-(
+
+;; To use:
+;; (require 'smiley)
+;; (setq gnus-treat-display-smileys t)
+
+;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
+
+(require 'cl)
+(require 'custom)
+
+(eval-and-compile
+ (when (featurep 'xemacs)
+ (require 'annotations)
+ (require 'messagexmas)))
(defgroup smiley nil
"Turn :-)'s into real images."
:group 'gnus-visual)
-(defvar smiley-data-directory)
-
-(defcustom smiley-style 'low-color
- "Smiley style."
- :type '(choice (const :tag "small, 3 colors" low-color)
- (const :tag "medium, ~10 colors" medium)
- (const :tag "dull, grayscale" grayscale))
- :set (lambda (symbol value)
- (set-default symbol value)
- (setq smiley-data-directory (smiley-directory))
- (smiley-update-cache))
- :initialize 'custom-initialize-default
- :version "23.0" ;; No Gnus
- :group 'smiley)
-
-;; For compatibility, honor the variable `smiley-data-directory' if the user
-;; has set it.
-
-(defun smiley-directory (&optional style)
- "Return a the location of the smiley faces files.
-STYLE specifies which style to use, see `smiley-style'. If STYLE
-is nil, use `smiley-style'."
- (unless style (setq style smiley-style))
- (nnheader-find-etc-directory
- (concat "images/smilies"
- (cond ((eq smiley-style 'low-color) "")
- ((eq smiley-style 'medium) "/medium")
- ((eq smiley-style 'grayscale) "/grayscale")))))
-
-(defcustom smiley-data-directory (smiley-directory)
+;; 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."
- :set (lambda (symbol value)
- (set-default symbol value)
- (smiley-update-cache))
- :initialize 'custom-initialize-default
:type 'directory
:group 'smiley)
-;; The XEmacs version has a baroque, if not rococo, set of these.
-(defcustom smiley-regexp-alist
- '(("\\(;-?)\\)\\W" 1 "blink")
- ("\\(:-]\\)\\W" 1 "forced")
- ("\\(8-)\\)\\W" 1 "braindamaged")
- ("\\(:-|\\)\\W" 1 "indifferent")
- ("\\(:-[/\\]\\)\\W" 1 "wry")
- ("\\(:-(\\)\\W" 1 "sad")
- ("\\(:-{\\)\\W" 1 "frown")
- ("\\(>:-)\\)\\W" 1 "evil")
- ("\\(;-(\\)\\W" 1 "cry")
- ("\\(X-)\\)\\W" 1 "dead")
- ("\\(:-D\\)\\W" 1 "grin")
- ;; "smile" must be come after "evil"
- ("\\(\\^?:-?)\\)\\W" 1 "smile"))
- "*A list of regexps to map smilies to images.
-The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in
-regexp to replace with IMAGE. IMAGE is the name of an image file in
-`smiley-data-directory'."
+;; 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")
+ ("\\(=[)»]+\\)\\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")
+ ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
+ ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
+ ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm")
+ ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
+ "*Normal and deformed faces for smilies."
:type '(repeat (list regexp
- (integer :tag "Regexp match number")
- (string :tag "Image name")))
- :set (lambda (symbol value)
- (set-default symbol value)
- (smiley-update-cache))
- :initialize 'custom-initialize-default
+ (integer :tag "Match")
+ (string :tag "Image")))
+ :group 'smiley)
+
+(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")
+ ("\\(=[)]+\\)\\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."
+ :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)
+
+(defcustom smiley-flesh-color "yellow"
+ "*Flesh color."
+ :type 'string
+ :group 'smiley)
+
+(defcustom smiley-features-color "black"
+ "*Features color."
+ :type 'string
+ :group 'smiley)
+
+(defcustom smiley-tongue-color "red"
+ "*Tongue color."
+ :type 'string
+ :group 'smiley)
+
+(defcustom smiley-circle-color "black"
+ "*Circle color."
+ :type 'string
:group 'smiley)
-(defcustom gnus-smiley-file-types
- (let ((types (list "pbm")))
- (when (gnus-image-type-available-p 'xpm)
- (push "xpm" types))
- types)
- "*List of suffixes on smiley file names to try."
- :version "22.1"
- :type '(repeat string)
+(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-cached-regexp-alist nil)
-
-(defun smiley-update-cache ()
- (setq smiley-cached-regexp-alist nil)
- (dolist (elt (if (symbolp smiley-regexp-alist)
- (symbol-value smiley-regexp-alist)
- smiley-regexp-alist))
- (let ((types gnus-smiley-file-types)
- file type)
- (while (and (not file)
- (setq type (pop types)))
- (unless (file-exists-p
- (setq file (expand-file-name (concat (nth 2 elt) "." type)
- smiley-data-directory)))
- (setq file nil)))
- (when type
- (let ((image (gnus-create-image file (intern type) nil
- :ascent 'center)))
- (when image
- (push (list (car elt) (cadr elt) image)
- smiley-cached-regexp-alist)))))))
-
-;; Not implemented:
-;; (defvar smiley-mouse-map
-;; (let ((map (make-sparse-keymap)))
-;; (define-key map [down-mouse-2] 'ignore) ; override widget
-;; (define-key map [mouse-2]
-;; 'smiley-mouse-toggle-buffer)
-;; map))
+(defvar smiley-glyph-cache nil)
+
+(defvar smiley-map (make-sparse-keymap "smiley-keys")
+ "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)
+ (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)))
;;;###autoload
-(defun smiley-region (start end)
- "Replace in the region `smiley-regexp-alist' matches with corresponding images.
-A list of images is returned."
+(defun smiley-region (beg end)
+ "Smilify the region between point and mark."
(interactive "r")
- (when (gnus-graphic-display-p)
- (unless smiley-cached-regexp-alist
- (smiley-update-cache))
+ (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)))))))
+
+(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)))
+
+;;;###autoload
+(defun smiley-buffer (&optional buffer st nd)
+ (interactive)
+ (when (featurep '(or x gtk mswindows))
(save-excursion
- (let ((beg (or start (point-min)))
- group image images string)
- (dolist (entry smiley-cached-regexp-alist)
- (setq group (nth 1 entry)
- image (nth 2 entry))
+ (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)
+ (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
+ (while (setq entry (pop alist))
+ (setq regexp (car entry)
+ group (cadr entry)
+ file (caddr entry))
(goto-char beg)
- (while (re-search-forward (car entry) end t)
- (setq string (match-string group))
- (goto-char (match-end group))
- (delete-region (match-beginning group) (match-end group))
- (when image
- (push image images)
- (gnus-add-wash-type 'smiley)
- (gnus-add-image 'smiley image)
- (gnus-put-image image string 'smiley))))
- images))))
+ (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 smiley-mouse-face)
+ (set-extent-property ext 'intangible t)
+ ;; set annotation params
+ (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)
+ ;; 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)))))))))
-;;;###autoload
-(defun smiley-buffer (&optional buffer)
- "Run `smiley-region' at the buffer, specified in the argument or
-interactively. If there's no argument, do it at the current buffer"
- (interactive "bBuffer to run smiley-region: ")
+(defun smiley-end-paren-p (start end)
+ "Try to guess whether the current smiley is an end-paren smiley."
(save-excursion
- (if buffer
- (set-buffer (get-buffer buffer)))
- (smiley-region (point-min) (point-max))))
+ (goto-char start)
+ (when (and (re-search-backward "[()]" nil t)
+ (eq (char-after) ?\()
+ (goto-char end)
+ (or (not (re-search-forward "[()]" nil t))
+ (eq (char-after (1- (point))) ?\()))
+ t)))
-(defun smiley-toggle-buffer (&optional arg)
- "Toggle displaying smiley faces in article buffer.
+(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")
- (gnus-with-article-buffer
- (if (if (numberp arg)
- (> arg 0)
- (not (memq 'smiley gnus-article-wash-types)))
- (smiley-region (point-min) (point-max))
- (gnus-delete-images 'smiley))))
-
-(defun smiley-mouse-toggle-buffer (event)
- "Toggle displaying smiley faces.
+ (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))))))
+
+(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 "e")
+ (interactive "P")
(save-excursion
- (save-window-excursion
- (mouse-set-point event)
- (smiley-toggle-buffer))))
+ (article-goto-body)
+ (let (buffer-read-only)
+ (smiley-toggle-buffer arg (current-buffer) (point) (point-max)))))
(provide 'smiley)
-;;; arch-tag: 5beb161b-4321-40af-8ac9-876afb8ee818
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
;;; smiley.el ends here
projects / gnus / blobdiff