;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'cl)
;; Fixme: this should be a gnus variable, not nnmail-.
(defvar nnmail-pathname-coding-system))
-(require 'nnheader)
(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))))
-
(defalias 'gnus-point-at-bol
(if (fboundp 'point-at-bol)
'point-at-bol
'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."
(if (equal (car list) elt)
;; 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
(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."
(delete-char 1))
(goto-char (next-single-property-change (point) prop nil (point-max))))))
-(require 'nnheader)
(defun gnus-newsgroup-directory-form (newsgroup)
"Make hierarchical directory name from NEWSGROUP name."
(let* ((newsgroup (gnus-newsgroup-savable-name newsgroup))
(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."
(condition-case ()
(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 "<[^> \t]+>" 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))
projects / gnus / blobdiff