;;; gnus-ems.el --- functions for making Semi-gnus work under different Emacsen
-;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
+
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Tatsuya Ichikawa <t-ichi@niagara.shiojiri.ne.jp>
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (require 'ring))
;;; Function aliases later to be redefined for XEmacs usage.
-(defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
- "Non-nil if running under XEmacs.")
-
(defvar gnus-mouse-2 [mouse-2])
-(defvar gnus-mouse-3 [mouse-3])
+(defvar gnus-down-mouse-3 [down-mouse-3])
(defvar gnus-down-mouse-2 [down-mouse-2])
(defvar gnus-widget-button-keymap nil)
(defvar gnus-mode-line-modified
- (if (or gnus-xemacs
- (< emacs-major-version 20))
+ (if (featurep 'xemacs)
'("--**-" . "-----")
'("**" "--")))
(eval-and-compile
(autoload 'gnus-xmas-define "gnus-xmas")
(autoload 'gnus-xmas-redefine "gnus-xmas")
- (autoload 'appt-select-lowest-window "appt"))
+ (autoload 'gnus-get-buffer-create "gnus")
+ (autoload 'nnheader-find-etc-directory "nnheader"))
-(or (fboundp 'mail-file-babyl-p)
- (fset 'mail-file-babyl-p 'rmail-file-p))
+(autoload 'smiley-region "smiley")
-;;; Mule functions.
+(defun gnus-kill-all-overlays ()
+ "Delete all overlays in the current buffer."
+ (let* ((overlayss (overlay-lists))
+ (buffer-read-only nil)
+ (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
+ (while overlays
+ (delete-overlay (pop overlays)))))
-(defun gnus-mule-cite-add-face (number prefix face)
- ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
- (when face
- (let ((inhibit-point-motion-hooks t)
- from to)
- (goto-line number)
- (unless (eobp) ; Sometimes things become confused (broken).
- (forward-char (chars-in-string prefix))
- (skip-chars-forward " \t")
- (setq from (point))
- (end-of-line 1)
- (skip-chars-backward " \t")
- (setq to (point))
- (when (< from to)
- (push (setq overlay (gnus-make-overlay from to))
- gnus-cite-overlay-list)
- (gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
-
-(defvar gnus-mule-bitmap-image-file nil)
-(defun gnus-mule-group-startup-message (&optional x y)
- "Insert startup message in current buffer."
- ;; Insert the message.
- (erase-buffer)
- (insert
- (if (featurep 'bitmap)
- (format " %s
-
-"
- "" (if (and (stringp gnus-mule-bitmap-image-file)
- (file-exists-p gnus-mule-bitmap-image-file))
- (insert-file gnus-mule-bitmap-image-file)))
- (format " %s
- _ ___ _ _
- _ ___ __ ___ __ _ ___
- __ _ ___ __ ___
- _ ___ _
- _ _ __ _
- ___ __ _
- __ _
- _ _ _
- _ _ _
- _ _ _
- __ ___
- _ _ _ _
- _ _
- _ _
- _ _
- _
- __
-
-"
- "")))
- ;; And then hack it.
- (gnus-indent-rigidly (point-min) (point-max)
- (/ (max (- (window-width) (or x 46)) 0) 2))
- (goto-char (point-min))
- (forward-line 1)
- (let* ((pheight (count-lines (point-min) (point-max)))
- (wheight (window-height))
- (rest (- wheight pheight)))
- (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
- ;; Fontify some.
- (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
- (goto-char (point-min))
- (setq mode-line-buffer-identification (concat " " gnus-version))
- (setq gnus-simple-splash t)
- (set-buffer-modified-p t))
-
-(defun gnus-encode-coding-string (string system)
- string)
-
-(defun gnus-decode-coding-string (string system)
- string)
+;;; Mule functions.
(eval-and-compile
- (if (string-match "XEmacs\\|Lucid" emacs-version)
- nil
-
+ (if (featurep 'xemacs)
+ (gnus-xmas-define)
(defvar gnus-mouse-face-prop 'mouse-face
- "Property used for highlighting mouse regions."))
-
- (cond
- ((string-match "XEmacs\\|Lucid" emacs-version)
- (gnus-xmas-define))
-
- ((or (not (boundp 'emacs-minor-version))
- (and (< emacs-major-version 20)
- (< emacs-minor-version 30)))
- ;; Remove the `intangible' prop.
- (let ((props (and (boundp 'gnus-hidden-properties)
- gnus-hidden-properties)))
- (while (and props (not (eq (car (cdr props)) 'intangible)))
- (setq props (cdr props)))
- (when props
- (setcdr props (cdr (cdr (cdr props))))))
- (unless (fboundp 'buffer-substring-no-properties)
- (defun buffer-substring-no-properties (beg end)
- (format "%s" (buffer-substring beg end)))))
-
- ((boundp 'MULE)
- (provide 'gnusutil))))
-
-(eval-and-compile
- (cond
- ((not window-system)
- (defun gnus-dummy-func (&rest args))
- (let ((funcs '(mouse-set-point set-face-foreground
- set-face-background x-popup-menu)))
- (while funcs
- (unless (fboundp (car funcs))
- (fset (car funcs) 'gnus-dummy-func))
- (setq funcs (cdr funcs)))))))
-
-(eval-and-compile
- (let ((case-fold-search t))
- (cond
- ((string-match "windows-nt\\|os/2\\|emx" (symbol-name system-type))
- (setq nnheader-file-name-translation-alist
- (append nnheader-file-name-translation-alist
- '((?: . ?_)
- (?+ . ?-))))))))
-
-(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)
+ "Property used for highlighting mouse regions.")))
+
+(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
- ((string-match "XEmacs\\|Lucid" emacs-version)
+ ((featurep 'xemacs)
(gnus-xmas-redefine))
((featurep 'mule)
;; Mule and new Emacs definitions
- ;; [Note] Now there are three kinds of mule implementations,
- ;; original MULE, XEmacs/mule and beta version of Emacs including
- ;; some mule features. Unfortunately these API are different. In
- ;; particular, Emacs (including original MULE) and XEmacs are
- ;; quite different.
- ;; Predicates to check are following:
- ;; (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.
-
- ;; These implementations may be able to share between original
- ;; MULE and beta version of new Emacs. In addition, it is able to
- ;; detect XEmacs/mule by (featurep 'mule) and to check variable
- ;; `emacs-version'. In this case, implementation for XEmacs/mule
- ;; may be able to share between XEmacs and XEmacs/mule.
+ ;; [Note] Now there are two kinds of mule implementations,
+ ;; XEmacs/mule and Emacs 20+ including Mule features.
+ ;; Unfortunately these APIs are different. In particular, Emacs
+ ;; and XEmacs are quite different. However, this version of Gnus
+ ;; doesn't support anything other than XEmacs 21+ and Emacs 21+.
+
+ ;; Predicate to check is the following:
+ ;; (featurep 'mule) is t when other mule variants are running.
+
+ ;; It is possible to detect XEmacs/mule by (featurep 'mule) and
+ ;; (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.")
- (fset 'gnus-summary-set-display-table (lambda ()))
- (fset 'gnus-encode-coding-string 'encode-coding-string)
- (fset 'gnus-decode-coding-string 'decode-coding-string)
+
+ (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))))
+ ))
+ (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 (> (string-width ,el) ,max)
- ,(if (< max-width 0)
- `(gnus-truncate-string
- ,el (string-width ,el)
- (- (string-width ,el) ,max))
- `(gnus-truncate-string ,el ,max))
- ,el)
- `(let ((val (eval ,el)))
- (if (> (string-width val) ,max)
- ,(if (< max-width 0)
- `(gnus-truncate-string
- val (string-width val)
- (- (string-width val) ,max))
- `(gnus-truncate-string val ,max))
- val)))))
+ (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 (> (string-width ,el) ,cut)
- ,(if (< cut-width 0)
- `(gnus-truncate-string
- ,el (- (string-width ,el) ,cut))
- `(gnus-truncate-string
- ,el (- (string-width ,el) ,cut) ,cut))
- ,el)
- `(let ((val (eval ,el)))
- (if (> (string-width val) ,cut)
- ,(if (< cut-width 0)
- `(gnus-truncate-string
- val (- (string-width val) ,cut))
- `(gnus-truncate-string
- val (- (string-width val) ,cut) ,cut))
- val)))))
-
- (when window-system
- (require 'path-util)
- (if (module-installed-p 'bitmap)
- (fset 'gnus-group-startup-message 'gnus-mule-group-startup-message)
- ))
-
- (when (boundp 'gnus-check-before-posting)
- (setq gnus-check-before-posting
- (delq 'long-lines
- (delq 'control-chars gnus-check-before-posting))))
-
- (when (fboundp 'chars-in-string)
- (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face))
-
- )))
+ (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))))))
+ ))
+
+;; Clone of `appt-select-lowest-window' in appt.el.
+(defun gnus-select-lowest-window ()
+"Select the lowest window on the frame."
+ (let ((lowest-window (selected-window))
+ (bottom-edge (nth 3 (window-edges))))
+ (walk-windows (lambda (w)
+ (let ((next-bottom-edge (nth 3 (window-edges w))))
+ (when (< bottom-edge next-bottom-edge)
+ (setq bottom-edge next-bottom-edge
+ lowest-window w)))))
+ (select-window lowest-window)))
(defun gnus-region-active-p ()
"Say whether the region is active."
(boundp 'mark-active)
mark-active))
-(defun gnus-add-minor-mode (mode name map)
- (if (fboundp 'add-minor-mode)
- (add-minor-mode mode name map)
- (set (make-local-variable mode) t)
- (unless (assq mode minor-mode-alist)
- (push `(,mode ,name) minor-mode-alist))
- (unless (assq mode minor-mode-map-alist)
- (push (cons mode map)
- minor-mode-map-alist))))
+(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.
(defun gnus-x-splash ()
"Show a splash screen using a pixmap in the current buffer."
pixmap file height beg i)
(save-excursion
(switch-to-buffer (gnus-get-buffer-create gnus-group-buffer))
- (let ((buffer-read-only nil))
+ (let ((buffer-read-only nil)
+ width height)
(erase-buffer)
(when (and dir
- (file-exists-p (setq file (concat dir "x-splash"))))
- (with-temp-file nil
- (insert-file-contents file)
- (goto-char (point-min))
- (ignore-errors
- (setq pixmap (read (current-buffer))))))
+ (file-exists-p (setq file
+ (expand-file-name "x-splash" dir))))
+ (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
- (erase-buffer)
- (unless (facep 'gnus-splash)
- (make-face 'gnus-splash))
+ (make-face 'gnus-splash)
(setq height (/ (car pixmap) (frame-char-height))
width (/ (cadr pixmap) (frame-char-width)))
- (set-face-foreground 'gnus-splash "ForestGreen")
+ (set-face-foreground 'gnus-splash "Brown")
(set-face-stipple 'gnus-splash pixmap)
(insert-char ?\n (* (/ (window-height) 2 height) height))
(setq i height)
(while (> i 0)
- (insert-char ? (* (+ (/ (window-width) 2 width) 1) width))
+ (insert-char ?\ (* (/ (window-width) 2 width) width))
(setq beg (point))
- (insert-char ? width)
+ (insert-char ?\ width)
(set-text-properties beg (point) '(face gnus-splash))
- (insert "\n")
+ (insert ?\n)
(decf i))
(goto-char (point-min))
(sit-for 0))))))
-(if (fboundp 'split-string)
- (fset 'gnus-split-string 'split-string)
- (defun gnus-split-string (string pattern)
- "Return a list of substrings of STRING which are separated by PATTERN."
- (let (parts (start 0))
- (while (string-match pattern string start)
- (setq parts (cons (substring string start (match-beginning 0)) parts)
- start (match-end 0)))
- (nreverse (cons (substring string start) parts)))))
+;;; 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)
+ "Remove the image matching IMAGE and CATEGORY found first."
+ (let ((start (point-min))
+ val end)
+ (while (and (not end)
+ (or (setq val (get-text-property start 'display))
+ (and (setq start
+ (next-single-property-change start 'display))
+ (setq val (get-text-property start 'display)))))
+ (setq end (or (next-single-property-change start 'display)
+ (point-max)))
+ (if (and (equal val image)
+ (equal (get-text-property start 'gnus-image-category)
+ category))
+ (progn
+ (put-text-property start end 'display nil)
+ (when (get-text-property start 'gnus-image-text-deletable)
+ (delete-region start end)))
+ (unless (= end (point-max))
+ (setq start end
+ end nil))))))
+
+(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)
-;; Local Variables:
-;; byte-compile-warnings: '(redefine callargs)
-;; End:
-
;;; gnus-ems.el ends here
projects / elisp / gnus.git- / blobdiff