Synch with Oort Gnus.
[elisp/gnus.git-] / lisp / smiley.el
index ac9566c..380cea9 100644 (file)
@@ -1,5 +1,6 @@
 ;;; smiley.el --- displaying smiley faces
 ;;; smiley.el --- displaying smiley faces
-;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;;        Free Software Foundation, Inc.
 
 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
 ;; Keywords: fun
 
 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
 ;; Keywords: fun
 
 ;; To use:
 ;; (require 'smiley)
 
 ;; 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 <jreiss@vt.edu>.
 
 
 ;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
 
-(require 'annotations)
-(require 'messagexmas)
-(require 'cl)
+(eval-when-compile (require 'cl))
 (require 'custom)
 
 (require 'custom)
 
+(eval-and-compile
+  (when (featurep 'xemacs)
+    (require 'annotations)
+    (require 'messagexmas)))
+
 (defgroup smiley nil
 (defgroup smiley nil
-  "Turn :-)'s into real images (XEmacs)."
+  "Turn :-)'s into real images."
   :group 'gnus-visual)
 
   :group 'gnus-visual)
 
-(defcustom smiley-data-directory (message-xmas-find-glyph-directory "smilies")
-  "Location of the smiley faces files."
+;; 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)
 
   :type 'directory
   :group 'smiley)
 
     ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm")
     ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
     ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
     ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm")
     ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
     ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
-    ("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm")
+    ("\\(:-*[<\e(I+\e(B]+\\)\\W" 1 "FaceAngry.xpm")
     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
     ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
     ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
-    ("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm")
-    ("\\(=[)>»]+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(:-*[)>}\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(=[)>\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
     ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
     ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
-    ("\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
+    ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
     ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
     ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
     ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
     ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
     ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
     ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
     ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
     ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
     ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
     ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
-    ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
-    ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm")
+    ("[^^;_]\\(;-*[>)}\e(I;\e(B]+\\)\\W" 1 "FaceWinking.xpm")
+    ("\\(:-*[Vv\e(I5\e(B]\\)\\W" 1 "FaceWry.xpm")
     ("\\([:|]-*P\\)\\W" 1 "FaceYukky.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)
 
 (defcustom smiley-nosey-regexp-alist
   :type '(repeat (list regexp
                       (integer :tag "Match")
                       (string :tag "Image")))
   :group 'smiley)
 
 (defcustom smiley-nosey-regexp-alist
-  '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm")
+  '(("\\(:-+[<\e(I+\e(B]+\\)\\W" 1 "FaceAngry.xpm")
     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
     ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
     ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
-    ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(:-+[}\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
     ("\\(:-*)+\\)\\W" 1 "FaceHappy.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 "FaceIronic.xpm")
     ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
     ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
     ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
     ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
     ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
     ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
     ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
     ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
-    ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
-    ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm")
+    ("\\(;-+[>)}\e(I;\e(B]+\\)\\W" 1 "FaceWinking.xpm")
+    ("\\(:-+[Vv\e(I5\e(B]\\)\\W" 1 "FaceWry.xpm")
     ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
     ("\\([:|]-+P\\)\\W" 1 "FaceYukky.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
   :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.
+  "*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.
 Defaults to the contents of `smiley-deformed-regexp-alist'.
 An alternative is `smiley-nosey-regexp-alist' that matches less
 aggressively.
@@ -123,27 +131,27 @@ If this is a symbol, take its value."
   :group 'smiley)
 
 (defcustom smiley-flesh-color "yellow"
   :group 'smiley)
 
 (defcustom smiley-flesh-color "yellow"
-  "Flesh color."
+  "*Flesh color."
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-features-color "black"
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-features-color "black"
-  "Features color."
+  "*Features color."
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-tongue-color "red"
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-tongue-color "red"
-  "Tongue color."
+  "*Tongue color."
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-circle-color "black"
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-circle-color "black"
-  "Circle color."
+  "*Circle color."
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-mouse-face 'highlight
   :type 'string
   :group 'smiley)
 
 (defcustom smiley-mouse-face 'highlight
-  "Face used for mouse highlighting in the smiley buffer.
+  "*Face used for mouse highlighting in the smiley buffer.
 
 Smiley buttons will be displayed in this face when the cursor is
 above them."
 
 Smiley buttons will be displayed in this face when the cursor is
 above them."
@@ -151,10 +159,9 @@ above them."
   :group 'smiley)
 
 (defvar smiley-glyph-cache nil)
   :group 'smiley)
 
 (defvar smiley-glyph-cache nil)
-(defvar smiley-running-xemacs (string-match "XEmacs" emacs-version))
 
 (defvar smiley-map (make-sparse-keymap "smiley-keys")
 
 (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)
 
 (define-key smiley-map [(button2)] 'smiley-toggle-extent)
 (define-key smiley-map [(button3)] 'smiley-popup-menu)
@@ -162,28 +169,35 @@ above them."
 (defun smiley-popup-menu (e)
   (interactive "e")
   (popup-menu
 (defun smiley-popup-menu (e)
   (interactive "e")
   (popup-menu
-   `("Smilies" 
+   `("Smilies"
      ["Toggle This Smiley" (smiley-toggle-extent ,e) t]
      ["Toggle All Smilies" (smiley-toggle-extents ,e) t])))
 
 (defun smiley-create-glyph (smiley pixmap)
      ["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)
 
 ;;;###autoload
 (defun smiley-region (beg end)
@@ -192,7 +206,7 @@ above them."
   (smiley-buffer (current-buffer) beg end))
 
 (defun smiley-toggle-extent (event)
   (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))
   (interactive "e")
   (let* ((ant (event-glyph-extent event))
         (pt (event-closest-point event))
@@ -208,27 +222,40 @@ above them."
            (reveal-annotation ant)
            (set-extent-property ext 'invisible t)))))))
 
            (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
 (defun smiley-toggle-extents (e)
   (interactive "e")
   (map-extents
-   '(lambda (e void)
-      (let (ant)
-       (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
-           (progn
-             (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))
+   (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)))
 
    (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)
 ;;;###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))
     (save-excursion
       (when buffer
        (set-buffer buffer))
@@ -239,10 +266,10 @@ above them."
            (case-fold-search nil)
            entry regexp beg group file)
        (map-extents
            (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)))
+        (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))
         buffer st nd)
        (goto-char (or st (point-min)))
        (setq beg (point))
@@ -275,10 +302,12 @@ above them."
                  (set-extent-property ant 'smiley-extent ext)
                  (set-extent-property ext 'smiley-annotation ant)
                  ;; Help
                  (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 '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 ext 'balloon-help
                                       "Mouse button2 - toggle smiley
 Mouse button3 - menu")
@@ -289,30 +318,127 @@ Mouse button3 - menu"))
                  (make-annotation ")" end 'text))
                (goto-char 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)
 (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))
               (goto-char end)
               (or (not (re-search-forward "[()]" nil t))
-                  (= (char-after (1- (point))) ?\()))
+                  (eq (char-after (1- (point))) ?\()))
       t)))
 
       t)))
 
+(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
+    (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
 (defvar gnus-article-buffer)
 ;;;###autoload
-(defun gnus-smiley-display ()
-  "Display \"smileys\" as small graphical icons." 
-  (interactive)
+(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
     (set-buffer gnus-article-buffer)
   (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))))
+    (save-restriction
+      (widen)
+      (article-goto-body)
+      (let (buffer-read-only)
+       (smiley-toggle-buffer arg (current-buffer) (point) (point-max))))))
 
 (provide 'smiley)
 
 
 (provide 'smiley)
 
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
 ;;; smiley.el ends here
 ;;; smiley.el ends here