-;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
+;;; gnus-ems.el --- functions for making Semi-gnus work under different Emacsen
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
;; Keywords: news
;; This file is part of GNU Emacs.
(eval-and-compile
(autoload 'gnus-xmas-define "gnus-xmas")
(autoload 'gnus-xmas-redefine "gnus-xmas")
- (autoload 'appt-select-lowest-window "appt"))
+ (autoload 'appt-select-lowest-window "appt")
+ (autoload 'gnus-get-buffer-create "gnus")
+ (autoload 'nnheader-find-etc-directory "nnheader"))
-(if (featurep 'xemacs)
- (autoload 'gnus-smiley-display "smiley")
- (autoload 'gnus-smiley-display "smiley-ems")) ; override XEmacs version
+(if (or (featurep 'xemacs)
+ (>= emacs-major-version 21))
+ (autoload 'smiley-region "smiley")
+ (autoload 'smiley-region "smiley-mule"))
+
+;; Fixme: shouldn't require message
+(autoload 'message-text-with-property "message")
(defun gnus-kill-all-overlays ()
"Delete all overlays in the current buffer."
;;; Mule functions.
-(defun gnus-mule-max-width-function (el max-width)
- `(let* ((val (eval (, el)))
- (valstr (if (numberp val)
- (int-to-string val) val)))
- (if (> (length valstr) ,max-width)
- (truncate-string-to-width valstr ,max-width)
- valstr)))
+(eval-and-compile
+ (defalias 'gnus-char-width
+ (if (fboundp 'char-width)
+ 'char-width
+ (lambda (ch) 1)))) ;; A simple hack.
(eval-and-compile
(if (featurep 'xemacs)
(defvar gnus-mouse-face-prop 'mouse-face
"Property used for highlighting mouse regions.")))
-(eval-and-compile
- (let ((case-fold-search t))
- (cond
- ((string-match "windows-nt\\|os/2\\|emx\\|cygwin32"
- (symbol-name system-type))
- (setq nnheader-file-name-translation-alist
- (append nnheader-file-name-translation-alist
- (mapcar (lambda (c) (cons c ?_))
- '(?: ?* ?\" ?< ?> ??))
- '((?+ . ?-))))))))
-
-(defvar gnus-tmp-unread)
-(defvar gnus-tmp-replied)
-(defvar gnus-tmp-score-char)
-(defvar gnus-tmp-indentation)
-(defvar gnus-tmp-opening-bracket)
-(defvar gnus-tmp-lines)
-(defvar gnus-tmp-name)
-(defvar gnus-tmp-closing-bracket)
-(defvar gnus-tmp-subject-or-nil)
-(defvar gnus-check-before-posting)
+(eval-when-compile
+ (defvar gnus-tmp-unread)
+ (defvar gnus-tmp-replied)
+ (defvar gnus-tmp-score-char)
+ (defvar gnus-tmp-indentation)
+ (defvar gnus-tmp-opening-bracket)
+ (defvar gnus-tmp-lines)
+ (defvar gnus-tmp-name)
+ (defvar gnus-tmp-closing-bracket)
+ (defvar gnus-tmp-subject-or-nil)
+ (defvar gnus-check-before-posting)
+ (defvar gnus-mouse-face)
+ (defvar gnus-group-buffer))
(defun gnus-ems-redefine ()
(cond
;; [Note] Now there are three kinds of mule implementations,
;; original MULE, XEmacs/mule and Emacs 20+ including
- ;; MULE features. Unfortunately these API are different. In
- ;; particular, Emacs (including original MULE) and XEmacs are
- ;; quite different. Howvere, this version of Gnus doesn't support
+ ;; MULE features. Unfortunately these APIs are different. In
+ ;; particular, Emacs (including original Mule) and XEmacs are
+ ;; quite different. However, this version of Gnus doesn't support
;; anything other than XEmacs 20+ and Emacs 20.3+.
;; Predicates to check are following:
- ;; (boundp 'MULE) is t only if MULE (original; anything older than
+ ;; (boundp 'MULE) is t only if Mule (original; anything older than
;; Mule 2.3) is running.
- ;; (featurep 'mule) is t when every mule variants are running.
+ ;; (featurep 'mule) is t when other mule variants are running.
;; It is possible to detect XEmacs/mule by (featurep 'mule) and
- ;; checking `emacs-version'. In this case, the implementation for
+ ;; (featurep 'xemacs). In this case, the implementation for
;; XEmacs/mule may be shareable between XEmacs and XEmacs/mule.
(defvar gnus-summary-display-table nil
"Display table used in summary mode buffers.")
- (defalias 'gnus-max-width-function 'gnus-mule-max-width-function)
+
+ (defalias 'gnus-summary-set-display-table (lambda ()))
+
+ (if (fboundp 'truncate-string-to-width)
+ (fset 'gnus-truncate-string 'truncate-string-to-width)
+ (fset 'gnus-truncate-string 'truncate-string))
(when (boundp 'gnus-check-before-posting)
(setq gnus-check-before-posting
(delq 'long-lines
(delq 'control-chars gnus-check-before-posting))))
-
- (defun gnus-summary-line-format-spec ()
- (insert gnus-tmp-unread gnus-tmp-replied
- gnus-tmp-score-char gnus-tmp-indentation)
- (put-text-property
- (point)
- (progn
- (insert
- gnus-tmp-opening-bracket
- (format "%4d: %-20s"
- gnus-tmp-lines
- (if (> (length gnus-tmp-name) 20)
- (truncate-string-to-width gnus-tmp-name 20)
- gnus-tmp-name))
- gnus-tmp-closing-bracket)
- (point))
- gnus-mouse-face-prop gnus-mouse-face)
- (insert " " gnus-tmp-subject-or-nil "\n")))))
+ ))
+ (when (featurep 'mule)
+ (defun gnus-tilde-max-form (el max-width)
+ "Return a form that limits EL to MAX-WIDTH."
+ (let ((max (abs max-width)))
+ (if (symbolp el)
+ (if (< max-width 0)
+ `(let ((width (string-width ,el)))
+ (gnus-truncate-string ,el width (- width ,max)))
+ `(gnus-truncate-string ,el ,max))
+ (if (< max-width 0)
+ `(let* ((val (eval ,el))
+ (width (string-width val)))
+ (gnus-truncate-string val width (- width ,max)))
+ `(let ((val (eval ,el)))
+ (gnus-truncate-string val ,max))))))
+
+ (defun gnus-tilde-cut-form (el cut-width)
+ "Return a form that cuts CUT-WIDTH off of EL."
+ (let ((cut (abs cut-width)))
+ (if (symbolp el)
+ (if (< cut-width 0)
+ `(gnus-truncate-string ,el (- (string-width ,el) ,cut))
+ `(gnus-truncate-string ,el (string-width ,el) ,cut))
+ (if (< cut-width 0)
+ `(let ((val (eval ,el)))
+ (gnus-truncate-string val (- (string-width val) ,cut)))
+ `(let ((val (eval ,el)))
+ (gnus-truncate-string val (string-width val) ,cut))))))
+ ))
(defun gnus-region-active-p ()
"Say whether the region is active."
(boundp 'mark-active)
mark-active))
+(defun gnus-mark-active-p ()
+ "Non-nil means the mark and region are currently active in this buffer."
+ mark-active) ; aliased to region-exists-p in XEmacs.
+
(if (fboundp 'add-minor-mode)
(defalias 'gnus-add-minor-mode 'add-minor-mode)
(defun gnus-add-minor-mode (mode name map &rest rest)
(when (and dir
(file-exists-p (setq file
(expand-file-name "x-splash" dir))))
- (with-temp-buffer
- (insert-file-contents file)
- (goto-char (point-min))
- (ignore-errors
- (setq pixmap (read (current-buffer))))))
+ (let ((coding-system-for-read 'raw-text)
+ default-enable-multibyte-characters)
+ (with-temp-buffer
+ (insert-file-contents-as-binary file)
+ (goto-char (point-min))
+ (ignore-errors
+ (setq pixmap (read (current-buffer)))))))
(when pixmap
(make-face 'gnus-splash)
(setq height (/ (car pixmap) (frame-char-height))
(goto-char (point-min))
(sit-for 0))))))
-(defvar gnus-article-xface-ring-internal nil
- "Cache for face data.")
-
-;; Worth customizing?
-(defvar gnus-article-xface-ring-size 6
- "Length of the ring used for `gnus-article-xface-ring-internal'.")
-
-(defvar gnus-article-compface-xbm
- (condition-case ()
- (eq 0 (string-match "#define"
- (shell-command-to-string "uncompface -X")))
- (error nil))
- "Non-nil means the compface program supports the -X option.
-That produces XBM output.")
-
-(defun gnus-article-display-xface (beg end)
- "Display an XFace header from between BEG and END in the current article.
-Requires support for images in your Emacs and the external programs
-`uncompface', and `icontopbm'. On a GNU/Linux system these
-might be in packages with names like `compface' or `faces-xface' and
-`netpbm' or `libgr-progs', for instance. See also
-`gnus-article-compface-xbm'.
-
-This function is for Emacs 21+. See `gnus-xmas-article-display-xface'
-for XEmacs."
- ;; It might be worth converting uncompface's output in Lisp.
-
- (when (if (fboundp 'display-graphic-p)
- (display-graphic-p))
- (unless gnus-article-xface-ring-internal ; Only load ring when needed.
- (setq gnus-article-xface-ring-internal
- (make-ring gnus-article-xface-ring-size)))
- (save-excursion
- (let* ((cur (current-buffer))
- (data (buffer-substring beg end))
- (image (cdr-safe (assoc data (ring-elements
- gnus-article-xface-ring-internal))))
- default-enable-multibyte-characters)
- (unless image
- (with-temp-buffer
- (insert data)
- (and (eq 0 (apply #'call-process-region (point-min) (point-max)
- "uncompface"
- 'delete '(t nil) nil
- (if gnus-article-compface-xbm
- '("-X"))))
- (if gnus-article-compface-xbm
- t
- (goto-char (point-min))
- (progn (insert "/* Width=48, Height=48 */\n") t)
- (eq 0 (call-process-region (point-min) (point-max)
- "icontopbm"
- 'delete '(t nil))))
- ;; Miles Bader says that faces don't look right as
- ;; light on dark.
- (if (eq 'dark (cdr-safe (assq 'background-mode
- (frame-parameters))))
- (setq image (create-image (buffer-string)
- (if gnus-article-compface-xbm
- 'xbm
- 'pbm)
- t
- :ascent 'center
- :foreground "black"
- :background "white"))
- (setq image (create-image (buffer-string)
- (if gnus-article-compface-xbm
- 'xbm
- 'pbm)
- t
- :ascent 'center)))))
- (ring-insert gnus-article-xface-ring-internal (cons data image)))
- (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)))
(provide 'gnus-ems)
projects / elisp / gnus.git- / blobdiff