Download
(eval-when-compile
(require 'cl))
(require 'tree-widget)
(require 'format-spec)
(require 'xml)
(defgroup emoticons nil
"Display ASCII emoticons with icons"
:group 'multimedia)
(defcustom emoticons-theme "adium"
"Theme name for emoticons."
:type 'string
:group 'emoticons)
(defcustom emoticons-icon-dir "~/.emacs.d/icons"
"Directory of icons."
:type 'directory
:group 'emoticons)
(defcustom emoticons-image-properties
'(:ascent center)
"Extra properties for the image to display"
:type 'sexp
:group 'emoticons)
(defcustom emoticons-help-echo-format "%e %n"
"Format string for display help-echo"
:type 'string
:group 'emoticons)
(defvar emoticons-image-suffix-regexp
(regexp-opt (apply 'append (mapcar 'cdr (tree-widget-image-formats))))
"Regexp to match suffex of images")
(defvar emoticons--theme nil
"Cache images that used.")
(defvar emoticons-mode nil)
(defun emoticons-parse-plist (file)
"Read ASCII emoticons and icon files pair from xml file."
(let* ((xml (xml-parse-file file))
alist file)
(dolist (node (xml-node-children (car (xml-get-children (car (xml-get-children (car xml) 'dict)) 'dict))))
(when (listp node)
(cond ((eq (xml-node-name node) 'key)
(setq file (car (xml-node-children node))))
((eq (xml-node-name node) 'dict)
(dolist (str (xml-get-children (car (xml-get-children node 'array)) 'string))
(push (cons (car (xml-node-children str)) file)
alist))))))
alist))
(defvar emoticons-alist
(let ((file (expand-file-name
"Emoticons.plist"
(concat (file-name-as-directory emoticons-icon-dir)
emoticons-theme))))
(when (file-exists-p file)
(emoticons-parse-plist file)))
"A list to transform ASCII emoticons to icon file.")
(defvar emoticons-regexp
(concat "\\(?:\\<\\|\\s-\\)" (regexp-opt (mapcar 'car emoticons-alist) t))
"Regexp to match ASCII emoticons.")
(defvar emoticons-keywords
(list
(list emoticons-regexp
'(1 (add-text-properties
(match-beginning 1) (match-end 1)
(emoticons-text-properties (match-string 1))))))
"Font-lock keywords to display emoticons.")
(defun emoticons-find-image (name)
"Find the image with NAME in current theme"
(let ((theme (assoc emoticons-theme emoticons--theme))
image)
(if (setq image (assoc name (cdr theme)))
(cdr image)
(let ((dir (concat (file-name-as-directory emoticons-icon-dir)
emoticons-theme))
formats file)
(if (string-match emoticons-image-suffix-regexp name)
(catch 'found
(mapc (lambda (fmt)
(dolist (f (cdr fmt))
(when (string-match (regexp-quote f) name)
(setq formats `((,(car fmt) "")))
(throw 'found t))))
(tree-widget-image-formats)))
(setq formats (tree-widget-image-formats)))
(setq image
(catch 'found
(dolist (fmt formats)
(dolist (ext (cdr fmt))
(setq file (expand-file-name (concat name ext) dir))
(and (file-readable-p file)
(file-regular-p file)
(throw 'found
(apply 'create-image file (car fmt) nil
emoticons-image-properties)))))))
(setq emoticons--theme
(cons (cons emoticons-theme
(cons (cons name image) (cdr theme)))
(delq theme emoticons--theme)))
image))))
(defun emoticons-text-properties (str)
(let ((name (assoc-default str emoticons-alist)))
(when name
(list
'display (emoticons-find-image name)
'emoticons t
'help-echo (format-spec emoticons-help-echo-format
(format-spec-make
?e str
?n name))))))
(defun emoticons-mode (&optional arg)
"Toggle display emoticons."
(interactive "P")
(setq emoticons-mode
(if (null arg) (not emoticons-mode)
(> (prefix-numeric-value arg) 0)))
(if emoticons-mode
(progn
(font-lock-add-keywords nil emoticons-keywords)
(font-lock-fontify-buffer))
(font-lock-remove-keywords nil emoticons-keywords)
(save-restriction
(widen)
(emoticons-erase-region (point-min) (point-max)))))
(defun emoticons-erase-region (beg end)
"Remove all icons in region."
(interactive "r")
(let ((modified (buffer-modified-p))
(inhibit-read-only t))
(save-restriction
(narrow-to-region beg end)
(let ((s (point-min))
(end (point-max)))
(if (get-text-property s 'display)
(remove-text-properties s (setq s (or (next-single-property-change s 'emoticons)
(point-max)))
(list 'display nil
'emoticons nil
'help-echo nil)))
(while (and s (< s end))
(setq s (next-single-property-change s 'emoticons))
(when s
(remove-text-properties
s (setq s (or (next-single-property-change s 'emoticons)
(point-max)))
(list 'display nil 'emoticons t 'help-echo nil))))))
(set-buffer-modified-p modified)))
(defun emoticons-erase-buffer ()
"Remove all icons in current buffer."
(interactive)
(emoticons-erase-region (point-min) (point-max)))
(defun emoticons-fill-region (beg end)
"Substitue all ASCII emoticons in the region with icons."
(interactive "r")
(let ((modified (buffer-modified-p))
(inhibit-read-only t))
(save-excursion
(save-restriction
(narrow-to-region beg end)
(goto-char (point-min))
(while (re-search-forward emoticons-regexp nil t)
(add-text-properties
(match-beginning 1) (match-end 1)
(emoticons-text-properties (match-string 1)))))
(set-buffer-modified-p modified))))
(defun emoticons-fill-buffer ()
"Substitue all ASCII emoticons in current buffer with icons."
(interactive)
(emoticons-fill-region (point-min) (point-max)))
(defun emoticons-replace (str)
(save-match-data
(string-match "^\\(\\s-*\\)" str)
(concat (match-string 0 str)
(let ((rest (substring str (match-end 0))))
(apply 'propertize rest
(emoticons-text-properties rest))))))
(defun emoticons-help-echo ()
(let ((tip (get-text-property (point) 'help-echo)))
(and tip (message tip))))
(provide 'emoticons)