X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=cba9137d8bee941b4b324b0867fa0b64f45184dc;hb=350392837795fde1f53e87f0f9402224a78c122b;hp=8cca4a98094a96021bc5c6118357f451db4880d9;hpb=4131ea9653854d4dd1b73263c52b6c0962ab74de;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 8cca4a9..cba9137 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,8 +1,8 @@ -;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;;; gnus-util.el --- utility functions for Semi-gnus +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; Author: Lars Magne Ingebrigtsen +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -35,9 +35,15 @@ (require 'nnheader) (require 'timezone) (require 'message) +(eval-when-compile + (when (locate-library "rmail") + (require 'rmail))) (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,10 +78,10 @@ (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) +;; Avoid byte-compile warning. +;; In Mule, this function will be redefined to `truncate-string', +;; which takes 3 or 4 args. +(defun gnus-truncate-string (str width &rest ignore) (substring str 0 width)) ;; Added by Geoffrey T. Dairiki . A safe way @@ -161,7 +167,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))) @@ -175,7 +180,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)) @@ -342,12 +346,11 @@ (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 () @@ -378,10 +381,10 @@ Cache the result as a text property stored in DATE." "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) @@ -475,22 +478,23 @@ If N, return the Nth ancestor instead." (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." @@ -542,7 +546,7 @@ Timezone package is used." (progn (set-buffer gnus-work-buffer) (erase-buffer)) - (set-buffer (get-buffer-create gnus-work-buffer)) + (set-buffer (gnus-get-buffer-create gnus-work-buffer)) (kill-all-local-variables) (buffer-disable-undo (current-buffer)))) @@ -582,6 +586,7 @@ Timezone package is used." Bind `print-quoted' and `print-readably' to t while printing." (let ((print-quoted t) (print-readably t) + (print-escape-multibyte nil) print-level print-length) (prin1 form (current-buffer)))) @@ -605,13 +610,20 @@ Bind `print-quoted' and `print-readably' to t while printing." ;; 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)))) +(defun gnus-write-buffer-as-binary (file) + "Write the current buffer's contents to FILE without code conversion." + ;; Make sure the directory exists. + (gnus-make-directory (file-name-directory file)) + ;; Write the buffer. + (write-region-as-binary (point-min) (point-max) file nil 'quietly)) -(defmacro gnus-delete-assoc (key list) - `(let ((listval ,list)) - (setq ,list (delq (assoc ,key listval) listval)))) +(defun gnus-write-buffer-as-coding-system (coding-system file) + "Write the current buffer's contents to FILE with code conversion." + ;; Make sure the directory exists. + (gnus-make-directory (file-name-directory file)) + ;; Write the buffer. + (write-region-as-coding-system + coding-system (point-min) (point-max) file nil 'quietly)) (defun gnus-delete-file (file) "Delete FILE if it exists." @@ -631,10 +643,22 @@ Bind `print-quoted' and `print-readably' to t while printing." (save-restriction (goto-char beg) (while (re-search-forward "[ \t]*\n" end 'move) - (put-text-property beg (match-beginning 0) prop val) + (gnus-put-text-property beg (match-beginning 0) prop val) (setq beg (point))) - (put-text-property beg (point) prop val))))) - + (gnus-put-text-property beg (point) prop val))))) + +(defun gnus-put-text-property-excluding-characters-with-faces (beg end + prop val) + "The same as `put-text-property', but don't put props on characters with the `gnus-face' property." + (let ((b beg)) + (while (/= b end) + (when (get-text-property b 'gnus-face) + (setq b (next-single-property-change b 'gnus-face nil end))) + (when (/= b end) + (gnus-put-text-property + b (setq b (next-single-property-change b 'gnus-face nil end)) + 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 @@ -756,11 +780,15 @@ with potentially long computations." (when msg (goto-char (point-min)) (widen) - (search-backward "\^_") - (narrow-to-region (point) (point-max)) - (goto-char (1+ (point-min))) + (search-backward "\n\^_") + (narrow-to-region (point) (point-max)) + (rmail-count-new-messages t) + (when (rmail-summary-exists) + (rmail-select-summary + (rmail-update-summary))) (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) @@ -779,7 +807,7 @@ with potentially long computations." (save-excursion (set-buffer file-buffer) (let ((require-final-newline nil)) - (gnus-write-buffer filename))) + (gnus-write-buffer-as-binary filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) (set-buffer tmpbuf) @@ -806,7 +834,8 @@ with potentially long computations." (insert "\n")) (insert "\n")) (goto-char (point-max)) - (append-to-file (point-min) (point-max) filename))) + (write-region-as-binary (point-min) (point-max) + filename 'append))) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil)) @@ -831,12 +860,152 @@ with potentially long computations." (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)) + (let ((myfuns funs)) (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) + (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*") + (unwind-protect + (progn + (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, + ;; except "default". + (when (and pair (or (cdr pair) + (equal (car pair) "default"))) + (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)))))) + (if alist + (push (nreverse alist) result)) + (setq alist nil + pair nil) + (widen) + (forward-line 1)) + (nreverse result)) + (kill-buffer " *netrc*")))))) + +(defun gnus-netrc-machine (list machine) + "Return the netrc values from LIST for MACHINE or for the default entry." + (let ((rest list)) + (while (and list + (not (equal (cdr (assoc "machine" (car list))) machine))) + (pop list)) + (car (or list + (progn (while (and rest (not (assoc "default" (car rest)))) + (pop rest)) + rest))))) + +(defun gnus-netrc-get (alist type) + "Return the value of token TYPE from ALIST." + (cdr (assoc type alist))) + +;;; Various + +(defvar gnus-group-buffer) ; Compiler directive +(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 + (unless (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))) + +(defun gnus-globalify-regexp (re) + "Returns a regexp that matches a whole line, iff RE matches a part of it." + (concat (unless (string-match "^\\^" re) "^.*") + re + (unless (string-match "\\$$" re) ".*$"))) + (provide 'gnus-util) ;;; gnus-util.el ends here