X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=334f0eea7db4bc1921db88dc4cbf5c4aa6cda578;hb=f760648d27b25a395063b64e7294717757652f4f;hp=75c3d87931617ba9aae00589c6301d6c1d6367d1;hpb=187ad2ef65bd8cb99dfcc15a15415c4200bbcbba;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 75c3d8793..334f0eea7 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,27 +1,25 @@ ;;; gnus-util.el --- utility functions for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -35,33 +33,35 @@ ;;; 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) - (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) + (require 'cl)) -(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")) +(eval-when-compile + (unless (fboundp 'with-no-warnings) + (defmacro with-no-warnings (&rest body) + `(progn ,@body)))) + +;; 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 ;; 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 + ;; 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\\)?" "") @@ -103,21 +103,12 @@ This is a compatibility function for different Emacsen." (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 . 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))) @@ -173,8 +164,13 @@ is slower." ;; 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 ``'' first in order to handle the quite common + ;; form ``"abc@xyz" '' (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
" format is used. (and address ;; Linear white space is not required. @@ -196,9 +192,21 @@ is slower." (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)) @@ -218,7 +226,15 @@ is slower." (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 @@ -258,6 +274,15 @@ is slower." (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) @@ -266,6 +291,15 @@ is slower." (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) @@ -322,15 +356,55 @@ is slower." ;; 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: +;; | +;; | 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 . Allows to have ;; age-depending date representations. (e.g. just the time if it's @@ -355,6 +429,20 @@ is slower." (+ (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 @@ -381,11 +469,11 @@ respectively.") (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)) @@ -403,23 +491,9 @@ Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." (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)) @@ -460,6 +534,79 @@ jabbering all the 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'. @@ -468,7 +615,9 @@ Guideline for numbers: 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'. @@ -489,7 +638,7 @@ ARGS are passed to `message'." (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))) @@ -499,7 +648,7 @@ ARGS are passed to `message'." (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) @@ -516,8 +665,9 @@ If N, return the Nth ancestor instead." (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." @@ -574,6 +724,10 @@ 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) @@ -702,9 +856,9 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (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))) @@ -758,6 +912,9 @@ If there's no subdirectory, delete DIRECTORY as well." (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 @@ -769,6 +926,10 @@ If there's no subdirectory, delete DIRECTORY as well." (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 @@ -808,11 +969,34 @@ If there's no subdirectory, delete DIRECTORY as well." (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.") @@ -831,7 +1015,7 @@ variables and then do only the assignment atomically." (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. @@ -886,45 +1070,54 @@ with potentially 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))) @@ -933,32 +1126,56 @@ with potentially long computations." (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))) @@ -976,8 +1193,7 @@ with potentially long computations." (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))) @@ -1056,8 +1272,7 @@ This function saves the current buffer." "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-if (predicate list) @@ -1079,6 +1294,14 @@ Return the modified alist." (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) @@ -1087,7 +1310,7 @@ Return the modified 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) ".*$"))) @@ -1118,9 +1341,16 @@ Return the modified alist." (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 @@ -1181,6 +1411,9 @@ Return the modified alist." (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." @@ -1207,11 +1440,11 @@ Return the modified alist." t)) (defun gnus-string-remove-all-properties (string) - (if (stringp string) + (condition-case () (let ((s string)) (set-text-properties 0 (length string) nil string) s) - string)) + (error string))) ;; This might use `compare-strings' to reduce consing in the ;; case-insensitive case, but it has to cope with null args. @@ -1344,11 +1577,9 @@ SPEC is a predicate specifier that contains stuff like `or', `and', (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)) @@ -1430,6 +1661,9 @@ CHOICE is a list of the choice char and help message at IDX." (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) @@ -1445,7 +1679,7 @@ CHOICE is a list of the choice char and help message at IDX." (t (raise-frame frame) (select-frame frame) - (cond ((memq window-system '(x mac)) + (cond ((memq window-system '(x ns mac)) (x-focus-frame frame)) ((eq window-system 'w32) (w32-focus-frame frame))) @@ -1467,8 +1701,7 @@ Return nil otherwise." display)) display))))) -(eval-when-compile - (defvar tool-bar-mode)) +(defvar tool-bar-mode) (defun gnus-tool-bar-update (&rest ignore) "Update the tool bar." @@ -1537,10 +1770,9 @@ predicate on the elements." (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." @@ -1573,13 +1805,16 @@ predicate on the elements." ((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) @@ -1614,7 +1849,49 @@ empty directories from OLD-PATH." (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