;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+;; For Emacs < 22.2.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
- (require 'cl)
- ;; Fixme: this should be a gnus variable, not nnmail-.
- (defvar nnmail-pathname-coding-system)
+ (require 'cl))
- ;; Inappropriate references to other parts of Gnus.
- (defvar gnus-emphasize-whitespace-regexp)
- )
-(require 'time-date)
-(require 'netrc)
+(eval-when-compile
+ (unless (fboundp 'with-no-warnings)
+ (defmacro with-no-warnings (&rest body)
+ `(progn ,@body))))
-(eval-and-compile
- (autoload 'message-fetch-field "message")
- (autoload 'gnus-get-buffer-window "gnus-win")
- (autoload 'rmail-insert-rmail-file-header "rmail")
- (autoload 'rmail-count-new-messages "rmail")
- (autoload 'rmail-show-message "rmail")
- (autoload 'nnheader-narrow-to-headers "nnheader")
- (autoload 'nnheader-replace-chars-in-string "nnheader"))
+;; Fixme: this should be a gnus variable, not nnmail-.
+(defvar nnmail-pathname-coding-system)
+(defvar nnmail-active-file-coding-system)
+
+;; Inappropriate references to other parts of Gnus.
+(defvar gnus-emphasize-whitespace-regexp)
+(defvar gnus-original-article-buffer)
+(defvar gnus-user-agent)
+
+(autoload 'gnus-get-buffer-window "gnus-win")
+(autoload 'nnheader-narrow-to-headers "nnheader")
+(autoload 'nnheader-replace-chars-in-string "nnheader")
+(autoload 'mail-header-remove-comments "mail-parse")
(eval-and-compile
(cond
- ((fboundp 'replace-in-string)
- (defalias 'gnus-replace-in-string 'replace-in-string))
+ ;; Prefer `replace-regexp-in-string' (present in Emacs, XEmacs 21.5,
+ ;; SXEmacs 22.1.4) over `replace-in-string'. The latter leads to inf-loops
+ ;; on empty matches:
+ ;; (replace-in-string "foo" "/*$" "/")
+ ;; (replace-in-string "xe" "\\(x\\)?" "")
((fboundp 'replace-regexp-in-string)
(defun gnus-replace-in-string (string regexp newtext &optional literal)
"Replace all matches for REGEXP with NEWTEXT in STRING.
string containing the replacements.
This is a compatibility function for different Emacsen."
- (replace-regexp-in-string regexp newtext string nil literal)))))
+ (replace-regexp-in-string regexp newtext string nil literal)))
+ ((fboundp 'replace-in-string)
+ (defalias 'gnus-replace-in-string 'replace-in-string))))
(defun gnus-boundp (variable)
"Return non-nil if VARIABLE is bound and non-nil."
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
(defmacro gnus-intern-safe (string hashtable)
- "Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
+ "Get hash value. Arguments are STRING and HASHTABLE."
`(let ((symbol (intern ,string ,hashtable)))
(or (boundp symbol)
(set symbol nil))
symbol))
-;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way
-;; to limit the length of a string. This function is necessary since
-;; `(substr "abc" 0 30)' pukes with "Args out of range".
-;; Fixme: Why not `truncate-string-to-width'?
-(defsubst gnus-limit-string (str width)
- (if (> (length str) width)
- (substring str 0 width)
- str))
-
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
;; First find the address - the thing with the @ in it. This may
;; not be accurate in mail addresses, but does the trick most of
;; the time in news messages.
- (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
- (setq address (substring from (match-beginning 0) (match-end 0))))
+ (cond (;; Check ``<foo@bar>'' first in order to handle the quite common
+ ;; form ``"abc@xyz" <foo@bar>'' (i.e. ``@'' as part of a comment)
+ ;; correctly.
+ (string-match "<\\([^@ \t<>]+[!@][^@ \t<>]+\\)>" from)
+ (setq address (substring from (match-beginning 1) (match-end 1))))
+ ((string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
+ (setq address (substring from (match-beginning 0) (match-end 0)))))
;; Then we check whether the "name <address>" format is used.
(and address
;; Linear white space is not required.
(match-end 0)))))
(list (if (string= name "") nil name) (or address from))))
+(defun gnus-extract-address-component-name (from)
+ "Extract name from a From header.
+Uses `gnus-extract-address-components'."
+ (nth 0 (gnus-extract-address-components from)))
+
+(defun gnus-extract-address-component-email (from)
+ "Extract e-mail address from a From header.
+Uses `gnus-extract-address-components'."
+ (nth 1 (gnus-extract-address-components from)))
+
+(declare-function message-fetch-field "message" (header &optional not-all))
(defun gnus-fetch-field (field)
"Return the value of the header FIELD of current article."
+ (require 'message)
(save-excursion
(save-restriction
(let ((inhibit-point-motion-hooks t))
(search-forward ":" eol t)
(point)))))
+(declare-function gnus-find-method-for-group "gnus" (group &optional info))
+(declare-function gnus-group-name-decode "gnus-group" (string charset))
+(declare-function gnus-group-name-charset "gnus-group" (method group))
+;; gnus-group requires gnus-int which requires message.
+(declare-function message-tokenize-header "message"
+ (header &optional separator))
+
(defun gnus-decode-newsgroups (newsgroups group &optional method)
+ (require 'gnus-group)
(let ((method (or method (gnus-find-method-for-group group))))
(mapconcat (lambda (group)
(gnus-group-name-decode group (gnus-group-name-charset
(not (or (string< s1 s2)
(string= s1 s2))))
+(defun gnus-string< (s1 s2)
+ "Return t if first arg string is less than second in lexicographic order.
+Case is significant if and only if `case-fold-search' is nil.
+Symbols are also allowed; their print names are used instead."
+ (if case-fold-search
+ (string-lessp (downcase (if (symbolp s1) (symbol-name s1) s1))
+ (downcase (if (symbolp s2) (symbol-name s2) s2)))
+ (string-lessp s1 s2)))
+
;;; Time functions.
(defun gnus-file-newer-than (file date)
(and (= (car fdate) (car date))
(> (nth 1 fdate) (nth 1 date))))))
+(eval-and-compile
+ (if (and (fboundp 'float-time)
+ (subrp (symbol-function 'float-time)))
+ (defalias 'gnus-float-time 'float-time)
+ (defun gnus-float-time (&optional time)
+ "Convert time value TIME to a floating point number.
+TIME defaults to the current time."
+ (with-no-warnings (time-to-seconds (or time (current-time)))))))
+
;;; Keymap macros.
(defmacro gnus-local-set-keys (&rest plist)
(defun gnus-completing-read-with-default (default prompt &rest args)
;; Like `completing-read', except that DEFAULT is the default argument.
(let* ((prompt (if default
- (concat prompt " (default " default ") ")
- (concat prompt " ")))
+ (concat prompt " (default " default "): ")
+ (concat prompt ": ")))
(answer (apply 'completing-read prompt args)))
(if (or (null answer) (zerop (length answer)))
default
;; Two silly functions to ensure that all `y-or-n-p' questions clear
;; the echo area.
-(defun gnus-y-or-n-p (prompt)
- (prog1
- (y-or-n-p prompt)
- (message "")))
-
-(defun gnus-yes-or-no-p (prompt)
- (prog1
- (yes-or-no-p prompt)
- (message "")))
+;;
+;; Do we really need these functions? Workarounds for bugs in the corresponding
+;; Emacs functions? Maybe these bugs are no longer present in any supported
+;; (X)Emacs version? Alias them to the original functions and see if anyone
+;; reports a problem. If not, replace with original functions. --rsteib,
+;; 2007-12-14
+;;
+;; All supported Emacsen clear the echo area after `yes-or-no-p', so we can
+;; remove `yes-or-no-p'. RMS says that not clearing after `y-or-n-p' is
+;; intentional (see below), so we could remove `gnus-y-or-n-p' too.
+;; Objections? --rsteib, 2008-02-16
+;;
+;; ,----[ http://thread.gmane.org/gmane.emacs.gnus.general/65099/focus=66070 ]
+;; | From: Richard Stallman
+;; | Subject: Re: Do we need gnus-yes-or-no-p and gnus-y-or-n-p?
+;; | To: Katsumi Yamaoka [...]
+;; | Cc: emacs-devel@[...], xemacs-beta@[...], ding@[...]
+;; | Date: Mon, 07 Jan 2008 12:16:05 -0500
+;; | Message-ID: <E1JBva1-000528-VY@fencepost.gnu.org>
+;; |
+;; | The behavior of `y-or-n-p' that it doesn't clear the question
+;; | and the answer is not serious of course, but I feel it is not
+;; | cool.
+;; |
+;; | It is intentional.
+;; |
+;; | Currently, it is commented out in the trunk by Reiner Steib. He
+;; | also wrote the benefit of leaving the question and the answer in
+;; | the echo area as follows:
+;; |
+;; | (http://article.gmane.org/gmane.emacs.gnus.general/66061)
+;; | > In contrast to yes-or-no-p it is much easier to type y, n,
+;; | > SPC, DEL, etc accidentally, so it might be useful for the user
+;; | > to see what he has typed.
+;; |
+;; | Yes, that is the reason.
+;; `----
+
+;; (defun gnus-y-or-n-p (prompt)
+;; (prog1
+;; (y-or-n-p prompt)
+;; (message "")))
+;; (defun gnus-yes-or-no-p (prompt)
+;; (prog1
+;; (yes-or-no-p prompt)
+;; (message "")))
+
+(defalias 'gnus-y-or-n-p 'y-or-n-p)
+(defalias 'gnus-yes-or-no-p 'yes-or-no-p)
;; By Frank Schmitt <ich@Frank-Schmitt.net>. Allows to have
;; age-depending date representations. (e.g. just the time if it's
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
(* (- (string-to-number days) 1) 3600 24))))
+(defmacro gnus-date-get-time (date)
+ "Convert DATE string to Emacs time.
+Cache the result as a text property stored in DATE."
+ ;; Either return the cached value...
+ `(let ((d ,date))
+ (if (equal "" d)
+ '(0 0)
+ (or (get-text-property 0 'gnus-time d)
+ ;; or compute the value...
+ (let ((time (safe-date-to-time d)))
+ ;; and store it back in the string.
+ (put-text-property 0 1 'gnus-time time d)
+ time)))))
+
(defvar gnus-user-date-format-alist
'(((gnus-seconds-today) . "%k:%M")
(604800 . "%a %k:%M") ;;that's one week
(defun gnus-user-date (messy-date)
"Format the messy-date according to gnus-user-date-format-alist.
-Returns \" ? \" if there's bad input or if an other error occurs.
+Returns \" ? \" if there's bad input or if another error occurs.
Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
(condition-case ()
- (let* ((messy-date (time-to-seconds (safe-date-to-time messy-date)))
- (now (time-to-seconds (current-time)))
+ (let* ((messy-date (gnus-float-time (gnus-date-get-time messy-date)))
+ (now (gnus-float-time))
;;If we don't find something suitable we'll use this one
(my-format "%b %d '%y"))
(let* ((difference (- now messy-date))
(defun gnus-dd-mmm (messy-date)
"Return a string like DD-MMM from a big messy string."
(condition-case ()
- (format-time-string "%d-%b" (safe-date-to-time messy-date))
+ (format-time-string "%d-%b" (gnus-date-get-time messy-date))
(error " - ")))
-(defmacro gnus-date-get-time (date)
- "Convert DATE string to Emacs time.
-Cache the result as a text property stored in DATE."
- ;; Either return the cached value...
- `(let ((d ,date))
- (if (equal "" d)
- '(0 0)
- (or (get-text-property 0 'gnus-time d)
- ;; or compute the value...
- (let ((time (safe-date-to-time d)))
- ;; and store it back in the string.
- (put-text-property 0 1 'gnus-time time d)
- time)))))
-
(defsubst gnus-time-iso8601 (time)
"Return a string of TIME in YYYYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
:group 'gnus-start
:type 'integer)
+(defcustom gnus-add-timestamp-to-message nil
+ "Non-nil means add timestamps to messages that Gnus issues.
+If it is `log', add timestamps to only the messages that go into the
+\"*Messages*\" buffer (in XEmacs, it is the \" *Message-Log*\" buffer).
+If it is neither nil nor `log', add timestamps not only to log messages
+but also to the ones displayed in the echo area."
+ :version "23.1" ;; No Gnus
+ :group 'gnus-various
+ :type '(choice :format "%{%t%}:\n %[Value Menu%] %v"
+ (const :tag "Logged messages only" log)
+ (sexp :tag "All messages"
+ :match (lambda (widget value) value)
+ :value t)
+ (const :tag "No timestamp" nil)))
+
+(eval-when-compile
+ (defmacro gnus-message-with-timestamp-1 (format-string args)
+ (let ((timestamp '((format-time-string "%Y%m%dT%H%M%S" time)
+ "." (format "%03d" (/ (nth 2 time) 1000)) "> ")))
+ (if (featurep 'xemacs)
+ `(let (str time)
+ (if (or (and (null ,format-string) (null ,args))
+ (progn
+ (setq str (apply 'format ,format-string ,args))
+ (zerop (length str))))
+ (prog1
+ (and ,format-string str)
+ (clear-message nil))
+ (cond ((eq gnus-add-timestamp-to-message 'log)
+ (setq time (current-time))
+ (display-message 'no-log str)
+ (log-message 'message (concat ,@timestamp str)))
+ (gnus-add-timestamp-to-message
+ (setq time (current-time))
+ (display-message 'message (concat ,@timestamp str)))
+ (t
+ (display-message 'message str))))
+ str)
+ `(let (str time)
+ (cond ((eq gnus-add-timestamp-to-message 'log)
+ (setq str (let (message-log-max)
+ (apply 'message ,format-string ,args)))
+ (when (and message-log-max
+ (> message-log-max 0)
+ (/= (length str) 0))
+ (setq time (current-time))
+ (with-current-buffer (get-buffer-create "*Messages*")
+ (goto-char (point-max))
+ (insert ,@timestamp str "\n")
+ (forward-line (- message-log-max))
+ (delete-region (point-min) (point))
+ (goto-char (point-max))))
+ str)
+ (gnus-add-timestamp-to-message
+ (if (or (and (null ,format-string) (null ,args))
+ (progn
+ (setq str (apply 'format ,format-string ,args))
+ (zerop (length str))))
+ (prog1
+ (and ,format-string str)
+ (message nil))
+ (setq time (current-time))
+ (message "%s" (concat ,@timestamp str))
+ str))
+ (t
+ (apply 'message ,format-string ,args))))))))
+
+(defun gnus-message-with-timestamp (format-string &rest args)
+ "Display message with timestamp. Arguments are the same as `message'.
+The `gnus-add-timestamp-to-message' variable controls how to add
+timestamp to message."
+ (gnus-message-with-timestamp-1 format-string args))
+
(defun gnus-message (level &rest args)
"If LEVEL is lower than `gnus-verbose' print ARGS using `message'.
that take a long time, 7 - not very important messages on stuff, 9 - messages
inside loops."
(if (<= level gnus-verbose)
- (apply 'message args)
+ (if gnus-add-timestamp-to-message
+ (apply 'gnus-message-with-timestamp args)
+ (apply 'message args))
;; We have to do this format thingy here even if the result isn't
;; shown - the return value has to be the same as the return value
;; from `message'.
(apply 'format args)))
(defun gnus-error (level &rest args)
- "Beep an error if LEVEL is equal to or less than `gnus-verbose'."
+ "Beep an error if LEVEL is equal to or less than `gnus-verbose'.
+ARGS are passed to `message'."
(when (<= (floor level) gnus-verbose)
(apply 'message args)
(ding)
(defun gnus-split-references (references)
"Return a list of Message-IDs in REFERENCES."
(let ((beg 0)
- (references (or references ""))
+ (references (mail-header-remove-comments (or references "")))
ids)
(while (string-match "<[^<]+[^< \t]" references beg)
(push (substring references (match-beginning 0) (setq beg (match-end 0)))
(defun gnus-extract-references (references)
"Return a list of Message-IDs in REFERENCES (in In-Reply-To
format), trimmed to only contain the Message-IDs."
- (let ((ids (gnus-split-references references))
+ (let ((ids (gnus-split-references references))
refs)
(dolist (id ids)
(when (string-match "<[^<>]+>" id)
(while (nthcdr n ids)
(setq ids (cdr ids)))
(car ids))
- (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
- (match-string 1 references)))))
+ (let ((references (mail-header-remove-comments references)))
+ (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
+ (match-string 1 references))))))
(defun gnus-buffer-live-p (buffer)
"Say whether BUFFER is alive or not."
(defvar gnus-work-buffer " *gnus work*")
+(declare-function gnus-get-buffer-create "gnus" (name))
+;; gnus.el requires mm-util.
+(declare-function mm-enable-multibyte "mm-util")
+
(defun gnus-set-work-buffer ()
"Put point in the empty Gnus work buffer."
(if (get-buffer gnus-work-buffer)
For example, (gnus-group-server \"nnimap+yxa:INBOX.foo\") would
yield \"nnimap:yxa\"."
`(let ((gname ,group))
- (if (string-match "^\\([^+]+\\).\\([^:]+\\):" gname)
- (format "%s:%s" (match-string 1 gname) (match-string 2 gname))
+ (if (string-match "^\\([^:+]+\\)\\(?:\\+\\([^:]*\\)\\)?:" gname)
+ (format "%s:%s" (match-string 1 gname) (or
+ (match-string 2 gname)
+ ""))
(format "%s:%s" (car gnus-select-method) (cadr gnus-select-method)))))
(defun gnus-make-sort-function (funs)
(defun gnus-write-buffer (file)
"Write the current buffer's contents to FILE."
- ;; Make sure the directory exists.
- (gnus-make-directory (file-name-directory file))
(let ((file-name-coding-system nnmail-pathname-coding-system))
+ ;; Make sure the directory exists.
+ (gnus-make-directory (file-name-directory file))
;; Write the buffer.
(write-region (point-min) (point-max) file nil 'quietly)))
(unless dir
(delete-directory directory)))))
+;; The following two functions are used in gnus-registry.
+;; They were contributed by Andreas Fuchs <asf@void.at>.
+(defun gnus-alist-to-hashtable (alist)
+ "Build a hashtable from the values in ALIST."
+ (let ((ht (make-hash-table
+ :size 4096
+ :test 'equal)))
+ (mapc
+ (lambda (kv-pair)
+ (puthash (car kv-pair) (cdr kv-pair) ht))
+ alist)
+ ht))
+
+(defun gnus-hashtable-to-alist (hash)
+ "Build an alist from the values in HASH."
+ (let ((list nil))
+ (maphash
+ (lambda (key value)
+ (setq list (cons (cons key value) list)))
+ hash)
+ list))
+
(defun gnus-strip-whitespace (string)
"Return STRING stripped of all whitespace."
(while (string-match "[\r\n\t ]+" string)
(setq string (replace-match "" t t string)))
string)
+(declare-function gnus-put-text-property "gnus"
+ (start end property value &optional object))
+
(defsubst gnus-put-text-property-excluding-newlines (beg end prop val)
"The same as `put-text-property', but don't put this prop on any newlines in the region."
(save-match-data
(setq beg (point)))
(gnus-put-text-property beg (point) prop val)))))
+(declare-function gnus-overlay-put "gnus" (overlay prop value))
+(declare-function gnus-make-overlay "gnus"
+ (beg end &optional buffer front-advance rear-advance))
+
(defsubst gnus-put-overlay-excluding-newlines (beg end prop val)
"The same as `put-text-property', but don't put this prop on any newlines in the region."
(save-match-data
(overlay-get overlay 'face))
(overlays-at pos)))))))
+(if (fboundp 'invisible-p)
+ (defalias 'gnus-invisible-p 'invisible-p)
+ ;; for Emacs < 22.2, and XEmacs.
+ (defun gnus-invisible-p (pos)
+ "Return non-nil if the character after POS is currently invisible."
+ (let ((prop (get-char-property pos 'invisible)))
+ (if (eq buffer-invisibility-spec t)
+ prop
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec))))))
+
+;; Note: the optional 2nd argument has a different meaning between
+;; Emacs and XEmacs.
+;; (next-char-property-change POSITION &optional LIMIT)
+;; (next-extent-change POS &optional OBJECT)
+(defalias 'gnus-next-char-property-change
+ (if (fboundp 'next-extent-change)
+ 'next-extent-change 'next-char-property-change))
+
+(defalias 'gnus-previous-char-property-change
+ (if (fboundp 'previous-extent-change)
+ 'previous-extent-change 'previous-char-property-change))
+
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996
-;;; The primary idea here is to try to protect internal datastructures
-;;; from becoming corrupted when the user hits C-g, or if a hook or
-;;; similar blows up. Often in Gnus multiple tables/lists need to be
-;;; updated at the same time, or information can be lost.
+;; The primary idea here is to try to protect internal datastructures
+;; from becoming corrupted when the user hits C-g, or if a hook or
+;; similar blows up. Often in Gnus multiple tables/lists need to be
+;; updated at the same time, or information can be lost.
(defvar gnus-atomic-be-safe t
"If t, certain operations will be protected from interruption by C-g.")
(put 'gnus-atomic-progn 'lisp-indent-function 0)
(defmacro gnus-atomic-progn-assign (protect &rest forms)
- "Evaluate FORMS, but insure that the variables listed in PROTECT
+ "Evaluate FORMS, but ensure that the variables listed in PROTECT
are not changed if anything in FORMS signals an error or otherwise
non-locally exits. The variables listed in PROTECT are updated atomically.
It is safe to use gnus-atomic-progn-assign with long computations.
;;; Functions for saving to babyl/mail files.
(eval-when-compile
- (condition-case nil
- (progn
- (require 'rmail)
- (autoload 'rmail-update-summary "rmailsum"))
- (error
- (define-compiler-macro rmail-select-summary (&rest body)
- ;; Rmail of the XEmacs version is supplied by the package, and
- ;; requires tm and apel packages. However, there may be those
- ;; who haven't installed those packages. This macro helps such
- ;; people even if they install those packages later.
- `(eval '(rmail-select-summary ,@body)))
- ;; If there's rmail but there's no tm (or there's apel of the
- ;; mainstream, not the XEmacs version), loading rmail of the XEmacs
- ;; version fails halfway, however it provides the rmail-select-summary
- ;; macro which uses the following functions:
- (autoload 'rmail-summary-displayed "rmail")
- (autoload 'rmail-maybe-display-summary "rmail")))
- (defvar rmail-default-rmail-file)
- (defvar mm-text-coding-system))
+ (if (featurep 'xemacs)
+ ;; Don't load tm and apel XEmacs packages that provide some
+ ;; Emacs emulating functions and variables.
+ (let ((features features))
+ (provide 'tm-view)
+ (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore))
+ (require 'rmail)) ;; It requires tm-view that loads apel.
+ (require 'rmail))
+ (autoload 'rmail-update-summary "rmailsum"))
+
+(defvar mm-text-coding-system)
+
+(declare-function mm-append-to-file "mm-util"
+ (start end filename &optional codesys inhibit))
(defun gnus-output-to-rmail (filename &optional ask)
- "Append the current article to an Rmail file named FILENAME."
+ "Append the current article to an Rmail file named FILENAME.
+In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
+FILENAME exists and is Babyl format."
(require 'rmail)
(require 'mm-util)
- ;; Most of these codes are borrowed from rmailout.el.
+ ;; Some of this codes is borrowed from rmailout.el.
(setq filename (expand-file-name filename))
- (setq rmail-default-rmail-file filename)
+ ;; FIXME should we really be messing with this defcustom?
+ ;; It is not needed for the operation of this function.
+ (if (boundp 'rmail-default-rmail-file)
+ (setq rmail-default-rmail-file filename) ; 22
+ (setq rmail-default-file filename)) ; 23
(let ((artbuf (current-buffer))
- (tmpbuf (get-buffer-create " *Gnus-output*")))
+ (tmpbuf (get-buffer-create " *Gnus-output*"))
+ ;; Babyl rmail.el defines this, mbox does not.
+ (babyl (fboundp 'rmail-insert-rmail-file-header)))
(save-excursion
- (or (get-file-buffer filename)
- (file-exists-p filename)
+ ;; Note that we ignore the possibility of visiting a Babyl
+ ;; format buffer in Emacs 23, since Rmail no longer supports that.
+ (or (get-file-buffer filename)
+ (progn
+ ;; In case someone wants to write to a Babyl file from Emacs 23.
+ (when (file-exists-p filename)
+ (setq babyl (mail-file-babyl-p filename))
+ t))
(if (or (not ask)
(gnus-yes-or-no-p
(concat "\"" filename "\" does not exist, create it? ")))
(let ((file-buffer (create-file-buffer filename)))
- (save-excursion
- (set-buffer file-buffer)
- (rmail-insert-rmail-file-header)
+ (with-current-buffer file-buffer
+ (if (fboundp 'rmail-insert-rmail-file-header)
+ (rmail-insert-rmail-file-header))
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(set-buffer tmpbuf)
(erase-buffer)
(insert-buffer-substring artbuf)
- (gnus-convert-article-to-rmail)
+ (if babyl
+ (gnus-convert-article-to-rmail)
+ ;; Non-Babyl case copied from gnus-output-to-mail.
+ (goto-char (point-min))
+ (if (looking-at "From ")
+ (forward-line 1)
+ (insert "From nobody " (current-time-string) "\n"))
+ (let (case-fold-search)
+ (while (re-search-forward "^From " nil t)
+ (beginning-of-line)
+ (insert ">"))))
;; Decide whether to append to a file or to an Emacs buffer.
(let ((outbuf (get-file-buffer filename)))
(if (not outbuf)
- (let ((file-name-coding-system nnmail-pathname-coding-system))
- (mm-append-to-file (point-min) (point-max) filename))
+ (progn
+ (unless babyl ; from gnus-output-to-mail
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (forward-char -2)
+ (unless (looking-at "\n\n")
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n"))))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (mm-append-to-file (point-min) (point-max) filename)))
;; File has been visited, in buffer OUTBUF.
(set-buffer outbuf)
(let ((buffer-read-only nil)
(msg (and (boundp 'rmail-current-message)
(symbol-value 'rmail-current-message))))
;; If MSG is non-nil, buffer is in RMAIL mode.
+ ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23.
(when msg
- (widen)
- (narrow-to-region (point-max) (point-max)))
+ (unless babyl
+ (rmail-swap-buffers-maybe)
+ (rmail-maybe-set-message-counters))
+ (widen)
+ (narrow-to-region (point-max) (point-max)))
(insert-buffer-substring tmpbuf)
(when msg
- (goto-char (point-min))
- (widen)
- (search-backward "\n\^_")
- (narrow-to-region (point) (point-max))
+ (when babyl
+ (goto-char (point-min))
+ (widen)
+ (search-backward "\n\^_")
+ (narrow-to-region (point) (point-max)))
(rmail-count-new-messages t)
(when (rmail-summary-exists)
(rmail-select-summary
(rmail-update-summary)))
- (rmail-count-new-messages t)
(rmail-show-message msg))
(save-buffer)))))
(kill-buffer tmpbuf)))
(gnus-y-or-n-p
(concat "\"" filename "\" does not exist, create it? ")))
(let ((file-buffer (create-file-buffer filename)))
- (save-excursion
- (set-buffer file-buffer)
+ (with-current-buffer file-buffer
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
"Say whether Gnus is running or not."
(and (boundp 'gnus-group-buffer)
(get-buffer gnus-group-buffer)
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(eq major-mode 'gnus-group-mode))))
-(defun gnus-remove-duplicates (list)
- (let (new)
- (while list
- (or (member (car list) new)
- (setq new (cons (car list) new)))
- (setq list (cdr list)))
- (nreverse new)))
-
(defun gnus-remove-if (predicate list)
"Return a copy of LIST with all items satisfying PREDICATE removed."
(let (out)
(setq alist (delq entry alist)))
alist)))
+(defun gnus-grep-in-list (word list)
+ "Find if a WORD matches any regular expression in the given LIST."
+ (when (and word list)
+ (catch 'found
+ (dolist (r list)
+ (when (string-match r word)
+ (throw 'found r))))))
+
(defmacro gnus-pull (key alist &optional assoc-p)
"Modify ALIST to be without KEY."
(unless (symbolp alist)
`(setq ,alist (delq (,fun ,key ,alist) ,alist))))
(defun gnus-globalify-regexp (re)
- "Return a regexp that matches a whole line, iff RE matches a part of it."
+ "Return a regexp that matches a whole line, if RE matches a part of it."
(concat (unless (string-match "^\\^" re) "^.*")
re
(unless (string-match "\\$$" re) ".*$")))
(throw 'found nil)))
t))
+;; gnus.el requires mm-util.
+(declare-function mm-disable-multibyte "mm-util")
+
(defun gnus-write-active-file (file hashtb &optional full-names)
+ ;; `coding-system-for-write' should be `raw-text' or equivalent.
(let ((coding-system-for-write nnmail-active-file-coding-system))
(with-temp-file file
+ ;; The buffer should be in the unibyte mode because group names
+ ;; are ASCII text or encoded non-ASCII text (i.e., unibyte).
+ (mm-disable-multibyte)
(mapatoms
(lambda (sym)
(when (and sym
(pop l2))
l1))))
+(declare-function gnus-add-text-properties "gnus"
+ (start end properties &optional object))
+
(defun gnus-add-text-properties-when
(property value start end properties &optional object)
"Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE."
(remove-text-properties start end properties object))
t))
+(defun gnus-string-remove-all-properties (string)
+ (condition-case ()
+ (let ((s string))
+ (set-text-properties 0 (length string) nil string)
+ s)
+ (error string)))
+
;; This might use `compare-strings' to reduce consing in the
;; case-insensitive case, but it has to cope with null args.
;; (`string-equal' uses symbol print names.)
(car (symbol-value history))))
(defun gnus-graphic-display-p ()
- (or (and (fboundp 'display-graphic-p)
- (display-graphic-p))
- ;;;!!!This is bogus. Fixme!
- (and (featurep 'xemacs)
- t)))
+ (if (featurep 'xemacs)
+ (device-on-window-system-p)
+ (display-graphic-p)))
(put 'gnus-parse-without-error 'lisp-indent-function 0)
(put 'gnus-parse-without-error 'edebug-form-spec '(body))
(kill-buffer buf))
tchar))
+(declare-function x-focus-frame "xfns.c" (frame))
+(declare-function w32-focus-frame "../term/w32-win" (frame))
+
(defun gnus-select-frame-set-input-focus (frame)
"Select FRAME, raise it, and set input focus, if possible."
(cond ((featurep 'xemacs)
- (raise-frame frame)
- (select-frame frame)
- (focus-frame frame))
- ;; The function `select-frame-set-input-focus' won't set
- ;; the input focus under Emacs 21.2 and X window system.
- ;;((fboundp 'select-frame-set-input-focus)
- ;; (defalias 'gnus-select-frame-set-input-focus
- ;; 'select-frame-set-input-focus)
- ;; (select-frame-set-input-focus frame))
+ (if (fboundp 'select-frame-set-input-focus)
+ (select-frame-set-input-focus frame)
+ (raise-frame frame)
+ (select-frame frame)
+ (focus-frame frame)))
+ ;; `select-frame-set-input-focus' defined in Emacs 21 will not
+ ;; set the input focus.
+ ((>= emacs-major-version 22)
+ (select-frame-set-input-focus frame))
(t
(raise-frame frame)
(select-frame frame)
- (cond ((and (eq window-system 'x)
- (fboundp 'x-focus-frame))
+ (cond ((memq window-system '(x ns mac))
(x-focus-frame frame))
((eq window-system 'w32)
(w32-focus-frame frame)))
display))
display)))))
+(defvar tool-bar-mode)
+
+(defun gnus-tool-bar-update (&rest ignore)
+ "Update the tool bar."
+ (when (and (boundp 'tool-bar-mode)
+ tool-bar-mode)
+ (let* ((args nil)
+ (func (cond ((featurep 'xemacs)
+ 'ignore)
+ ((fboundp 'tool-bar-update)
+ 'tool-bar-update)
+ ((fboundp 'force-window-update)
+ 'force-window-update)
+ ((fboundp 'redraw-frame)
+ (setq args (list (selected-frame)))
+ 'redraw-frame)
+ (t 'ignore))))
+ (apply func args))))
+
;; Fixme: This has only one use (in gnus-agent), which isn't worthwhile.
(defmacro gnus-mapcar (function seq1 &rest seqs2_n)
"Apply FUNCTION to each element of the sequences, and make a list of the results.
(push (pop list1) res)))
(nconc (nreverse res) list1 list2))))
-(eval-when-compile
- (defvar xemacs-codename)
- (defvar sxemacs-codename)
- (defvar emacs-program-version))
+(defvar xemacs-codename)
+(defvar sxemacs-codename)
+(defvar emacs-program-version)
(defun gnus-emacs-version ()
"Stringified Emacs version."
((or (featurep 'sxemacs) (featurep 'xemacs))
;; XEmacs or SXEmacs:
(concat emacsname "/" emacs-program-version
- " ("
- (when (and (memq 'codename lst)
- codename)
- (concat codename
- (when system-v ", ")))
- (when system-v system-v)
- ")"))
+ (let (plst)
+ (when (memq 'codename lst)
+ (push codename plst))
+ (when system-v
+ (push system-v plst))
+ (unless (featurep 'mule)
+ (push "no MULE" plst))
+ (when (> (length plst) 0)
+ (concat
+ " (" (mapconcat 'identity (reverse plst) ", ") ")")))))
(t emacs-version))))
(defun gnus-rename-file (old-path new-path &optional trim)
(ignore-errors
(set-file-modes filename mode)))
+(if (fboundp 'set-process-query-on-exit-flag)
+ (defalias 'gnus-set-process-query-on-exit-flag
+ 'set-process-query-on-exit-flag)
+ (defalias 'gnus-set-process-query-on-exit-flag
+ 'process-kill-without-query))
+
+(if (fboundp 'with-local-quit)
+ (defalias 'gnus-with-local-quit 'with-local-quit)
+ (defmacro gnus-with-local-quit (&rest body)
+ "Execute BODY, allowing quits to terminate BODY but not escape further.
+When a quit terminates BODY, `gnus-with-local-quit' returns nil but
+requests another quit. That quit will be processed as soon as quitting
+is allowed once again. (Immediately, if `inhibit-quit' is nil.)"
+ ;;(declare (debug t) (indent 0))
+ `(condition-case nil
+ (let ((inhibit-quit nil))
+ ,@body)
+ (quit (setq quit-flag t)
+ ;; This call is to give a chance to handle quit-flag
+ ;; in case inhibit-quit is nil.
+ ;; Without this, it will not be handled until the next function
+ ;; call, and that might allow it to exit thru a condition-case
+ ;; that intends to handle the quit signal next time.
+ (eval '(ignore nil))))))
+
+(defalias 'gnus-read-shell-command
+ (if (fboundp 'read-shell-command) 'read-shell-command 'read-string))
+
+(defmacro gnus-put-display-table (range value display-table)
+ "Set the value for char RANGE to VALUE in DISPLAY-TABLE. "
+ (if (featurep 'xemacs)
+ (progn
+ `(if (fboundp 'put-display-table)
+ (put-display-table ,range ,value ,display-table)
+ (if (sequencep ,display-table)
+ (aset ,display-table ,range ,value)
+ (put-char-table ,range ,value ,display-table))))
+ `(aset ,display-table ,range ,value)))
+
+(defmacro gnus-get-display-table (character display-table)
+ "Find value for CHARACTER in DISPLAY-TABLE. "
+ (if (featurep 'xemacs)
+ `(if (fboundp 'get-display-table)
+ (get-display-table ,character ,display-table)
+ (if (sequencep ,display-table)
+ (aref ,display-table ,character)
+ (get-char-table ,character ,display-table)))
+ `(aref ,display-table ,character)))
+
(provide 'gnus-util)
-;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
;;; gnus-util.el ends here
projects / gnus / blobdiff