gnus-smiley.el -- new version

[hardaker@ece.ucdavis.edu (Wes Hardaker)]

Did things slightly more correctly this time:

  -- cached last glyph for faster loading (of frequent smilies :-)
  -- Used "invisible extents" rather than deleting the original region
  -- more reg-exp -> smily matching

Additionally, I made the smily faces yellow with a trasparent edge, so
they look like they really should now!  Get a new copy at
ftp.ece.ucdavis.edu:/pub/hardaker/smilies.tar.gz

:-)

Wes Hardaker
Professional Time Waster

;;
;; comments go here.
;;

;; To use:
;; (load "gnus-smiley.el")
;; (add-hook 'gnus-article-display-hook 'gnus-smiley-display t)

(defvar gnus-smiley-db-dir "/home/hardaker/lib/smilies"
  "Location of the smiley xpm faces files.")

(defvar gnus-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 gnus-smiley-glyph nil)

(defvar gnus-smiley-last-file nil)

(defun gnus-smiley-display ()
  (interactive)
  (if (and (featurep 'xpm) 
           (or (not (fboundp 'device-type)) (equal (device-type) 'x)))
      (save-excursion
	(set-buffer gnus-article-buffer)
	;; search and replace
	(let ((buffer-read-only nil)
	      (alist gnus-smiley-regexp-alist)
	      bug entry regexp)
	  (goto-char (point-min))
	  ;; We skip the headers.
	  (unless (search-forward "\n\n" nil t)
	    (goto-char (point-max)))
	  (setq beg (point))
	  ;; loop through alist
	  (while (setq entry (pop alist))
	    (setq regexp (car entry))
	    (goto-char beg)
	    (while (re-search-forward regexp nil t)
	      (let ((start (match-beginning 0))
		    (end (match-end 0))
		    (file (concat (file-name-as-directory gnus-smiley-db-dir) 
				 (nth 1 entry))))
		(if (not (equal file gnus-smiley-last-file))
		    (setq gnus-smiley-glyph (make-glyph file)))
		(if gnus-smiley-glyph
		    (progn 
		      (set-glyph-face gnus-smiley-glyph 'default)
		      (let ((ext (make-extent start end)))
			(set-extent-property ext 'invisible t)
			(set-extent-property ext 'end-open t))
		      (make-annotation gnus-smiley-glyph end 'text)
		      (goto-char end))
		  ))))))))