;;; gnus-util.el --- utility functions for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
(eval-when-compile
(require 'cl))
+
+(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)
(defvar gnus-original-article-buffer)
(defvar gnus-user-agent)
-(require 'time-date)
-(require 'netrc)
-
-(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")
+(autoload 'mail-header-remove-comments "mail-parse")
(eval-and-compile
(cond
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))
(point)))))
(declare-function gnus-find-method-for-group "gnus" (group &optional info))
-(autoload 'gnus-group-name-decode "gnus-group")
+(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
(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)
(+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
(* (- (string-to-number days) 1) 3600 24))))
+(defmacro gnus-date-get-time (date)
+ "Convert DATE string to Emacs time.
+Cache the result as a text property stored in DATE."
+ ;; Either return the cached value...
+ `(let ((d ,date))
+ (if (equal "" d)
+ '(0 0)
+ (or (get-text-property 0 'gnus-time d)
+ ;; or compute the value...
+ (let ((time (safe-date-to-time d)))
+ ;; and store it back in the string.
+ (put-text-property 0 1 'gnus-time time d)
+ time)))))
+
(defvar gnus-user-date-format-alist
'(((gnus-seconds-today) . "%k:%M")
(604800 . "%a %k:%M") ;;that's one week
(defun gnus-user-date (messy-date)
"Format the messy-date according to gnus-user-date-format-alist.
-Returns \" ? \" if there's bad input or if an other error occurs.
+Returns \" ? \" if there's bad input or if another error occurs.
Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
(condition-case ()
- (let* ((messy-date (time-to-seconds (safe-date-to-time messy-date)))
- (now (time-to-seconds (current-time)))
+ (let* ((messy-date (gnus-float-time (gnus-date-get-time messy-date)))
+ (now (gnus-float-time))
;;If we don't find something suitable we'll use this one
(my-format "%b %d '%y"))
(let* ((difference (- now messy-date))
(defun gnus-dd-mmm (messy-date)
"Return a string like DD-MMM from a big messy string."
(condition-case ()
- (format-time-string "%d-%b" (safe-date-to-time messy-date))
+ (format-time-string "%d-%b" (gnus-date-get-time messy-date))
(error " - ")))
-(defmacro gnus-date-get-time (date)
- "Convert DATE string to Emacs time.
-Cache the result as a text property stored in DATE."
- ;; Either return the cached value...
- `(let ((d ,date))
- (if (equal "" d)
- '(0 0)
- (or (get-text-property 0 'gnus-time d)
- ;; or compute the value...
- (let ((time (safe-date-to-time d)))
- ;; and store it back in the string.
- (put-text-property 0 1 'gnus-time time d)
- time)))))
-
(defsubst gnus-time-iso8601 (time)
"Return a string of TIME in YYYYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
(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)))
(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."
(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
;;; 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)
+ (if (featurep 'xemacs)
+ ;; Don't load tm and apel XEmacs packages that provide some
+ ;; Emacs emulating functions and variables.
+ (let ((features features))
+ (provide 'tm-view)
+ (unless (fboundp 'set-alist) (defalias 'set-alist 'ignore))
+ (require 'rmail)) ;; It requires tm-view that loads apel.
+ (require 'rmail))
+ (autoload 'rmail-update-summary "rmailsum"))
+
(defvar mm-text-coding-system)
(declare-function mm-append-to-file "mm-util"
(start end filename &optional codesys inhibit))
(defun gnus-output-to-rmail (filename &optional ask)
- "Append the current article to an Rmail file named FILENAME."
+ "Append the current article to an Rmail file named FILENAME.
+In Emacs 22 this writes Babyl format; in Emacs 23 it writes mbox unless
+FILENAME exists and is Babyl format."
(require 'rmail)
(require 'mm-util)
- ;; Most of these codes are borrowed from rmailout.el.
+ ;; Some of this codes is borrowed from rmailout.el.
(setq filename (expand-file-name filename))
- (setq rmail-default-rmail-file filename)
+ ;; FIXME should we really be messing with this defcustom?
+ ;; It is not needed for the operation of this function.
+ (if (boundp 'rmail-default-rmail-file)
+ (setq rmail-default-rmail-file filename) ; 22
+ (setq rmail-default-file filename)) ; 23
(let ((artbuf (current-buffer))
- (tmpbuf (get-buffer-create " *Gnus-output*")))
+ (tmpbuf (get-buffer-create " *Gnus-output*"))
+ ;; Babyl rmail.el defines this, mbox does not.
+ (babyl (fboundp 'rmail-insert-rmail-file-header)))
(save-excursion
- (or (get-file-buffer filename)
- (file-exists-p filename)
+ ;; Note that we ignore the possibility of visiting a Babyl
+ ;; format buffer in Emacs 23, since Rmail no longer supports that.
+ (or (get-file-buffer filename)
+ (progn
+ ;; In case someone wants to write to a Babyl file from Emacs 23.
+ (when (file-exists-p filename)
+ (setq babyl (mail-file-babyl-p filename))
+ t))
(if (or (not ask)
(gnus-yes-or-no-p
(concat "\"" filename "\" does not exist, create it? ")))
(let ((file-buffer (create-file-buffer filename)))
- (save-excursion
- (set-buffer file-buffer)
- (rmail-insert-rmail-file-header)
+ (with-current-buffer file-buffer
+ (if (fboundp 'rmail-insert-rmail-file-header)
+ (rmail-insert-rmail-file-header))
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(set-buffer tmpbuf)
(erase-buffer)
(insert-buffer-substring artbuf)
- (gnus-convert-article-to-rmail)
+ (if babyl
+ (gnus-convert-article-to-rmail)
+ ;; Non-Babyl case copied from gnus-output-to-mail.
+ (goto-char (point-min))
+ (if (looking-at "From ")
+ (forward-line 1)
+ (insert "From nobody " (current-time-string) "\n"))
+ (let (case-fold-search)
+ (while (re-search-forward "^From " nil t)
+ (beginning-of-line)
+ (insert ">"))))
;; Decide whether to append to a file or to an Emacs buffer.
(let ((outbuf (get-file-buffer filename)))
(if (not outbuf)
- (let ((file-name-coding-system nnmail-pathname-coding-system))
- (mm-append-to-file (point-min) (point-max) filename))
+ (progn
+ (unless babyl ; from gnus-output-to-mail
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (forward-char -2)
+ (unless (looking-at "\n\n")
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n"))))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (mm-append-to-file (point-min) (point-max) filename)))
;; File has been visited, in buffer OUTBUF.
(set-buffer outbuf)
(let ((buffer-read-only nil)
(msg (and (boundp 'rmail-current-message)
(symbol-value 'rmail-current-message))))
;; If MSG is non-nil, buffer is in RMAIL mode.
+ ;; Compare this with rmail-output-to-rmail-buffer in Emacs 23.
(when msg
- (widen)
- (narrow-to-region (point-max) (point-max)))
+ (unless babyl
+ (rmail-swap-buffers-maybe)
+ (rmail-maybe-set-message-counters))
+ (widen)
+ (narrow-to-region (point-max) (point-max)))
(insert-buffer-substring tmpbuf)
(when msg
- (goto-char (point-min))
- (widen)
- (search-backward "\n\^_")
- (narrow-to-region (point) (point-max))
+ (when babyl
+ (goto-char (point-min))
+ (widen)
+ (search-backward "\n\^_")
+ (narrow-to-region (point) (point-max)))
(rmail-count-new-messages t)
(when (rmail-summary-exists)
(rmail-select-summary
(rmail-update-summary)))
- (rmail-count-new-messages t)
(rmail-show-message msg))
(save-buffer)))))
(kill-buffer tmpbuf)))
(gnus-y-or-n-p
(concat "\"" filename "\" does not exist, create it? ")))
(let ((file-buffer (create-file-buffer filename)))
- (save-excursion
- (set-buffer file-buffer)
+ (with-current-buffer file-buffer
(let ((require-final-newline nil)
(coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
"Say whether Gnus is running or not."
(and (boundp 'gnus-group-buffer)
(get-buffer gnus-group-buffer)
- (save-excursion
- (set-buffer gnus-group-buffer)
+ (with-current-buffer gnus-group-buffer
(eq major-mode 'gnus-group-mode))))
(defun gnus-remove-if (predicate list)
(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)
(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))
(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)))
(provide 'gnus-util)
-;; arch-tag: f94991af-d32b-4c97-8c26-ca12a934de49
;;; gnus-util.el ends here
projects / gnus / blobdiff