X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fsmiley.el;h=c74d3ee39cf0bdc9df381f515b4ab31ad5d54242;hb=6ddf4efe9c1528cc39fb33ffd455351316cc3d1f;hp=88d88e06c1f4a0bc53c5b571555e561233942a2c;hpb=4c0bad76d2316c59b181d93baf04bb796ed439b0;p=gnus diff --git a/lisp/smiley.el b/lisp/smiley.el index 88d88e06c..c74d3ee39 100644 --- a/lisp/smiley.el +++ b/lisp/smiley.el @@ -1,5 +1,6 @@ ;;; 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 ;; Keywords: fun @@ -31,28 +32,51 @@ ;; 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 . +;; The smilies were drawn by Joe Reiss . -(require 'annotations) -(require 'messagexmas) (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") @@ -60,72 +84,120 @@ ("\\(;-*[>)}»]+\\)\\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) @@ -134,7 +206,7 @@ If this is a symbol, take its value.") (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)) @@ -145,15 +217,45 @@ If this is a symbol, take its value.") (hide-annotation ant)) (when pt (while (setq ext (extent-at pt (event-buffer event) nil ext 'at)) - (when (annotationp (setq ant + (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)) @@ -161,7 +263,14 @@ If this is a symbol, take its value.") (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 @@ -184,40 +293,149 @@ If this is a symbol, take its value.") (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 '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