X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=856b7a2e5f6037ea60cb673d5f252c48f844b90f;hb=754a007c9c67f3506008dab6e7e8943eb51848f2;hp=8c96631cb4f0b7523ce090bc50e0c2d9636a05fb;hpb=465f723d3d71a1f7ff25de35a661abb4678176ed;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 8c96631cb..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 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -31,26 +31,39 @@ ;;; 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) + (symbol-value 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)) @@ -62,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)) @@ -79,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))) @@ -95,21 +106,25 @@ (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." @@ -130,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) @@ -146,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))) @@ -160,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)) @@ -240,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." @@ -306,7 +320,7 @@ (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))) @@ -361,7 +375,7 @@ Cache the result as a text property stored in DATE." (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" (condition-case () @@ -378,18 +392,22 @@ Cache the result as a text property stored in DATE." (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. @@ -424,13 +442,6 @@ jabbering all the time." (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) @@ -440,7 +451,16 @@ If N, return the Nth ancestor instead." 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) @@ -463,7 +483,7 @@ If N, return the Nth ancestor instead." (goto-char orig) ;; Scroll horizontally to center (sort of) the point. (if (> max (window-width)) - (set-window-hscroll + (set-window-hscroll (get-buffer-window (current-buffer) t) (min (- (current-column) (/ (window-width) 3)) (+ 2 (- max (window-width))))) @@ -473,6 +493,7 @@ If N, return the Nth ancestor instead." (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) @@ -480,8 +501,8 @@ If N, return the Nth ancestor instead." 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 @@ -490,7 +511,7 @@ Timezone package is used." (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 @@ -505,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*") @@ -533,7 +553,7 @@ Timezone package is used." (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) @@ -551,23 +571,28 @@ Timezone package is used." `(,(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." - (when (not (file-exists-p directory)) + (when (and directory + (not (file-exists-p directory))) (make-directory directory t)) t) @@ -591,6 +616,310 @@ Bind `print-quoted' to t while printing." (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 +;;; from becoming corrupted when the user hits C-g, or if a hook or +;;; similar blows up. Often in Gnus multiple tables/lists need to be +;;; updated at the same time, or information can be lost. + +(defvar gnus-atomic-be-safe t + "If t, certain operations will be protected from interruption by C-g.") + +(defmacro gnus-atomic-progn (&rest forms) + "Evaluate FORMS atomically, which means to protect the evaluation +from being interrupted by the user. An error from the forms themselves +will return without finishing the operation. Since interrupts from +the user are disabled, it is recommended that only the most minimal +operations are performed by FORMS. If you wish to assign many +complicated values atomically, compute the results into temporary +variables and then do only the assignment atomically." + `(let ((inhibit-quit gnus-atomic-be-safe)) + ,@forms)) + +(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 +non-locally exits. The variables listed in PROTECT are updated atomically. +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 +non-local exit, it will still be unbound." + (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol + (concat (symbol-name x) + "-tmp")) + x)) + protect)) + (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x))) + temp-sym-map)) + (temp-sym-let (mapcar (lambda (x) (list (car x) + `(and (boundp ',(cadr x)) + ,(cadr x)))) + temp-sym-map)) + (sym-temp-let sym-temp-map) + (temp-sym-assign (apply 'append temp-sym-map)) + (sym-temp-assign (apply 'append sym-temp-map)) + (result (make-symbol "result-tmp"))) + `(let (,@temp-sym-let + ,result) + (let ,sym-temp-let + (setq ,result (progn ,@forms)) + (setq ,@temp-sym-assign)) + (let ((inhibit-quit gnus-atomic-be-safe)) + (setq ,@sym-temp-assign)) + ,result))) + +(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 +done so atomically. If other variables might be changed via side-effect, +see gnus-atomic-progn-assign. It is safe to use gnus-atomic-setq +with potentially long computations." + (let ((tpairs pairs) + syms) + (while tpairs + (push (car tpairs) syms) + (setq tpairs (cddr tpairs))) + `(gnus-atomic-progn-assign ,syms + (setq ,@pairs)))) + +;(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")) + 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