cgit.sxemacs.org Git - gnus/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 (require 'cl)
  40 (require 'custom)
  41
  42 (eval-and-compile
  43   (when (featurep 'xemacs)
  44     (require 'annotations)
  45     (require 'messagexmas)))
  46
  47 (defgroup smiley nil
  48   "Turn :-)'s into real images."
  49   :group 'gnus-visual)
  50
  51 ;; FIXME: Where is the directory when using Emacs?
  52 (defcustom smiley-data-directory
  53   (if (featurep 'xemacs)
  54     (message-xmas-find-glyph-directory "smilies")
  55     "/usr/local/lib/xemacs/xemacs-packages/etc/smilies")
  56   "*Location of the smiley faces files."
  57   :type 'directory
  58   :group 'smiley)
  59
  60 ;; Notice the subtle differences in the regular expressions in the
  61 ;; two alists below.
  62
  63 (defcustom smiley-deformed-regexp-alist
  64   '(("\\(\\^_?\\^;;;\\)\\W" 1 "WideFaceAse3.xbm")
  65     ("\\(\\^_?\\^;;\\)\\W" 1 "WideFaceAse2.xbm")
  66     ("\\(\\^_?\\^;\\)\\W" 1 "WideFaceAse1.xbm")
  67     ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm")
  68     ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
  69     ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
  70     ("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm")
  71     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
  72     ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
  73     ("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm")
  74     ("\\(=[)»]+\\)\\W" 1 "FaceHappy.xpm")
  75     ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
  76     ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
  77     ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
  78     ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
  79     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
  80     ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
  81     ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
  82     ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
  83     ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
  84     ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
  85     ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm")
  86     ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
  87   "*Normal and deformed faces for smilies."
  88   :type '(repeat (list regexp
  89                        (integer :tag "Match")
  90                        (string :tag "Image")))
  91   :group 'smiley)
  92
  93 (defcustom smiley-nosey-regexp-alist
  94   '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm")
  95     ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
  96     ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
  97     ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm")
  98     ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm")
  99     ("\\(=[)]+\\)\\W" 1 "FaceHappy.xpm")
 100     ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
 101     ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
 102     ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
 103     ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
 104     ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
 105     ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
 106     ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
 107     ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
 108     ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
 109     ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
 110     ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm")
 111     ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
 112     ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
 113   "*Smileys with noses.  These get less false matches."
 114   :type '(repeat (list regexp
 115                        (integer :tag "Match")
 116                        (string :tag "Image")))
 117   :group 'smiley)
 118
 119 (defcustom smiley-regexp-alist smiley-deformed-regexp-alist
 120   "*A list of regexps to map smilies to real images.
 121 Defaults to the contents of `smiley-deformed-regexp-alist'.
 122 An alternative is `smiley-nosey-regexp-alist' that matches less
 123 aggressively.
 124 If this is a symbol, take its value."
 125   :type '(radio (variable-item smiley-deformed-regexp-alist)
 126                 (variable-item smiley-nosey-regexp-alist)
 127                 symbol
 128                 (repeat (list regexp
 129                               (integer :tag "Match")
 130                               (string :tag "Image"))))
 131   :group 'smiley)
 132
 133 (defcustom smiley-flesh-color "yellow"
 134   "*Flesh color."
 135   :type 'string
 136   :group 'smiley)
 137
 138 (defcustom smiley-features-color "black"
 139   "*Features color."
 140   :type 'string
 141   :group 'smiley)
 142
 143 (defcustom smiley-tongue-color "red"
 144   "*Tongue color."
 145   :type 'string
 146   :group 'smiley)
 147
 148 (defcustom smiley-circle-color "black"
 149   "*Circle color."
 150   :type 'string
 151   :group 'smiley)
 152
 153 (defcustom smiley-mouse-face 'highlight
 154   "*Face used for mouse highlighting in the smiley buffer.
 155
 156 Smiley buttons will be displayed in this face when the cursor is
 157 above them."
 158   :type 'face
 159   :group 'smiley)
 160
 161 (defvar smiley-glyph-cache nil)
 162
 163 (defvar smiley-map (make-sparse-keymap "smiley-keys")
 164   "Keymap to toggle smiley states.")
 165
 166 (define-key smiley-map [(button2)] 'smiley-toggle-extent)
 167 (define-key smiley-map [(button3)] 'smiley-popup-menu)
 168
 169 (defun smiley-popup-menu (e)
 170   (interactive "e")
 171   (popup-menu
 172    `("Smilies"
 173      ["Toggle This Smiley" (smiley-toggle-extent ,e) t]
 174      ["Toggle All Smilies" (smiley-toggle-extents ,e) t])))
 175
 176 (defun smiley-create-glyph (smiley pixmap)
 177   (or
 178    (cdr-safe (assoc pixmap smiley-glyph-cache))
 179    (let* ((xpm-color-symbols
 180            (and (featurep 'xpm)
 181                 (append `(("flesh" ,smiley-flesh-color)
 182                           ("features" ,smiley-features-color)
 183                           ("tongue" ,smiley-tongue-color))
 184                         xpm-color-symbols)))
 185           (glyph (make-glyph
 186                   (list
 187                    (cons (if (featurep 'gtk) 'gtk 'x)
 188                          (expand-file-name pixmap smiley-data-directory))
 189                    (cons 'mswindows
 190                          (expand-file-name pixmap smiley-data-directory))
 191                    (cons 'tty smiley)))))
 192      (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
 193      (set-glyph-face glyph 'default)
 194      glyph)))
 195
 196 (defun smiley-create-glyph-ems (smiley pixmap)
 197   (condition-case e
 198       (create-image (expand-file-name pixmap smiley-data-directory))
 199     (error nil)))
 200
 201
 202 ;;;###autoload
 203 (defun smiley-region (beg end)
 204   "Smilify the region between point and mark."
 205   (interactive "r")
 206   (smiley-buffer (current-buffer) beg end))
 207
 208 (defun smiley-toggle-extent (event)
 209   "Toggle smiley at given point."
 210   (interactive "e")
 211   (let* ((ant (event-glyph-extent event))
 212          (pt (event-closest-point event))
 213          ext)
 214     (if (annotationp ant)
 215         (when (extentp (setq ext (extent-property ant 'smiley-extent)))
 216           (set-extent-property ext 'invisible nil)
 217           (hide-annotation ant))
 218       (when pt
 219         (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
 220           (when (annotationp (setq ant
 221                                    (extent-property ext 'smiley-annotation)))
 222             (reveal-annotation ant)
 223             (set-extent-property ext 'invisible t)))))))
 224
 225 ;; FIXME::
 226 (defun smiley-toggle-extent-ems (event)
 227   "Toggle smiley at given point.
 228 Note -- this function hasn't been implemented yet."
 229   (interactive "e")
 230   (error "This function hasn't been implemented yet.")
 231 )
 232
 233 (defun smiley-toggle-extents (e)
 234   (interactive "e")
 235   (map-extents
 236    (lambda (e void)
 237      (let (ant)
 238        (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
 239            (if (eq (extent-property e 'invisible) nil)
 240                (progn
 241                  (reveal-annotation ant)
 242                  (set-extent-property e 'invisible t)
 243                  )
 244              (hide-annotation ant)
 245              (set-extent-property e 'invisible nil)))
 246        nil))
 247    (event-buffer e)))
 248
 249 ;; FIXME::
 250 (defun smiley-toggle-extents-ems (e)
 251   (interactive "e")
 252   (error "This function hasn't been implemented yet.")
 253 )
 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     (set-buffer gnus-article-buffer)
 432     (save-restriction
 433       (widen)
 434       (article-goto-body)
 435       (let (buffer-read-only)
 436         (smiley-toggle-buffer arg (current-buffer) (point) (point-max))))))
 437
 438 (provide 'smiley)
 439
 440 ;; Local Variables:
 441 ;; coding: iso-8859-1
 442 ;; End:
 443
 444 ;;; smiley.el ends here