;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007, 2008 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:
;; Gnus first.
;; [Unfortunately, it does depend on other parts of Gnus, e.g. the
-;; autoloads below...]
+;; autoloads and defvars below...]
;;; Code:
-(require 'custom)
+;; 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))
+;; 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)
+
(require 'time-date)
(require 'netrc)
(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 later 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.
+If LITERAL is non-nil, insert NEWTEXT literally. Return a new
+string containing the replacements.
+
+This is a compatibility function for different Emacsen."
(replace-regexp-in-string regexp newtext string nil literal)))
- (t
- (defun gnus-replace-in-string (string regexp newtext &optional literal)
- (let ((start 0) tail)
- (while (string-match regexp string start)
- (setq tail (- (length string) (match-end 0)))
- (setq string (replace-match newtext nil literal string))
- (setq start (- (length string) tail))))
- string))))
-
-;;; bring in the netrc functions as aliases
-(defalias 'gnus-netrc-get 'netrc-get)
-(defalias 'gnus-netrc-machine 'netrc-machine)
-(defalias 'gnus-parse-netrc 'netrc-parse)
+ ((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)))
(funcall (if (stringp buffer) 'get-buffer 'buffer-name)
buffer))))
-(defalias 'gnus-point-at-bol
- (if (fboundp 'point-at-bol)
- 'point-at-bol
- 'line-beginning-position))
-
-(defalias 'gnus-point-at-eol
- (if (fboundp 'point-at-eol)
- 'point-at-eol
- 'line-end-position))
-
;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and
;; XEmacs. In Emacs we don't need to call `make-local-hook' first.
;; It's harmless, though, so the main purpose of this alias is to shut
;; Delete the current line (and the next N lines).
(defmacro gnus-delete-line (&optional n)
- `(delete-region (gnus-point-at-bol)
+ `(delete-region (point-at-bol)
(progn (forward-line ,(or n 1)) (point))))
(defun gnus-byte-code (func)
;; 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)))
(defun gnus-fetch-field (field)
"Return the value of the header FIELD of current article."
(save-excursion
(save-restriction
- (let ((case-fold-search t)
- (inhibit-point-motion-hooks t))
+ (let ((inhibit-point-motion-hooks t))
(nnheader-narrow-to-headers)
(message-fetch-field field)))))
(defun gnus-goto-colon ()
(beginning-of-line)
- (let ((eol (gnus-point-at-eol)))
+ (let ((eol (point-at-eol)))
(goto-char (or (text-property-any (point) eol 'gnus-position t)
(search-forward ":" eol t)
(point)))))
+(declare-function gnus-find-method-for-group "gnus" (group &optional info))
+(autoload 'gnus-group-name-decode "gnus-group")
+(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)
(let ((method (or method (gnus-find-method-for-group group))))
(mapconcat (lambda (group)
(defun gnus-remove-text-with-property (prop)
"Delete all text in the current buffer with text property PROP."
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (while (get-text-property (point) prop)
- (delete-char 1))
- (goto-char (next-single-property-change (point) prop nil (point-max))))))
+ (let ((start (point-min))
+ end)
+ (unless (get-text-property start prop)
+ (setq start (next-single-property-change start prop)))
+ (while start
+ (setq end (text-property-any start (point-max) prop nil))
+ (delete-region start (or end (point-max)))
+ (setq start (when end
+ (next-single-property-change start prop))))))
(defun gnus-newsgroup-directory-form (newsgroup)
"Make hierarchical directory name from NEWSGROUP name."
(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)
(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
: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 ""))
ids)
(while (string-match "<[^<]+[^< \t]" references beg)
(push (substring references (match-beginning 0) (setq beg (match-end 0)))
ids))
(nreverse ids)))
+(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))
+ refs)
+ (dolist (id ids)
+ (when (string-match "<[^<>]+>" id)
+ (push (match-string 0 id) refs)))
+ refs))
+
(defsubst gnus-parent-id (references &optional n)
"Return the last Message-ID in REFERENCES.
If N, return the Nth ancestor instead."
(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)
(substring gname (match-end 0))
gname)))
+(defmacro gnus-group-server (group)
+ "Find the server name of a foreign newsgroup.
+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) (or
+ (match-string 2 gname)
+ ""))
+ (format "%s:%s" (car gnus-select-method) (cadr gnus-select-method)))))
+
(defun gnus-make-sort-function (funs)
"Return a composite sort condition based on the functions in FUNS."
(cond
(define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
[menu-bar edit] 'undefined))
+(defmacro gnus-bind-print-variables (&rest forms)
+ "Bind print-* variables and evaluate FORMS.
+This macro is used with `prin1', `pp', etc. in order to ensure printed
+Lisp objects are loadable. Bind `print-quoted' and `print-readably'
+to t, and `print-escape-multibyte', `print-escape-newlines',
+`print-escape-nonascii', `print-length', `print-level' and
+`print-string-length' to nil."
+ `(let ((print-quoted t)
+ (print-readably t)
+ ;;print-circle
+ ;;print-continuous-numbering
+ print-escape-multibyte
+ print-escape-newlines
+ print-escape-nonascii
+ ;;print-gensym
+ print-length
+ print-level
+ print-string-length)
+ ,@forms))
+
(defun gnus-prin1 (form)
"Use `prin1' on FORM in the current buffer.
-Bind `print-quoted' and `print-readably' to t while printing."
- (let ((print-quoted t)
- (print-readably t)
- (print-escape-multibyte nil)
- print-level print-length)
- (prin1 form (current-buffer))))
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (prin1 form (current-buffer))))
(defun gnus-prin1-to-string (form)
"The same as `prin1'.
-Bind `print-quoted' and `print-readably' to t, and `print-length'
-and `print-level' to nil."
- (let ((print-quoted t)
- (print-readably t)
- (print-length nil)
- (print-level nil))
- (prin1-to-string form)))
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (prin1-to-string form)))
+
+(defun gnus-pp (form &optional stream)
+ "Use `pp' on FORM in the current buffer.
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (pp form (or stream (current-buffer)))))
+
+(defun gnus-pp-to-string (form)
+ "The same as `pp-to-string'.
+Bind `print-quoted' and `print-readably' to t, and `print-length' and
+`print-level' to nil. See also `gnus-bind-print-variables'."
+ (gnus-bind-print-variables (pp-to-string form)))
(defun gnus-make-directory (directory)
"Make DIRECTORY (and all its parents) if it doesn't exist."
(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)))
(when (file-exists-p file)
(delete-file file)))
+(defun gnus-delete-directory (directory)
+ "Delete files in DIRECTORY. Subdirectories remain.
+If there's no subdirectory, delete DIRECTORY as well."
+ (when (file-directory-p directory)
+ (let ((files (directory-files
+ directory t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))
+ file dir)
+ (while files
+ (setq file (pop files))
+ (if (eq t (car (file-attributes file)))
+ ;; `file' is a subdirectory.
+ (setq dir t)
+ ;; `file' is a file or a symlink.
+ (delete-file file)))
+ (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
;;; Functions for saving to babyl/mail files.
(eval-when-compile
- (when (featurep 'xemacs)
- ;; The XEmacs version of rmail requires tm, however tm was taken
- ;; over to SEMI and FLIM long ago. So, there may be those who
- ;; have not installed tm.
- (require 'alist)
- (provide 'tm-view))
- (require 'rmail)
- (autoload 'rmail-update-summary "rmailsum")
- (defvar rmail-default-rmail-file)
- (defvar mm-text-coding-system))
+ (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)
+
+(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."
(save-current-buffer
(apply 'run-hooks funcs)))
+(defun gnus-run-mode-hooks (&rest funcs)
+ "Run `run-mode-hooks' if it is available, otherwise `run-hooks'.
+This function saves the current buffer."
+ (if (fboundp 'run-mode-hooks)
+ (save-current-buffer (apply 'run-mode-hooks funcs))
+ (save-current-buffer (apply 'run-hooks funcs))))
+
;;; Various
(defvar gnus-group-buffer) ; Compiler directive
(set-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 (,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
(standard-output
(lambda (c)
(aset ,buffer ,leng c)
-
+
(if (= ,size (setq ,leng (1+ ,leng)))
(progn (write-region ,buffer nil ,file ,append 'no-msg)
(setq ,leng 0
(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.)
Setting it to nil has no effect after the first time `gnus-byte-compile'
is run."
:type 'boolean
- :version "21.1"
+ :version "22.1"
:group 'gnus-various)
(defun gnus-byte-compile (form)
"Delete by side effect any elements of LIST whose car is `equal' to KEY.
The modified LIST is returned. If the first member
of LIST has a car that is `equal' to KEY, there is no way to remove it
-by side effect; therefore, write `(setq foo (remassoc key foo))' to be
+by side effect; therefore, write `(setq foo (gnus-remassoc key foo))' to be
sure of changing the value of `foo'."
(when alist
(if (equal key (caar alist))
`(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec)))
(error "Invalid predicate specifier: %s" spec)))))
-(defun gnus-local-map-property (map)
- "Return a list suitable for a text property list specifying keymap MAP."
- (cond
- ((featurep 'xemacs)
- (list 'keymap map))
- ((>= emacs-major-version 21)
- (list 'keymap map))
- (t
- (list 'local-map map))))
-
-(defmacro gnus-completing-read-maybe-default (prompt table &optional predicate
- require-match initial-contents
- history default)
- "Like `completing-read', allowing for non-existent 7th arg in older XEmacsen."
- `(completing-read ,prompt ,table ,predicate ,require-match
- ,initial-contents ,history
- ,@(if (and (featurep 'xemacs) (< emacs-minor-version 2))
- ()
- (list default))))
-
(defun gnus-completing-read (prompt table &optional predicate require-match
history)
(when (and history
(not (boundp history)))
(set history nil))
- (gnus-completing-read-maybe-default
+ (completing-read
(if (symbol-value history)
(concat prompt " (" (car (symbol-value history)) "): ")
(concat prompt ": "))
(kill-buffer buf))
tchar))
+(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 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 xemacs-codename)
+(defvar sxemacs-codename)
+(defvar emacs-program-version)
(defun gnus-emacs-version ()
- (let ((system-v
- (cond
- ((eq gnus-user-agent 'emacs-gnus-config)
- system-configuration)
- ((eq gnus-user-agent 'emacs-gnus-type)
- (symbol-name system-type))
- (t nil))))
+ "Stringified Emacs version."
+ (let* ((lst (if (listp gnus-user-agent)
+ gnus-user-agent
+ '(gnus emacs type)))
+ (system-v (cond ((memq 'config lst)
+ system-configuration)
+ ((memq 'type lst)
+ (symbol-name system-type))
+ (t nil)))
+ codename emacsname)
+ (cond ((featurep 'sxemacs)
+ (setq emacsname "SXEmacs"
+ codename sxemacs-codename))
+ ((featurep 'xemacs)
+ (setq emacsname "XEmacs"
+ codename xemacs-codename))
+ (t
+ (setq emacsname "Emacs")))
(cond
- ((eq gnus-user-agent 'gnus)
+ ((not (memq 'emacs lst))
nil)
((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
+ ;; Emacs:
(concat "Emacs/" (match-string 1 emacs-version)
(if system-v
(concat " (" system-v ")")
"")))
- ((string-match
- "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
- emacs-version)
- (concat
- (match-string 1 emacs-version)
- (format "/%d.%d" emacs-major-version emacs-minor-version)
- (if (match-beginning 3)
- (match-string 3 emacs-version)
- "")
- (if (boundp 'xemacs-codename)
- (concat
- " (" xemacs-codename
- (if system-v
- (concat ", " system-v ")")
- ")"))
- "")))
+ ((or (featurep 'sxemacs) (featurep 'xemacs))
+ ;; XEmacs or SXEmacs:
+ (concat emacsname "/" emacs-program-version
+ (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)
+ "Rename OLD-PATH as NEW-PATH. If TRIM, recursively delete
+empty directories from OLD-PATH."
+ (when (file-exists-p old-path)
+ (let* ((old-dir (file-name-directory old-path))
+ (old-name (file-name-nondirectory old-path))
+ (new-dir (file-name-directory new-path))
+ (new-name (file-name-nondirectory new-path))
+ temp)
+ (gnus-make-directory new-dir)
+ (rename-file old-path new-path t)
+ (when trim
+ (while (progn (setq temp (directory-files old-dir))
+ (while (member (car temp) '("." ".."))
+ (setq temp (cdr temp)))
+ (= (length temp) 0))
+ (delete-directory old-dir)
+ (setq old-dir (file-name-as-directory
+ (file-truename
+ (concat old-dir "..")))))))))
+
+(defun gnus-set-file-modes (filename mode)
+ "Wrapper for set-file-modes."
+ (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))))))
+
(provide 'gnus-util)
+;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
;;; gnus-util.el ends here
projects / gnus / blobdiff