;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;;; Code:
(require 'custom)
-(eval-when-compile (require 'cl))
-(require 'nnheader)
-(require 'message)
+(eval-when-compile
+ (require 'cl)
+ ;; Fixme: this should be a gnus variable, not nnmail-.
+ (defvar nnmail-pathname-coding-system))
(require 'time-date)
+(require 'netrc)
(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 'rmail-show-message "rmail")
+ (autoload 'nnheader-narrow-to-headers "nnheader")
+ (autoload 'nnheader-replace-chars-in-string "nnheader"))
+
+(eval-and-compile
+ (cond
+ ((fboundp 'replace-in-string)
+ (defalias 'gnus-replace-in-string 'replace-in-string))
+ ((fboundp 'replace-regexp-in-string)
+ (defun gnus-replace-in-string (string regexp newtext &optional literal)
+ (replace-regexp-in-string regexp newtext string nil literal)))
+ (t
+ (defun gnus-replace-in-string (string regexp newtext &optional literal)
+ (let ((start 0) tail)
+ (while (string-match regexp string start)
+ (setq tail (- (length string) (match-end 0)))
+ (setq string (replace-match newtext nil literal string))
+ (setq start (- (length string) tail))))
+ string))))
+
+;;; bring in the netrc functions as aliases
+(defalias 'gnus-netrc-get 'netrc-get)
+(defalias 'gnus-netrc-machine 'netrc-machine)
+(defalias 'gnus-parse-netrc 'netrc-parse)
(defun gnus-boundp (variable)
"Return non-nil if VARIABLE is bound and non-nil."
(defmacro gnus-eval-in-buffer-window (buffer &rest forms)
"Pop to BUFFER, evaluate FORMS, and then return to the original window."
(let ((tempvar (make-symbol "GnusStartBufferWindow"))
- (w (make-symbol "w"))
- (buf (make-symbol "buf")))
+ (w (make-symbol "w"))
+ (buf (make-symbol "buf")))
`(let* ((,tempvar (selected-window))
- (,buf ,buffer)
- (,w (get-buffer-window ,buf 'visible)))
+ (,buf ,buffer)
+ (,w (gnus-get-buffer-window ,buf 'visible)))
(unwind-protect
- (progn
- (if ,w
- (progn
- (select-window ,w)
- (set-buffer (window-buffer ,w)))
- (pop-to-buffer ,buf))
- ,@forms)
- (select-window ,tempvar)))))
+ (progn
+ (if ,w
+ (progn
+ (select-window ,w)
+ (set-buffer (window-buffer ,w)))
+ (pop-to-buffer ,buf))
+ ,@forms)
+ (select-window ,tempvar)))))
(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>. A safe way
;; to limit the length of a string. This function is necessary since
;; `(substr "abc" 0 30)' pukes with "Args out of range".
+;; Fixme: Why not `truncate-string-to-width'?
(defsubst gnus-limit-string (str width)
(if (> (length str) width)
(substring str 0 width)
str))
-(defsubst gnus-functionp (form)
- "Return non-nil if FORM is funcallable."
- (or (and (symbolp form) (fboundp form))
- (and (listp form) (eq (car form) 'lambda))
- (byte-code-function-p form)))
-
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
(funcall (if (stringp buffer) 'get-buffer 'buffer-name)
buffer))))
-(defmacro gnus-kill-buffer (buffer)
- `(let ((buf ,buffer))
- (when (gnus-buffer-exists-p buf)
- (kill-buffer buf))))
-
-(fset 'gnus-point-at-bol
- (if (fboundp 'point-at-bol)
- 'point-at-bol
- 'line-beginning-position))
-
-(fset 'gnus-point-at-eol
- (if (fboundp 'point-at-eol)
- 'point-at-eol
- 'line-end-position))
+(defalias 'gnus-point-at-bol
+ (if (fboundp 'point-at-bol)
+ 'point-at-bol
+ 'line-beginning-position))
+
+(defalias 'gnus-point-at-eol
+ (if (fboundp 'point-at-eol)
+ 'point-at-eol
+ 'line-end-position))
+
+;; The LOCAL arg to `add-hook' is interpreted differently in Emacs and
+;; XEmacs. In Emacs we don't need to call `make-local-hook' first.
+;; It's harmless, though, so the main purpose of this alias is to shut
+;; 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
(defun gnus-delete-first (elt list)
"Delete by side effect the first occurrence of ELT as a member of LIST."
;; Delete the current line (and the next N lines).
(defmacro gnus-delete-line (&optional n)
- `(delete-region (progn (beginning-of-line) (point))
+ `(delete-region (gnus-point-at-bol)
(progn (forward-line ,(or n 1)) (point))))
(defun gnus-byte-code (func)
(string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
(and (setq name (substring from 0 (match-beginning 0)))
;; Strip any quotes from the name.
- (string-match "\".*\"" name)
+ (string-match "^\".*\"$" name)
(setq name (substring name 1 (1- (match-end 0))))))
;; If not, then "address (name)" is used.
(or name
(and (string-match "(.*" from)
(setq name (substring from (1+ (match-beginning 0))
(match-end 0)))))
- ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
- (list (or name from) (or address from))))
+ (list (if (string= name "") nil name) (or address from))))
+
(defun gnus-fetch-field (field)
"Return the value of the header FIELD of current article."
(nnheader-narrow-to-headers)
(message-fetch-field field)))))
+(defun gnus-fetch-original-field (field)
+ "Fetch FIELD from the original version of the current article."
+ (with-current-buffer gnus-original-article-buffer
+ (gnus-fetch-field field)))
+
+
(defun gnus-goto-colon ()
(beginning-of-line)
- (search-forward ":" (gnus-point-at-eol) t))
+ (let ((eol (gnus-point-at-eol)))
+ (goto-char (or (text-property-any (point) eol 'gnus-position t)
+ (search-forward ":" eol t)
+ (point)))))
+
+(defun gnus-decode-newsgroups (newsgroups group &optional method)
+ (let ((method (or method (gnus-find-method-for-group group))))
+ (mapconcat (lambda (group)
+ (gnus-group-name-decode group (gnus-group-name-charset
+ method group)))
+ (message-tokenize-header newsgroups)
+ ",")))
(defun gnus-remove-text-with-property (prop)
"Delete all text in the current buffer with text property PROP."
(defun gnus-newsgroup-directory-form (newsgroup)
"Make hierarchical directory name from NEWSGROUP name."
- (let ((newsgroup (gnus-newsgroup-savable-name newsgroup))
- (len (length newsgroup))
- idx)
- ;; If this is a foreign group, we don't want to translate the
- ;; entire name.
- (if (setq idx (string-match ":" newsgroup))
- (aset newsgroup idx ?/)
- (setq idx 0))
- ;; Replace all occurrences of `.' with `/'.
- (while (< idx len)
- (when (= (aref newsgroup idx) ?.)
- (aset newsgroup idx ?/))
- (setq idx (1+ idx)))
- newsgroup))
+ (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
+ (idx (string-match ":" newsgroup)))
+ (concat
+ (if idx (substring newsgroup 0 idx))
+ (if idx "/")
+ (nnheader-replace-chars-in-string
+ (if idx (substring newsgroup (1+ idx)) newsgroup)
+ ?. ?/))))
(defun gnus-newsgroup-savable-name (group)
;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
(define-key keymap key (pop plist))
(pop plist)))))
-(defun gnus-completing-read (default prompt &rest args)
+(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 ") ")
(yes-or-no-p prompt)
(message "")))
+;; By Frank Schmitt <ich@Frank-Schmitt.net>. Allows to have
+;; age-depending date representations. (e.g. just the time if it's
+;; from today, the day of the week if it's within the last 7 days and
+;; the full date if it's older)
+(defun gnus-seconds-today ()
+ "Returns the number of seconds passed today"
+ (let ((now (decode-time (current-time))))
+ (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600))))
+
+(defun gnus-seconds-month ()
+ "Returns the number of seconds passed this month"
+ (let ((now (decode-time (current-time))))
+ (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
+ (* (- (car (nthcdr 3 now)) 1) 3600 24))))
+
+(defun gnus-seconds-year ()
+ "Returns the number of seconds passed this year"
+ (let ((now (decode-time (current-time)))
+ (days (format-time-string "%j" (current-time))))
+ (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)
+ (* (- (string-to-number days) 1) 3600 24))))
+
+(defvar gnus-user-date-format-alist
+ '(((gnus-seconds-today) . "%k:%M")
+ (604800 . "%a %k:%M") ;;that's one week
+ ((gnus-seconds-month) . "%a %d")
+ ((gnus-seconds-year) . "%b %d")
+ (t . "%b %d '%y")) ;;this one is used when no
+ ;;other does match
+ "Specifies date format depending on age of article.
+This is an alist of items (AGE . FORMAT). AGE can be a number (of
+seconds) or a Lisp expression evaluating to a number. When the age of
+the article is less than this number, then use `format-time-string'
+with the corresponding FORMAT for displaying the date of the article.
+If AGE is not a number or a Lisp expression evaluating to a
+non-number, then the corresponding FORMAT is used as a default value.
+
+Note that the list is processed from the beginning, so it should be
+sorted by ascending AGE. Also note that items following the first
+non-number AGE will be ignored.
+
+You can use the functions `gnus-seconds-today', `gnus-seconds-month'
+and `gnus-seconds-year' in the AGE spec. They return the number of
+seconds passed since the start of today, of this month, of this year,
+respectively.")
+
+(defun gnus-user-date (messy-date)
+ "Format the messy-date acording to gnus-user-date-format-alist.
+Returns \" ? \" if there's bad input or if an other error occurs.
+Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"."
+ (condition-case ()
+ (let* ((messy-date (safe-date-to-time messy-date))
+ (now (current-time))
+ ;;If we don't find something suitable we'll use this one
+ (my-format "%b %m '%y")
+ (high (lsh (- (car now) (car messy-date)) 16)))
+ (if (and (> high -1) (= (logand high 65535) 0))
+ ;;overflow and bad input
+ (let* ((difference (+ high (- (car (cdr now))
+ (car (cdr messy-date)))))
+ (templist gnus-user-date-format-alist)
+ (top (eval (caar templist))))
+ (while (if (numberp top) (< top difference) (not top))
+ (progn
+ (setq templist (cdr templist))
+ (setq top (eval (caar templist)))))
+ (if (stringp (cdr (car templist)))
+ (setq my-format (cdr (car templist))))))
+ (format-time-string (eval my-format) messy-date))
+ (error " ? ")))
+;;end of Frank's code
+
(defun gnus-dd-mmm (messy-date)
"Return a string like DD-MMM from a big messy string."
- (format-time-string "%d-%b" (safe-date-to-time messy-date)))
+ (condition-case ()
+ (format-time-string "%d-%b" (safe-date-to-time messy-date))
+ (error " - ")))
(defmacro gnus-date-get-time (date)
"Convert DATE string to Emacs time.
time)))))
(defsubst gnus-time-iso8601 (time)
- "Return a string of TIME in YYMMDDTHHMMSS format."
+ "Return a string of TIME in YYYYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
(defun gnus-date-iso8601 (date)
- "Convert the DATE to YYMMDDTHHMMSS."
+ "Convert the DATE to YYYYMMDDTHHMMSS."
(condition-case ()
(gnus-time-iso8601 (gnus-date-get-time date))
(error "")))
(defun gnus-mode-string-quote (string)
"Quote all \"%\"'s in STRING."
- (save-excursion
- (gnus-set-work-buffer)
- (insert string)
- (goto-char (point-min))
- (while (search-forward "%" nil t)
- (insert "%"))
- (buffer-string)))
+ (gnus-replace-in-string string "%" "%%"))
;; Make a hash table (default and minimum size is 256).
;; Optional argument HASHSIZE specifies the table size.
:group 'gnus-start
:type 'integer)
-;; Show message if message has a lower level than `gnus-verbose'.
-;; Guideline for numbers:
-;; 1 - error messages, 3 - non-serious error messages, 5 - messages
-;; for things that take a long time, 7 - not very important messages
-;; on stuff, 9 - messages inside loops.
(defun gnus-message (level &rest args)
+ "If LEVEL is lower than `gnus-verbose' print ARGS using `message'.
+
+Guideline for numbers:
+1 - error messages, 3 - non-serious error messages, 5 - messages for things
+that take a long time, 7 - not very important messages on stuff, 9 - messages
+inside loops."
(if (<= level gnus-verbose)
(apply 'message args)
;; We have to do this format thingy here even if the result isn't
"Return a list of Message-IDs in REFERENCES."
(let ((beg 0)
ids)
- (while (string-match "<[^>]+>" references beg)
+ (while (string-match "<[^<]+[^< \t]" references beg)
(push (substring references (match-beginning 0) (setq beg (match-end 0)))
ids))
(nreverse ids)))
(defsubst gnus-parent-id (references &optional n)
"Return the last Message-ID in REFERENCES.
If N, return the Nth ancestor instead."
- (when references
- (let ((ids (inline (gnus-split-references references))))
- (while (nthcdr (or n 1) ids)
- (setq ids (cdr ids)))
- (car ids))))
-
-(defsubst gnus-buffer-live-p (buffer)
+ (when (and references
+ (not (zerop (length references))))
+ (if n
+ (let ((ids (inline (gnus-split-references references))))
+ (while (nthcdr n ids)
+ (setq ids (cdr ids)))
+ (car ids))
+ (when (string-match "\\(<[^<]+>\\)[ \t]*\\'" references)
+ (match-string 1 references)))))
+
+(defun gnus-buffer-live-p (buffer)
"Say whether BUFFER is alive or not."
(and buffer
(get-buffer buffer)
(defun gnus-horizontal-recenter ()
"Recenter the current buffer horizontally."
(if (< (current-column) (/ (window-width) 2))
- (set-window-hscroll (get-buffer-window (current-buffer) t) 0)
+ (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0)
(let* ((orig (point))
- (end (window-end (get-buffer-window (current-buffer) t)))
+ (end (window-end (gnus-get-buffer-window (current-buffer) t)))
(max 0))
(when end
;; Find the longest line currently displayed in the window.
;; Scroll horizontally to center (sort of) the point.
(if (> max (window-width))
(set-window-hscroll
- (get-buffer-window (current-buffer) t)
+ (gnus-get-buffer-window (current-buffer) t)
(min (- (current-column) (/ (window-width) 3))
(+ 2 (- max (window-width)))))
- (set-window-hscroll (get-buffer-window (current-buffer) t) 0))
+ (set-window-hscroll (gnus-get-buffer-window (current-buffer) t) 0))
max))))
-(defun gnus-read-event-char ()
+(defun gnus-read-event-char (&optional prompt)
"Get the next event."
- (let ((event (read-event)))
+ (let ((event (read-event prompt)))
;; should be gnus-characterp, but this can't be called in XEmacs anyway
(cons (and (numberp event) event) event)))
(file-name-nondirectory file))))
(copy-file file to))
-(defun gnus-kill-all-overlays ()
- "Delete all overlays in the current buffer."
- (let* ((overlayss (overlay-lists))
- (buffer-read-only nil)
- (overlays (delq nil (nconc (car overlayss) (cdr overlayss)))))
- (while overlays
- (delete-overlay (pop overlays)))))
-
(defvar gnus-work-buffer " *gnus work*")
(defun gnus-set-work-buffer ()
"Return a composite sort condition based on the functions in FUNC."
(cond
;; Just a simple function.
- ((gnus-functionp funs) funs)
+ ((functionp funs) funs)
;; No functions at all.
((null funs) funs)
;; A list of functions.
((or (cdr funs)
(listp (car funs)))
- `(lambda (t1 t2)
- ,(gnus-make-sort-function-1 (reverse funs))))
+ (gnus-byte-compile
+ `(lambda (t1 t2)
+ ,(gnus-make-sort-function-1 (reverse funs)))))
;; A list containing just one function.
(t
(car funs))))
(setq function (cadr function)
first 't2
last 't1))
- ((gnus-functionp function)
+ ((functionp function)
+ ;; Do nothing.
)
(t
(error "Invalid sort spec: %s" function))))
(prin1 form (current-buffer))))
(defun gnus-prin1-to-string (form)
- "The same as `prin1', but bind `print-quoted' and `print-readably' to t."
+ "The same as `prin1'.
+Bind `print-quoted' and `print-readably' to t, and `print-length'
+and `print-level' to nil."
(let ((print-quoted t)
- (print-readably t))
+ (print-readably t)
+ (print-length nil)
+ (print-level nil))
(prin1-to-string form)))
(defun gnus-make-directory (directory)
"Make DIRECTORY (and all its parents) if it doesn't exist."
- (when (and directory
- (not (file-exists-p directory)))
- (make-directory directory t))
+ (require 'nnmail)
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (when (and directory
+ (not (file-exists-p directory)))
+ (make-directory directory t)))
t)
(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))
- ;; Write the buffer.
- (write-region (point-min) (point-max) file nil 'quietly))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ ;; Write the buffer.
+ (write-region (point-min) (point-max) file nil 'quietly)))
(defun gnus-delete-file (file)
"Delete FILE if it exists."
(save-excursion
(save-restriction
(goto-char beg)
- (while (re-search-forward "[ \t]*\n" end 'move)
+ (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
(gnus-put-text-property beg (match-beginning 0) prop val)
(setq beg (point)))
(gnus-put-text-property beg (point) prop val)))))
+(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
+ (save-excursion
+ (save-restriction
+ (goto-char beg)
+ (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move)
+ (gnus-overlay-put
+ (gnus-make-overlay beg (match-beginning 0))
+ prop val)
+ (setq beg (point)))
+ (gnus-overlay-put (gnus-make-overlay beg (point)) prop val)))))
+
(defun gnus-put-text-property-excluding-characters-with-faces (beg end
prop val)
"The same as `put-text-property', but don't put props on characters with the `gnus-face' property."
(when (get-text-property b 'gnus-face)
(setq b (next-single-property-change b 'gnus-face nil end)))
(when (/= b end)
- (gnus-put-text-property
- b (setq b (next-single-property-change b 'gnus-face nil end))
- prop val)))))
+ (inline
+ (gnus-put-text-property
+ b (setq b (next-single-property-change b 'gnus-face nil end))
+ prop val))))))
+
+(defmacro gnus-faces-at (position)
+ "Return a list of faces at POSITION."
+ (if (featurep 'xemacs)
+ `(let ((pos ,position))
+ (mapcar-extents 'extent-face
+ nil (current-buffer) pos pos nil 'face))
+ `(let ((pos ,position))
+ (delq nil (cons (get-text-property pos 'face)
+ (mapcar
+ (lambda (overlay)
+ (overlay-get overlay 'face))
+ (overlays-at pos)))))))
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996
;;; The primary idea here is to try to protect internal datastructures
It is safe to use gnus-atomic-progn-assign with long computations.
Note that if any of the symbols in PROTECT were unbound, they will be
-set to nil on a sucessful assignment. In case of an error or other
+set to nil on a successful assignment. In case of an error or other
non-local exit, it will still be unbound."
(let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol
(concat (symbol-name x)
(save-excursion
(set-buffer file-buffer)
(rmail-insert-rmail-file-header)
- (let ((require-final-newline nil))
+ (let ((require-final-newline nil)
+ (coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(kill-buffer file-buffer))
(error "Output file does not exist")))
;; Decide whether to append to a file or to an Emacs buffer.
(let ((outbuf (get-file-buffer filename)))
(if (not outbuf)
- (append-to-file (point-min) (point-max) filename)
+ (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)
(when msg
(goto-char (point-min))
(widen)
- (search-backward "\n\^_")
- (narrow-to-region (point) (point-max))
- (rmail-count-new-messages t)
- (when (rmail-summary-exists)
+ (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)
(let ((file-buffer (create-file-buffer filename)))
(save-excursion
(set-buffer file-buffer)
- (let ((require-final-newline nil))
+ (let ((require-final-newline nil)
+ (coding-system-for-write mm-text-coding-system))
(gnus-write-buffer filename)))
(kill-buffer file-buffer))
(error "Output file does not exist")))
(insert "\n"))
(insert "\n"))
(goto-char (point-max))
- (append-to-file (point-min) (point-max) filename)))
+ (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))
(defun gnus-map-function (funs arg)
"Applies the result of the first function in FUNS to the second, and so on.
ARG is passed to the first function."
- (let ((myfuns funs))
- (while myfuns
- (setq arg (funcall (pop myfuns) arg)))
- arg))
+ (while funs
+ (setq arg (funcall (pop funs) arg)))
projects / gnus / blobdiff