;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; This file is part of GNU Emacs.
;;; Code:
(require 'custom)
-(require 'cl)
+(eval-when-compile (require 'cl))
(require 'nnheader)
(require 'timezone)
(require 'message)
+(eval-and-compile
+ (autoload 'nnmail-date-to-time "nnmail")
+ (autoload 'rmail-insert-rmail-file-header "rmail")
+ (autoload 'rmail-count-new-messages "rmail")
+ (autoload 'rmail-show-message "rmail"))
+
(defun gnus-boundp (variable)
"Return non-nil if VARIABLE is bound and non-nil."
(and (boundp variable)
(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 (get-buffer-window ,buf 'visible)))
(unwind-protect
- (progn
- (if ,w
- (select-window ,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))
(set symbol nil))
symbol))
-;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;; function `substring' might cut on a middle of multi-octet
-;; character.
(defun gnus-truncate-string (str width)
(substring str 0 width))
(defsubst gnus-functionp (form)
"Return non-nil if FORM is funcallable."
(or (and (symbolp form) (fboundp form))
- (and (listp form) (eq (car form) 'lambda))))
+ (and (listp form) (eq (car form) 'lambda))
+ (byte-code-function-p form)))
(defsubst gnus-goto-char (point)
(and point (goto-char point)))
(when (gnus-buffer-exists-p buf)
(kill-buffer buf))))
-(defsubst gnus-point-at-bol ()
- "Return point at the beginning of the line."
- (let ((p (point)))
- (beginning-of-line)
- (prog1
- (point)
- (goto-char p))))
-
-(defsubst gnus-point-at-eol ()
- "Return point at the end of the line."
- (let ((p (point)))
- (end-of-line)
- (prog1
- (point)
- (goto-char p))))
+(if (fboundp 'point-at-bol)
+ (fset 'gnus-point-at-bol 'point-at-bol)
+ (defun gnus-point-at-bol ()
+ "Return point at the beginning of the line."
+ (let ((p (point)))
+ (beginning-of-line)
+ (prog1
+ (point)
+ (goto-char p)))))
+
+(if (fboundp 'point-at-eol)
+ (fset 'gnus-point-at-eol 'point-at-eol)
+ (defun gnus-point-at-eol ()
+ "Return point at the end of the line."
+ (let ((p (point)))
+ (end-of-line)
+ (prog1
+ (point)
+ (goto-char p)))))
(defun gnus-delete-first (elt list)
"Delete by side effect the first occurrence of ELT as a member of LIST."
(defun gnus-byte-code (func)
"Return a form that can be `eval'ed based on FUNC."
- (let ((fval (symbol-function func)))
+ (let ((fval (indirect-function func)))
(if (byte-code-function-p fval)
(let ((flist (append fval nil)))
(setcar flist 'byte-code)
(setq address (substring from (match-beginning 0) (match-end 0))))
;; Then we check whether the "name <address>" format is used.
(and address
- ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; Linear white space is not required.
(string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
(and (setq name (substring from 0 (match-beginning 0)))
(1- (match-end 0)))))
(and (string-match "()" from)
(setq name address))
- ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>.
;; XOVER might not support folded From headers.
(and (string-match "(.*" from)
(setq name (substring from (1+ (match-beginning 0))
(date (mapcar (lambda (d) (and d (string-to-int d))) parse))
(time (mapcar 'string-to-int (timezone-parse-time (aref parse 3)))))
(encode-time (caddr time) (cadr time) (car time)
- (caddr date) (cadr date) (car date) (nth 4 date))))
+ (caddr date) (cadr date) (car date)
+ (* 60 (timezone-zone-to-minute (nth 4 date))))))
(defun gnus-time-minus (t1 t2)
"Subtract two internal times."
(defun gnus-completing-read (default prompt &rest args)
;; Like `completing-read', except that DEFAULT is the default argument.
- (let* ((prompt (if default
+ (let* ((prompt (if default
(concat prompt " (default " default ") ")
(concat prompt " ")))
(answer (apply 'completing-read prompt args)))
(yes-or-no-p prompt)
(message "")))
-;; I suspect there's a better way, but I haven't taken the time to do
-;; it yet. -erik selberg@cs.washington.edu
(defun gnus-dd-mmm (messy-date)
- "Return a string like DD-MMM from a big messy string"
+ "Return a string like DD-MMM from a big messy string."
(let ((datevec (ignore-errors (timezone-parse-date messy-date))))
- (if (not datevec)
+ (if (or (not datevec)
+ (string-equal "0" (aref datevec 1)))
"??-???"
(format "%2s-%s"
(condition-case ()
(defsubst gnus-time-iso8601 (time)
"Return a string of TIME in YYMMDDTHHMMSS format."
(format-time-string "%Y%m%dT%H%M%S" time))
-
-(defun gnus-date-iso8601 (header)
- "Convert the date field in HEADER to YYMMDDTHHMMSS"
+
+(defun gnus-date-iso8601 (date)
+ "Convert the DATE to YYMMDDTHHMMSS."
(condition-case ()
- (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header)))
+ (gnus-time-iso8601 (gnus-date-get-time date))
(error "")))
(defun gnus-mode-string-quote (string)
(insert "%"))
(buffer-string)))
-;; Make a hash table (default and minimum size is 255).
+;; Make a hash table (default and minimum size is 256).
;; Optional argument HASHSIZE specifies the table size.
(defun gnus-make-hashtable (&optional hashsize)
- (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 255) 255) 0))
-
-;; Make a number that is suitable for hashing; bigger than MIN and one
-;; less than 2^x.
+ (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0))
+
+;; Make a number that is suitable for hashing; bigger than MIN and
+;; equal to some 2^x. Many machines (such as sparcs) do not have a
+;; hardware modulo operation, so they implement it in software. On
+;; many sparcs over 50% of the time to intern is spent in the modulo.
+;; Yes, it's slower than actually computing the hash from the string!
+;; So we use powers of 2 so people can optimize the modulo to a mask.
(defun gnus-create-hash-size (min)
(let ((i 1))
(while (< i min)
(setq i (* 2 i)))
- (1- i)))
+ i))
(defcustom gnus-verbose 7
"*Integer that says how verbose Gnus should be.
(sit-for duration))))
nil)
-(defun gnus-parent-id (references &optional n)
- "Return the last Message-ID in REFERENCES.
-If N, return the Nth ancestor instead."
- (when references
- (let ((ids (gnus-split-references references)))
- (car (last ids (or n 1))))))
-
(defun gnus-split-references (references)
"Return a list of Message-IDs in REFERENCES."
(let ((beg 0)
ids))
(nreverse ids)))
-(defun gnus-buffer-live-p (buffer)
+(defun 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)
"Say whether BUFFER is alive or not."
(and buffer
(get-buffer buffer)
(let* ((orig (point))
(end (window-end (get-buffer-window (current-buffer) t)))
(max 0))
- ;; Find the longest line currently displayed in the window.
- (goto-char (window-start))
- (while (and (not (eobp))
- (< (point) end))
- (end-of-line)
- (setq max (max max (current-column)))
- (forward-line 1))
- (goto-char orig)
- ;; Scroll horizontally to center (sort of) the point.
- (if (> max (window-width))
- (set-window-hscroll
- (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))
- max)))
+ (when end
+ ;; Find the longest line currently displayed in the window.
+ (goto-char (window-start))
+ (while (and (not (eobp))
+ (< (point) end))
+ (end-of-line)
+ (setq max (max max (current-column)))
+ (forward-line 1))
+ (goto-char orig)
+ ;; Scroll horizontally to center (sort of) the point.
+ (if (> max (window-width))
+ (set-window-hscroll
+ (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))
+ max))))
(defun gnus-read-event-char ()
"Get the next event."
(let ((event (read-event)))
+ ;; should be gnus-characterp, but this can't be called in XEmacs anyway
(cons (and (numberp event) event) event)))
(defun gnus-sortable-date (date)
Timezone package is used."
(condition-case ()
(progn
- (setq date (inline (timezone-fix-time
- date nil
+ (setq date (inline (timezone-fix-time
+ date nil
(aref (inline (timezone-parse-date date)) 4))))
(inline
(timezone-make-sortable-date
(timezone-make-time-string
(aref date 3) (aref date 4) (aref date 5))))))
(error "")))
-
+
(defun gnus-copy-file (file &optional to)
"Copy FILE to TO."
(interactive
(defun gnus-kill-all-overlays ()
"Delete all overlays in the current buffer."
- (when (fboundp 'overlay-lists)
- (let* ((overlayss (overlay-lists))
- (buffer-read-only nil)
- (overlays (nconc (car overlayss) (cdr overlayss))))
- (while overlays
- (delete-overlay (pop overlays))))))
+ (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-make-sort-function (funs)
"Return a composite sort condition based on the functions in FUNC."
- (cond
+ (cond
((not (listp funs)) funs)
((null funs) funs)
((cdr funs)
`(,(car funs) t1 t2)))
(defun gnus-turn-off-edit-menu (type)
- "Turn off edit meny in `gnus-TYPE-mode-map'."
+ "Turn off edit menu in `gnus-TYPE-mode-map'."
(define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
[menu-bar edit] 'undefined))
(defun gnus-prin1 (form)
"Use `prin1' on FORM in the current buffer.
-Bind `print-quoted' to t while printing."
- (let ((print-quoted t))
+Bind `print-quoted' and `print-readably' to t while printing."
+ (let ((print-quoted t)
+ (print-readably t)
+ print-level print-length)
(prin1 form (current-buffer))))
(defun gnus-prin1-to-string (form)
- "The same as `prin1', but but `print-quoted' to t."
- (prin1-to-string form))
+ "The same as `prin1', but bind `print-quoted' and `print-readably' to t."
+ (let ((print-quoted t)
+ (print-readably t))
+ (prin1-to-string form)))
(defun gnus-make-directory (directory)
"Make DIRECTORY (and all its parents) if it doesn't exist."
;; Write the buffer.
(write-region (point-min) (point-max) file nil 'quietly))
-(defmacro gnus-delete-assq (key list)
- `(let ((listval (eval ,list)))
- (setq ,list (delq (assq ,key listval) listval))))
-
-(defmacro gnus-delete-assoc (key list)
- `(let ((listval ,list))
- (setq ,list (delq (assoc ,key listval) listval))))
-
(defun gnus-delete-file (file)
"Delete FILE if it exists."
(when (file-exists-p file)
(delete-file file)))
+(defun gnus-strip-whitespace (string)
+ "Return STRING stripped of all whitespace."
+ (while (string-match "[\r\n\t ]+" string)
+ (setq string (replace-match "" t t string)))
+ string)
+
+(defun 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
+ (save-excursion
+ (save-restriction
+ (goto-char beg)
+ (while (re-search-forward "[ \t]*\n" end 'move)
+ (put-text-property beg (match-beginning 0) prop val)
+ (setq beg (point)))
+ (put-text-property beg (point) prop val)))))
;;; Protected and atomic operations. dmoore@ucsd.edu 21.11.1996
;;; The primary idea here is to try to protect internal datastructures
(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
are not changed if anything in FORMS signals an error or otherwise
(put 'gnus-atomic-progn-assign 'lisp-indent-function 1)
;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body))
-
(defmacro gnus-atomic-setq (&rest pairs)
"Similar to setq, except that the real symbols are only assigned when
there are no errors. And when the real symbols are assigned, they are
;(put 'gnus-atomic-setq 'edebug-form-spec '(body))
+;;; Functions for saving to babyl/mail files.
+
+(defvar rmail-default-rmail-file)
+(defun gnus-output-to-rmail (filename &optional ask)
+ "Append the current article to an Rmail file named FILENAME."
+ (require 'rmail)
+ ;; Most of these codes are borrowed from rmailout.el.
+ (setq filename (expand-file-name filename))
+ (setq rmail-default-rmail-file filename)
+ (let ((artbuf (current-buffer))
+ (tmpbuf (get-buffer-create " *Gnus-output*")))
+ (save-excursion
+ (or (get-file-buffer filename)
+ (file-exists-p filename)
+ (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)
+ (let ((require-final-newline nil))
+ (gnus-write-buffer filename)))
+ (kill-buffer file-buffer))
+ (error "Output file does not exist")))
+ (set-buffer tmpbuf)
+ (erase-buffer)
+ (insert-buffer-substring artbuf)
+ (gnus-convert-article-to-rmail)
+ ;; 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)
+ ;; 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.
+ (when msg
+ (widen)
+ (narrow-to-region (point-max) (point-max)))
+ (insert-buffer-substring tmpbuf)
+ (when msg
+ (goto-char (point-min))
+ (widen)
+ (search-backward "\^_")
+ (narrow-to-region (point) (point-max))
+ (goto-char (1+ (point-min)))
+ (rmail-count-new-messages t)
+ (rmail-show-message msg))
+ (save-buffer)))))
+ (kill-buffer tmpbuf)))
+
+(defun gnus-output-to-mail (filename &optional ask)
+ "Append the current article to a mail file named FILENAME."
+ (setq filename (expand-file-name filename))
+ (let ((artbuf (current-buffer))
+ (tmpbuf (get-buffer-create " *Gnus-output*")))
+ (save-excursion
+ ;; Create the file, if it doesn't exist.
+ (when (and (not (get-file-buffer filename))
+ (not (file-exists-p filename)))
+ (if (or (not ask)
+ (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)
+ (let ((require-final-newline nil))
+ (gnus-write-buffer filename)))
+ (kill-buffer file-buffer))
+ (error "Output file does not exist")))
+ (set-buffer tmpbuf)
+ (erase-buffer)
+ (insert-buffer-substring artbuf)
+ (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 ((buffer-read-only nil))
+ (save-excursion
+ (goto-char (point-max))
+ (forward-char -2)
+ (unless (looking-at "\n\n")
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))
+ (insert "\n"))
+ (goto-char (point-max))
+ (append-to-file (point-min) (point-max) filename)))
+ ;; File has been visited, in buffer OUTBUF.
+ (set-buffer outbuf)
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (unless (eobp)
+ (insert "\n"))
+ (insert "\n")
+ (insert-buffer-substring tmpbuf)))))
+ (kill-buffer tmpbuf)))
+
+(defun gnus-convert-article-to-rmail ()
+ "Convert article in current buffer to Rmail message format."
+ (let ((buffer-read-only nil))
+ ;; Convert article directly into Babyl format.
+ (goto-char (point-min))
+ (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+ (while (search-forward "\n\^_" nil t) ;single char
+ (replace-match "\n^_" t t)) ;2 chars: "^" and "_"
+ (goto-char (point-max))
+ (insert "\^_")))
+
+(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)
+ (myarg arg))
+ (while myfuns
+ (setq arg (funcall (pop myfuns) arg)))
+ arg))
+
+(defun gnus-run-hooks (&rest funcs)
+ "Does the same as `run-hooks', but saves excursion."
+ (let ((buf (current-buffer)))
+ (unwind-protect
+ (apply 'run-hooks funcs)
+ (set-buffer buf))))
+
+;;;
+;;; .netrc and .authinforc parsing
+;;;
+
+(defvar gnus-netrc-syntax-table
+ (let ((table (copy-syntax-table text-mode-syntax-table)))
+ (modify-syntax-entry ?- "w" table)
+ (modify-syntax-entry ?_ "w" table)
+ (modify-syntax-entry ?! "w" table)
+ (modify-syntax-entry ?. "w" table)
+ (modify-syntax-entry ?, "w" table)
+ (modify-syntax-entry ?: "w" table)
+ (modify-syntax-entry ?\; "w" table)
+ (modify-syntax-entry ?% "w" table)
+ (modify-syntax-entry ?) "w" table)
+ (modify-syntax-entry ?( "w" table)
+ table)
+ "Syntax table when parsing .netrc files.")
+
+(defun gnus-parse-netrc (file)
+ "Parse FILE and return an list of all entries in the file."
+ (if (not (file-exists-p file))
+ ()
+ (save-excursion
+ (let ((tokens '("machine" "default" "login"
+ "password" "account" "macdef" "force"))
+ alist elem result pair)
+ (nnheader-set-temp-buffer " *netrc*")
+ (set-syntax-table gnus-netrc-syntax-table)
+ (insert-file-contents file)
+ (goto-char (point-min))
+ ;; Go through the file, line by line.
+ (while (not (eobp))
+ (narrow-to-region (point) (gnus-point-at-eol))
+ ;; For each line, get the tokens and values.
+ (while (not (eobp))
+ (skip-chars-forward "\t ")
+ (unless (eobp)
+ (setq elem (buffer-substring
+ (point) (progn (forward-sexp 1) (point))))
+ (cond
+ ((equal elem "macdef")
+ ;; We skip past the macro definition.
+ (widen)
+ (while (and (zerop (forward-line 1))
+ (looking-at "$")))
+ (narrow-to-region (point) (point)))
+ ((member elem tokens)
+ ;; Tokens that don't have a following value are ignored.
+ (when (and pair (cdr pair))
+ (push pair alist))
+ (setq pair (list elem)))
+ (t
+ ;; Values that haven't got a preceding token are ignored.
+ (when pair
+ (setcdr pair elem)
+ (push pair alist)
+ (setq pair nil))))))
+ (push alist result)
+ (setq alist nil
+ pair nil)
+ (widen)
+ (forward-line 1))
+ result))))
+
+(defun gnus-netrc-machine (list machine)
+ "Return the netrc values from LIST for MACHINE."
+ (while (and list
+ (not (equal (cdr (assoc "machine" (car list))) machine)))
+ (pop list))
+ (when list
+ (car list)))
+
+(defun gnus-netrc-get (alist type)
+ "Return the value of token TYPE from ALIST."
+ (cdr (assoc type alist)))
+
+;;; Various
+
+(defun gnus-alive-p ()
+ "Say whether Gnus is running or not."
+ (and (boundp 'gnus-group-buffer)
+ (get-buffer gnus-group-buffer)
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (eq major-mode 'gnus-group-mode))))
+
+(defun gnus-remove-duplicates (list)
+ (let (new (tail list))
+ (while tail
+ (or (member (car tail) new)
+ (setq new (cons (car tail) new)))
+ (setq tail (cdr tail)))
+ (nreverse new)))
+
+(defun gnus-delete-if (predicate list)
+ "Delete elements from LIST that satisfy PREDICATE."
+ (let (out)
+ (while list
+ (when (funcall predicate (car list))
+ (push (car list) out))
+ (pop list))
+ (nreverse out)))
+
+(defun gnus-delete-alist (key alist)
+ "Delete all entries in ALIST that have a key eq to KEY."
+ (let (entry)
+ (while (setq entry (assq key alist))
+ (setq alist (delq entry alist)))
+ alist))
+
+(defmacro gnus-pull (key alist)
+ "Modify ALIST to be without KEY."
+ (unless (symbolp alist)
+ (error "Not a symbol: %s" alist))
+ `(setq ,alist (delq (assq ,key ,alist) ,alist)))
(provide 'gnus-util)