X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fsmiley.el;h=afffc64f12fa8468f6df9bdeb5f887f5da1aa394;hp=b9449a720d7f0d9205a30635bb2428b908b6598f;hb=b7df893161350265e845a70d711a97a32536a221;hpb=d49c9aab7fdcca8dee6c65ac78ae7c775b13cf67 diff --git a/lisp/smiley.el b/lisp/smiley.el index b9449a720..afffc64f1 100644 --- a/lisp/smiley.el +++ b/lisp/smiley.el @@ -1,253 +1,230 @@ ;;; smiley.el --- displaying smiley faces -;; Copyright (C) 1996,97 Free Software Foundation, Inc. -;; Author: Wes Hardaker -;; Keywords: fun +;; Copyright (C) 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Dave Love +;; Keywords: news mail multimedia ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: -;; -;; comments go here. -;; - -;;; Test smileys: :-] :-o :-) ;-) :-\ :-| :-d :-P 8-| :-( - -;; To use: -;; (require 'smiley) -;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t) - -;; The smilies were drawn by Joe Reiss . - -(require 'annotations) -(require 'messagexmas) -(require 'cl) -(require 'custom) +;; 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) (defgroup smiley nil - "Turn :-)'s into real images (XEmacs)." + "Turn :-)'s into real images." :group 'gnus-visual) -(defcustom smiley-data-directory (message-xmas-find-glyph-directory "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 "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 "FaceNyah.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 "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 "FaceIronic.xpm") - ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm") - ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.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 content of smiley-deformed-regexp-alist. -An alternative smiley-nosey-regexp-alist that -matches less aggressively is available. -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 +(defvar smiley-data-directory) + +(defcustom smiley-style + (if (or (and (fboundp 'face-attribute) + (>= (face-attribute 'default :height) 160)) + (and (fboundp 'face-height) + (>= (face-height 'default) 14))) + 'medium + 'low-color) + "Smiley style." + :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14 + (const :tag "medium, ~10 colors" medium) ;; 16x16 + (const :tag "dull, grayscale" grayscale));; 14x14 + :set (lambda (symbol value) + (set-default symbol value) + (setq smiley-data-directory (smiley-directory)) + (smiley-update-cache)) + :initialize 'custom-initialize-default + :version "23.1" ;; No Gnus :group 'smiley) -(defcustom smiley-features-color "black" - "Features color." - :type 'string +;; 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) + "*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) -(defcustom smiley-tongue-color "red" - "Tongue color." - :type 'string +;; The XEmacs version has a baroque, if not rococo, set of these. +(defcustom smiley-regexp-alist + '(("\\(;-)\\)\\W" 1 "blink") + ("[^;]\\(;)\\)\\W" 1 "blink") + ("\\(:-]\\)\\W" 1 "forced") + ("\\(8-)\\)\\W" 1 "braindamaged") + ("\\(:-|\\)\\W" 1 "indifferent") + ("\\(:-[/\\]\\)\\W" 1 "wry") + ("\\(:-(\\)\\W" 1 "sad") + ("\\(X-)\\)\\W" 1 "dead") + ("\\(:-{\\)\\W" 1 "frown") + ("\\(>:-)\\)\\W" 1 "evil") + ("\\(;-(\\)\\W" 1 "cry") + ("\\(:-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'." + :version "24.1" + :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 :group 'smiley) -(defcustom smiley-circle-color "black" - "Circle color." - :type 'string +(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) :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") - -(define-key smiley-map [(button2)] 'smiley-toggle-extent) - -(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)))) +(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)) ;;;###autoload -(defun smiley-region (beg end) - "Smilify the region between point and mark." +(defun smiley-region (start end) + "Replace in the region `smiley-regexp-alist' matches with corresponding images. +A list of images is returned." (interactive "r") - (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))))))) - -;;;###autoload -(defun smiley-buffer (&optional buffer st nd) - (interactive) - (when (featurep 'x) + (when (gnus-graphic-display-p) + (unless smiley-cached-regexp-alist + (smiley-update-cache)) (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)) - entry regexp beg group file) - (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)) + (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)) (goto-char beg) - (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 gnus-article-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 'keymap smiley-map) - ;; remember each other - (set-extent-property ant 'smiley-extent ext) - (set-extent-property ext 'smiley-annotation ant)) - (when (smiley-end-paren-p start end) - (make-annotation ")" end 'text)) - (goto-char end))))))))) - -(defun smiley-end-paren-p (start end) - "Try to guess whether the current smiley is an end-paren smiley." + (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)))) + +;;;###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: ") (save-excursion - (goto-char start) - (when (and (re-search-backward "[()]" nil t) - (= (following-char) ?\() - (goto-char end) - (or (not (re-search-forward "[()]" nil t)) - (= (char-after (1- (point))) ?\())) - t))) - -;;;###autoload -(defun gnus-smiley-display () - (interactive) + (if buffer + (set-buffer (get-buffer buffer))) + (smiley-region (point-min) (point-max)))) + +(defun smiley-toggle-buffer (&optional arg) + "Toggle displaying smiley faces in article buffer. +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. +With arg, turn displaying on if and only if arg is positive." + (interactive "e") (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-window-excursion + (mouse-set-point event) + (smiley-toggle-buffer)))) (provide 'smiley)