X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=856b7a2e5f6037ea60cb673d5f252c48f844b90f;hb=754a007c9c67f3506008dab6e7e8943eb51848f2;hp=bb13125a959730d8ac3f3760daaa8c61ac6266c9;hpb=b28454eed83f245c4160228b076134ce930b320a;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index bb13125a9..856b7a2e5 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,5 +1,5 @@ ;;; 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 ;; Keywords: news @@ -31,13 +31,16 @@ ;;; 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." @@ -72,9 +75,6 @@ (set symbol nil)) symbol)) -;; modified by MORIOKA Tomohiko -;; function `substring' might cut on a middle of multi-octet -;; character. (defun gnus-truncate-string (str width) (substring str 0 width)) @@ -89,7 +89,8 @@ (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))) @@ -144,7 +145,7 @@ (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) @@ -160,7 +161,6 @@ (setq address (substring from (match-beginning 0) (match-end 0)))) ;; Then we check whether the "name
" format is used. (and address - ;; Fix by MORIOKA Tomohiko ;; Linear white space is not required. (string-match (concat "[ \t]*<" (regexp-quote address) ">") from) (and (setq name (substring from 0 (match-beginning 0))) @@ -174,7 +174,6 @@ (1- (match-end 0))))) (and (string-match "()" from) (setq name address)) - ;; Fix by MORIOKA Tomohiko . ;; XOVER might not support folded From headers. (and (string-match "(.*" from) (setq name (substring from (1+ (match-beginning 0)) @@ -254,7 +253,8 @@ (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." @@ -456,9 +456,11 @@ jabbering all the time." 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)))) -(defun gnus-buffer-live-p (buffer) +(defsubst gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." (and buffer (get-buffer buffer) @@ -524,12 +526,11 @@ Timezone package is used." (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*") @@ -576,14 +577,16 @@ Timezone package is used." (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) @@ -755,7 +758,8 @@ with potentially long computations." (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) @@ -823,6 +827,99 @@ with potentially long computations." (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