X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=ec4f4900844a3987e7779fe57970b1f5d3483df7;hb=1e294f2ccb951a4215cd3354cef17e0305433db4;hp=6011354f27f81da4fb067856ce1132e09ffd9d4d;hpb=d7dfde895896ad0f0cab555a8a4c411f48b28966;p=gnus diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 6011354f2..ec4f49008 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,16 +32,35 @@ ;;; 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")) +(eval-and-compile + (cond + ((fboundp 'replace-in-string) + (defalias 'gnus-replace-in-string 'replace-in-string)) + ((fboundp 'replace-regexp-in-string) + (defun gnus-replace-in-string (string regexp newtext &optional literal) + (replace-regexp-in-string regexp newtext string nil literal))) + (t + (defun gnus-replace-in-string (string regexp newtext &optional literal) + (let ((start 0) tail) + (while (string-match regexp string start) + (setq tail (- (length string) (match-end 0))) + (setq string (replace-match newtext t t string)) + (setq start (- (length string) tail)))) + string)))) + (defun gnus-boundp (variable) "Return non-nil if VARIABLE is bound and non-nil." (and (boundp variable) @@ -49,20 +69,20 @@ (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 - (progn - (select-window ,w) - (set-buffer (window-buffer ,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)) @@ -102,15 +122,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 +184,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." @@ -178,7 +198,18 @@ (defun gnus-goto-colon () (beginning-of-line) - (search-forward ":" (gnus-point-at-eol) t)) + (let ((eol (gnus-point-at-eol))) + (goto-char (or (text-property-any (point) eol 'gnus-position t) + (search-forward ":" eol t) + (point))))) + +(defun gnus-decode-newsgroups (newsgroups group &optional method) + (let ((method (or method (gnus-find-method-for-group group)))) + (mapconcat (lambda (group) + (gnus-group-name-decode group (gnus-group-name-charset + method group))) + (message-tokenize-header newsgroups) + ","))) (defun gnus-remove-text-with-property (prop) "Delete all text in the current buffer with text property PROP." @@ -189,22 +220,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) @@ -289,6 +315,70 @@ (yes-or-no-p prompt) (message ""))) +;; By Frank Schmitt . Allows to have +;; age-depending date representations. (e.g. just the time if it's +;; from today, the day of the week if it's within the last 7 days and +;; the full date if it's older) +(defun gnus-seconds-today () + "Returns the number of seconds passed today" + (let ((now (decode-time (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600)))) + +(defun gnus-seconds-month () + "Returns the number of seconds passed this month" + (let ((now (decode-time (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (* (- (car (nthcdr 3 now)) 1) 3600 24)))) + +(defun gnus-seconds-year () + "Returns the number of seconds passed this year" + (let ((now (decode-time (current-time))) + (days (format-time-string "%j" (current-time)))) + (+ (car now) (* (car (cdr now)) 60) (* (car (nthcdr 2 now)) 3600) + (* (- (string-to-number days) 1) 3600 24)))) + +(defvar gnus-user-date-format-alist + '(((gnus-seconds-today) . "%k:%M") + (604800 . "%a %k:%M") ;;that's one week + ((gnus-seconds-month) . "%a %d") + ((gnus-seconds-year) . "%b %d") + (t . "%b %m '%y")) ;;this one is used when no other does match + "Alist of time in seconds and format specification used to display dates not older. +The first element must be a number or a function returning a +number. The second element is a format-specification as described in +the documentation for format-time-string. The list must be ordered +smallest number up. When there is an element, which is not a number, +the corresponding format-specification will be used, disregarding any +following elements. You can use the functions gnus-seconds-today, +gnus-seconds-month, gnus-seconds-year which will return the number of +seconds which passed today/this month/this year.") + +(defun gnus-user-date (messy-date) + "Format the messy-date acording to gnus-user-date-format-alist. +Returns \" ? \" if there's bad input or if an other error occurs. +Input should look like this: \"Sun, 14 Oct 2001 13:34:39 +0200\"." + (condition-case () + (let* ((messy-date (safe-date-to-time messy-date)) + (now (current-time)) + ;;If we don't find something suitable we'll use this one + (my-format "%b %m '%y") + (high (lsh (- (car now) (car messy-date)) 16))) + (if (and (> high -1) (= (logand high 65535) 0)) + ;;overflow and bad input + (let* ((difference (+ high (- (car (cdr now)) + (car (cdr messy-date))))) + (templist gnus-user-date-format-alist) + (top (eval (caar templist)))) + (while (if (numberp top) (< top difference) (not top)) + (progn + (setq templist (cdr templist)) + (setq top (eval (caar templist))))) + (if (stringp (cdr (car templist))) + (setq my-format (cdr (car templist)))))) + (format-time-string (eval my-format) messy-date)) + (error " ? "))) +;;end of Frank's code + (defun gnus-dd-mmm (messy-date) "Return a string like DD-MMM from a big messy string." (condition-case () @@ -310,24 +400,18 @@ 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 ""))) (defun gnus-mode-string-quote (string) "Quote all \"%\"'s in STRING." - (save-excursion - (gnus-set-work-buffer) - (insert string) - (goto-char (point-min)) - (while (search-forward "%" nil t) - (insert "%")) - (buffer-string))) + (gnus-replace-in-string string "%" "%%")) ;; Make a hash table (default and minimum size is 256). ;; Optional argument HASHSIZE specifies the table size. @@ -383,7 +467,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))) @@ -397,7 +481,7 @@ If N, return the Nth ancestor instead." (setq ids (cdr ids))) (car ids)))) -(defsubst gnus-buffer-live-p (buffer) +(defun gnus-buffer-live-p (buffer) "Say whether BUFFER is alive or not." (and buffer (get-buffer buffer) @@ -450,14 +534,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 () @@ -487,8 +563,9 @@ If N, return the Nth ancestor instead." ;; A list of functions. ((or (cdr funs) (listp (car funs))) - `(lambda (t1 t2) - ,(gnus-make-sort-function-1 (reverse funs)))) + (gnus-byte-compile + `(lambda (t1 t2) + ,(gnus-make-sort-function-1 (reverse funs))))) ;; A list containing just one function. (t (car funs)))) @@ -506,6 +583,7 @@ If N, return the Nth ancestor instead." first 't2 last 't1)) ((gnus-functionp function) + ;; Do nothing. ) (t (error "Invalid sort spec: %s" function)))) @@ -537,17 +615,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." @@ -566,7 +647,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))))) @@ -679,7 +760,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"))) @@ -690,7 +772,8 @@ 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) - (mm-append-to-file (point-min) (point-max) filename) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (mm-append-to-file (point-min) (point-max) filename)) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil) @@ -704,10 +787,10 @@ with potentially long computations." (when msg (goto-char (point-min)) (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max)) - (rmail-count-new-messages t) - (when (rmail-summary-exists) + (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) @@ -730,7 +813,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"))) @@ -758,7 +842,8 @@ with potentially long computations." (insert "\n")) (insert "\n")) (goto-char (point-max)) - (mm-append-to-file (point-min) (point-max) filename))) + (let ((file-name-coding-system nnmail-pathname-coding-system)) + (mm-append-to-file (point-min) (point-max) filename)))) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil)) @@ -804,7 +889,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)) @@ -852,16 +938,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." @@ -895,12 +995,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." @@ -942,23 +1045,120 @@ ARG is passed to the first function." t)) (defun gnus-write-active-file (file hashtb &optional full-names) - (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)))) + (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))))) + +(defcustom gnus-use-byte-compile t + "If non-nil, byte-compile crucial run-time codes." + :type 'boolean + :version "21.1" + :group 'gnus-various) + +(defun gnus-byte-compile (form) + "Byte-compile FORM if `gnus-use-byte-compile' is non-nil." + (if gnus-use-byte-compile + (progn + (require 'bytecomp) + (defalias 'gnus-byte-compile 'byte-compile) + (byte-compile form)) + form)) + +(defun gnus-remassoc (key alist) + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member +of LIST has a car that is `equal' to KEY, there is no way to remove it +by side effect; therefore, write `(setq foo (remassoc key foo))' to be +sure of changing the value of `foo'." + (when alist + (if (equal key (caar alist)) + (cdr alist) + (setcdr alist (gnus-remassoc key (cdr alist))) + alist))) + +(defun gnus-update-alist-soft (key value alist) + (if value + (cons (cons key value) (gnus-remassoc key alist)) + (gnus-remassoc key alist))) + +(defun gnus-create-info-command (node) + "Create a command that will go to info NODE." + `(lambda () + (interactive) + ,(concat "Enter the info system at node " node) + (Info-goto-node ,node) + (setq gnus-info-buffer (current-buffer)) + (gnus-configure-windows 'info))) + +(defun gnus-not-ignore (&rest args) + t) + +(defvar gnus-directory-sep-char-regexp "/" + "The regexp of directory separator character. +If you find some problem with the directory separator character, try +\"[/\\\\\]\" for some systems.") (provide 'gnus-util)