X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=26d6e2c08b6b873ead9a2c418c3c19e721b8e90b;hb=8339220cc25db3fbdab4367d6252e596bddd9cb1;hp=3167d367cebe4631b2e7b1c7afa577f5feed2d44;hpb=93fe069ce59e6b3662d3f1f723d4cf75a97fda52;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 3167d367c..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 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\\)?" "") @@ -103,21 +130,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))) @@ -131,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." @@ -173,8 +189,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 +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)) @@ -218,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 @@ -258,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) @@ -266,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) @@ -310,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 @@ -355,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 @@ -381,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)) @@ -403,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)) @@ -460,6 +549,81 @@ 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)))))))) + +(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 +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,12 +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) - (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'." @@ -489,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))) @@ -499,7 +677,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 +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." @@ -574,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) @@ -702,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))) @@ -758,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 @@ -769,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 @@ -808,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.") @@ -831,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. @@ -886,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))) @@ -933,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))) @@ -976,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))) @@ -1056,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) @@ -1079,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) @@ -1087,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) ".*$"))) @@ -1118,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 @@ -1181,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." @@ -1206,6 +1468,13 @@ Return the modified alist." (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.) @@ -1223,12 +1492,6 @@ is run." :version "22.1" :group 'gnus-various) -(defun kill-empty-logs () - (dolist (buf (list (get-buffer "*Compile-Log*") - (get-buffer "*Compile-Log-Show*"))) - (if (and buf (= (buffer-size buf) 0)) - (kill-buffer buf)))) - (defun gnus-byte-compile (form) "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." (if gnus-use-byte-compile @@ -1241,9 +1504,7 @@ is run." (defalias 'gnus-byte-compile (lambda (form) (let ((byte-compile-warnings '(unresolved callargs redefine))) - (prog1 - (byte-compile form) - (kill-empty-logs))))) + (byte-compile form)))) (gnus-byte-compile form)) form)) @@ -1328,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)) @@ -1431,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. @@ -1468,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." @@ -1538,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." @@ -1574,13 +1845,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) @@ -1615,7 +1889,69 @@ 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))) + +(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