X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=7adedd63057ab965f1afd431446e9b488e6c7f2c;hb=8c38e845dfdda7201684fa5dbbe511e487dd5893;hp=ce7998142ea0b89b818c369302092dfa7f0c07fd;hpb=5d1a64fb1b1af779c970cd233581031a1a3d26a6;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index ce79981..7adedd6 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1,8 +1,9 @@ -;;; gnus-util.el --- utility functions for Gnus -;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. +;;; gnus-util.el --- utility functions for Semi-gnus +;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. -;; Author: Lars Magne Ingebrigtsen -;; Keywords: news +;; Author: Lars Magne Ingebrigtsen +;; Tatsuya Ichikawa +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -33,11 +34,11 @@ (require 'custom) (eval-when-compile (require 'cl)) (require 'nnheader) -(require 'timezone) (require 'message) +(require 'time-date) +(eval-when-compile (require 'static)) (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")) @@ -75,7 +76,10 @@ (set symbol nil)) symbol)) -(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 @@ -106,25 +110,34 @@ (when (gnus-buffer-exists-p buf) (kill-buffer buf)))) -(if (fboundp 'point-at-bol) - (fset 'gnus-point-at-bol 'point-at-bol) +(static-cond + ((fboundp 'point-at-bol) + (fset 'gnus-point-at-bol 'point-at-bol)) + ((fboundp 'line-beginning-position) + (fset 'gnus-point-at-bol 'line-beginning-position)) + (t (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) + (goto-char p)))) + )) +(static-cond + ((fboundp 'point-at-eol) + (fset 'gnus-point-at-eol 'point-at-eol)) + ((fboundp 'line-end-position) + (fset 'gnus-point-at-eol 'line-end-position)) + (t (defun gnus-point-at-eol () "Return point at the end of the line." (let ((p (point))) (end-of-line) (prog1 (point) - (goto-char p))))) + (goto-char p)))) + )) (defun gnus-delete-first (elt list) "Delete by side effect the first occurrence of ELT as a member of LIST." @@ -231,43 +244,6 @@ ;;; Time functions. -(defun gnus-days-between (date1 date2) - ;; Return the number of days between date1 and date2. - (- (gnus-day-number date1) (gnus-day-number date2))) - -(defun gnus-day-number (date) - (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) ) - (timezone-parse-date date)))) - (timezone-absolute-from-gregorian - (nth 1 dat) (nth 2 dat) (car dat)))) - -(defun gnus-time-to-day (time) - "Convert TIME to day number." - (let ((tim (decode-time time))) - (timezone-absolute-from-gregorian - (nth 4 tim) (nth 3 tim) (nth 5 tim)))) - -(defun gnus-encode-date (date) - "Convert DATE to internal time." - (let* ((parse (timezone-parse-date date)) - (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) - (* 60 (timezone-zone-to-minute (nth 4 date)))))) - -(defun gnus-time-minus (t1 t2) - "Subtract two internal times." - (let ((borrow (< (cadr t1) (cadr t2)))) - (list (- (car t1) (car t2) (if borrow 1 0)) - (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) - -(defun gnus-time-less (t1 t2) - "Say whether time T1 is less than time T2." - (or (< (car t1) (car t2)) - (and (= (car t1) (car t2)) - (< (nth 1 t1) (nth 1 t2))))) - (defun gnus-file-newer-than (file date) (let ((fdate (nth 5 (file-attributes file)))) (or (> (car fdate) (car date)) @@ -340,25 +316,9 @@ (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" - (if (equal messy-date "") - "??-???" - (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) - (if (not datevec) - "??-???" - (format "%2s-%s" - (condition-case () - ;; Make sure leading zeroes are stripped. - (number-to-string (string-to-number (aref datevec 2))) - (error "??")) - (capitalize - (or (car - (nth (1- (string-to-number (aref datevec 1))) - timezone-months-assoc)) - "???"))))))) + "Return a string like DD-MMM from a big messy string." + (format-time-string "%d-%b" (safe-date-to-time messy-date))) (defmacro gnus-date-get-time (date) "Convert DATE string to Emacs time. @@ -369,7 +329,7 @@ Cache the result as a text property stored in DATE." '(0 0) (or (get-text-property 0 'gnus-time d) ;; or compute the value... - (let ((time (nnmail-date-to-time d))) + (let ((time (safe-date-to-time d))) ;; and store it back in the string. (put-text-property 0 1 'gnus-time time d) time))))) @@ -379,7 +339,7 @@ Cache the result as a text property stored in DATE." (format-time-string "%Y%m%dT%H%M%S" time)) (defun gnus-date-iso8601 (date) - "Convert the DATE to YYMMDDTHHMMSS" + "Convert the DATE to YYMMDDTHHMMSS." (condition-case () (gnus-time-iso8601 (gnus-date-get-time date)) (error ""))) @@ -453,7 +413,7 @@ jabbering all the time." ids)) (nreverse ids))) -(defun gnus-parent-id (references &optional n) +(defsubst gnus-parent-id (references &optional n) "Return the last Message-ID in REFERENCES. If N, return the Nth ancestor instead." (when references @@ -500,20 +460,8 @@ If N, return the Nth ancestor instead." (cons (and (numberp event) event) event))) (defun gnus-sortable-date (date) - "Make sortable string by string-lessp from DATE. -Timezone package is used." - (condition-case () - (progn - (setq date (inline (timezone-fix-time - date nil - (aref (inline (timezone-parse-date date)) 4)))) - (inline - (timezone-make-sortable-date - (aref date 0) (aref date 1) (aref date 2) - (inline - (timezone-make-time-string - (aref date 3) (aref date 4) (aref date 5)))))) - (error ""))) + "Make string suitable for sorting from DATE." + (gnus-time-iso8601 (date-to-time date))) (defun gnus-copy-file (file &optional to) "Copy FILE to TO." @@ -543,9 +491,8 @@ Timezone package is used." (progn (set-buffer gnus-work-buffer) (erase-buffer)) - (set-buffer (get-buffer-create gnus-work-buffer)) - (kill-all-local-variables) - (buffer-disable-undo (current-buffer)))) + (set-buffer (gnus-get-buffer-create gnus-work-buffer)) + (kill-all-local-variables))) (defmacro gnus-group-real-name (group) "Find the real name of a foreign newsgroup." @@ -557,21 +504,40 @@ Timezone package is used." (defun gnus-make-sort-function (funs) "Return a composite sort condition based on the functions in FUNC." (cond - ((not (listp funs)) funs) + ;; Just a simple function. + ((gnus-functionp funs) funs) + ;; No functions at all. ((null funs) funs) - ((cdr funs) + ;; A list of functions. + ((or (cdr funs) + (listp (car funs))) `(lambda (t1 t2) ,(gnus-make-sort-function-1 (reverse funs)))) + ;; A list containing just one function. (t (car funs)))) (defun gnus-make-sort-function-1 (funs) "Return a composite sort condition based on the functions in FUNC." - (if (cdr funs) - `(or (,(car funs) t1 t2) - (and (not (,(car funs) t2 t1)) - ,(gnus-make-sort-function-1 (cdr funs)))) - `(,(car funs) t1 t2))) + (let ((function (car funs)) + (first 't1) + (last 't2)) + (when (consp function) + (cond + ;; Reversed spec. + ((eq (car function) 'not) + (setq function (cadr function) + first 't2 + last 't1)) + ((gnus-functionp function) + ) + (t + (error "Invalid sort spec: %s" function)))) + (if (cdr funs) + `(or (,function ,first ,last) + (and (not (,function ,last ,first)) + ,(gnus-make-sort-function-1 (cdr funs)))) + `(,function ,first ,last)))) (defun gnus-turn-off-edit-menu (type) "Turn off edit menu in `gnus-TYPE-mode-map'." @@ -583,6 +549,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)))) @@ -606,13 +573,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." @@ -625,16 +599,28 @@ Bind `print-quoted' and `print-readably' to t while printing." (setq string (replace-match "" t t string))) string) -(defun gnus-put-text-property-excluding-newlines (beg end prop val) +(defsubst 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) + (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 @@ -757,9 +743,12 @@ 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)) (save-buffer))))) @@ -780,9 +769,8 @@ with potentially long computations." (let ((file-buffer (create-file-buffer filename))) (save-excursion (set-buffer file-buffer) - (let ((require-final-newline nil) - (coding-system-for-write 'binary)) - (gnus-write-buffer filename))) + (let ((require-final-newline nil)) + (gnus-write-buffer-as-binary filename))) (kill-buffer file-buffer)) (error "Output file does not exist"))) (set-buffer tmpbuf) @@ -799,8 +787,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) - (let ((buffer-read-only nil) - (coding-system-for-write 'binary)) + (let ((buffer-read-only nil)) (save-excursion (goto-char (point-max)) (forward-char -2) @@ -810,7 +797,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)) @@ -835,8 +823,7 @@ 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)) @@ -847,36 +834,18 @@ ARG is passed to the first function." (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 + (when (file-exists-p file) + (with-temp-buffer (let ((tokens '("machine" "default" "login" "password" "account" "macdef" "force")) 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. @@ -885,41 +854,51 @@ ARG is passed to the first function." ;; 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) + ;; Skip lines that begin with a "#". + (if (eq (char-after) ?#) + (goto-char (point-max)) + (unless (eobp) + (setq elem (buffer-substring + (point) (progn (skip-chars-forward "^\t ") + (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))))))) + (when alist + (push (nreverse alist) result)) (setq alist nil pair nil) (widen) (forward-line 1)) - result)))) + (nreverse 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))) + "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." @@ -927,6 +906,7 @@ ARG is passed to the first function." ;;; Various +(defvar gnus-group-buffer) ; Compiler directive (defun gnus-alive-p () "Say whether Gnus is running or not." (and (boundp 'gnus-group-buffer) @@ -935,6 +915,95 @@ ARG is passed to the first function." (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 &optional assoc-p) + "Modify ALIST to be without KEY." + (unless (symbolp alist) + (error "Not a symbol: %s" alist)) + (let ((fun (if assoc-p 'assoc 'assq))) + `(setq ,alist (delq (,fun ,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) ".*$"))) + +(defun gnus-set-window-start (&optional point) + "Set the window start to POINT, or (point) if nil." + (let ((win (get-buffer-window (current-buffer) t))) + (when win + (set-window-start win (or point (point)))))) + +(defun gnus-annotation-in-region-p (b e) + (if (= b e) + (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t) + (text-property-any b e 'gnus-undeletable t))) + +(defun gnus-or (&rest elems) + "Return non-nil if any of the elements are non-nil." + (catch 'found + (while elems + (when (pop elems) + (throw 'found t))))) + +(defun gnus-and (&rest elems) + "Return non-nil if all of the elements are non-nil." + (catch 'found + (while elems + (unless (pop elems) + (throw 'found nil))) + t)) + +(static-if (boundp 'MULE) + (defun gnus-write-active-file-as-coding-system (coding-system file hashtb) + (let ((output-coding-system coding-system)) + (with-temp-file file + (mapatoms + (lambda (sym) + (when (and sym + (boundp sym) + (symbol-value 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-as-coding-system (coding-system file hashtb) + (let ((coding-system-for-write coding-system)) + (with-temp-file file + (mapatoms + (lambda (sym) + (when (and sym + (boundp sym) + (symbol-value sym)) + (insert (format "%s %d %d y\n" + (symbol-name sym) (cdr (symbol-value sym)) + (car (symbol-value sym)))))) + hashtb)))) + ) (provide 'gnus-util)