-(defun gnus-article-display-xface (beg end)
- "Display an XFace header from between BEG and END in the current article.
-This requires support for XPM or XBM images in your Emacs and the
-external programs `uncompface', `icontopbm' and either `ppmtoxpm' (for
-XPM support) or `ppmtoxbm' (for XBM support). On a GNU/Linux system
-these might be in packages with names like `compface' or `faces-xface'
-and `netpbm' or `libgr-progs', for instance.
-
-This function is for Emacs 21+. See `gnus-xmas-article-display-xface'
-for XEmacs."
- (save-excursion
- (let ((cur (current-buffer))
- image type)
- (when (and (fboundp 'image-type-available-p)
- (cond ((image-type-available-p 'xpm) (setq type 'xpm))
- ((image-type-available-p 'xbm) (setq type 'xbm))))
- (with-temp-buffer
- (insert-buffer-substring cur beg end)
- (call-process-region (point-min) (point-max) "uncompface"
- 'delete '(t nil))
- (goto-char (point-min))
- (insert "/* Width=48, Height=48 */\n")
- (and (eq 0 (call-process-region (point-min) (point-max) "icontopbm"
- 'delete '(t nil)))
- (eq 0 (call-process-region (point-min) (point-max)
- (if (eq type 'xpm)
- "ppmtoxpm"
- "pbmtoxbm")
- 'delete '(t nil)))
- (setq image (create-image (buffer-string) type t))))
- (when image
- (goto-char (point-min))
- (re-search-forward "^From:" nil 'move)
- (insert-image image " "))))))
+;;; Image functions.
+
+(defun gnus-image-type-available-p (type)
+ (and (fboundp 'image-type-available-p)
+ (image-type-available-p type)))
+
+(defun gnus-create-image (file &optional type data-p &rest props)
+ (let ((face (plist-get props :face)))
+ (when face
+ (setq props (plist-put props :foreground (face-foreground face)))
+ (setq props (plist-put props :background (face-background face))))
+ (apply 'create-image file type data-p props)))
+
+(defun gnus-put-image (glyph &optional string category)
+ (let ((point (point)))
+ (insert-image glyph (or string " "))
+ (put-text-property point (point) 'gnus-image-category category)
+ (unless string
+ (put-text-property (1- (point)) (point)
+ 'gnus-image-text-deletable t))
+ glyph))
+
+(defun gnus-remove-image (image &optional category)
+ (dolist (position (message-text-with-property 'display))
+ (when (and (equal (get-text-property position 'display) image)
+ (equal (get-text-property position 'gnus-image-category)
+ category))
+ (put-text-property position (1+ position) 'display nil)
+ (when (get-text-property position 'gnus-image-text-deletable)
+ (delete-region position (1+ position))))))
+
+(defun-maybe assoc-ignore-case (key alist)
+ "Like `assoc', but assumes KEY is a string and ignores case when comparing."
+ (setq key (downcase key))
+ (let (element)
+ (while (and alist (not element))
+ (if (equal key (downcase (car (car alist))))
+ (setq element (car alist)))
+ (setq alist (cdr alist)))
+ element))
+
+\f
+;;; Language support staffs.
+
+(defvar-maybe current-language-environment "English"
+ "The language environment.")
+
+(defvar-maybe language-info-alist nil
+ "Alist of language environment definitions.")
+
+(defun-maybe get-language-info (lang-env key)
+ "Return information listed under KEY for language environment LANG-ENV."
+ (if (symbolp lang-env)
+ (setq lang-env (symbol-name lang-env)))
+ (let ((lang-slot (assoc-ignore-case lang-env language-info-alist)))
+ (if lang-slot
+ (cdr (assq key (cdr lang-slot))))))
+
+(defun-maybe set-language-info (lang-env key info)
+ "Modify part of the definition of language environment LANG-ENV."
+ (if (symbolp lang-env)
+ (setq lang-env (symbol-name lang-env)))
+ (let (lang-slot key-slot)
+ (setq lang-slot (assoc lang-env language-info-alist))
+ (if (null lang-slot) ; If no slot for the language, add it.
+ (setq lang-slot (list lang-env)
+ language-info-alist (cons lang-slot language-info-alist)))
+ (setq key-slot (assq key lang-slot))
+ (if (null key-slot) ; If no slot for the key, add it.
+ (progn
+ (setq key-slot (list key))
+ (setcdr lang-slot (cons key-slot (cdr lang-slot)))))
+ (setcdr key-slot info)))