X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=174f2fba3b3b001a2bfa90b5228d705b6ab26211;hb=55f610143f1f63a6cc448649d02a51a0b99c04f1;hp=61975ef93d76a33d2971f3f6fe001b7931f2b675;hpb=dfe2be6a7d23a287ecb44e495675d8c83dc44c8c;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 61975ef93..174f2fba3 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,5 +1,6 @@ ;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -31,12 +32,15 @@ ;;; Code: (require 'custom) -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + ;; Fixme: this should be a gnus variable, not nnmail-. + (defvar nnmail-pathname-coding-system)) (require 'nnheader) -(require 'message) (require 'time-date) (eval-and-compile + (autoload 'message-fetch-field "message") (autoload 'rmail-insert-rmail-file-header "rmail") (autoload 'rmail-count-new-messages "rmail") (autoload 'rmail-show-message "rmail")) @@ -102,15 +106,15 @@ (when (gnus-buffer-exists-p buf) (kill-buffer buf)))) -(fset 'gnus-point-at-bol - (if (fboundp 'point-at-bol) - 'point-at-bol - 'line-beginning-position)) +(defalias 'gnus-point-at-bol + (if (fboundp 'point-at-bol) + 'point-at-bol + 'line-beginning-position)) -(fset 'gnus-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position)) +(defalias 'gnus-point-at-eol + (if (fboundp 'point-at-eol) + 'point-at-eol + 'line-end-position)) (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -164,8 +168,8 @@ (and (string-match "(.*" from) (setq name (substring from (1+ (match-beginning 0)) (match-end 0))))) - ;; Fix by Hallvard B Furuseth . - (list (or name from) (or address from)))) + (list (if (string= name "") nil name) (or address from)))) + (defun gnus-fetch-field (field) "Return the value of the header FIELD of current article." @@ -189,22 +193,17 @@ (delete-char 1)) (goto-char (next-single-property-change (point) prop nil (point-max)))))) +(require 'nnheader) (defun gnus-newsgroup-directory-form (newsgroup) "Make hierarchical directory name from NEWSGROUP name." - (let ((newsgroup (gnus-newsgroup-savable-name newsgroup)) - (len (length newsgroup)) - idx) - ;; If this is a foreign group, we don't want to translate the - ;; entire name. - (if (setq idx (string-match ":" newsgroup)) - (aset newsgroup idx ?/) - (setq idx 0)) - ;; Replace all occurrences of `.' with `/'. - (while (< idx len) - (when (= (aref newsgroup idx) ?.) - (aset newsgroup idx ?/)) - (setq idx (1+ idx))) - newsgroup)) + (let* ((newsgroup (gnus-newsgroup-savable-name newsgroup)) + (idx (string-match ":" newsgroup))) + (concat + (if idx (substring newsgroup 0 idx)) + (if idx "/") + (nnheader-replace-chars-in-string + (if idx (substring newsgroup (1+ idx)) newsgroup) + ?. ?/)))) (defun gnus-newsgroup-savable-name (group) ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group) @@ -291,7 +290,9 @@ (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." - (format-time-string "%d-%b" (safe-date-to-time messy-date))) + (condition-case () + (format-time-string "%d-%b" (safe-date-to-time messy-date)) + (error " - "))) (defmacro gnus-date-get-time (date) "Convert DATE string to Emacs time. @@ -308,11 +309,11 @@ Cache the result as a text property stored in DATE." time))))) (defsubst gnus-time-iso8601 (time) - "Return a string of TIME in YYMMDDTHHMMSS format." + "Return a string of TIME in YYYYMMDDTHHMMSS format." (format-time-string "%Y%m%dT%H%M%S" time)) (defun gnus-date-iso8601 (date) - "Convert the DATE to YYMMDDTHHMMSS." + "Convert the DATE to YYYYMMDDTHHMMSS." (condition-case () (gnus-time-iso8601 (gnus-date-get-time date)) (error ""))) @@ -381,7 +382,7 @@ jabbering all the time." "Return a list of Message-IDs in REFERENCES." (let ((beg 0) ids) - (while (string-match "<[^>]+>" references beg) + (while (string-match "<[^> \t]+>" references beg) (push (substring references (match-beginning 0) (setq beg (match-end 0))) ids)) (nreverse ids))) @@ -448,14 +449,6 @@ If N, return the Nth ancestor instead." (file-name-nondirectory file)))) (copy-file file to)) -(defun gnus-kill-all-overlays () - "Delete all overlays in the current buffer." - (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-set-work-buffer () @@ -504,6 +497,7 @@ If N, return the Nth ancestor instead." first 't2 last 't1)) ((gnus-functionp function) + ;; Do nothing. ) (t (error "Invalid sort spec: %s" function)))) @@ -535,17 +529,20 @@ Bind `print-quoted' and `print-readably' to t while printing." (defun gnus-make-directory (directory) "Make DIRECTORY (and all its parents) if it doesn't exist." - (when (and directory - (not (file-exists-p directory))) - (make-directory directory t)) + (require 'nnmail) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (when (and directory + (not (file-exists-p directory))) + (make-directory directory t))) t) (defun gnus-write-buffer (file) "Write the current buffer's contents to FILE." ;; Make sure the directory exists. (gnus-make-directory (file-name-directory file)) - ;; Write the buffer. - (write-region (point-min) (point-max) file nil 'quietly)) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + ;; Write the buffer. + (write-region (point-min) (point-max) file nil 'quietly))) (defun gnus-delete-file (file) "Delete FILE if it exists." @@ -564,7 +561,7 @@ Bind `print-quoted' and `print-readably' to t while printing." (save-excursion (save-restriction (goto-char beg) - (while (re-search-forward "[ \t]*\n" end 'move) + (while (re-search-forward gnus-emphasize-whitespace-regexp end 'move) (gnus-put-text-property beg (match-beginning 0) prop val) (setq beg (point))) (gnus-put-text-property beg (point) prop val))))) @@ -677,7 +674,8 @@ with potentially long computations." (save-excursion (set-buffer file-buffer) (rmail-insert-rmail-file-header) - (let ((require-final-newline nil)) + (let ((require-final-newline nil) + (coding-system-for-write mm-text-coding-system)) (gnus-write-buffer filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) @@ -688,7 +686,7 @@ with potentially long computations." ;; 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) + (mm-append-to-file (point-min) (point-max) filename) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil) @@ -728,7 +726,8 @@ with potentially long computations." (let ((file-buffer (create-file-buffer filename))) (save-excursion (set-buffer file-buffer) - (let ((require-final-newline nil)) + (let ((require-final-newline nil) + (coding-system-for-write mm-text-coding-system)) (gnus-write-buffer filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) @@ -756,7 +755,7 @@ with potentially long computations." (insert "\n")) (insert "\n")) (goto-char (point-max)) - (append-to-file (point-min) (point-max) filename))) + (mm-append-to-file (point-min) (point-max) filename))) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil)) @@ -802,7 +801,8 @@ ARG is passed to the first function." (when (file-exists-p file) (with-temp-buffer (let ((tokens '("machine" "default" "login" - "password" "account" "macdef" "force")) + "password" "account" "macdef" "force" + "port")) alist elem result pair) (insert-file-contents file) (goto-char (point-min)) @@ -816,9 +816,12 @@ ARG is passed to the first function." (if (eq (char-after) ?#) (goto-char (point-max)) (unless (eobp) - (setq elem (buffer-substring - (point) (progn (skip-chars-forward "^\t ") - (point)))) + (setq elem + (if (= (following-char) ?\") + (read (current-buffer)) + (buffer-substring + (point) (progn (skip-chars-forward "^\t ") + (point))))) (cond ((equal elem "macdef") ;; We skip past the macro definition. @@ -847,16 +850,30 @@ ARG is passed to the first function." (forward-line 1)) (nreverse result))))) -(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))) +(defun gnus-netrc-machine (list machine &optional port defaultport) + "Return the netrc values from LIST for MACHINE or for the default entry. +If PORT specified, only return entries with matching port tokens. +Entries without port tokens default to DEFAULTPORT." + (let ((rest list) + result) + (while list + (when (equal (cdr (assoc "machine" (car list))) machine) + (push (car list) result)) (pop list)) - (car (or list - (progn (while (and rest (not (assoc "default" (car rest)))) - (pop rest)) - rest))))) + (unless result + ;; No machine name matches, so we look for default entries. + (while rest + (when (assoc "default" (car rest)) + (push (car rest) result)) + (pop rest))) + (when result + (setq result (nreverse result)) + (while (and result + (not (equal (or port defaultport "nntp") + (or (gnus-netrc-get (car result) "port") + defaultport "nntp")))) + (pop result)) + (car result)))) (defun gnus-netrc-get (alist type) "Return the value of token TYPE from ALIST." @@ -890,12 +907,15 @@ ARG is passed to the first function." (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)) +(if (fboundp 'assq-delete-all) + (defalias 'gnus-delete-alist 'assq-delete-all) + (defun gnus-delete-alist (key alist) + "Delete from ALIST all elements whose car is KEY. +Return the modified alist." + (let (entry) + (while (setq entry (assq key alist)) + (setq alist (delq entry alist))) + alist))) (defmacro gnus-pull (key alist &optional assoc-p) "Modify ALIST to be without KEY." @@ -936,15 +956,72 @@ ARG is passed to the first function." (throw 'found nil))) t)) -(defun gnus-write-active-file (file hashtb) - (with-temp-file file - (mapatoms - (lambda (sym) - (when (and sym (boundp sym)) - (insert (format "%s %d %d y\n" - (symbol-name sym) (cdr (symbol-value sym)) - (car (symbol-value sym)))))) - hashtb))) +(defun gnus-write-active-file (file hashtb &optional full-names) + (let ((coding-system-for-write nnmail-active-file-coding-system)) + (with-temp-file file + (mapatoms + (lambda (sym) + (when (and sym + (boundp sym) + (symbol-value sym)) + (insert (format "%S %d %d y\n" + (if full-names + sym + (intern (gnus-group-real-name (symbol-name sym)))) + (or (cdr (symbol-value sym)) + (car (symbol-value sym))) + (car (symbol-value sym)))))) + hashtb) + (goto-char (point-max)) + (while (search-backward "\\." nil t) + (delete-char 1))))) + +(if (fboundp 'union) + (defalias 'gnus-union 'union) + (defun gnus-union (l1 l2) + "Set union of lists L1 and L2." + (cond ((null l1) l2) + ((null l2) l1) + ((equal l1 l2) l1) + (t + (or (>= (length l1) (length l2)) + (setq l1 (prog1 l2 (setq l2 l1)))) + (while l2 + (or (member (car l2) l1) + (push (car l2) l1)) + (pop l2)) + l1)))) + +(defun gnus-add-text-properties-when + (property value start end properties &optional object) + "Like `gnus-add-text-properties', only applied on where PROPERTY is VALUE." + (let (point) + (while (and start + (< start end) ;; XEmacs will loop for every when start=end. + (setq point (text-property-not-all start end property value))) + (gnus-add-text-properties start point properties object) + (setq start (text-property-any point end property value))) + (if start + (gnus-add-text-properties start end properties object)))) + +(defun gnus-remove-text-properties-when + (property value start end properties &optional object) + "Like `remove-text-properties', only applied on where PROPERTY is VALUE." + (let (point) + (while (and start + (< start end) + (setq point (text-property-not-all start end property value))) + (remove-text-properties start point properties object) + (setq start (text-property-any point end property value))) + (if start + (remove-text-properties start end properties object)) + t)) + +(defun gnus-string-equal (x y) + "Like `string-equal', except it compares case-insensitively." + (and (= (length x) (length y)) + (or (string-equal x y) + (string-equal (downcase x) (downcase y))))) (provide 'gnus-util)