;;; gnus-util.el --- utility functions for Gnus
-;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;;; 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 '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."
(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)))
(defun gnus-byte-code (func)
"Return a form that can be `eval'ed based on FUNC."
- (let ((fval (symbol-function func)))
- (if (compiled-function-p fval)
+ (let ((fval (indirect-function func)))
+ (if (byte-code-function-p fval)
(let ((flist (append fval nil)))
(setcar flist 'byte-code)
flist)
(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."
If N, return the Nth ancestor instead."
(when references
(let ((ids (inline (gnus-split-references references))))
- (car (last ids (or n 1))))))
+ (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)
+ (buffer-name (get-buffer buffer))))
(defun gnus-horizontal-recenter ()
"Recenter the current buffer horizontally."
(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-prin1 (form)
"Use `prin1' on FORM in the current buffer.
-Bind `print-quoted' to t while printing."
+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."
- (let ((print-quoted t))
+ "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)
(narrow-to-region (point) (point-max))
(goto-char (1+ (point-min)))
(rmail-count-new-messages t)
- (rmail-show-message msg))))))
+ (rmail-show-message msg))
+ (save-buffer)))))
(kill-buffer tmpbuf)))
(defun gnus-output-to-mail (filename &optional ask)
(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"))
+ 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)))
+
(provide 'gnus-util)
;;; gnus-util.el ends here
projects / gnus / blobdiff