smiley.el (was Re: gnus-smiley.el -- new version)

[William Perry <wmperry@monolith.spry.com>]

Here is a slightly modified version that uses a tty-specifier in the glyph
so that you do not have to check if you are in X or not.  Also, its been
generalized a bit, so that you can (smiley-buffer your-fav-buffer start end)
gnus-smiley-buffer becomes a trivial wrapper.  This way it can be used in
VM or Emacs-W3, etc.

The finding of the pixmap directory needs to be automatic though.

-Bill P.

;;
;; comments go here.
;;

;; To use:
;; (require 'smiley)
;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t)

(defvar smiley-data-directory "/tmp/smilies/"
  "Location of the smiley faces files.")

(defvar smiley-regexp-alist '((":-*\\]" "FaceGrinning.xpm")
			      (":-*[oO]" "FaceStartled.xpm")
			      (":-*[)>]" "FaceHappy.xpm")
			      (";-*[>)]" "FaceWinking.xpm")
			      (":-[/\\]" "FaceIronic.xpm")
			      (":-*|" "FaceStraight.xpm")
			      (":-*<" "FaceAngry.xpm")
			      (":-*d" "FaceTasty.xpm")
			      (":-*[pP]" "FaceYukky.xpm")
			      ("8-*|" "FaceKOed.xpm")
			      (":-*(" "FaceAngry.xpm"))
  "A list of regexps to map smilies to real images.")

(defvar smiley-glyph-cache nil)
(defvar smiley-running-xemacs (string-match "XEmacs" emacs-version))

(defun smiley-create-glyph (smiley pixmap)
  (and
   smiley-running-xemacs
   (or
    (cdr-safe (assoc pixmap smiley-glyph-cache))
    (let ((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))))

(defun smiley-buffer (&optional buffer st nd)
  (save-excursion
    (and buffer (set-buffer buffer))
    (let ((buffer-read-only nil)
	  (alist smiley-regexp-alist)
	  bug entry regexp)
      (goto-char (or st (point-min)))
      (setq beg (point))
      ;; loop through alist
      (while (setq entry (pop alist))
	(setq regexp (car entry))
	(goto-char beg)
	(while (re-search-forward regexp nd t)
	  (let* ((start (match-beginning 0))
		 (end (match-end 0))
		 (file (nth 1 entry))
		 (glyph (smiley-create-glyph (buffer-substring start end)
					     file)))
	    (if glyph
		(progn 
		  (let ((ext (make-extent start end)))
		    (set-extent-property ext 'invisible t)
		    (set-extent-property ext 'end-open t))
		  (make-annotation glyph end 'text)
		  (goto-char end)))))))))
    
(defun gnus-smiley-display ()
  (interactive)
  (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))))

(provide 'smiley)