X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-util.el;h=cba9137d8bee941b4b324b0867fa0b64f45184dc;hb=59a448f3da4fdb3076a6d696f7d08029bc4c82d8;hp=61975ef93d76a33d2971f3f6fe001b7931f2b675;hpb=09868cf7efbfa51562d76580eafc9a7b6b0c8d72;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index 61975ef..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,98,99 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 +;; Keywords: mail, news, MIME ;; This file is part of GNU Emacs. @@ -33,10 +33,14 @@ (require 'custom) (eval-when-compile (require 'cl)) (require 'nnheader) +(require 'timezone) (require 'message) -(require 'time-date) +(eval-when-compile + (when (locate-library "rmail") + (require 'rmail))) (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")) @@ -74,6 +78,12 @@ (set symbol nil)) symbol)) +;; 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 ;; to limit the length of a string. This function is necessary since ;; `(substr "abc" 0 30)' pukes with "Args out of range". @@ -102,15 +112,25 @@ (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)) - -(fset 'gnus-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position)) +(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." @@ -217,6 +237,43 @@ ;;; 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)) @@ -291,7 +348,20 @@ (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))) + (let ((datevec (ignore-errors (timezone-parse-date messy-date)))) + (if (or (not datevec) + (string-equal "0" (aref datevec 1))) + "??-???" + (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)) + "???")))))) (defmacro gnus-date-get-time (date) "Convert DATE string to Emacs time. @@ -302,7 +372,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 (safe-date-to-time d))) + (let ((time (nnmail-date-to-time d))) ;; and store it back in the string. (put-text-property 0 1 'gnus-time time d) time))))) @@ -386,7 +456,7 @@ jabbering all the time." ids)) (nreverse ids))) -(defsubst gnus-parent-id (references &optional n) +(defun gnus-parent-id (references &optional n) "Return the last Message-ID in REFERENCES. If N, return the Nth ancestor instead." (when references @@ -433,8 +503,20 @@ If N, return the Nth ancestor instead." (cons (and (numberp event) event) event))) (defun gnus-sortable-date (date) - "Make string suitable for sorting from DATE." - (gnus-time-iso8601 (date-to-time 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 ""))) (defun gnus-copy-file (file &optional to) "Copy FILE to TO." @@ -466,7 +548,7 @@ If N, return the Nth ancestor instead." (erase-buffer)) (set-buffer (gnus-get-buffer-create gnus-work-buffer)) (kill-all-local-variables) - (mm-enable-multibyte))) + (buffer-disable-undo (current-buffer)))) (defmacro gnus-group-real-name (group) "Find the real name of a foreign newsgroup." @@ -478,40 +560,21 @@ If N, return the Nth ancestor instead." (defun gnus-make-sort-function (funs) "Return a composite sort condition based on the functions in FUNC." (cond - ;; Just a simple function. - ((gnus-functionp funs) funs) - ;; No functions at all. + ((not (listp funs)) funs) ((null funs) funs) - ;; A list of functions. - ((or (cdr funs) - (listp (car funs))) + ((cdr 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." - (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)))) + (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))) (defun gnus-turn-off-edit-menu (type) "Turn off edit menu in `gnus-TYPE-mode-map'." @@ -547,6 +610,21 @@ Bind `print-quoted' and `print-readably' to t while printing." ;; Write the buffer. (write-region (point-min) (point-max) file nil 'quietly)) +(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)) + +(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." (when (file-exists-p file) @@ -558,7 +636,7 @@ Bind `print-quoted' and `print-readably' to t while printing." (setq string (replace-match "" t t string))) string) -(defsubst gnus-put-text-property-excluding-newlines (beg end prop val) +(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 @@ -580,7 +658,7 @@ Bind `print-quoted' and `print-readably' to t while printing." (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 @@ -729,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) @@ -756,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)) @@ -792,60 +871,78 @@ 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) + (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." - (when (file-exists-p file) - (with-temp-buffer + (if (not (file-exists-p file)) + () + (save-excursion (let ((tokens '("machine" "default" "login" "password" "account" "macdef" "force")) alist elem result pair) - (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 ") - ;; 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)) - (nreverse result))))) + (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." @@ -864,7 +961,7 @@ ARG is passed to the first function." ;;; Various -(defvar gnus-group-buffer) ; Compiler directive +(defvar gnus-group-buffer) ; Compiler directive (defun gnus-alive-p () "Say whether Gnus is running or not." (and (boundp 'gnus-group-buffer) @@ -897,12 +994,11 @@ ARG is passed to the first function." (setq alist (delq entry alist))) alist)) -(defmacro gnus-pull (key alist &optional assoc-p) +(defmacro gnus-pull (key alist) "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)))) + `(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." @@ -910,42 +1006,6 @@ ARG is passed to the first function." 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)) - -(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))) - (provide 'gnus-util) ;;; gnus-util.el ends here