X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=26d6e2c08b6b873ead9a2c418c3c19e721b8e90b;hp=78a6a1cd0d3cb46fa73b233209389e1a82e90185;hb=76b6b2b0a969b427bb993110f6d8c05060cf5f64;hpb=1946c4f9f108ec6ca2600faf55f72f0b37e93099 diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 78a6a1cd0..26d6e2c08 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, 2007 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,62 @@ ;;; 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)))) + +(defcustom gnus-completing-read-function 'gnus-emacs-completing-read + "Function use to do completing read." + :version "24.1" + :group 'gnus-meta + :type '(radio (function-item + :doc "Use Emacs standard `completing-read' function." + gnus-emacs-completing-read) + (function-item + :doc "Use `ido-completing-read' function." + gnus-ido-completing-read) + (function-item + :doc "Use iswitchb based completing-read function." + gnus-iswitchb-completing-read))) + +(defcustom gnus-completion-styles + (if (and (boundp 'completion-styles-alist) + (boundp 'completion-styles)) + (append (when (and (assq 'substring completion-styles-alist) + (not (memq 'substring completion-styles))) + (list 'substring)) + completion-styles) + nil) + "Value of `completion-styles' to use when completing." + :version "24.1" + :group 'gnus-meta + :type 'list) + +;; 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\\)?" "") @@ -122,11 +149,9 @@ This is a compatibility function for different Emacsen." ;; 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 ;; up the byte compiler. -(defalias 'gnus-make-local-hook - (if (eq (get 'make-local-hook 'byte-compile) - 'byte-compile-obsolete) - 'ignore ; Emacs - 'make-local-hook)) ; XEmacs +(defalias 'gnus-make-local-hook (if (featurep 'xemacs) + 'make-local-hook + 'ignore)) (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -192,9 +217,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)) @@ -214,7 +251,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 @@ -254,6 +299,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) @@ -262,6 +316,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) @@ -306,27 +369,57 @@ is slower." (define-key keymap key (pop plist)) (pop 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 ": "))) - (answer (apply 'completing-read prompt args))) - (if (or (null answer) (zerop (length answer))) - default - answer))) - ;; 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 @@ -351,6 +444,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 @@ -377,11 +484,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)) @@ -399,23 +506,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)) @@ -462,7 +555,7 @@ 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.0" ;; No Gnus + :version "23.1" ;; No Gnus :group 'gnus-various :type '(choice :format "%{%t%}:\n %[Value Menu%] %v" (const :tag "Logged messages only" log) @@ -523,6 +616,8 @@ but also to the ones displayed in the echo area." (t (apply 'message ,format-string ,args)))))))) +(defvar gnus-action-message-log nil) + (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 @@ -537,14 +632,26 @@ Guideline for numbers: that take a long time, 7 - not very important messages on stuff, 9 - messages inside loops." (if (<= level gnus-verbose) - (if gnus-add-timestamp-to-message - (apply 'gnus-message-with-timestamp args) - (apply 'message args)) + (let ((message + (if gnus-add-timestamp-to-message + (apply 'gnus-message-with-timestamp args) + (apply 'message args)))) + (when (and (consp gnus-action-message-log) + (<= level 3)) + (push message gnus-action-message-log)) + message) ;; 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-final-warning () + (when (and (consp gnus-action-message-log) + (setq gnus-action-message-log + (delete nil gnus-action-message-log))) + (message "Warning: %s" + (mapconcat #'identity gnus-action-message-log "; ")))) + (defun gnus-error (level &rest args) "Beep an error if LEVEL is equal to or less than `gnus-verbose'. ARGS are passed to `message'." @@ -560,7 +667,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))) @@ -587,8 +694,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." @@ -645,6 +753,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) @@ -773,9 +885,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))) @@ -829,6 +941,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 @@ -840,6 +955,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 @@ -879,11 +998,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.") @@ -902,7 +1044,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. @@ -957,45 +1099,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))) @@ -1004,32 +1155,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))) @@ -1047,8 +1222,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))) @@ -1127,8 +1301,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) @@ -1150,6 +1323,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) @@ -1158,7 +1339,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) ".*$"))) @@ -1189,9 +1370,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 @@ -1252,6 +1440,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." @@ -1398,28 +1589,53 @@ SPEC is a predicate specifier that contains stuff like `or', `and', `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) (error "Invalid predicate specifier: %s" spec))))) -(defun gnus-completing-read (prompt table &optional predicate require-match - history) - (when (and history - (not (boundp history))) - (set history nil)) - (completing-read - (if (symbol-value history) - (concat prompt " (" (car (symbol-value history)) "): ") - (concat prompt ": ")) - table - predicate - require-match - nil - history - (car (symbol-value history)))) +(defun gnus-completing-read (prompt collection &optional require-match + initial-input history def) + "Call `gnus-completing-read-function'." + (funcall gnus-completing-read-function + (concat prompt (when def + (concat " (default " def ")")) + ": ") + collection require-match initial-input history def)) + +(defun gnus-emacs-completing-read (prompt collection &optional require-match + initial-input history def) + "Call standard `completing-read-function'." + (let ((completion-styles gnus-completion-styles)) + (completing-read prompt collection nil require-match initial-input history def))) + +(defun gnus-ido-completing-read (prompt collection &optional require-match + initial-input history def) + "Call `ido-completing-read-function'." + (require 'ido) + (ido-completing-read prompt collection nil require-match initial-input history def)) + +(defun gnus-iswitchb-completing-read (prompt collection &optional require-match + initial-input history def) + "`iswitchb' based completing-read function." + (require 'iswitchb) + (let ((iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist + (let ((choices (append + (when initial-input (list initial-input)) + (symbol-value history) collection)) + filtered-choices) + (dolist (x choices) + (setq filtered-choices (adjoin x filtered-choices))) + (nreverse filtered-choices)))))) + (unwind-protect + (progn + (when (not iswitchb-mode) + (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)) + (iswitchb-read-buffer prompt def require-match)) + (when (not iswitchb-mode) + (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) (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)) @@ -1501,27 +1717,14 @@ CHOICE is a list of the choice char and help message at IDX." (kill-buffer buf)) tchar)) -(defun gnus-select-frame-set-input-focus (frame) - "Select FRAME, raise it, and set input focus, if possible." - (cond ((featurep 'xemacs) - (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 ((memq window-system '(x mac)) - (x-focus-frame frame)) - ((eq window-system 'w32) - (w32-focus-frame frame))) - (when focus-follows-mouse - (set-mouse-position frame (1- (frame-width frame)) 0))))) +(if (fboundp 'select-frame-set-input-focus) + (defalias 'gnus-select-frame-set-input-focus 'select-frame-set-input-focus) + ;; XEmacs 21.4, SXEmacs + (defun gnus-select-frame-set-input-focus (frame) + "Select FRAME, raise it, and set input focus, if possible." + (raise-frame frame) + (select-frame frame) + (focus-frame frame))) (defun gnus-frame-or-window-display-name (object) "Given a frame or window, return the associated display name. @@ -1538,8 +1741,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." @@ -1608,10 +1810,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." @@ -1707,7 +1908,50 @@ is allowed once again. (Immediately, if `inhibit-quit' is nil.)" ;; 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))) + +(defun gnus-rescale-image (image size) + "Rescale IMAGE to SIZE if possible. +SIZE is in format (WIDTH . HEIGHT). Return a new image. +Sizes are in pixels." + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) + image + (let ((new-width (car size)) + (new-height (cdr size))) + (when (> (cdr (image-size image t)) new-height) + (setq image (or (create-image (plist-get (cdr image) :data) 'imagemagick t + :height new-height) + image))) + (when (> (car (image-size image t)) new-width) + (setq image (or + (create-image (plist-get (cdr image) :data) 'imagemagick t + :width new-width) + image))) + image))) + (provide 'gnus-util) -;;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49 ;;; gnus-util.el ends here