git.chise.org Git - elisp/gnus.git-/blob - lisp/smiley.el

   1 ;;; smiley.el --- displaying smiley faces
   2 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
   6 ;; Keywords: fun
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;
  28 ;; comments go here.
  29 ;;
  30
  31 ;;; Test smileys:  :-] :-o :-) ;-) :-\ :-| :-d :-P 8-| :-(
  32
  33 ;; To use:
  34 ;; (require 'smiley)
  35 ;; (setq gnus-treat-display-smileys t)
  36
  37 ;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
  38
  39 ;;; Code:
  40
  41 (eval-when-compile (require 'cl))
  42 (require 'custom)
  43
  44 (eval-and-compile
  45   (when (featurep 'xemacs)
  46     (require 'annotations)
  47     (require 'messagexmas)))
  48
  49 (defgroup smiley nil
  50   "Turn :-)'s into real images."
  51   :group 'gnus-visual)
  52
  53 ;; FIXME: Where is the directory when using Emacs?
  54 (defcustom smiley-data-directory
  55   (if (featurep 'xemacs)
  56       (message-xmas-find-glyph-directory "smilies")
  57     "/usr/local/lib/xemacs/xemacs-packages/etc/smilies")
  58   "*Location of the smiley faces files."
  59   :type 'directory
  60   :group 'smiley)
  61
  62 ;; Notice the subtle differences in the regular expressions in the
  63 ;; two alists below.
  64
  65 (defcustom smiley-deformed-regexp-alist
  66   '(("\\(\\^_?\\^;;;\\)\\W" 1 "WideFaceAse3.xbm")
  67     ("\\(\\^_?\\^;;\\)\\W" 1 "WideFaceAse2.xbm")
  68     ("\\(\\^_?\\^;\\)\\W" 1 "WideFaceAse1.xbm")
  69     ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm")
  70     ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
  71     ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
  72     ("\\(:-*[<\e(I+\e(B]+\\)\\W" 1 "FaceAngry.xpm")
  73     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
  74     ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
  75     ("\\(:-*[)>}\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
  76     ("\\(=[)>\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
  77     ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
  78     ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
  79     ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
  80     ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
  81     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
  82     ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
  83     ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
  84     ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
  85     ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
  86     ("[^^;_]\\(;-*[>)}\e(I;\e(B]+\\)\\W" 1 "FaceWinking.xpm")
  87     ("\\(:-*[Vv\e(I5\e(B]\\)\\W" 1 "FaceWry.xpm")
  88     ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
  89   "*Normal and deformed faces for smilies."
  90   :type '(repeat (list regexp
  91                        (integer :tag "Match")
  92                        (string :tag "Image")))
  93   :group 'smiley)
  94
  95 (defcustom smiley-nosey-regexp-alist
  96   '(("\\(:-+[<\e(I+\e(B]+\\)\\W" 1 "FaceAngry.xpm")
  97     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
  98     ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
  99     ("\\(:-+[}\e(I;\e(B]+\\)\\W" 1 "FaceHappy.xpm")
 100     ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm")
 101     ("\\(=[)]+\\)\\W" 1 "FaceHappy.xpm")
 102     ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
 103     ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
 104     ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
 105     ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
 106     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
 107     ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
 108     ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
 109     ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
 110     ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
 111     ("\\(;-+[>)}\e(I;\e(B]+\\)\\W" 1 "FaceWinking.xpm")
 112     ("\\(:-+[Vv\e(I5\e(B]\\)\\W" 1 "FaceWry.xpm")
 113     ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
 114     ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
 115   "*Smileys with noses.  These get less false matches."
 116   :type '(repeat (list regexp
 117                        (integer :tag "Match")
 118                        (string :tag "Image")))
 119   :group 'smiley)
 120
 121 (defcustom smiley-regexp-alist smiley-deformed-regexp-alist
 122   "*A list of regexps to map smilies to real images.
 123 Defaults to the contents of `smiley-deformed-regexp-alist'.
 124 An alternative is `smiley-nosey-regexp-alist' that matches less
 125 aggressively.
 126 If this is a symbol, take its value."
 127   :type '(radio (variable-item smiley-deformed-regexp-alist)
 128                 (variable-item smiley-nosey-regexp-alist)
 129                 symbol
 130                 (repeat (list regexp
 131                               (integer :tag "Match")
 132                               (string :tag "Image"))))
 133   :group 'smiley)
 134
 135 (defcustom smiley-flesh-color "yellow"
 136   "*Flesh color."
 137   :type 'string
 138   :group 'smiley)
 139
 140 (defcustom smiley-features-color "black"
 141   "*Features color."
 142   :type 'string
 143   :group 'smiley)
 144
 145 (defcustom smiley-tongue-color "red"
 146   "*Tongue color."
 147   :type 'string
 148   :group 'smiley)
 149
 150 (defcustom smiley-circle-color "black"
 151   "*Circle color."
 152   :type 'string
 153   :group 'smiley)
 154
 155 (defcustom smiley-mouse-face 'highlight
 156   "*Face used for mouse highlighting in the smiley buffer.
 157
 158 Smiley buttons will be displayed in this face when the cursor is
 159 above them."
 160   :type 'face
 161   :group 'smiley)
 162
 163 (defvar smiley-glyph-cache nil)
 164
 165 (defvar smiley-map (make-sparse-keymap "smiley-keys")
 166   "Keymap to toggle smiley states.")
 167
 168 (define-key smiley-map [(button2)] 'smiley-toggle-extent)
 169 (define-key smiley-map [(button3)] 'smiley-popup-menu)
 170
 171 (defun smiley-popup-menu (e)
 172   (interactive "e")
 173   (popup-menu
 174    `("Smilies"
 175      ["Toggle This Smiley" (smiley-toggle-extent ,e) t]
 176      ["Toggle All Smilies" (smiley-toggle-extents ,e) t])))
 177
 178 (defun smiley-create-glyph (smiley pixmap)
 179   (or
 180    (cdr-safe (assoc pixmap smiley-glyph-cache))
 181    (let* ((xpm-color-symbols
 182            (and (featurep 'xpm)
 183                 (append `(("flesh" ,smiley-flesh-color)
 184                           ("features" ,smiley-features-color)
 185                           ("tongue" ,smiley-tongue-color))
 186                         xpm-color-symbols)))
 187           (glyph (make-glyph
 188                   (list
 189                    (cons (if (featurep 'gtk) 'gtk 'x)
 190                          (expand-file-name pixmap smiley-data-directory))
 191                    (cons 'mswindows
 192                          (expand-file-name pixmap smiley-data-directory))
 193                    (cons 'tty smiley)))))
 194      (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
 195      (set-glyph-face glyph 'default)
 196      glyph)))
 197
 198 (defun smiley-create-glyph-ems (smiley pixmap)
 199   (condition-case e
 200       (create-image (expand-file-name pixmap smiley-data-directory))
 201     (error nil)))
 202
 203
 204 ;;;###autoload
 205 (defun smiley-region (beg end)
 206   "Smilify the region between point and mark."
 207   (interactive "r")
 208   (smiley-buffer (current-buffer) beg end))
 209
 210 (defun smiley-toggle-extent (event)
 211   "Toggle smiley at given point."
 212   (interactive "e")
 213   (let* ((ant (event-glyph-extent event))
 214          (pt (event-closest-point event))
 215          ext)
 216     (if (annotationp ant)
 217         (when (extentp (setq ext (extent-property ant 'smiley-extent)))
 218           (set-extent-property ext 'invisible nil)
 219           (hide-annotation ant))
 220       (when pt
 221         (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
 222           (when (annotationp (setq ant
 223                                    (extent-property ext 'smiley-annotation)))
 224             (reveal-annotation ant)
 225             (set-extent-property ext 'invisible t)))))))
 226
 227 ;; FIXME::
 228 (defun smiley-toggle-extent-ems (event)
 229   "Toggle smiley at given point.
 230 Note -- this function hasn't been implemented yet."
 231   (interactive "e")
 232   (error "This function hasn't been implemented yet"))
 233
 234 (defun smiley-toggle-extents (e)
 235   (interactive "e")
 236   (map-extents
 237    (lambda (e void)
 238      (let (ant)
 239        (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 240            (if (eq (extent-property e 'invisible) nil)
 241                (progn
 242                  (reveal-annotation ant)
 243                  (set-extent-property e 'invisible t)
 244                  )
 245              (hide-annotation ant)
 246              (set-extent-property e 'invisible nil)))
 247        nil))
 248    (event-buffer e)))
 249
 250 ;; FIXME::
 251 (defun smiley-toggle-extents-ems (e)
 252   (interactive "e")
 253   (error "This function hasn't been implemented yet"))
 254
 255 ;;;###autoload
 256 (defun smiley-buffer (&optional buffer st nd)
 257   (interactive)
 258   (when (featurep '(or x gtk mswindows))
 259     (save-excursion
 260       (when buffer
 261         (set-buffer buffer))
 262       (let ((buffer-read-only nil)
 263             (alist (if (symbolp smiley-regexp-alist)
 264                        (symbol-value smiley-regexp-alist)
 265                      smiley-regexp-alist))
 266             (case-fold-search nil)
 267             entry regexp beg group file)
 268         (map-extents
 269          (lambda (e void)
 270            (when (or (extent-property e 'smiley-extent)
 271                      (extent-property e 'smiley-annotation))
 272              (delete-extent e)))
 273          buffer st nd)
 274         (goto-char (or st (point-min)))
 275         (setq beg (point))
 276         ;; loop through alist
 277         (while (setq entry (pop alist))
 278           (setq regexp (car entry)
 279                 group (cadr entry)
 280                 file (caddr entry))
 281           (goto-char beg)
 282           (while (re-search-forward regexp nd t)
 283             (let* ((start (match-beginning group))
 284                    (end (match-end group))
 285                    (glyph (smiley-create-glyph (buffer-substring start end)
 286                                                file)))
 287               (when glyph
 288                 (mapcar 'delete-annotation (annotations-at end))
 289                 (let ((ext (make-extent start end))
 290                       (ant (make-annotation glyph end 'text)))
 291                   ;; set text extent params
 292                   (set-extent-property ext 'end-open t)
 293                   (set-extent-property ext 'start-open t)
 294                   (set-extent-property ext 'invisible t)
 295                   (set-extent-property ext 'keymap smiley-map)
 296                   (set-extent-property ext 'mouse-face smiley-mouse-face)
 297                   (set-extent-property ext 'intangible t)
 298                   ;; set annotation params
 299                   (set-extent-property ant 'mouse-face smiley-mouse-face)
 300                   (set-extent-property ant 'keymap smiley-map)
 301                   ;; remember each other
 302                   (set-extent-property ant 'smiley-extent ext)
 303                   (set-extent-property ext 'smiley-annotation ant)
 304                   ;; Help
 305                   (set-extent-property
 306                    ext 'help-echo
 307                    "button2 toggles smiley, button3 pops up menu")
 308                   (set-extent-property
 309                    ant 'help-echo
 310                    "button2 toggles smiley, button3 pops up menu")
 311                   (set-extent-property ext 'balloon-help
 312                                        "Mouse button2 - toggle smiley
 313 Mouse button3 - menu")
 314                   (set-extent-property ant 'balloon-help
 315                                        "Mouse button2 - toggle smiley
 316 Mouse button3 - menu"))
 317                 (when (smiley-end-paren-p start end)
 318                   (make-annotation ")" end 'text))
 319                 (goto-char end)))))))))
 320
 321 ;; FIXME: No popup menu, no customized color
 322 (defun smiley-buffer-ems (&optional buffer st nd)
 323   (interactive)
 324   (when window-system
 325     (save-excursion
 326       (when buffer
 327         (set-buffer buffer))
 328       (let ((buffer-read-only nil)
 329             (alist (if (symbolp smiley-regexp-alist)
 330                        (symbol-value smiley-regexp-alist)
 331                      smiley-regexp-alist))
 332             (case-fold-search nil)
 333             entry regexp beg group file)
 334         (dolist (overlay (overlays-in (or st (point-min))
 335                                       (or nd (point-max))))
 336           (when (overlay-get overlay 'smiley)
 337             (remove-text-properties (overlay-start overlay)
 338                                     (overlay-end overlay) '(display))
 339             (delete-overlay overlay)))
 340         (goto-char (or st (point-min)))
 341         (setq beg (point))
 342         ;; loop through alist
 343         (while (setq entry (pop alist))
 344           (setq regexp (car entry)
 345                 group (cadr entry)
 346                 file (caddr entry))
 347           (goto-char beg)
 348           (while (re-search-forward regexp nd t)
 349             (let* ((start (match-beginning group))
 350                    (end (match-end group))
 351                    (glyph (smiley-create-glyph nil file))
 352                    (overlay (make-overlay start end)))
 353               (when glyph
 354                 (add-text-properties start end
 355                                      `(display ,glyph))
 356                 (overlay-put overlay 'smiley glyph)
 357                 (goto-char end)))))))))
 358
 359 (defun smiley-end-paren-p (start end)
 360   "Try to guess whether the current smiley is an end-paren smiley."
 361   (save-excursion
 362     (goto-char start)
 363     (when (and (re-search-backward "[()]" nil t)
 364                (eq (char-after) ?\()
 365                (goto-char end)
 366                (or (not (re-search-forward "[()]" nil t))
 367                    (eq (char-after (1- (point))) ?\()))
 368       t)))
 369
 370 (defun smiley-toggle-buffer (&optional arg buffer st nd)
 371   "Toggle displaying smiley faces.
 372 With arg, turn displaying on if and only if arg is positive."
 373   (interactive "P")
 374   (let (on off)
 375     (map-extents
 376      (lambda (e void)
 377        (let (ant)
 378          (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 379              (if (eq (extent-property e 'invisible) nil)
 380                  (setq off (cons (cons ant e) off))
 381                (setq on (cons (cons ant e) on)))))
 382        nil)
 383      buffer st nd)
 384     (if (and (not (and (numberp arg) (< arg 0)))
 385              (or (and (numberp arg) (> arg 0))
 386                  (null on)))
 387         (if off
 388             (while off
 389               (reveal-annotation (caar off))
 390               (set-extent-property (cdar off) 'invisible t)
 391               (setq off (cdr off)))
 392           (smiley-buffer))
 393       (while on
 394         (hide-annotation (caar on))
 395         (set-extent-property (cdar on) 'invisible nil)
 396         (setq on (cdr on))))))
 397
 398 ;; Simply removing all smiley if existing.
 399 ;; FIXME: make it work as the one in XEmacs.
 400 (defun smiley-toggle-buffer-ems (&optional arg buffer st nd)
 401   "Toggle displaying smiley faces.
 402 With arg, turn displaying on if and only if arg is positive."
 403   (interactive "P")
 404   (save-excursion
 405     (when buffer
 406       (set-buffer buffer))
 407     (let (found)
 408       (dolist (overlay (overlays-in (or st (point-min))
 409                                     (or nd (point-max))))
 410         (when (overlay-get overlay 'smiley)
 411           (remove-text-properties (overlay-start overlay)
 412                                   (overlay-end overlay) '(display))
 413           (setq found t)))
 414       (unless found
 415         (smiley-buffer buffer st nd)))))
 416
 417 (unless (featurep 'xemacs)
 418   (defalias 'smiley-create-glyph 'smiley-create-glyph-ems)
 419   (defalias 'smiley-toggle-extent 'smiley-toggle-extent-ems)
 420   (defalias 'smiley-toggle-extents 'smiley-toggle-extents-ems)
 421   (defalias 'smiley-buffer 'smiley-buffer-ems)
 422   (defalias 'smiley-toggle-buffer 'smiley-toggle-buffer-ems))
 423
 424 (defvar gnus-article-buffer)
 425 ;;;###autoload
 426 (defun gnus-smiley-display (&optional arg)
 427   "Display \"smileys\" as small graphical icons.
 428 With arg, turn displaying on if and only if arg is positive."
 429   (interactive "P")
 430   (save-excursion
 431     (article-goto-body)
 432     (let (buffer-read-only)
 433       (smiley-toggle-buffer arg (current-buffer) (point) (point-max)))))
 434
 435 (provide 'smiley)
 436
 437 ;; Local Variables:
 438 ;; coding: iso-8859-1
 439 ;; End:
 440
 441 ;;; smiley.el ends here